fcl-passrc: resolver: inherit RTTI visibility

packages/fcl-passrc/src/pasresolver.pp

@@ -8871,6 +8871,14 @@ begin
       else
         RaiseNotYetImplemented(20190825195203,aClass,GetObjName(El));
     until El=nil;
+
+    if not aClass.RTTIVisibility.Explicit then
+      begin
+      // inherit extended RTTI visibilities
+      aClass.RTTIVisibility.Fields:=AncestorClassEl.RTTIVisibility.Fields+aClass.RTTIVisibility.Fields;
+      aClass.RTTIVisibility.Methods:=AncestorClassEl.RTTIVisibility.Methods+aClass.RTTIVisibility.Methods;
+      aClass.RTTIVisibility.Properties:=AncestorClassEl.RTTIVisibility.Properties+aClass.RTTIVisibility.Properties;
+      end;
     end;
 
   if TopScope is TPasGenericParamsScope then
@@ -18662,6 +18670,7 @@ var
   SpecScope: TPasGenericScope;
 begin
   SpecEl.PackMode:=GenEl.PackMode;
+  SpecEl.RTTIVisibility:=GenEl.RTTIVisibility;
   if SpecializedItem<>nil then
     begin
     // specialized generic record
@@ -18704,6 +18713,7 @@ begin
   GenericTemplateTypes:=GenEl.GenericTemplateTypes;
   SpecEl.ObjKind:=GenEl.ObjKind;
   SpecEl.PackMode:=GenEl.PackMode;
+  SpecEl.RTTIVisibility:=GenEl.RTTIVisibility;
   if GenEl.HelperForType<>nil then
     RaiseNotYetImplemented(20190730182758,GenEl,'');
   if GenEl.IsForward then
@@ -22053,6 +22063,7 @@ begin
                               NewType.Name,NewType.Parent,NewType.Visibility,
                               NewType.SourceFilename,NewType.SourceLinenumber));
     aClass.ObjKind := AncestorClass.ObjKind;
+    aClass.RTTIVisibility:=AncestorClass.RTTIVisibility;
 
     // release old alias type
     OldType := TPasTypeAliasType(NewType);

packages/fcl-passrc/src/pastree.pp

@@ -432,7 +432,6 @@ type
     Destructor Destroy; override;
     Procedure FreeChildren(Prepare: boolean); override;
     function ElementTypeName: TPasTreeString; override;
-
   end;
 
 
@@ -463,6 +462,7 @@ type
   { TPasUnitModule }
 
   TPasUnitModule = Class(TPasModule)
+  public
     function ElementTypeName: TPasTreeString; override;
   end;
 

packages/fcl-passrc/src/pparser.pp

@@ -565,8 +565,7 @@ type
     procedure ParseStatement(Parent: TPasImplBlock; out NewImplElement: TPasImplElement);
     procedure ParseAdhocExpression(out NewExprElement: TPasExpr);
     procedure ParseLabels(AParent: TPasElement);
-    procedure ParseProcBeginBlock(Parent: TProcedureBody);
-    procedure ParseProcAsmBlock(Parent: TProcedureBody);
+    function ParseRTTIDirective(const Param: TPasScannerString; out Vis: TPasMembersType.TRTTIVisibility): boolean;
     // Function/Procedure declaration
     function ParseProcedureOrFunctionDecl(Parent: TPasElement;
       ProcType: TProcType; MustBeGeneric: boolean;
@@ -578,6 +577,8 @@ type
       Element: TPasProcedureType; ProcType: TProcType; OfObjectPossible: Boolean);
     procedure ParseProcedureBody(Parent: TPasElement);
     function ParseMethodResolution(Parent: TPasElement): TPasMethodResolution;
+    procedure ParseProcBeginBlock(Parent: TProcedureBody);
+    procedure ParseProcAsmBlock(Parent: TProcedureBody);
     // Properties for external access
     property FileResolver: TBaseFileResolver read FFileResolver;
     property Scanner: TPascalScanner read FScanner;
@@ -3841,7 +3842,7 @@ begin
       Scanner.UnSetTokenOption(toOperatorToken);
     NextToken;
     Scanner.SkipGlobalSwitches:=true;
