fcl-passrc: option to parse directive rtti

packages/fcl-passrc/src/pastree.pp

@@ -766,9 +766,20 @@ type
   { TPasMembersType - base type for TPasRecordType and TPasClassType }
 
   TPasMembersType = class(TPasGenericType)
+  public
+    type
+      TRTTIVisibilitySection = (vcPrivate,vcProtected,vcPublic,vcPublished);
+      TRTTIVisibilitySections = set of TRTTIVisibilitySection;
+      TRTTIVisibility = record
+        Explicit: boolean; // inherit or explicit
+        Fields: TRTTIVisibilitySections;
+        Methods: TRTTIVisibilitySections;
+        Properties: TRTTIVisibilitySections;
+      end;
   public
     PackMode: TPackMode;
     Members: TFPList;
+    RTTIVisibility: TRTTIVisibility;
     Constructor Create(const AName: TPasTreeString; AParent: TPasElement); override;
     Destructor Destroy; override;
     procedure FreeChildren(Prepare: boolean); override;
@@ -1860,6 +1871,8 @@ procedure FreePasExprArray(Parent: TPasElement; var A: TPasExprArray; Prepare: b
 function GenericTemplateTypesAsString(List: TFPList): TPasTreeString;
 
 function dbgs(const s: TProcTypeModifiers): TPasTreeString; overload;
+function dbgs(const v: TPasMembersType.TRTTIVisibilitySection): TPasTreeString; overload;
+function dbgs(const Sections: TPasMembersType.TRTTIVisibilitySections): TPasTreeString; overload;
 function WritePasElTree(Expr: TPasExpr; FollowPrefix: TPasTreeString = ''): TPasTreeString;
 function GetPasElementDesc(El: TPasElement): TPasTreeString;
 
@@ -1935,6 +1948,24 @@ begin
   Result:='['+Result+']';
 end;
 
+function dbgs(const v: TPasMembersType.TRTTIVisibilitySection): TPasTreeString;
+begin
+  str(v,Result);
+end;
+
+function dbgs(const Sections: TPasMembersType.TRTTIVisibilitySections): TPasTreeString;
+var
+  s: TPasMembersType.TRTTIVisibilitySection;
+begin
+  Result:='';
+  for s in Sections do
+    begin
+    if Result<>'' then Result:=Result+',';
+    Result:=Result+dbgs(s);
+    end;
+  Result:='['+Result+']';
+end;
+
 function WritePasElTree(Expr: TPasExpr; FollowPrefix: TPasTreeString): TPasTreeString;
 {  TBinary Kind= OpCode=
     +Left=TBinary Kind= OpCode=

packages/fcl-passrc/src/pparser.pp

@@ -111,7 +111,7 @@ const
   nFileSystemsNotSupported = 2057;
   nInvalidMessageType = 2058;
   nErrCompilationAborted = 2059; // FPC = 1018;
-
+  nErrInvalidCompilerDirectiveRTTI = 2060;
 
 // resourcestring patterns of messages
 resourcestring
@@ -175,6 +175,7 @@ resourcestring
   SErrFileSystemNotSupported = 'No support for filesystems enabled';
   SErrInvalidMessageType = 'Invalid message type: string or integer expression expected';
   SErrCompilationAborted = 'Compilation aborted';
+  SErrInvalidCompilerDirectiveX = 'Invalid compiler directive %s';
 
 type
   TPasScopeType = (
@@ -391,6 +392,8 @@ type
     procedure SetOptions(AValue: TPOptions);
     procedure OnScannerModeChanged(Sender: TObject; NewMode: TModeSwitch;
       Before: boolean; var Handled: boolean);
+    procedure OnScannerDirectiveRTTI(Sender: TObject; Directive, Param: TPasScannerString;
+      var Handled: boolean);
   protected
     function AllowFinal(aType: TPasType): Boolean;
     function CheckCurtokenIsFinal(aType: TPasType): boolean;
@@ -482,8 +485,9 @@ type
     // Set this to false to NOT raise an error when errors were ignored during parsing.
     Property FailOnModuleErors : Boolean Read FFailOnModuleErors Write FFailOnModuleErors;
   public
+    RTTIVisibility: TPasMembersType.TRTTIVisibility;
     constructor Create(AScanner: TPascalScanner; AFileResolver: TBaseFileResolver;  AEngine: TPasTreeContainer);
-    Destructor Destroy; override;
+    destructor Destroy; override;
     procedure SetLastMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : String; Args : Array of const);
     // General parsing routines
     function CurTokenName: String;
@@ -492,7 +496,7 @@ type
     function CurTokenPos: TPasSourcePos;
     function CurSourcePos: TPasSourcePos;
     function HasToken: boolean;
-    Function SavedComments : String;
+    function SavedComments : String;
     procedure NextToken; // read next non whitespace, non space
     procedure ChangeToken(tk: TToken);
     procedure UngetToken;
@@ -502,8 +506,8 @@ type
     procedure ExpectTokens(tk:  TTokens);
     function GetPrevToken: TToken;
     function ExpectIdentifier(CountAsIdentifier : TTokens = []): String;
-    Procedure SaveIdentifierPosition;
-    Function CurTokenIsIdentifier(Const S : String) : Boolean;
+    procedure SaveIdentifierPosition;
+    function CurTokenIsIdentifier(Const S : String) : Boolean;
     // Expression parsing
     function isEndOfExp(AllowEqual : Boolean = False; CheckHints : Boolean = True): Boolean;
     function ExprToText(Expr: TPasExpr): String;
@@ -1246,6 +1250,7 @@ begin
   FScanner := AScanner;
   if FScanner.OnModeChanged=nil then
     FScanner.OnModeChanged:=@OnScannerModeChanged;
+  FScanner.RegisterDirectiveHandler('rtti',@OnScannerDirectiveRTTI);
   FFileResolver := AFileResolver;
   FTokenRingCur:=High(FTokenRing);
   FEngine := AEngine;
@@ -4773,6 +4778,7 @@ 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<>'');
@@ -4789,6 +4795,7 @@ begin
        begin
        RecordEl := TPasRecordType(CreateElement(TPasRecordType,
          TypeName, Parent, visDefault, NamePos, TypeParams));
+       RecordEl.RTTIVisibility:=RTTIVisibility;
        if AddToParent and (Parent is TPasDeclarations) then
          TPasDeclarations(Parent).Classes.Add(RecordEl);
        InitGenericType(RecordEl,TypeParams);
@@ -5127,6 +5134,119 @@ begin
   if Sender=nil then ;
 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;
+begin
+  if not (po_CheckRTTI 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;
+end;
+
 function TPasParser.SaveComments: String;
 begin
   if Engine.NeedComments then
@@ -6871,7 +6991,7 @@ procedure TPasParser.ParseRecordVariantParts(ARec: TPasRecordType;
   AEndToken: TToken);
 
 Var
-  M : TPasRecordType;
+  RecordEl : TPasRecordType;
   V : TPasVariant;
   Done : Boolean;
 
@@ -6887,9 +7007,10 @@ begin
     Until (curToken=tkColon);
     ExpectToken(tkBraceOpen);
     NextToken;
-    M:=TPasRecordType(CreateElement(TPasRecordType,'',V));
-    V.Members:=M;
-    ParseRecordMembers(M,tkBraceClose,False);
+    RecordEl:=TPasRecordType(CreateElement(TPasRecordType,'',V));
+    RecordEl.RTTIVisibility:=RTTIVisibility;
+    V.Members:=RecordEl;
+    ParseRecordMembers(RecordEl,tkBraceClose,False);
     // Current token is closing ), so we eat that
     NextToken;
     // If there is a semicolon, we eat that too.
@@ -7163,6 +7284,7 @@ var
   AllowAdvanced : Boolean;
 begin
   Result := TPasRecordType(CreateElement(TPasRecordType, TypeName, Parent, NamePos));
+  Result.RTTIVisibility:=RTTIVisibility;
   Result.PackMode:=PackMode;
   NextToken;
   AllowAdvanced:=(msAdvancedRecords in Scanner.CurrentModeSwitches)
@@ -7804,7 +7926,7 @@ function TPasParser.ParseClassDecl(Parent: TPasElement;
 Var
   isExternal, isSealed, isAbstract, ok: Boolean;
   AExternalNameSpace,AExternalName : String;
-  PCT:TPasClassType;
+  ClassEl: TPasClassType;
 
 begin
   NextToken;
@@ -7834,34 +7956,35 @@ begin
       ParseExcSyntaxError;
     NextToken;
     end;
-  PCT := TPasClassType(CreateElement(TPasClassType, AClassName,
+  ClassEl := TPasClassType(CreateElement(TPasClassType, AClassName,
     Parent, NamePos));
-  Result:=PCT;
+  ClassEl.RTTIVisibility:=RTTIVisibility;
+  Result:=ClassEl;
   ok:=false;
   try
     if IsAbstract then
-      PCT.Modifiers.Add('abstract');
+      ClassEl.Modifiers.Add('abstract');
     if IsSealed then
-      PCT.Modifiers.Add('sealed');
-    PCT.HelperForType:=nil;
-    PCT.IsExternal:=IsExternal;
+      ClassEl.Modifiers.Add('sealed');
+    ClassEl.HelperForType:=nil;
+    ClassEl.IsExternal:=IsExternal;
     if AExternalName<>'' then
-      PCT.ExternalName:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalName,'''');
+      ClassEl.ExternalName:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalName,'''');
     if AExternalNameSpace<>'' then
-      PCT.ExternalNameSpace:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalNameSpace,'''');
-    PCT.ObjKind := AObjKind;
-    PCT.PackMode:=PackMode;
+      ClassEl.ExternalNameSpace:={$ifdef pas2js}DeQuoteString{$else}AnsiDequotedStr{$endif}(AExternalNameSpace,'''');
+    ClassEl.ObjKind := AObjKind;
+    ClassEl.PackMode:=PackMode;
     if AObjKind=okInterface then
       begin
       if SameText(Scanner.CurrentValueSwitch[vsInterfaces],'CORBA') then
-        PCT.InterfaceType:=citCorba;
+        ClassEl.InterfaceType:=citCorba;
       end;
-    DoParseClassType(PCT);
+    DoParseClassType(ClassEl);
     Engine.FinishScope(stTypeDef,Result);
     ok:=true;
   finally
     if not ok then
-      PCT.Parent:=nil; // clear references from members to PCT
+      ClassEl.Parent:=nil; // clear references from members to ClassEl
   end;
 end;
 

packages/fcl-passrc/src/pscanner.pp

@@ -41,7 +41,7 @@ uses
   {$ENDIF}
   Types,
   {$endif}
-  SysUtils, Classes;
+  SysUtils, Classes, Types;
 {$ENDIF FPC_DOTTEDUNITS}
 
 // message numbers
@@ -727,11 +727,12 @@ type
     po_ExtConstWithoutExpr,  // allow typed const without expression in external class and with external modifier
     po_StopOnUnitInterface,  // parse only a unit name and stop at interface keyword
     po_IgnoreUnknownResource,// Ignore resources for which no handler is registered.
-    po_AsyncProcs,            // allow async procedure modifier
-    po_DisableResources,      // Disable resources altogether
+    po_AsyncProcs,           // allow async procedure modifier
+    po_DisableResources,     // Disable resources altogether
     po_AsmPascalComments,    // Allow pascal comments/directives in asm blocks
-    po_AllowMem,              // Allow use of meml, mem, memw arrays
-    po_WarnResourceNotFound // Do not raise error if resource not found.
+    po_AllowMem,             // Allow use of meml, mem, memw arrays
+    po_WarnResourceNotFound, // Do not raise error if resource not found.
+    po_CheckRTTI             // parse $RTTI directive and error on invalid
     );
   TPOptions = set of TPOption;
 
@@ -768,6 +769,10 @@ type
         Ext : TPasScannerString;
         Handler : TResourceHandler;
       end;
+      TDirectiveHandlerRecord = record
+        Directive : TPasScannerString;
+        Handler : TPScannerDirectiveEvent;
+      end;
       TWarnMsgNumberState = record
         Number: integer;
         State: TWarnMsgState;
@@ -829,7 +834,8 @@ type
     FIncludeStack: TFPList;
     FFiles: TStrings;
     FWarnMsgStates: TWarnMsgNumberStateArr;
-    FResourceHandlers : Array of TResourceHandlerRecord;
+    FResourceHandlers: Array of TResourceHandlerRecord;
+    FDirectiveHandles: Array of TDirectiveHandlerRecord;
 
     // Preprocessor $IFxxx skipping data
     PPSkipMode: TPascalScannerPPSkipMode;
@@ -858,17 +864,18 @@ type
     // extension without initial dot (.)
     Function IndexOfResourceHandler(Const aExt : TPasScannerString) : Integer;
     Function FindResourceHandler(Const aExt : TPasScannerString) : TResourceHandler;
+    function IndexOfDirectiveHandle(const aDirective: TPasScannerString; ForInsert: boolean = false): Integer;
     function ReadIdentifier(const AParam: TPasScannerString): TPasScannerString;
     function FetchLine: boolean;
     procedure AddFile(aFilename: TPasScannerString); virtual;
     function GetMacroName(const Param: TPasScannerString): TPasScannerString;
     procedure SetCurMsg(MsgType: TMessageType; MsgNumber: integer; Const Fmt : TPasScannerString; Args : Array of const);
     procedure SetCurMsg(MsgType: TMessageType; MsgNumber: integer; Const Msg : TPasScannerString);
-    Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : TPasScannerString; SkipSourceInfo : Boolean = False);overload;
-    Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : TPasScannerString; Args : Array of const;SkipSourceInfo : Boolean = False);overload;
-    procedure ErrorAt(MsgNumber: integer; const Msg: TPasScannerString; aRow,ACol : Integer);overload;
-    procedure Error(MsgNumber: integer; const Msg: TPasScannerString);overload;
-    procedure Error(MsgNumber: integer; const Fmt: TPasScannerString; Args: array of const);overload;
+    Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Msg : TPasScannerString; SkipSourceInfo : Boolean = False); overload;
+    Procedure DoLog(MsgType: TMessageType; MsgNumber: integer; Const Fmt : TPasScannerString; Args : Array of const;SkipSourceInfo : Boolean = False); overload;
+    procedure ErrorAt(MsgNumber: integer; const Msg: TPasScannerString; aRow,ACol : Integer); overload;
+    procedure Error(MsgNumber: integer; const Msg: TPasScannerString); overload;
+    procedure Error(MsgNumber: integer; const Fmt: TPasScannerString; Args: array of const); overload;
     procedure PushSkipMode;
     function GetMultiLineStringLineEnd(aReader: TLineReader): TPasScannerString;
     function MakeLibAlias(const LibFileName: TPasScannerString): TPasScannerString; virtual;
@@ -932,12 +939,14 @@ type
     constructor Create(AFileResolver: TBaseFileResolver);
     destructor Destroy; override;
     // extension without initial dot  (.), case insensitive
-    Procedure RegisterResourceHandler(aExtension : String; aHandler : TResourceHandler); overload;
-    Procedure RegisterResourceHandler(aExtensions : Array of String; aHandler : TResourceHandler); overload;
+    procedure RegisterResourceHandler(aExtension : String; const aHandler : TResourceHandler); overload;
+    procedure RegisterResourceHandler(const aExtensions : Array of String; const aHandler : TResourceHandler); overload;
+    procedure RegisterDirectiveHandler(const aDirective: String; const aHandler : TPScannerDirectiveEvent); overload;
+    procedure RegisterDirectiveHandler(const aDirectives : TStringDynArray; const aHandler : TPScannerDirectiveEvent); overload;
     procedure OpenFile(AFilename: TPasScannerString);
     procedure FinishedModule; virtual; // called by parser after end.
     function FormatPath(const aFilename: String): String; virtual;
-    Procedure DisablePackageTokens;
+    procedure DisablePackageTokens;
     procedure SetNonToken(aToken : TToken);
     procedure UnsetNonToken(aToken : TToken);
     procedure SetTokenOption(aOption : TTokenoption);
@@ -3393,7 +3402,8 @@ begin
   inherited Destroy;
 end;
 
-procedure TPascalScanner.RegisterResourceHandler(aExtension: String; aHandler: TResourceHandler);
+procedure TPascalScanner.RegisterResourceHandler(aExtension: String;
+  const aHandler: TResourceHandler);
 
 Var
   Idx: Integer;
@@ -3413,7 +3423,8 @@ begin
   FResourceHandlers[Idx].handler:=aHandler;
 end;
 
-procedure TPascalScanner.RegisterResourceHandler(aExtensions: array of String; aHandler: TResourceHandler);
+procedure TPascalScanner.RegisterResourceHandler(const aExtensions: array of String;
+  const aHandler: TResourceHandler);
 
 Var
   S : TPasScannerString;
@@ -3423,6 +3434,38 @@ begin
     RegisterResourceHandler(S,aHandler);
 end;
 
+procedure TPascalScanner.RegisterDirectiveHandler(const aDirective: String;
+  const aHandler: TPScannerDirectiveEvent);
+var
+  i: Integer;
+  Item: TDirectiveHandlerRecord;
+begin
+  if aDirective='' then exit;
+  i:=IndexOfDirectiveHandle(aDirective,true);
+  if (i<length(FDirectiveHandles))
+      and (CompareText(aDirective,FDirectiveHandles[i].Directive)=0) then
+    begin
+    // replace
+    FDirectiveHandles[i].Directive:=aDirective;
+    FDirectiveHandles[i].Handler:=aHandler;
+    end
+  else
+    begin
+    Item.Directive:=aDirective;
+    Item.Handler:=aHandler;
+    Insert(Item,FDirectiveHandles,i);
+    end;
+end;
+
+procedure TPascalScanner.RegisterDirectiveHandler(const aDirectives: TStringDynArray;
+  const aHandler: TPScannerDirectiveEvent);
+var
+  S: String;
+begin
+  for S in aDirectives do
+    RegisterDirectiveHandler(S,aHandler);
+end;
+
 procedure TPascalScanner.ClearFiles;
 
 begin
@@ -5360,9 +5403,17 @@ end;
 
 procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
   Param: TPasScannerString; var Handled: boolean);
