compiler: types in classes:

  - fix type visibility (was always public)
  - fix parsing of class sections after the type declaration
  - allow nested classes declarations
  + tests

git-svn-id: trunk@14607 -

.gitattributes

@@ -8890,6 +8890,8 @@ tests/test/tcg1.pp svneol=native#text/plain
 tests/test/tcint64.pp svneol=native#text/plain
 tests/test/tclass1.pp svneol=native#text/plain
 tests/test/tclass10.pp svneol=native#text/pascal
+tests/test/tclass11a.pp svneol=native#text/pascal
+tests/test/tclass11b.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

compiler/pdecl.pas

@@ -38,7 +38,7 @@ interface
     procedure const_dec;
     procedure label_dec;
     procedure type_dec;
-    procedure types_dec;
+    procedure types_dec(in_class: boolean);
     procedure var_dec;
     procedure threadvar_dec;
     procedure property_dec(is_classpropery: boolean);
@@ -282,7 +282,7 @@ implementation
       end;
 
 
-    procedure types_dec;
+    procedure types_dec(in_class: boolean);
 
       procedure get_cpp_class_external_status(od: tobjectdef);
         var
@@ -483,6 +483,7 @@ implementation
               hdef:=generrordef;
               storetokenpos:=current_tokenpos;
               newtype:=ttypesym.create(orgtypename,hdef);
+              newtype.visibility:=symtablestack.top.currentvisibility;
               symtablestack.top.insert(newtype);
               current_tokenpos:=defpos;
               current_tokenpos:=storetokenpos;
@@ -619,7 +620,7 @@ implementation
              end;
            if assigned(generictypelist) then
              generictypelist.free;
-         until token<>_ID;
+         until (token<>_ID)or(in_class and (idtoken in [_PRIVATE,_PROTECTED,_PUBLIC,_PUBLISHED,_STRICT]));
          resolve_forward_types;
          block_type:=old_block_type;
       end;
@@ -629,7 +630,7 @@ implementation
     procedure type_dec;
       begin
         consume(_TYPE);
-        types_dec;
+        types_dec(false);
       end;
 
 

compiler/pdecobj.pas

@@ -671,7 +671,7 @@ implementation
                               read_record_fields([vd_object])
                           end
                         else
-                          types_dec;
+                          types_dec(true);
                       end;
                 end;
               end;
@@ -843,7 +843,7 @@ implementation
         current_objectdef:=nil;
 
         { objects and class types can't be declared local }
-        if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable]) and
+        if not(symtablestack.top.symtabletype in [globalsymtable,staticsymtable,objectsymtable]) and
            not assigned(genericlist) then
           Message(parser_e_no_local_objects);
 

compiler/pdecsub.pas

@@ -764,52 +764,65 @@ implementation
            (symtablestack.top.symtablelevel=main_program_level) and
            try_to_consume(_POINT) then
          begin
-           { search for object name }
-           storepos:=current_tokenpos;
-           current_tokenpos:=procstartfilepos;
-           searchsym(sp,srsym,srsymtable);
-           if not assigned(srsym) then
-            begin
-              identifier_not_found(orgsp);
-              srsym:=generrorsym;
-            end;
-           current_tokenpos:=storepos;
-           { consume proc name }
-           sp:=pattern;
-           orgsp:=orgpattern;
-           procstartfilepos:=current_tokenpos;
-           consume(_ID);
-           { qualifier is class name ? }
-           if (srsym.typ=typesym) and
-              (ttypesym(srsym).typedef.typ=objectdef) then
-            begin
-              aclass:=tobjectdef(ttypesym(srsym).typedef);
-              srsym:=tsym(aclass.symtable.Find(sp));
-              if assigned(srsym) then
-               begin
-                 if srsym.typ=procsym then
-                   aprocsym:=tprocsym(srsym)
-                 else
-                   begin
-                     {  we use a different error message for tp7 so it looks more compatible }
-                     if (m_fpc in current_settings.modeswitches) then
-                       Message1(parser_e_overloaded_no_procedure,srsym.realname)
-                     else
-                       Message(parser_e_methode_id_expected);
-                     { rename the name to an unique name to avoid an
-                       error when inserting the symbol in the symtable }
-                     orgsp:=orgsp+'$'+tostr(current_filepos.line);
-                   end;
-               end
-              else
+           repeat
+             searchagain:=false;
+             if not assigned(aclass) then
                begin
-                 Message(parser_e_methode_id_expected);
-                 { recover by making it a normal procedure instead of method }
-                 aclass:=nil;
+                 { search for object name }
+                 storepos:=current_tokenpos;
+                 current_tokenpos:=procstartfilepos;
+                 searchsym(sp,srsym,srsymtable);
+                 if not assigned(srsym) then
+                  begin
+                    identifier_not_found(orgsp);
+                    srsym:=generrorsym;
+                  end;
+                 current_tokenpos:=storepos;
                end;