-  //  writeln('TPasParser.ParseDeclarations Token=',CurTokenString,' ',CurToken, ' ',scanner.CurFilename);
+    //writeln('TPasParser.ParseDeclarations Token=',CurTokenString,' ',CurToken, ' ',scanner.CurFilename);
     case CurToken of
     tkend:
       begin
@@ -4778,7 +4779,6 @@ begin
         if AObjKind=okInterface then
           if SameText(Scanner.CurrentValueSwitch[vsInterfaces],'CORBA') then
             ClassEl.InterfaceType:=citCorba;
-        ClassEl.RTTIVisibility:=RTTIVisibility;
         if AddToParent and (Parent is TPasDeclarations) then
           TPasDeclarations(Parent).Classes.Add(ClassEl);
         ClassEl.IsExternal:=(AExternalName<>'');
@@ -4786,6 +4786,8 @@ begin
           ClassEl.ExternalName:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalName,'''');
         if AExternalNameSpace<>'' then
           ClassEl.ExternalNameSpace:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalNameSpace,'''');
+        if not ClassEl.IsExternal then
+          ClassEl.RTTIVisibility:=RTTIVisibility;
         InitGenericType(ClassEl,TypeParams);
         DoParseClassType(ClassEl);
         CheckHint(ClassEl,True);
@@ -5136,115 +5138,14 @@ end;
 
 procedure TPasParser.OnScannerDirectiveRTTI(Sender: TObject; Directive, Param: TPasScannerString;
   var Handled: boolean);
