浏览代码

compiler: nested class types:
- fix is_visible_for_object to work correctly if symbol is in the objectsymtable but no current_objectdef present
- fix ClassName for nested classes
+ test


git-svn-id: trunk@14617 -

paul 15 年之前
父节点
当前提交
6b087799ef
共有 5 个文件被更改,包括 87 次插入22 次删除
  1. 1 0
      .gitattributes
  2. 4 5
      compiler/nobj.pas
  3. 17 10
      compiler/symdef.pas
  4. 19 7
      compiler/symtable.pas
  5. 46 0
      tests/test/tclass13.pp

+ 1 - 0
.gitattributes

@@ -8895,6 +8895,7 @@ tests/test/tclass11b.pp svneol=native#text/pascal
 tests/test/tclass12a.pp svneol=native#text/pascal
 tests/test/tclass12b.pp svneol=native#text/pascal
 tests/test/tclass12c.pp svneol=native#text/pascal
+tests/test/tclass13.pp svneol=native#text/pascal
 tests/test/tclass2.pp svneol=native#text/plain
 tests/test/tclass3.pp svneol=native#text/plain
 tests/test/tclass4.pp svneol=native#text/plain

+ 4 - 5
compiler/nobj.pas

@@ -1394,13 +1394,11 @@ implementation
          methodnametable,intmessagetable,
          strmessagetable,classnamelabel,
          fieldtablelabel : tasmlabel;
+         hs: string;
 {$ifdef WITHDMT}
          dmtlabel : tasmlabel;
 {$endif WITHDMT}
          interfacetable : tasmlabel;
-{$ifdef vtentry}
-         hs: string;
-{$endif vtentry}
       begin
 {$ifdef WITHDMT}
          dmtlabel:=gendmt;
@@ -1422,8 +1420,9 @@ implementation
             fieldtablelabel:=generate_field_table;
             { write class name }
             current_asmdata.asmlists[al_globals].concat(Tai_label.Create(classnamelabel));
-            current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(_class.objrealname^)));
-            current_asmdata.asmlists[al_globals].concat(Tai_string.Create(_class.objrealname^));
+            hs:=_class.RttiName;
+            current_asmdata.asmlists[al_globals].concat(Tai_const.Create_8bit(length(hs)));
+            current_asmdata.asmlists[al_globals].concat(Tai_string.Create(hs));
 
             { generate message and dynamic tables }
             if (oo_has_msgstr in _class.objectoptions) then

+ 17 - 10
compiler/symdef.pas

@@ -316,6 +316,7 @@ interface
           procedure finish_objc_data;
           { C++ }
           procedure finish_cpp_data;
+          function RttiName: string;
        end;
 
        tclassrefdef = class(tabstractpointerdef)
@@ -3230,7 +3231,6 @@ implementation
       var
         s : string;
         t : ttoken;
-        tmp: tobjectdef;
       begin
 {$ifdef EXTDEBUG}
         showhidden:=true;
@@ -3238,15 +3238,7 @@ implementation
         s:='';
         if assigned(_class) then
          begin
-           tmp:=_class;
-           while assigned(tmp) do
-           begin
-             s:=tmp.objrealname^+'.'+s;
-             if assigned(tmp.owner) and (tmp.owner.symtabletype=ObjectSymtable) then
-               tmp:=tobjectdef(tmp.owner.defowner)
-             else
-               tmp:=nil;
-           end;
+           s:=_class.RttiName+'.';
            if (po_classmethod in procoptions) then
              s:='class ' + s;
          end;
@@ -4848,6 +4840,21 @@ implementation
         self.symtable.DefList.ForEachCall(@do_cpp_import_info,nil);
       end;
 
+    function tobjectdef.RttiName: string;
+      var
+        tmp: tobjectdef;
+      begin
+        Result:=objrealname^;
+        tmp:=self;
+        repeat
+          if tmp.owner.symtabletype=ObjectSymtable then
+            tmp:=tobjectdef(tmp.owner.defowner)
+          else
+            break;
+          Result:=tmp.objrealname^+'.'+Result;
+        until tmp=nil;
+      end;
+
 
 {****************************************************************************
                              TImplementedInterface

+ 19 - 7
compiler/symtable.pas

@@ -1601,10 +1601,16 @@ implementation
                       ) or
                       ( // the case of specialize inside the generic declaration
                        (symownerdef.owner.symtabletype = objectsymtable) and
-                       assigned(current_objectdef) and
                        (
-                         (current_objectdef=symownerdef) or
-                         (current_objectdef.owner.moduleid=symownerdef.owner.moduleid)
+                         assigned(current_objectdef) and
+                         (
+                           (current_objectdef=symownerdef) or
+                           (current_objectdef.owner.moduleid=symownerdef.owner.moduleid)
+                         )
+                       ) or
+                       (
+                         not assigned(current_objectdef) and
+                         (symownerdef.owner.moduleid=current_module.moduleid)
                        )
                       );
             end;
@@ -1636,11 +1642,17 @@ implementation
                        ) or
                        ( // the case of specialize inside the generic declaration
                         (symownerdef.owner.symtabletype = objectsymtable) and
-                        assigned(current_objectdef) and
                         (
-                         (current_objectdef=symownerdef) or
-                         (current_objectdef.owner.moduleid=symownerdef.owner.moduleid)
-                        )
+                          assigned(current_objectdef) and
+                          (
+                            (current_objectdef=symownerdef) or
+                            (current_objectdef.owner.moduleid=symownerdef.owner.moduleid)
+                          )
+                        ) or
+                        (
+                          not assigned(current_objectdef) and
+                          (symownerdef.owner.moduleid=current_module.moduleid)
+                         )
                        )
                       );
             end;

+ 46 - 0
tests/test/tclass13.pp

@@ -0,0 +1,46 @@
+program tclass13;
+
+{$ifdef fpc}
+  {$mode delphi}{$H+}
+{$endif}
+{$apptype console}
+uses
+  typinfo;
+type
+  TRootClass = class
+  public
+    type
+      TNode = class
+      private
+        FTest: Integer;
+        type
+          TNode = class
+          end;
+          en = (e1,e2);
+      published
+        property Test: Integer read FTest write FTest;
+      end;
+    class procedure DoTest;
+  end;
+
+class procedure TRootClass.DoTest;
+var
+  Test: TNode;
+  Test1: TNode.TNode;
+begin
+  Test := TNode.Create;
+  Test.Test := 1;
+  if Test.ClassName <> 'TRootClass.TNode' then
+    halt(1);
+  Test.Free;
+  Test1 := TNode.TNode.Create;
+  if Test1.ClassName <> 'TRootClass.TNode.TNode' then
+    halt(2);
+  Test1.Free;
+end;
+
+begin
+  TRootClass.DoTest;
+  if GetEnumName(TypeInfo(TRootClass.TNode.en), ord(e1))<>'e1' then
+    halt(3);
+end.