* Implement parsing of RTTI directive

compiler/fmodule.pas

@@ -234,6 +234,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

@@ -146,7 +146,7 @@ general_t_unitscope=01027_T_Using unit scope: $1
 #
 # 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
@@ -441,6 +441,11 @@ 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)
+scan_e_incomplete_rtti_clause=02110_E_A Explicit clause requires at least one option (Methods, Properties or Fields)
+scan_e_invalid_rtti_option=02111_E_A Invalid RTTI option "$1" (expected Methods, Properties or Fields)
+scan_e_duplicate_rtti_option=02112_E_A Duplicate RTTI option "$1"
+scan_e_misplaced_rtti_directive=02113_E_A The RTTI directive cannot be used here 
 % \end{description}
 #
 # Parser

compiler/msgidx.inc

@@ -132,6 +132,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;
@@ -1157,9 +1162,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 90618;
+  MsgTxtSize = 90929;
 
   MsgIdxMax : array[1..20] of longint=(
-    28,109,366,132,100,63,148,38,223,71,
+    28,114,366,132,100,63,148,38,223,71,
     65,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;
 
 {*****************************************************************************
@@ -1340,6 +1340,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);
@@ -2048,6 +2135,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);

compiler/scanner.pas

@@ -28,6 +28,7 @@ interface
     uses
        cclasses,
        globtype,globals,constexp,version,tokens,
+       symtype,symdef,symsym,
        verbose,comphook,
        finput,
        widestr;
@@ -253,6 +254,7 @@ interface
           procedure readtoken(allowrecordtoken:boolean);
           function  readpreproc:ttoken;
           function  readpreprocint(var value:int64;const place:string):boolean;
+          function  readpreprocset(conform_to:tsetdef;var value:tnormalset;const place:string):boolean;
           function  asmgetchar:char;
        end;
 
@@ -309,7 +311,7 @@ implementation
       cutils,cfileutl,
       systems,
       switches,
-      symbase,symtable,symtype,symsym,symconst,symdef,defutil,
+      symbase,symtable,symconst,defutil,defcmp,node,
       { This is needed for tcputype }
       cpuinfo,
       fmodule,fppu,
@@ -1022,6 +1024,7 @@ type
     function asInt: Integer;
     function asInt64: Int64;
     function asStr: String;
+    function asSet: tnormalset;
     destructor destroy; override;
   end;
 
@@ -1478,6 +1481,11 @@ type
       result:=value.valueord.svalue;
     end;
 
+  function texprvalue.asSet: tnormalset;
+    begin
+      result:=pnormalset(value.valueptr)^;
+    end;
+
   function texprvalue.asStr: String;
     var
       b:byte;
@@ -1566,7 +1574,7 @@ type
       end;
 
 
-    function preproc_comp_expr:texprvalue;
+    function preproc_comp_expr(conform_to:tdef):texprvalue;
 
         function preproc_sub_expr(pred_level:Toperator_precedence;eval:Boolean):texprvalue; forward;
 
@@ -1821,7 +1829,8 @@ type
            srsymtable : TSymtable;
            hdef : TDef;
            l : longint;
-           hasKlammer: Boolean;
+           hasKlammer,
+           read_next: Boolean;
            exprvalue:texprvalue;
            ns:tnormalset;
            fs,path,name: tpathstr;
@@ -2216,21 +2225,54 @@ type
                               case srsym.typ of
                                 constsym:
                                   begin
-                                    result.free;
-                                    result:=texprvalue.create_const(tconstsym(srsym));
-                                    tconstsym(srsym).IncRefCount;
+                                    { const def must conform to the set type }
+                                    if (conform_to<>nil) and 
+                                      (conform_to.typ=setdef) and
+                                      (tconstsym(srsym).constdef.typ=setdef) and
+                                      (compare_defs(tsetdef(tconstsym(srsym).constdef).elementdef,tsetdef(conform_to).elementdef,nothingn)<>te_exact) then
+                                        begin
+                                          result.free;
+                                          result:=nil;
+                                          // TODO(ryan): better error?
+                                          Message(scan_e_error_in_preproc_expr);
+                                        end;
+                                    if result<>nil then
+                                      begin
+                                        result.free;
+                                        result:=texprvalue.create_const(tconstsym(srsym));
+                                      end;
                                   end;
                                 enumsym:
                                   begin