+var
+  i: Integer;
 begin
   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);
@@ -6537,6 +6588,32 @@ begin
     Result:=FResourceHandlers[Idx].handler;
 end;
 
+function TPascalScanner.IndexOfDirectiveHandle(const aDirective: TPasScannerString;
+  ForInsert: boolean): Integer;
+var
+  l, r, m, cmp: Integer;
+begin
+  l:=0;
+  r:=length(FDirectiveHandles)-1;
+  m:=0;
+  while l<=r do begin
+    m:=(l+r) div 2;
+    cmp:=CompareText(aDirective,FDirectiveHandles[m].Directive);
+    if cmp>0 then
+      l:=m+1
+    else if cmp<0 then
+      r:=m-1
+    else
+      exit(m);
+  end;
+  if not ForInsert then exit(-1);
+  Result:=m;
+  if length(FDirectiveHandles)=0 then
+    exit;
+  if cmp>0 then
+    inc(Result);
+end;
+
 function TPascalScanner.ReadIdentifier(const AParam: TPasScannerString): TPasScannerString;
 var
   p, l: Integer;

packages/fcl-passrc/tests/tcclasstype.pas

@@ -50,6 +50,8 @@ type
     procedure AssertMemberType(AType : TClass; Member : TPaselement = Nil);
     procedure AssertMemberName(AName : string; Member : TPaselement = Nil);
     Procedure AssertProperty(P : TPasProperty; AVisibility : TPasMemberVisibility;AName,ARead,AWrite,AStored,AImplements : String; AArgCount : Integer; ADefault,ANodefault : Boolean);
