+ added support for nested procvars in the i8086 far data memory models

git-svn-id: trunk@27812 -

compiler/i8086/hlcgcpu.pas

@@ -52,7 +52,9 @@ interface
         and registerhi with the following sizes:
 
         register   - cgsize = int_cgsize(voidcodepointertype.size)
-        registerhi - cgsize = int_cgsize(voidpointertype.size) }
+        registerhi - cgsize = int_cgsize(voidpointertype.size) or int_cgsize(parentfpvoidpointertype.size)
+                              (check d.size to determine which one of the two)
+        }
       function is_methodptr_like_type(d:tdef): boolean;
 
       { 4-byte records in registers need special handling as well. A record may
@@ -307,7 +309,13 @@ implementation
           tmpref:=ref;
           a_load_reg_ref(list,voidcodepointertype,voidcodepointertype,loc.register,tmpref);
           inc(tmpref.offset,voidcodepointertype.size);
-          a_load_reg_ref(list,voidpointertype,voidpointertype,loc.registerhi,tmpref);
+          { the second part could be either self or parentfp }
+          if tosize.size=(voidcodepointertype.size+voidpointertype.size) then
+            a_load_reg_ref(list,voidpointertype,voidpointertype,loc.registerhi,tmpref)
+          else if tosize.size=(voidcodepointertype.size+parentfpvoidpointertype.size) then
+            a_load_reg_ref(list,parentfpvoidpointertype,parentfpvoidpointertype,loc.registerhi,tmpref)
+          else
+            internalerror(2014052201);
         end
       else if is_fourbyterecord(tosize) and (loc.loc in [LOC_REGISTER,LOC_CREGISTER]) then
         begin
@@ -396,7 +404,13 @@ implementation
 
           a_load_reg_ref(list,voidcodepointertype,voidcodepointertype,l.register,tmpref);
           inc(tmpref.offset,voidcodepointertype.size);
-          a_load_reg_ref(list,voidpointertype,voidpointertype,l.registerhi,tmpref);
+          { the second part could be either self or parentfp }
+          if size.size=(voidcodepointertype.size+voidpointertype.size) then
+            a_load_reg_ref(list,voidpointertype,voidpointertype,l.registerhi,tmpref)
+          else if size.size=(voidcodepointertype.size+parentfpvoidpointertype.size) then
+            a_load_reg_ref(list,parentfpvoidpointertype,parentfpvoidpointertype,l.registerhi,tmpref)
+          else
+            internalerror(2014052202);
 
           location_reset_ref(l,LOC_REFERENCE,l.size,0);
           l.reference:=r;

compiler/ncal.pas

@@ -65,7 +65,8 @@ interface
           function  is_simple_para_load(p:tnode; may_be_in_reg: boolean):boolean;
           procedure maybe_load_in_temp(var p:tnode);
           function  gen_high_tree(var p:tnode;paradef:tdef):tnode;
-          function  gen_procvar_context_tree:tnode;
+          function  gen_procvar_context_tree_self:tnode;
+          function  gen_procvar_context_tree_parentfp:tnode;
           function  gen_self_tree:tnode;
           function  gen_vmt_tree:tnode;
           procedure gen_hidden_parameters;
@@ -1742,15 +1743,24 @@ implementation
       end;
 
 
-    function tcallnode.gen_procvar_context_tree:tnode;
+    function tcallnode.gen_procvar_context_tree_self:tnode;
       begin
-        { Load tmehodpointer(right).self (either self or parentfp) }
+        { Load tmehodpointer(right).self }
         result:=genloadfield(ctypeconvnode.create_internal(
           right.getcopy,methodpointertype),
           'self');
       end;
 
 
+    function tcallnode.gen_procvar_context_tree_parentfp: tnode;
+      begin
+        { Load tnestedprocpointer(right).parentfp }
+        result:=genloadfield(ctypeconvnode.create_internal(
+          right.getcopy,nestedprocpointertype),
+          'parentfp');
+      end;
+
+
     function tcallnode.gen_self_tree:tnode;
       var
         selftree : tnode;
@@ -2508,7 +2518,7 @@ implementation
                  if vo_is_self in para.parasym.varoptions then
                    begin
                      if assigned(right) then
-                       para.left:=gen_procvar_context_tree
+                       para.left:=gen_procvar_context_tree_self
                      else
                        para.left:=gen_self_tree;
                      { make sure that e.g. the self pointer of an advanced
@@ -2540,7 +2550,7 @@ implementation
                            internalerror(200309287);
                        end
                      else
-                       para.left:=gen_procvar_context_tree;
+                       para.left:=gen_procvar_context_tree_parentfp;
                    end
                 else
                  if vo_is_range_check in para.parasym.varoptions then

compiler/psystem.pas

@@ -496,6 +496,12 @@ implementation
             addfield(hrecst,cfieldvarsym.create('$self',vs_value,voidpointertype,[]));
             methodpointertype:=crecorddef.create('',hrecst);
             addtype('$methodpointer',methodpointertype);
+            { Add a type for nested proc pointers }
+            hrecst:=trecordsymtable.create('',1);
+            addfield(hrecst,cfieldvarsym.create('$proc',vs_value,voidcodepointertype,[]));
+            addfield(hrecst,cfieldvarsym.create('$parentfp',vs_value,parentfpvoidpointertype,[]));
+            nestedprocpointertype:=crecorddef.create('',hrecst);
+            addtype('$nestedprocpointer',nestedprocpointertype);
           end;
         symtablestack.pop(systemunit);
       end;
@@ -593,6 +599,7 @@ implementation
         loadtype('variant',cvarianttype);
         loadtype('olevariant',colevarianttype);
         loadtype('methodpointer',methodpointertype);
+        loadtype('nestedprocpointer',nestedprocpointertype);
         loadtype('HRESULT',hresultdef);
         set_default_int_types;
         set_default_ptr_types;

compiler/symdef.pas

@@ -986,6 +986,7 @@ interface
        cfiletype,                 { get the same definition for all file }
                                   { used for stabs }
        methodpointertype,         { typecasting of methodpointers to extract self }
+       nestedprocpointertype,     { typecasting of nestedprocpointers to extract parentfp }
        hresultdef,
        { we use only one variant def for every variant class }
        cvarianttype,
@@ -5597,7 +5598,12 @@ implementation
          if ((po_methodpointer in procoptions) or
              is_nested_pd(self)) and
             not(po_addressonly in procoptions) then
-           size:=voidcodepointertype.size+voidpointertype.size
+           begin
+             if is_nested_pd(self) then
+               size:=voidcodepointertype.size+parentfpvoidpointertype.size
+             else
+               size:=voidcodepointertype.size+voidpointertype.size;
+           end
          else
            size:=voidcodepointertype.size;
       end;