* fixed loading of addresses of virtual methods to methodpointers in delphi mode

git-svn-id: trunk@1182 -

.gitattributes

@@ -4978,6 +4978,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/ncnv.pas

@@ -1382,7 +1382,7 @@ implementation
 
       var
         htype : ttype;
-        hp : tnode;
+        hp,hp2 : tnode;
         currprocdef : tabstractprocdef;
         aprocdef : tprocdef;
         eq : tequaltype;
@@ -1518,7 +1518,23 @@ implementation
                             if (tcallnode(left).symtableprocentry.owner.symtabletype=objectsymtable) then
                              begin
                                if assigned(tcallnode(left).methodpointer) then
-                                 tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
+                                 begin
+                                   { kick the loadvmtaddrnode we added in ncal.pas around line 1920?
+                                     if you mess around here, check tbs/tb0496.pp (FK)
+                                   }
+                                   if (po_virtualmethod in tcallnode(left).procdefinition.procoptions) and
+                                     (tcallnode(left).methodpointer.nodetype=loadvmtaddrn) and
+                                     assigned(tloadvmtaddrnode(tcallnode(left).methodpointer).left) and
+                                     (tloadvmtaddrnode(tcallnode(left).methodpointer).left.nodetype<>typen) and
+                                     (tloadvmtaddrnode(tcallnode(left).methodpointer).left.resulttype.def.deftype<>classrefdef) then
+                                     begin
+                                       hp2:=tcallnode(left).methodpointer;
+                                       tcallnode(left).methodpointer:=tloadvmtaddrnode(tcallnode(left).methodpointer).left;
+                                       tloadvmtaddrnode(hp2).left:=nil;
+                                       hp2.free;
+                                     end;
+                                   tloadnode(hp).set_mp(tcallnode(left).get_load_methodpointer)
+                                 end
                                else
                                  tloadnode(hp).set_mp(load_self_node);
                              end;

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.