Merged revisions 1182,1196 via svnmerge from

/trunk

git-svn-id: branches/fixes_2_0@1197 -

.gitattributes

@@ -4785,6 +4785,7 @@ tests/tbs/tb0492.pp svneol=native#text/plain
 tests/tbs/tb0493.pp svneol=native#text/plain
 tests/tbs/tb0494.pp -text
 tests/tbs/tb0495.pp svneol=native#text/plain
+tests/tbs/tb0496.pp svneol=native#text/plain
 tests/tbs/ub0060.pp svneol=native#text/plain
 tests/tbs/ub0069.pp svneol=native#text/plain
 tests/tbs/ub0119.pp svneol=native#text/plain

compiler/ncal.pas

@@ -1906,22 +1906,6 @@ type
          { bind parasyms to the callparanodes and insert hidden parameters }
          bind_parasym;
 
-         { methodpointer needs to be a pointer to the VMT for virtual calls.
-           Note: We need to keep the methodpointer in the callnode for TP
-           procvar support, because this calln still maybe converted to a loadn,
-           see tw3499 }
-         if (po_virtualmethod in procdefinition.procoptions) then
-          begin
-            if not assigned(methodpointer) then
-              internalerror(200305063);
-            if (methodpointer.nodetype<>typen) and
-               (methodpointer.resulttype.def.deftype<>classrefdef) then
-              begin
-                methodpointer:=cloadvmtaddrnode.create(methodpointer);
-                resulttypepass(methodpointer);
-              end;
-          end;
-
          { insert type conversions for parameters }
          if assigned(left) then
            tcallparanode(left).insert_typeconv(true);

compiler/ncgcal.pas

@@ -855,22 +855,27 @@ implementation
                 assigned(methodpointer) and
                 (methodpointer.nodetype<>typen) then
                begin
-                 secondpass(methodpointer);
-                 location_force_reg(exprasmlist,methodpointer.location,OS_ADDR,false);
-
                  { virtual methods require an index }
                  if tprocdef(procdefinition).extnumber=$ffff then
                    internalerror(200304021);
-                 { VMT should already be loaded in a register }
-                 if methodpointer.location.register=NR_NO then
-                   internalerror(200304022);
+
+                 secondpass(methodpointer);
+
+                 { Load VMT from self }
+                 if methodpointer.resulttype.def.deftype=objectdef then
+                   gen_load_vmt_register(exprasmlist,tobjectdef(methodpointer.resulttype.def),methodpointer.location,vmtreg)
+                 else
+                   begin
+                     { Load VMT value in register }
+                     location_force_reg(exprasmlist,methodpointer.location,OS_ADDR,false);
+                     vmtreg:=methodpointer.location.register;
+                   end;
 
                  { test validity of VMT }
                  if not(is_interface(tprocdef(procdefinition)._class)) and
                     not(is_cppclass(tprocdef(procdefinition)._class)) then
-                   cg.g_maybe_testvmt(exprasmlist,methodpointer.location.register,tprocdef(procdefinition)._class);
+                   cg.g_maybe_testvmt(exprasmlist,vmtreg,tprocdef(procdefinition)._class);
 
-                 vmtreg:=methodpointer.location.register;
                  pvreg:=cg.getintregister(exprasmlist,OS_ADDR);
                  reference_reset_base(href,vmtreg,
                     tprocdef(procdefinition)._class.vmtmethodoffset(tprocdef(procdefinition).extnumber));

compiler/ncgmem.pas

@@ -98,60 +98,19 @@ implementation
 
       begin
          location_reset(location,LOC_REGISTER,OS_ADDR);