-// $rtti explicit|inherit space-separated-clauses
-// clause: methods|fields|properties([enums])
-// enums: comma separated list of vcPrivate,vcProtected,vcPublic,vcPublished
-var
-  p, l: Integer;
-
-  procedure Err;
-  begin
-    ParseExc(nErrInvalidCompilerDirectiveRTTI,SErrInvalidCompilerDirectiveX,[Directive]);
-  end;
-
-  procedure SkipWhiteSpace;
-  begin
-    while (p<=l) and (Param[p] in [' ',#9,#10,#13]) do
-      inc(p);
-  end;
-
-  function ReadIdentifier: string;
-  var
-    StartP: Integer;
-  begin
-    StartP:=p;
-    while (p<=l) and (Param[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
-      inc(p);
-    Result:=copy(Param,StartP,p-StartP);
-  end;
-
 var
-  StartP, ElType: Integer;
-  Value: String;
-  NewRTTIVisibility: TPasMembersType.TRTTIVisibility;
-  Visibility: TPasMembersType.TRTTIVisibilitySections;
+  NewVisibility: TPasMembersType.TRTTIVisibility;
 begin
   if not (po_CheckDirectiveRTTI in Options) then exit;
   Handled:=true;
-  p:=1;
-  l:=length(Param);
-
-  NewRTTIVisibility:=Default(TPasMembersType.TRTTIVisibility);
-
-  // read Explicit, Inherit
-  SkipWhiteSpace;
-  Value:=ReadIdentifier;
-  case lowercase(Value) of
-  'explicit': NewRTTIVisibility.Explicit:=true;
-  'inherit': NewRTTIVisibility.Explicit:=false;
-  else Err;
-  end;
-
-  // read clauses
-  while p<=l do
-    begin
-    // read what type of elements
-    SkipWhiteSpace;
-    if p>l then break;
-    Value:=ReadIdentifier;
-    case lowercase(Value) of
-    'fields': ElType:=0;
-    'methods': ElType:=1;
-    'properties': ElType:=2;
-    else Err;
-    end;
-
-    // parameters
-    SkipWhiteSpace;
-    if (p>l) or (Param[p]<>'(') then
-      Err;
-    inc(p);
-    SkipWhiteSpace;
-    if (p>l) or (Param[p]<>'[') then
-      Err;
-    inc(p);
-
-    Visibility:=[];
-    repeat
-      SkipWhiteSpace;
-      if (p<=l) and (Param[p]=']') then break;
-      Value:=ReadIdentifier;
-      case lowercase(Value) of
-      'vcprivate': Include(Visibility,vcPrivate);
-      'vcprotected': Include(Visibility,vcProtected);
-      'vcpublic': Include(Visibility,vcPublic);
-      'vcpublished': Include(Visibility,vcPublished);
-      else Err;
-      end;
-      SkipWhiteSpace;
-      if p>l then
-        Err;
-      case Param[p] of
-      ',': ;
-      ']': break;
-      else Err;
-      end;
-      inc(p);
-    until false;
-    inc(p);
-    SkipWhiteSpace;
-    if (p>l) or (Param[p]<>')') then
-      Err;
-    inc(p);
-
-    case ElType of
-    0: NewRTTIVisibility.Fields:=Visibility;
-    1: NewRTTIVisibility.Methods:=Visibility;
-    2: NewRTTIVisibility.Properties:=Visibility;
-    end;
-
-    end;
-  RTTIVisibility:=NewRTTIVisibility;
+  if not ParseRTTIDirective(Param,NewVisibility) then
+    ParseExc(nErrInvalidCompilerDirectiveRTTI,SErrInvalidCompilerDirectiveX,[Directive]);
+  RTTIVisibility:=NewVisibility;
 end;
 
 function TPasParser.SaveComments: String;
@@ -6749,6 +6650,112 @@ begin
 
 end;
 
+function TPasParser.ParseRTTIDirective(const Param: TPasScannerString; out Vis: TPasMembersType.
+  TRTTIVisibility): boolean;
+// $rtti explicit|inherit space-separated-clauses
+// clause: methods|fields|properties([enums])
+// enums: comma separated list of vcPrivate,vcProtected,vcPublic,vcPublished
+var
+  p, l: Integer;
+
+  procedure SkipWhiteSpace;
+  begin
+    while (p<=l) and (Param[p] in [' ',#9,#10,#13]) do
+      inc(p);
+  end;
+
+  function ReadIdentifier: TPasScannerString;
+  var
+    StartP: Integer;
+  begin
+    StartP:=p;
+    while (p<=l) and (Param[p] in ['a'..'z','A'..'Z','0'..'9','_']) do
+      inc(p);
+    Result:=copy(Param,StartP,p-StartP);
+  end;
+
+var
+  StartP, ElType: Integer;
+  Value: TPasScannerString;
+  Visibility: TPasMembersType.TRTTIVisibilitySections;
+begin
+  Result:=false;
+  Vis:=Default(TPasMembersType.TRTTIVisibility);
+
+  p:=1;
+  l:=length(Param);
+
+  // read Explicit, Inherit
+  SkipWhiteSpace;
+  Value:=ReadIdentifier;
+  case lowercase(Value) of
+  'explicit': Vis.Explicit:=true;
+  'inherit': Vis.Explicit:=false;
+  else exit;
+  end;
+
+  // read clauses
+  while p<=l do
+    begin
+    // read what type of elements
+    SkipWhiteSpace;
+    if p>l then break;
+    Value:=ReadIdentifier;
+    case lowercase(Value) of
+    'fields': ElType:=0;
+    'methods': ElType:=1;
+    'properties': ElType:=2;
+    else exit;
+    end;
+
+    // parameters
+    SkipWhiteSpace;
+    if (p>l) or (Param[p]<>'(') then
+      exit;
+    inc(p);
+    SkipWhiteSpace;
+    if (p>l) or (Param[p]<>'[') then
+      exit;
+    inc(p);
+
+    Visibility:=[];
+    repeat
+      SkipWhiteSpace;
+      if (p<=l) and (Param[p]=']') then break;
+      Value:=ReadIdentifier;
+      case lowercase(Value) of
+      'vcprivate': Include(Visibility,vcPrivate);
+      'vcprotected': Include(Visibility,vcProtected);
+      'vcpublic': Include(Visibility,vcPublic);
+      'vcpublished': Include(Visibility,vcPublished);
+      else exit;
+      end;
+      SkipWhiteSpace;
+      if p>l then
+        exit;
+      case Param[p] of
+      ',': ;
+      ']': break;
+      else exit;
+      end;
+      inc(p);
+    until false;
+    inc(p);
+    SkipWhiteSpace;
+    if (p>l) or (Param[p]<>')') then
+      exit;
+    inc(p);
+
+    case ElType of
+    0: Vis.Fields:=Visibility;
+    1: Vis.Methods:=Visibility;
+    2: Vis.Properties:=Visibility;
+    end;
+
+    end;
+  Result:=true;
+end;
+
 // Starts after the "procedure" or "function" token
 function TPasParser.GetProcedureClass(ProcType: TProcType): TPTreeElement;
 
@@ -7958,7 +7965,6 @@ begin
     end;
   ClassEl := TPasClassType(CreateElement(TPasClassType, AClassName,
     Parent, NamePos));
-  ClassEl.RTTIVisibility:=RTTIVisibility;
   Result:=ClassEl;
   ok:=false;
   try
@@ -7979,6 +7985,8 @@ begin
       if SameText(Scanner.CurrentValueSwitch[vsInterfaces],'CORBA') then
         ClassEl.InterfaceType:=citCorba;
       end;
+    if not ClassEl.IsExternal then
+      ClassEl.RTTIVisibility:=RTTIVisibility;
     DoParseClassType(ClassEl);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;

packages/fcl-passrc/src/pscanner.pp

@@ -5406,14 +5406,14 @@ procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
 var
   i: Integer;
 begin
+  i:=IndexOfDirectiveHandle(Directive);
+  if i>=0 then
+    FDirectiveHandles[i].Handler(Sender,Directive,Param,Handled);
   if Assigned(OnDirective) then
     begin
     OnDirective(Sender,Directive,Param,Handled);
     if Handled then exit;
     end;
-  i:=IndexOfDirectiveHandle(Directive);
-  if i>=0 then
-    FDirectiveHandles[i].Handler(Sender,Directive,Param,Handled);
 end;
 
 procedure TPascalScanner.HandleMultilineStringTrimLeft(const AParam: TPasScannerString);

packages/fcl-passrc/tests/tcresolver.pas

@@ -38,6 +38,7 @@ type
     Row: cardinal;
     StartCol, EndCol: integer; // token start, end column
     Identifier: string;
+    Param: string;
     Next: PSrcMarker;
   end;
 
@@ -154,6 +155,9 @@ type
     procedure CheckAccessMarkers; virtual;
     procedure CheckParamsExpr_pkSet_Markers; virtual;
     procedure CheckAttributeMarkers; virtual;
+    procedure CheckRTTIVisibility(aMarker: PSrcMarker; El: TPasMembersType; Explicit: boolean;
+        const ExpectedFields, ExpectedMethods, ExpectedProperties: TPasMembersType.TRTTIVisibilitySections); virtual;
+    procedure CheckRTTIVisibilityMarkers; virtual;
     procedure GetSrc(Index: integer; out SrcLines: TStringList; out aFilename: string);
     function FindElementsAt(aFilename: string; aLine, aStartCol, aEndCol: integer): TFPList;// list of TPasElement
     function FindElementsAt(aMarker: PSrcMarker; ErrorOnNoElements: boolean = true): TFPList;// list of TPasElement
@@ -665,6 +669,7 @@ type
     Procedure TestClass_TypeAlias;
     Procedure TestClass_Message;
     Procedure TestClass_Message_MissingParamFail;
+    Procedure TestClass_ExtRTTI_Explicit;
 
     // published
     Procedure TestClass_PublishedClassVarFail;
@@ -1317,7 +1322,7 @@ var
   end;
 
   function AddMarker(Kind: TSrcMarkerKind; const aFilename: string;
-    aLine, aStartCol, aEndCol: integer; const Identifier: string): PSrcMarker;
+    aLine, aStartCol, aEndCol: integer; const Identifier, Param: string): PSrcMarker;
   begin
     New(Result);
     Result^.Kind:=Kind;
@@ -1326,20 +1331,21 @@ var
     Result^.StartCol:=aStartCol;
     Result^.EndCol:=aEndCol;
     Result^.Identifier:=Identifier;
+    Result^.Param:=Param;
     Result^.Next:=nil;
     //writeln('AddMarker Line="',SrcLine,'" Identifier=',Identifier,' Col=',aStartCol,'-',aEndCol,' "',copy(SrcLine,aStartCol,aEndCol-aStartCol),'"');
     AddMarker(Result);
   end;
 
   function AddMarkerForTokenBehindComment(Kind: TSrcMarkerKind;
-    const Identifier: string): PSrcMarker;
+    const Identifier, Param: string): PSrcMarker;
   var
     TokenStart, p: PChar;
   begin
     p:=CommentEndP;
     ReadNextPascalToken(p,TokenStart,false,false);
     Result:=AddMarker(Kind,Filename,LineNumber,
-      CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifier);
+      CommentEndP-PChar(SrcLine)+1,p-PChar(SrcLine)+1,Identifier,Param);
   end;
 
   function ReadIdentifier(var p: PChar): string;
@@ -1356,9 +1362,17 @@ var
     Move(StartP^,Result[1],length(Result)*SizeOf(Char));
   end;
 
+  function ReadParam(p: PChar): string;
+  begin
+    while p^ in [' ',#9,#10,#13] do inc(p);
+    SetLength(Result{%H-},CommentEndP-p-1);
+    if Result>'' then
+      Move(p^,Result[1],length(Result)*SizeOf(Char));
+  end;
+
   procedure AddLabel;
   var
-    Identifier: String;
+    Identifier, Param: String;
     p: PChar;
   begin
     p:=CommentStartP+2;
@@ -1366,7 +1380,7 @@ var
     //writeln('TTestResolver.CheckReferenceDirectives.AddLabel ',Identifier);
     if FindSrcLabel(Identifier)<>nil then
       RaiseError('duplicate label "'+Identifier+'"',p);
-    AddMarkerForTokenBehindComment(mkLabel,Identifier);
+    AddMarkerForTokenBehindComment(mkLabel,Identifier,ReadParam(p));
   end;
 
   procedure AddResolverReference;
@@ -1377,7 +1391,7 @@ var
     p:=CommentStartP+2;
     Identifier:=ReadIdentifier(p);
     //writeln('TTestResolver.CheckReferenceDirectives.AddReference ',Identifier);
-    AddMarkerForTokenBehindComment(mkResolverReference,Identifier);
+    AddMarkerForTokenBehindComment(mkResolverReference,Identifier,ReadParam(p));
   end;
 
   procedure AddDirectReference;
@@ -1388,12 +1402,12 @@ var
     p:=CommentStartP+2;
     Identifier:=ReadIdentifier(p);
     //writeln('TTestResolver.CheckReferenceDirectives.AddDirectReference ',Identifier);
-    AddMarkerForTokenBehindComment(mkDirectReference,Identifier);
+    AddMarkerForTokenBehindComment(mkDirectReference,Identifier,ReadParam(p));
   end;
 
   procedure ParseCode(SrcLines: TStringList; aFilename: string);
   var
-    p,pstart,pend: PChar;
+    p,StartP,EndP: PChar;
     IsDirective: Boolean;
   begin
     //writeln('TTestResolver.CheckReferenceDirectives.ParseCode File=',aFilename);
@@ -1407,13 +1421,13 @@ var
       if SrcLine='' then continue;
       //writeln('TTestResolver.CheckReferenceDirectives Line=',SrcLine);
 
-      pstart:=PChar(SrcLine);
-      pend:=pstart;
-      inc(PEnd,length(SrcLine));
-      p:=pstart;
+      StartP:=PChar(SrcLine);
+      EndP:=StartP;
+      inc(EndP,length(SrcLine));
+      p:=StartP;
       repeat
         case p^ of
-          #0: if (p>=pend) then break;
+          #0: if (p>=EndP) then break;
           '{':
             begin
             CommentStartP:=p;
@@ -1424,7 +1438,7 @@ var
             repeat
               case p^ of
               #0:
-                if (p>=pend) then
+                if (p>=EndP) then
                   begin
                   // multi line comment
                   if IsDirective then
@@ -1435,10 +1449,10 @@ var
                     SrcLine:=SrcLines[LineNumber-1];
                     //writeln('TTestResolver.CheckReferenceDirectives Comment Line=',SrcLine);
                   until SrcLine<>'';
-                  pstart:=PChar(SrcLine);
-                  pend:=pstart;
-                  inc(PEnd,length(SrcLine));
-                  p:=pstart;
+                  StartP:=PChar(SrcLine);
+                  EndP:=StartP;
+                  inc(EndP,length(SrcLine));
+                  p:=StartP;
                   continue;
                   end;
               '}':
@@ -2036,6 +2050,60 @@ begin
     end;
 end;
 
+procedure TCustomTestResolver.CheckRTTIVisibility(aMarker: PSrcMarker; El: TPasMembersType;
+  Explicit: boolean; const ExpectedFields, ExpectedMethods, ExpectedProperties: TPasMembersType.
+  TRTTIVisibilitySections);
+
+  procedure Check(const Types: string; const Expected, Actual: TPasMembersType.TRTTIVisibilitySections);
+  begin
+    if Expected=Actual then exit;
+    RaiseErrorAtSrcMarker(Types+' visibility expected '+dbgs(Expected)+', but found '+dbgs(Actual),aMarker);
+  end;
+
+begin
+  if Explicit<>El.RTTIVisibility.Explicit then
+    if Explicit then
+      RaiseErrorAtSrcMarker('rtti visibility explicit expected',aMarker)
+    else
+      RaiseErrorAtSrcMarker('rtti visibility inherit expected',aMarker);
+  Check('Fields',El.RTTIVisibility.Fields,ExpectedFields);
+  Check('Methods',El.RTTIVisibility.Methods,ExpectedMethods);
+  Check('Properties',El.RTTIVisibility.Properties,ExpectedProperties);
+end;
+
+procedure TCustomTestResolver.CheckRTTIVisibilityMarkers;
+var
+  aMarker: PSrcMarker;
+  Elements: TFPList;
+  i: Integer;
+  Visibility: TPasMembersType.TRTTIVisibility;
+  MemberEl: TPasMembersType;
+begin
+  aMarker:=FirstSrcMarker;
+  while aMarker<>nil do
+    begin
+    if lowercase(LeftStr(aMarker^.Identifier,5))='rtti_' then
+      begin
+      //writeln('TTestResolver.CheckRTTIVisibilityMarkers ',aMarker^.Identifier,' "',aMarker^.Param,'" ',aMarker^.StartCol,' ',aMarker^.EndCol);
+      if not Parser.ParseRTTIDirective(aMarker^.Param,Visibility) then
+        RaiseErrorAtSrcMarker('invalid rtti marker',aMarker);
+      Elements:=FindElementsAt(aMarker);
+      try
+        i:=Elements.Count-1;
+        while (i>=0) and not (TPasElement(Elements[i]) is TPasMembersType) do dec(i);
+        if i<0 then
+          RaiseErrorAtSrcMarker('rtti marker not at membertype',aMarker);
+        MemberEl:=TPasMembersType(Elements[i]);
+        CheckRTTIVisibility(aMarker,MemberEl,Visibility.Explicit,
+          Visibility.Fields,Visibility.Methods,Visibility.Properties);
+      finally
+        Elements.Free;
+      end;
+      end;
+    aMarker:=aMarker^.Next;
+    end;
+end;
+
 procedure TCustomTestResolver.GetSrc(Index: integer; out SrcLines: TStringList; out
   aFilename: string);
 var
@@ -12015,6 +12083,27 @@ begin
   CheckResolverException(sMessageHandlersInvalidParams,nMessageHandlersInvalidParams);
 end;
 
+procedure TTestResolver.TestClass_ExtRTTI_Explicit;
+begin
+  Parser.Options:=Parser.Options+[po_CheckDirectiveRTTI];
+  StartProgram(false);
+  Add([
+  'type',
+  '  {$RTTI explicit Fields([vcProtected,vcPublic])}',
+  '  {#rtti_TObject explicit Fields([vcProtected,vcPublic])}TObject = class',
+  '  end;',
+  '  {$RTTI explicit Fields([vcPrivate,vcProtected])}',
+  '  {#rtti_TAnimal explicit Fields([vcPrivate,vcProtected])}TAnimal = class',
+  '  end;',
+  '  {$RTTI inherit Fields([vcPublic])}',
+  '  {#rtti_TBird inherit Fields([vcPrivate,vcProtected,vcPublic])}TBird = class(TAnimal)',
+  '  end;',
+  'begin',
+  '']);
+  ParseProgram;
+  CheckRTTIVisibilityMarkers;
+end;
+
 procedure TTestResolver.TestClass_PublishedClassVarFail;
 begin
   StartProgram(false);