-                                    result.free;
-                                    result:=texprvalue.create_int(tenumsym(srsym).value);
-                                    tenumsym(srsym).IncRefCount;
+                                    { enum definition must conform to the set type }
+                                    if (conform_to<>nil) and 
+                                      (conform_to.typ=setdef) and
+                                      (compare_defs(tenumsym(srsym).definition,tsetdef(conform_to).elementdef,nothingn)<>te_exact) then
+                                        begin
+                                          result.free;
+                                          result:=nil;
+                                          // TODO(ryan): better error?
+                                          Message(scan_e_error_in_preproc_expr);
+                                        end;
+                                    if result<>nil then
+                                      begin
+                                        result.free;
+                                        result:=texprvalue.create_int(tenumsym(srsym).value);
+                                      end;
                                   end;
                                 else
                                   ;
                               end;
                           end
-                        end
+                        { the id must be belong to the set type }
+                        else if (conform_to<>nil) and (conform_to.typ=setdef) then
+                          begin
+                            result.free;
+                            result:=nil;
+                            // TODO(ryan): better error?
+                            Message(scan_e_error_in_preproc_expr);
+                          end;
+                      end
                       { skip id(<expr>) if expression must not be evaluated }
                       else if not(eval) and (result.consttyp=conststring) then
                         begin
@@ -2258,16 +2300,36 @@ type
              begin
                preproc_consume(_LECKKLAMMER);
                ns:=[];
-               while current_scanner.preproc_token in [_ID,_INTCONST] do
+               read_next:=false;
+               while (current_scanner.preproc_token in [_ID,_INTCONST]) or read_next do
                begin
+                 read_next:=false;
                  exprvalue:=preproc_factor(eval);
+                 { the const set does not conform to the set def }
+                 if (conform_to<>nil) and 
+                   (conform_to.typ=setdef) and 
+                   (exprvalue.consttyp=constnone) then
+                   begin
+                     result:=texprvalue.create_error;
+                     break;
+                   end;
+                 { reject duplicate enums in the set }
+                 if exprvalue.asInt in ns then
+                   begin
+                     Message1(sym_e_duplicate_id,current_scanner.preproc_pattern);
+                     result:=texprvalue.create_error;
+                     break;
+                   end;
                  include(ns,exprvalue.asInt);
                  if current_scanner.preproc_token = _COMMA then
-                   preproc_consume(_COMMA);
+                   begin
+                     preproc_consume(_COMMA);
+                     read_next:=true;
+                   end
                end;
-               // TODO Add check of setElemType
                preproc_consume(_RECKKLAMMER);
-               result:=texprvalue.create_set(ns);
+               if result=nil then
+                 result:=texprvalue.create_set(ns);
              end
            else if current_scanner.preproc_token = _INTCONST then
              begin
@@ -2366,7 +2428,7 @@ type
       var
         hs: texprvalue;
       begin
-        hs:=preproc_comp_expr;
+        hs:=preproc_comp_expr(nil);
         if hs.isBoolean then
           result:=hs.asBool
         else
@@ -2545,7 +2607,7 @@ type
         if c='=' then
           begin
              current_scanner.readchar;
-             exprvalue:=preproc_comp_expr;
+             exprvalue:=preproc_comp_expr(nil);
              if not is_boolean(exprvalue.def) and
                 not is_integer(exprvalue.def) then
                exprvalue.error('Boolean, Integer', 'SETC');
@@ -2769,7 +2831,6 @@ type
          end;
       end;
 
-
 {*****************************************************************************
                             Preprocessor writing
 *****************************************************************************}
@@ -6080,7 +6141,7 @@ exit_label:
       var
         hs : texprvalue;
       begin
-        hs:=preproc_comp_expr;
+        hs:=preproc_comp_expr(nil);
         if hs.isInt then
           begin
             value:=hs.asInt64;
@@ -6095,6 +6156,25 @@ exit_label:
       end;
 
 
+    function tscannerfile.readpreprocset(conform_to:tsetdef;var value:tnormalset;const place:string):boolean;
+      var
+        hs : texprvalue;
+      begin
+        hs:=preproc_comp_expr(conform_to);
+        if hs.def.typ=setdef then
+          begin
+            value:=hs.asSet;
+            result:=true;
+          end
+        else
+          begin
+            hs.error('Set',place);
+            result:=false;
+          end;
+        hs.free;
+      end;
+
+
     function tscannerfile.asmgetchar : char;
       begin
          readchar;