From 3e153102a8f116b320deb0b4fd9041adf640db49 Mon Sep 17 00:00:00 2001
From: Jonas Maebe <jonas@freepascal.org>
Date: Fri, 19 Jan 2007 18:05:58 +0000
Subject: [PATCH]   * fixed calling class methods via classrefdefs (mantis
 #8145)

git-svn-id: trunk@6075 -
---
 .gitattributes         |   1 +
 compiler/ncal.pas      |   3 +-
 tests/webtbs/tw8145.pp | 105 +++++++++++++++++++++++++++++++++++++++++
 3 files changed, 108 insertions(+), 1 deletion(-)
 create mode 100644 tests/webtbs/tw8145.pp

diff --git a/.gitattributes b/.gitattributes
index f2a2b18d4f..497adec751 100644
--- a/.gitattributes
+++ b/.gitattributes
@@ -7974,6 +7974,7 @@ tests/webtbs/tw8140f.pp svneol=native#text/plain
 tests/webtbs/tw8140g.pp svneol=native#text/plain
 tests/webtbs/tw8140h.pp svneol=native#text/plain
 tests/webtbs/tw8141.pp svneol=native#text/plain
+tests/webtbs/tw8145.pp svneol=native#text/plain
 tests/webtbs/ub1873.pp svneol=native#text/plain
 tests/webtbs/ub1883.pp svneol=native#text/plain
 tests/webtbs/uw0555.pp svneol=native#text/plain
diff --git a/compiler/ncal.pas b/compiler/ncal.pas
index fd434c83b4..004d4d691c 100644
--- a/compiler/ncal.pas
+++ b/compiler/ncal.pas
@@ -1507,7 +1507,8 @@ implementation
                     need to check for typen, because that will always get the
                     loadvmtaddrnode added }
                   selftree:=methodpointer.getcopy;
-                  if methodpointer.resultdef.typ<>classrefdef then
+                  if (methodpointer.resultdef.typ<>classrefdef) or
+                     (methodpointer.nodetype = typen) then
                     selftree:=cloadvmtaddrnode.create(selftree);
                 end
               else
diff --git a/tests/webtbs/tw8145.pp b/tests/webtbs/tw8145.pp
new file mode 100644
index 0000000000..cdd5c18301
--- /dev/null
+++ b/tests/webtbs/tw8145.pp
@@ -0,0 +1,105 @@
+program ClassOfDifference;
+
+{$IFDEF FPC}
+  {$mode delphi}
+{$ENDIF}
+
+var
+  l: longint;
+
+type
+  TMyObject = class
+    class procedure Foo;
+    class procedure Foo2; virtual;
+  end;
+
+  TMyClass = class of TMyObject;
+
+  TMyDerivedObject = class(TMyObject)
+    class procedure Foo2; override;
+  end;
+
+  TMyDerivedClass = class of TMyDerivedObject;
+
+
+  TMyObject2 = class
+    class procedure Foo3;
+  end;
+  TMyClass2 = class of TMyObject2;
+
+  TMyDerivedObject2 = class(TMyObject2)
+  end;
+  TMyDerivedClass2 = class of TMyDerivedObject2;
+
+
+class procedure TMyObject.Foo;
+begin
+  if (l <> 1) then
+    halt(1);
+end;
+
+class procedure TMyObject.Foo2;
+begin
+  if (l <> 2) then
+    halt(2);
+end;
+
+
+class procedure TMyDerivedObject.Foo2;
+begin
+  if (l <> 3) then
+    halt(3);
+end;
+
+
+class procedure TMyObject2.Foo3;
+begin
+  if (l <> 4) then
+    halt(4);
+end;
+
+
+var
+  MyClassA : TMyClass = TMyObject;
+  MyClassB : TMyClass = TMyDerivedObject;
+  MyDerivedClass : TMyDerivedClass = TMyDerivedObject;
+
+  MyClassA2 : TMyClass2 = TMyObject2;
+  MyClassB2 : TMyClass2 = TMyDerivedObject2;
+  MyDerivedClass2 : TMyDerivedClass2 = TMyDerivedObject2;
+
+begin
+
+  l := 1;
+  TMyObject.Foo; //works in FPC and Delphi
+  TMyDerivedObject.Foo; //works in FPC and Delphi
+
+  MyClassA.Foo; //works in FPC and Delphi
+  MyClassB.Foo; //works in FPC and Delphi
+  MyDerivedClass.Foo; //works in FPC and Delphi
+  TMyClass.Foo; //works only in Delphi
+  TMyDerivedClass.Foo; //works only in Delphi
+
+  l := 2;
+  TMyObject.Foo2;
+  MyClassA.Foo2;
+  TMyClass.Foo2;
+
+  l := 3;
+  TMyDerivedObject.Foo2;
+  TMyDerivedClass.Foo2;
+  MyClassB.Foo2;
+
+
+  l := 4;
+  TMyObject2.Foo3; //works in FPC and Delphi
+  TMyDerivedObject2.Foo3; //works in FPC and Delphi
+
+  MyClassA2.Foo3; //works in FPC and Delphi
+  MyClassB2.Foo3; //works in FPC and Delphi
+  MyDerivedClass2.Foo3; //works in FPC and Delphi
+  TMyClass2.Foo3; //works only in Delphi
+  TMyDerivedClass2.Foo3; //works only in Delphi
+
+end.
+