* Implement parsing of RTTI directive

compiler/fmodule.pas

@@ -235,6 +235,9 @@ interface
            -- actual type: tnode (but fmodule should not depend on node) }
          tcinitcode     : tobject;
 
+        { the current extended rtti directive }
+        rtti_directive : trtti_directive;
+
         {create creates a new module which name is stored in 's'. LoadedFrom
         points to the module calling it. It is nil for the first compiled
         module. This allow inheritence of all path lists. MUST pay attention

compiler/msg/errore.msg

@@ -150,7 +150,7 @@ general_i_reduced_filesearch=01028_I_Reduced file search: Not searching for uppe
 #
 # Scanner
 #
-# 02107 is the last used one
+# 02112 is the last used one
 #
 % \section{Scanner messages.}
 % This section lists the messages that the scanner emits. The scanner takes
@@ -445,6 +445,20 @@ scan_e_unexpected_endif=02108_E_$ENDIF directive found without a matching $IF(N)
 % When legacy ifend is turned on by the directive \var{\$LEGACYIFEND}, then the
 % \var{\$IF} directive must be closed by the \var{\$IFEND} directive and the
 % \var{\$IFDEF} directive must be closed by the \var{\$ENDIF} directive.
+scan_e_invalid_rtti_clause=02109_E_A Invalid RTTI clause (expected Explicit or Inherit)
+% The \var{\$RTTI} directive needs to be followed either by \var{EXPLICIT} or \var{INHERIT}
+% and entries for \var{FIELDS}, \var{PROPERTIES} or \var{METHODS}.
+scan_e_incomplete_rtti_clause=02110_E_A Explicit clause requires at least one option (Methods, Properties or Fields)
+% An \var{\$RTTI EXPLICIT} directive requires at least one of the \var{FIELDS}, \var{PROPERTIES}
+% or \var{METHODS} entries.
+scan_e_invalid_rtti_option=02111_E_A Invalid RTTI option "$1" (expected Methods, Properties or Fields)
+% The \var{\$RTTI EXPLICIT} can only contain \var{FIELDS}, \var{PROPERTIES} and \var{METHODS}
+% entries.
+scan_e_duplicate_rtti_option=02112_E_A Duplicate RTTI option "$1"
+% An option in a \var{$RTTI EXPLICIT} directive can only appear once.
+scan_e_misplaced_rtti_directive=02113_E_A The RTTI directive cannot be used here
+% The \var{\$RTTI} directive can not be used in this location (e.g. before the \var{PROGRAM}
+% or \var{UNIT} headers).
 % \end{description}
 #
 # Parser

compiler/msgidx.inc

@@ -133,6 +133,11 @@ const
   scan_e_emptymacroname=02106;
   scan_e_unexpected_ifend=02107;
   scan_e_unexpected_endif=02108;
+  scan_e_invalid_rtti_clause=02109;
+  scan_e_incomplete_rtti_clause=02110;
+  scan_e_invalid_rtti_option=02111;
+  scan_e_duplicate_rtti_option=02112;
+  scan_e_misplaced_rtti_directive=02113;
   parser_e_syntax_error=03000;
   parser_e_dont_nest_interrupt=03004;
   parser_w_proc_directive_ignored=03005;
@@ -1172,9 +1177,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 92413;
+  MsgTxtSize = 92723;
 
   MsgIdxMax : array[1..20] of longint=(
-    29,109,371,134,102,63,148,38,224,71,
+    29,114,371,134,102,63,148,38,224,71,
     69,20,30,1,1,1,1,1,1,1
   );

compiler/scandir.pas

@@ -57,14 +57,14 @@ unit scandir;
     uses
       SysUtils,
       cutils,cfileutl,
-      globals,widestr,cpuinfo,
+      globals,widestr,cpuinfo,tokens,
       verbose,comphook,ppu,
       scanner,switches,
       fmodule,
       defutil,
       dirparse,link,
       syscinfo,
-      symconst,symtable,symbase,symtype,symsym,
+      symconst,symtable,symbase,symtype,symsym,symdef,
       rabase;
 
 {*****************************************************************************
@@ -1373,6 +1373,93 @@ unit scandir;
           Message(scan_e_resourcefiles_not_supported);
       end;
 
+    procedure dir_rtti;
+
+      function read_rtti_options: trtti_visibilities;
+        var
+          sym: ttypesym;
+          value: tnormalset;
+        begin
+          result:=[];
+          sym:=search_system_type('TVISIBILITYCLASSES');
+          if current_scanner.readpreprocset(tsetdef(sym.typedef),value,'RTTI') then
+            begin
+              result:=prtti_visibilities(@value)^;
+              // if the set was empty we need to read the next id
+              if result=[] then
+                begin
+                  current_scanner.skipspace;
+                  current_scanner.readid
+                end;
+            end;
+        end;
+
+      var
+        dir: trtti_directive;
+        option: trtti_option;
+        options: array[trtti_option] of boolean;
+      begin
+        { the system unit has not yet loaded which means the directive is misplaced}
+        if systemunit=nil then
+          begin
+            Message(scan_e_misplaced_rtti_directive);
+            exit;
+          end;
+
+        dir:=default(trtti_directive);
+
+        options[ro_fields]:=false;
+        options[ro_methods]:=false;
+        options[ro_properties]:=false;
+
+        { read the clause }
+        current_scanner.skipspace;
+        current_scanner.readid;
+        case pattern of
+          'INHERIT':
+            dir.clause:=rtc_inherit;
+          'EXPLICIT':
+            dir.clause:=rtc_explicit;
+          otherwise
+            Message(scan_e_invalid_rtti_clause);
+        end;
+
+        { read the visibility options}
+        current_scanner.skipspace;
+        current_scanner.readid;
+        { the inherit clause doesn't require any options but explicit does }
+        if (pattern='') and (dir.clause=rtc_explicit) then
+          Message(scan_e_incomplete_rtti_clause);
+        while pattern<>'' do
+          begin
+            case pattern of
+              'METHODS':
+                option:=ro_methods;
+              'PROPERTIES':
+                option:=ro_properties;
+              'FIELDS':
+                option:=ro_fields;
+              otherwise
+                begin
+                  if current_scanner.preproc_token=_ID then
+                    Message1(scan_e_invalid_rtti_option,pattern);
+                  break;
+                end;
+            end;
+            { the option has already been used }
+            if options[option] then
+              begin
+                Message1(scan_e_duplicate_rtti_option,pattern);
+                break;
+              end;
+            dir.options[option]:=read_rtti_options;
+            options[option]:=true;
+          end;
+
+        { set the directive in the module }
+        current_module.rtti_directive:=dir;
+      end;
+
     procedure dir_saturation;
       begin
         do_localswitch(cs_mmx_saturation);
@@ -2082,6 +2169,7 @@ unit scandir;
         AddDirective('PROFILE',directive_all, @dir_profile);
         AddDirective('PUSH',directive_all, @dir_push);
         AddDirective('R',directive_all, @dir_resource);
+        AddDirective('RTTI',directive_all, @dir_rtti);
         AddDirective('RANGECHECKS',directive_all, @dir_rangechecks);
         AddDirective('REFERENCEINFO',directive_all, @dir_referenceinfo);
         AddDirective('REGION',directive_all, @dir_region);