* methodpointer self pushing fixed

compiler/ncal.pas

@@ -65,6 +65,7 @@ interface
 {$ifdef EXTDEBUG}
           procedure candidates_dump_info(lvl:longint;procs:pcandidate);
 {$endif EXTDEBUG}
+          function  gen_self_tree_methodpointer:tnode;
           function  gen_self_tree:tnode;
           function  gen_vmt_tree:tnode;
           procedure bind_paraitem;
@@ -1598,6 +1599,21 @@ type
       end;
 
 
+    function tcallnode.gen_self_tree_methodpointer:tnode;
+      var
+        hsym : tvarsym;
+      begin
+        { find self field in methodpointer record }
+        hsym:=tvarsym(trecorddef(methodpointertype.def).symtable.search('self'));
+        if not assigned(hsym) then
+          internalerror(200305251);
+        { Load tmehodpointer(right).self }
+        result:=csubscriptnode.create(
+                     hsym,
+                     ctypeconvnode.create_explicit(right.getcopy,methodpointertype));
+      end;
+
+
     function tcallnode.gen_self_tree:tnode;
       var
         selftree : tnode;
@@ -1789,11 +1805,10 @@ type
               else
                if vo_is_self in tvarsym(currpara.parasym).varoptions then
                  begin
-{$warning todo methodpointer}
-                   if (right=nil) then
-                     hiddentree:=gen_self_tree
+                   if assigned(right) then
+                     hiddentree:=gen_self_tree_methodpointer
                    else
-                     hiddentree:=cnothingnode.create;
+                     hiddentree:=gen_self_tree;
                  end
               else
                if vo_is_vmt in tvarsym(currpara.parasym).varoptions then
@@ -2720,7 +2735,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.160  2003-05-25 08:59:16  peter
+  Revision 1.161  2003-05-25 11:34:17  peter
+    * methodpointer self pushing fixed
+
+  Revision 1.160  2003/05/25 08:59:16  peter
     * inline fixes
 
   Revision 1.159  2003/05/24 17:16:37  jonas

compiler/ncgcal.pas

@@ -810,28 +810,11 @@ implementation
               if (po_interrupt in procdefinition.procoptions) then
                 extra_interrupt_code;
 
-              if (po_methodpointer in procdefinition.procoptions) then
-                begin
-                   { push self }
-                   href:=right.location.reference;
-                   inc(href.offset,POINTER_SIZE);
-                   cg.a_param_ref(exprasmlist,OS_ADDR,href,paramanager.getintparaloc(1));
-
-                   rg.saveintregvars(exprasmlist,ALL_INTREGISTERS);
-                   rg.saveotherregvars(exprasmlist,ALL_REGISTERS);
-                   cg.a_call_ref(exprasmlist,right.location.reference);
-
-                   reference_release(exprasmlist,right.location.reference);
-                   tg.Ungetiftemp(exprasmlist,right.location.reference);
-                end
-              else
-                begin
-                   rg.saveintregvars(exprasmlist,ALL_INTREGISTERS);
-                   rg.saveotherregvars(exprasmlist,ALL_REGISTERS);
-                   cg.a_call_loc(exprasmlist,right.location);
-                   location_release(exprasmlist,right.location);
-                   location_freetemp(exprasmlist,right.location);
-                end;
+              rg.saveintregvars(exprasmlist,ALL_INTREGISTERS);
+              rg.saveotherregvars(exprasmlist,ALL_REGISTERS);
+              cg.a_call_loc(exprasmlist,right.location);
+              location_release(exprasmlist,right.location);
+              location_freetemp(exprasmlist,right.location);
            end;
 
          { Need to remove the parameters from the stack? }
@@ -1127,7 +1110,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.73  2003-05-25 08:59:16  peter
+  Revision 1.74  2003-05-25 11:34:17  peter
+    * methodpointer self pushing fixed
+
+  Revision 1.73  2003/05/25 08:59:16  peter
     * inline fixes
 
   Revision 1.72  2003/05/24 13:36:54  jonas

compiler/psystem.pas

@@ -123,7 +123,7 @@ implementation
         { several defs to simulate more or less C++ objects for GDB }
         vmttype,
         vmtarraytype : ttype;
-        vmtsymtable  : tsymtable;
+        hrecst : trecordsymtable;
       begin
 {$ifdef cpufpemu}
         { Normal types }
@@ -195,20 +195,26 @@ implementation
         addtype('$s80real',s80floattype);
         addtype('$s64currency',s64currencytype);
         { Add a type for virtual method tables }
