From be99f2a7fdf6b5c24c98ae38a4fce6929d66606b Mon Sep 17 00:00:00 2001
From: florian <florian@freepascal.org>
Date: Sun, 25 Sep 2005 10:58:17 +0000
Subject: [PATCH] * fixed loading of addresses of virtual methods to
 methodpointers in delphi mode

git-svn-id: trunk@1182 -
---
 .gitattributes      |  1 +
 compiler/ncnv.pas   | 20 ++++++++++++++++++--
 tests/tbs/tb0496.pp | 38 ++++++++++++++++++++++++++++++++++++++
 3 files changed, 57 insertions(+), 2 deletions(-)
 create mode 100644 tests/tbs/tb0496.pp

diff --git a/.gitattributes b/.gitattributes
index a31a5bacec..60d92690a0 100644
--- a/.gitattributes
+++ b/.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
diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas
index c0e7bc5a56..05fcb31151 100644
--- a/compiler/ncnv.pas
+++ b/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;
diff --git a/tests/tbs/tb0496.pp b/tests/tbs/tb0496.pp
new file mode 100644
index 0000000000..dfbfb3bea5
--- /dev/null
+++ b/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.