+    Procedure TestDirectiveRTTI(Param: string; ExpectedExplicit: boolean;
+        const ExpectedFields, ExpectedMethods, ExpectedProperties: TPasMembersType.TRTTIVisibilitySections);
     Property TheClass : TPasClassType Read FClass;
     Property Members[AIndex : Integer] : TPasElement Read GetM;
     Property Member1 : TPasElement Read FMember1;
@@ -204,6 +206,12 @@ type
     procedure TestRecordHelperOneMethod;
     procedure TestEscapedVisibilityVar;
     procedure TestEscapedAbsoluteVar;
+    procedure TestClassRTTIInherit;
+    procedure TestClassRTTIExplicit;
+    procedure TestClassRTTIExplicitFields;
+    procedure TestClassRTTIExplicitFieldsPublic;
+    procedure TestClassRTTIExplicitMethodsAll;
+    procedure TestClassRTTIExplicitAllPublic;
   end;
 
 implementation
@@ -534,6 +542,30 @@ begin
   Assertequals(P.Name+': nodefault',ANodefault,P.IsNoDefault);
 end;
 
+procedure TTestClassType.TestDirectiveRTTI(Param: string; ExpectedExplicit: boolean;
+  const ExpectedFields, ExpectedMethods, ExpectedProperties: TPasMembersType.TRTTIVisibilitySections
+  );
+
+  procedure Check(const El: string; const Expected, Actual: TPasMembersType.TRTTIVisibilitySections);
+  var
+    s: String;
+  begin
+    if Expected=Actual then exit;
+    Fail(El+' visibility expected '+dbgs(Expected)+', but found '+dbgs(Actual));
+  end;
+
+begin
+  Parser.Options:=Parser.Options+[po_CheckRTTI];
+  Add('{$RTTI '+Param+'}');
+  FStarted:=True;
+  FDecl.add('TMyClass = Class');
+  ParseClass;
+  AssertEquals('rtti directive explicit (not inherit)',ExpectedExplicit,FClass.RTTIVisibility.Explicit);
+  Check('Fields',FClass.RTTIVisibility.Fields,ExpectedFields);
+  Check('Methods',FClass.RTTIVisibility.Methods,ExpectedMethods);
+  Check('Properties',FClass.RTTIVisibility.Properties,ExpectedProperties);
+end;
+
 procedure TTestClassType.TestEmpty;
 begin
   EndClass('');