-        vmtsymtable:=trecordsymtable.create;
-        vmttype.setdef(trecorddef.create(vmtsymtable));
+        hrecst:=trecordsymtable.create;
+        vmttype.setdef(trecorddef.create(hrecst));
         pvmttype.setdef(tpointerdef.create(vmttype));
-        vmtsymtable.insert(tvarsym.create('$parent',vs_value,pvmttype));
-        vmtsymtable.insert(tvarsym.create('$length',vs_value,s32bittype));
-        vmtsymtable.insert(tvarsym.create('$mlength',vs_value,s32bittype));
+        hrecst.insertfield(tvarsym.create('$parent',vs_value,pvmttype));
+        hrecst.insertfield(tvarsym.create('$length',vs_value,s32bittype));
+        hrecst.insertfield(tvarsym.create('$mlength',vs_value,s32bittype));
         vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
         tarraydef(vmtarraytype.def).setelementtype(voidpointertype);
-        vmtsymtable.insert(tvarsym.create('$__pfn',vs_value,vmtarraytype));
+        hrecst.insertfield(tvarsym.create('$__pfn',vs_value,vmtarraytype));
         addtype('$__vtbl_ptr_type',vmttype);
         addtype('$pvmt',pvmttype);
         vmtarraytype.setdef(tarraydef.create(0,1,s32bittype));
         tarraydef(vmtarraytype.def).setelementtype(pvmttype);
         addtype('$vtblarray',vmtarraytype);
+        { Add a type for methodpointers }
+        hrecst:=trecordsymtable.create;
+        hrecst.insertfield(tvarsym.create('$proc',vs_value,voidpointertype));
+        hrecst.insertfield(tvarsym.create('$self',vs_value,voidpointertype));
+        methodpointertype.setdef(trecorddef.create(hrecst));
+        addtype('$methodpointer',methodpointertype);
       { Add functions that require compiler magic }
         insertinternsyms(p);
       end;
@@ -246,6 +252,7 @@ implementation
         globaldef('file',cfiletype);
         globaldef('pvmt',pvmttype);
         globaldef('variant',cvarianttype);
+        globaldef('methodpointer',methodpointertype);
 {$ifdef i386}
         ordpointertype:=u32bittype;
         defaultordconsttype:=s32bittype;
@@ -487,7 +494,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.50  2003-05-13 19:14:41  peter
+  Revision 1.51  2003-05-25 11:34:17  peter
+    * methodpointer self pushing fixed
+
+  Revision 1.50  2003/05/13 19:14:41  peter
     * failn removed
     * inherited result code check moven to pexpr
 

compiler/symdef.pas

@@ -678,6 +678,7 @@ interface
                                     needed for readln() }
        cfiletype,                 { get the same definition for all file }
                                   { used for stabs }
+       methodpointertype,         { typecasting of methodpointers to extract self }
        { we use only one variant def }
        cvarianttype,
        { unsigned ord type with the same size as a pointer }
@@ -5761,7 +5762,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.144  2003-05-15 18:58:53  peter
+  Revision 1.145  2003-05-25 11:34:17  peter
+    * methodpointer self pushing fixed
+
+  Revision 1.144  2003/05/15 18:58:53  peter
     * removed selfpointer_offset, vmtpointer_offset
     * tvarsym.adjusted_address
     * address in localsymtable is now in the real direction

compiler/symtable.pas

@@ -99,6 +99,7 @@ interface
           procedure load_references(ppufile:tcompilerppufile;locals:boolean);override;
           procedure write_references(ppufile:tcompilerppufile;locals:boolean);override;
           procedure insertvardata(sym : tsymentry);override;
+          procedure insertfield(sym:tvarsym);
        end;
 
        trecordsymtable = class(tabstractrecordsymtable)
@@ -1076,6 +1077,13 @@ implementation
       end;
 
 
+    procedure tabstractrecordsymtable.insertfield(sym : tvarsym);
+      begin
+        insert(sym);
+        insertvardata(sym);
+      end;
+
+
 {****************************************************************************
                               TRecordSymtable
 ****************************************************************************}
@@ -2421,7 +2429,10 @@ implementation
 end.
 {
   $Log$
-  Revision 1.102  2003-05-23 14:27:35  peter
+  Revision 1.103  2003-05-25 11:34:17  peter
+    * methodpointer self pushing fixed
+
+  Revision 1.102  2003/05/23 14:27:35  peter
     * remove some unit dependencies
     * current_procinfo changes to store more info