-            end
-           else
-            Message(parser_e_class_id_expected);
+             { consume proc name }
+             sp:=pattern;
+             orgsp:=orgpattern;
+             procstartfilepos:=current_tokenpos;
+             consume(_ID);
+             { qualifier is class name ? }
+             if (srsym.typ=typesym) and
+                (ttypesym(srsym).typedef.typ=objectdef) then
+              begin
+                aclass:=tobjectdef(ttypesym(srsym).typedef);
+                srsym:=tsym(aclass.symtable.Find(sp));
+                if assigned(srsym) then
+                 begin
+                   if srsym.typ=procsym then
+                     aprocsym:=tprocsym(srsym)
+                   else
+                   if (srsym.typ=typesym) and
+                      (ttypesym(srsym).typedef.typ=objectdef) then
+                     begin
+                       searchagain:=true;
+                       consume(_POINT);
+                     end
+                   else
+                     begin
+                       {  we use a different error message for tp7 so it looks more compatible }
+                       if (m_fpc in current_settings.modeswitches) then
+                         Message1(parser_e_overloaded_no_procedure,srsym.realname)
+                       else
+                         Message(parser_e_methode_id_expected);
+                       { rename the name to an unique name to avoid an
+                         error when inserting the symbol in the symtable }
+                       orgsp:=orgsp+'$'+tostr(current_filepos.line);
+                     end;
+                 end
+                else
+                 begin
+                   Message(parser_e_methode_id_expected);
+                   { recover by making it a normal procedure instead of method }
+                   aclass:=nil;
+                 end;
+              end
+             else
+              Message(parser_e_class_id_expected);
+           until not searchagain;
          end
         else
          begin

compiler/symdef.pas

@@ -3230,19 +3230,28 @@ implementation
       var
         s : string;
         t : ttoken;
+        tmp: tobjectdef;
       begin
 {$ifdef EXTDEBUG}
         showhidden:=true;
 {$endif EXTDEBUG}
         s:='';
-        if owner.symtabletype=localsymtable then
-         s:=s+'local ';
         if assigned(_class) then
          begin
-           if po_classmethod in procoptions then
-            s:=s+'class ';
-           s:=s+_class.objrealname^+'.';
+           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;
+           if (po_classmethod in procoptions) then
+             s:='class ' + s;
          end;
+        if owner.symtabletype=localsymtable then
+          s:='local ' + s;
         if proctypeoption=potype_operator then
           begin
             for t:=NOTOKEN to last_overloaded do

tests/test/tclass11a.pp

@@ -0,0 +1,64 @@
+program tclass11a;
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+{$apptype console}
+
+type
+  TSomeClass = class
+  strict private
+    type
+      TPrivateNestedClass = class
+      public
+        procedure DoSomething;
+      end;
+  public
+    type
+      TNestedClass = class
+      public
+        procedure DoSomething;
+      end;
+    class procedure Test; virtual;
+  end;
+
+  TDescendant = class(TSomeClass)
+  public
+    class procedure Test; override;
+  end;
+
+procedure TSomeClass.TPrivateNestedClass.DoSomething;
+begin
+  WriteLn('TSomeClass.TPrivateNestedClass.DoSomething: ok');
+end;
+
+procedure TSomeClass.TNestedClass.DoSomething;
+begin
+  WriteLn('TSomeClass.TNestedClass.DoSomething: ok');
+end;
+
+class procedure TSomeClass.Test;
+var
+  P: TPrivateNestedClass;
+  N: TNestedClass;
+begin
+  P := TPrivateNestedClass.Create;
+  P.DoSomething;
+  P.Free;
+  N := TNestedClass.Create;
+  N.DoSomething;
+  N.Free;
+end;
+
+class procedure TDescendant.Test;
+var
+  N: TNestedClass;
+begin
+  N := TNestedClass.Create;
+  N.DoSomething;
+  N.Free;
+end;
+
+begin
+  TSomeClass.Test;
+  TDescendant.Test;
+end.

tests/test/tclass11b.pp

@@ -0,0 +1,70 @@
+{ %FAIL}
+program tclass11b;
+
+{$ifdef fpc}
+  {$mode delphi}
+{$endif}
+{$apptype console}
+
+type
+  TSomeClass = class
+  strict private
+    type
+      TPrivateNestedClass = class
+      public
+        procedure DoSomething;
+      end;
+  public
+    type
+      TNestedClass = class
+      public
+        procedure DoSomething;
+      end;
+    class procedure Test; virtual;
+  end;
+
+  TDescendant = class(TSomeClass)
+  public
+    class procedure Test; override;
+  end;
+
+procedure TSomeClass.TPrivateNestedClass.DoSomething;
+begin
+  WriteLn('TSomeClass.TPrivateNestedClass.DoSomething: ok');
+end;
+
+procedure TSomeClass.TNestedClass.DoSomething;
+begin
+  WriteLn('TSomeClass.TNestedClass.DoSomething: ok');
+end;
+
+class procedure TSomeClass.Test;
+var
+  P: TPrivateNestedClass;
+  N: TNestedClass;
+begin
+  P := TPrivateNestedClass.Create;
+  P.DoSomething;
+  P.Free;
+  N := TNestedClass.Create;
+  N.DoSomething;
+  N.Free;
+end;
+
+class procedure TDescendant.Test;
+var
+  P: TPrivateNestedClass;
+  N: TNestedClass;
+begin
+  P := TPrivateNestedClass.Create;
+  P.DoSomething;
+  P.Free;
+  N := TNestedClass.Create;
+  N.DoSomething;
+  N.Free;
+end;
+
+begin
+  TSomeClass.Test;
+  TDescendant.Test;
+end.