-         if (left.nodetype<>typen) then
-          begin
-            { left contains self, load vmt from self }
-            secondpass(left);
-            if is_object(left.resulttype.def) then
-             begin
-               case left.location.loc of
-                  LOC_CREFERENCE,
-                  LOC_REFERENCE:
-                    begin
-                       reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
-                       cg.a_loadaddr_ref_reg(exprasmlist,left.location.reference,href.base);
-                    end;
-                  else
-                    internalerror(200305056);
-               end;
-             end
-            else
-             begin
-               case left.location.loc of
-                  LOC_REGISTER:
-                    begin
-                    {$ifdef cpu_uses_separate_address_registers}
-                      if getregtype(left.location.register)<>R_ADDRESSREGISTER then
-                        begin
-                          reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
-                          cg.a_load_reg_reg(exprasmlist,OS_ADDR,OS_ADDR,left.location.register,href.base);
-                        end
-                      else
-                    {$endif}
-                        reference_reset_base(href,left.location.register,tobjectdef(left.resulttype.def).vmt_offset);
-                    end;
-                  LOC_CREGISTER,
-                  LOC_CREFERENCE,
-                  LOC_REFERENCE:
-                    begin
-                       reference_reset_base(href,cg.getaddressregister(exprasmlist),tobjectdef(left.resulttype.def).vmt_offset);
-                       cg.a_load_loc_reg(exprasmlist,OS_ADDR,left.location,href.base);
-                    end;
-                  else
-                    internalerror(200305057);
-               end;
-             end;
-            location.register:=cg.getaddressregister(exprasmlist);
-            cg.g_maybe_testself(exprasmlist,href.base);
-            cg.a_load_ref_reg(exprasmlist,OS_ADDR,OS_ADDR,href,location.register);
-          end
+         if (left.nodetype=typen) then
+           begin
+             reference_reset_symbol(href,
+               objectlibrary.newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
+             location.register:=cg.getaddressregister(exprasmlist);
+             cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
+           end
          else
-          begin
-            reference_reset_symbol(href,
-              objectlibrary.newasmsymbol(tobjectdef(tclassrefdef(resulttype.def).pointertype.def).vmt_mangledname,AB_EXTERNAL,AT_DATA),0);
-            location.register:=cg.getaddressregister(exprasmlist);
-            cg.a_loadaddr_ref_reg(exprasmlist,href,location.register);
-          end;
+           begin
+             { left contains self, load vmt from self }
+             secondpass(left);
+             gen_load_vmt_register(exprasmlist,tobjectdef(left.resulttype.def),left.location,location.register);
+           end;
       end;
 
 

compiler/ncgutil.pas

@@ -71,6 +71,7 @@ interface
 
     procedure gen_external_stub(list:taasmoutput;pd:tprocdef;const externalname:string);
     procedure gen_intf_wrappers(list:taasmoutput;st:tsymtable);
+    procedure gen_load_vmt_register(list:taasmoutput;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
 
    {#
       Allocate the buffers for exception management and setjmp environment.
@@ -2352,4 +2353,53 @@ implementation
           end;
       end;
 
+
+    procedure gen_load_vmt_register(list:taasmoutput;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
+      var
+        href : treference;
+      begin
+        if is_object(objdef) then
+          begin
+            case selfloc.loc of
+              LOC_CREFERENCE,
+              LOC_REFERENCE:
+                begin
+                  reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
+                  cg.a_loadaddr_ref_reg(list,selfloc.reference,href.base);
+                end;
+              else
+                internalerror(200305056);
+            end;
+          end
+        else
+          begin
+            case selfloc.loc of
+              LOC_REGISTER:
+                begin
+{$ifdef cpu_uses_separate_address_registers}
+                  if getregtype(left.location.register)<>R_ADDRESSREGISTER then
+                    begin
+                      reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
+                      cg.a_load_reg_reg(list,OS_ADDR,OS_ADDR,selfloc.register,href.base);
+                    end
+                  else
+{$endif cpu_uses_separate_address_registers}
+                    reference_reset_base(href,selfloc.register,objdef.vmt_offset);
+                end;
+              LOC_CREGISTER,
+              LOC_CREFERENCE,
+              LOC_REFERENCE:
+                begin
+                    reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset);
+                    cg.a_load_loc_reg(list,OS_ADDR,selfloc,href.base);
+                end;
+              else
+                internalerror(200305057);
+            end;
+          end;
+        vmtreg:=cg.getaddressregister(list);
+        cg.g_maybe_testself(list,href.base);
+        cg.a_load_ref_reg(list,OS_ADDR,OS_ADDR,href,vmtreg);
+      end;
+
 end.

compiler/ncnv.pas

@@ -1382,7 +1382,7 @@ implementation
 
       var
         htype : ttype;
-        hp : tnode;
+        hp,hp2 : tnode;
         currprocdef : tabstractprocdef;
         aprocdef : tprocdef;
         eq : tequaltype;

tests/tbs/tb0496.pp

@@ -0,0 +1,38 @@
+{$mode delphi}
+type
+  tmyclass = class
+    procedure m1;virtual;
+    procedure m2;virtual;
+  end;
+
+  tm1 = procedure of object;
+
+var
+  res : longint;
+
+procedure tmyclass.m1;
+  begin
+    res:=1;
+  end;
+
+procedure p2(m1 : tm1);
+  begin
+    m1;
+  end;
+
+procedure tmyclass.m2;
+  begin
+    p2(m1);
+  end;
+
+var
+  myclass : tmyclass;
+begin
+  res:=$deadbeef;
+  myclass:=tmyclass.create;
+  myclass.m2;
+  myclass.free;
+  if res<>1 then
+    halt(1);
+  writeln('ok');
+end.

tests/webtbs/tw3499.pp

@@ -3,10 +3,13 @@
 { e-mail: [email protected] }
 program test;
 
-{$mode delphi}
+{$ifdef fpc}{$mode delphi}{$endif}
 
 uses SysUtils;
 
+var
+  err : boolean;
+
 type
   TProcedure = procedure of object;
   Class1 = class
@@ -27,13 +30,18 @@ end;
 procedure Class2.d();
 begin
   writeLn('procedure called');
+  err:=false;
 end;
 
 var
   c: Class1;
   e: Class2;
 begin
+  err:=true;
   c := Class1.create();
   e := Class2.create();
   c.p(e.d);
+  c.proc;
+  if err then
+    halt(1);
 end.