Просмотр исходного кода

* fixed calling inherited class methods from a regular method (mantis
#11825)

git-svn-id: trunk@12810 -

Jonas Maebe 16 лет назад
Родитель
Сommit
5474004dcc
3 измененных файлов с 64 добавлено и 1 удалено
  1. 1 0
      .gitattributes
  2. 9 1
      compiler/ncal.pas
  3. 54 0
      tests/webtbs/tw11825.pp

+ 1 - 0
.gitattributes

@@ -8703,6 +8703,7 @@ tests/webtbs/tw11762.pp svneol=native#text/plain
 tests/webtbs/tw11763.pp svneol=native#text/plain
 tests/webtbs/tw11786.pp svneol=native#text/plain
 tests/webtbs/tw1181.pp svneol=native#text/plain
+tests/webtbs/tw11825.pp svneol=native#text/plain
 tests/webtbs/tw11846a.pp svneol=native#text/plain
 tests/webtbs/tw11846b.pp svneol=native#text/plain
 tests/webtbs/tw11848.pp svneol=native#text/plain

+ 9 - 1
compiler/ncal.pas

@@ -1469,7 +1469,15 @@ implementation
 
         { inherited }
         if (cnf_inherited in callnodeflags) then
-          selftree:=load_self_node
+          begin
+            selftree:=load_self_node;
+           { we can call an inherited class static/method from a regular method
+             -> self node must change from instance pointer to vmt pointer)
+           }
+           if (procdefinition.procoptions*[po_classmethod,po_staticmethod] <> []) and
+              (selftree.resultdef.typ<>classrefdef) then
+             selftree:=cloadvmtaddrnode.create(selftree);
+          end
         else
           { constructors }
           if (procdefinition.proctypeoption=potype_constructor) then

+ 54 - 0
tests/webtbs/tw11825.pp

@@ -0,0 +1,54 @@
+{$MODE objfpc}
+
+program bug7;
+
+type
+  TMyObj = class;
+  TMyObjClass = class of TMyObj;
+
+  TMyObj = class(TObject)
+     function ClassType: TMyObjClass; reintroduce;
+     class function test: string;
+  end;	
+
+  TMyObj2 = class(TMyObj)
+  end;
+
+
+var O: TObject;
+
+
+
+function TMyObj.ClassType: TMyObjClass;
+begin
+   Result := TMyObjClass(inherited ClassType);
+end;
+
+class function tmyobj.test: string;
+begin
+  result:=inherited classname;
+end;
+
+function GetObj: TObject;
+begin
+   Result := O
+end;
+
+function GetMyObj: TMyObj;
+begin
+   Result:= TMyObj(GetObj)
+end; 
+
+
+
+begin
+   O := TMyObj2.Create;
+   WriteLn(GetMyObj.ClassName);
+   WriteLn(GetMyObj.ClassType.ClassName);
+   if (GetMyObj.ClassName<>'TMyObj2') or
+      (GetMyObj.ClassType.ClassName<>'TMyObj2') then
+     halt(1);
+   writeln(tmyobj.test);
+   if (tmyobj.test<>'TMyObj') then
+     halt(2);
+end.