@@ -2379,6 +2411,38 @@ begin
   AssertVisibility;
 end;
 
+procedure TTestClassType.TestClassRTTIInherit;
+begin
+  TestDirectiveRTTI('inherit',false,[],[],[]);
+end;
+
+procedure TTestClassType.TestClassRTTIExplicit;
+begin
+  TestDirectiveRTTI('explicit',true,[],[],[]);
+end;
+
+procedure TTestClassType.TestClassRTTIExplicitFields;
+begin
+  TestDirectiveRTTI('explicit fields([])',true,[],[],[]);
+end;
+
+procedure TTestClassType.TestClassRTTIExplicitFieldsPublic;
+begin
+  TestDirectiveRTTI('explicit fields ( [vcPublic] ) ',true,[vcPublic],[],[]);
+end;
+
+procedure TTestClassType.TestClassRTTIExplicitMethodsAll;
+begin
+  TestDirectiveRTTI('explicit methods([vcPublic,vcPrivate,vcPublished,vcProtected])',true,
+    [],[vcPrivate,vcProtected,vcPublic,vcPublished],[]);
+end;
+
+procedure TTestClassType.TestClassRTTIExplicitAllPublic;
+begin
+  TestDirectiveRTTI('explicit fields([vcPublic]) Methods([vcPublic]) Properties([vcPublic])',true,
+    [vcPublic],[vcPublic],[vcPublic]);
+end;
+
 initialization
 
   RegisterTest(TTestClassType);