+ compile time expression type checking

  * fixed bug in $DEFINE under macpas

git-svn-id: trunk@919 -

compiler/msg/errore.msg

@@ -309,8 +309,8 @@ scan_e_wrong_switch_toggle_default=02066_E_Wrong switch toggle, use ON/OFF/DEFAU
 scan_e_mode_switch_not_allowed=02067_E_Mode switch "$1" not allowed here
 % A mode switch has already been encountered, or, in case of option -Mmacpas,
 % a mode switch occur after UNIT.
-scan_e_error_macro_undefined=02068_E_Compile time variable "$1" is not defined.
-% Thus the conditional compile time expression cannot be evaluated.
+scan_e_error_macro_undefined=02068_E_Compile time variable or macro "$1" is not defined.
+% Thus the conditional compile time expression cannot be evaluated. Only in mode MacPas.
 scan_e_utf8_bigger_than_65535=02069_E_UTF-8 code greater than 65535 found
 % \fpc handles utf-8 strings internally as widestrings e.g. the char codes are limited to 65535
 scan_e_utf8_malformed=02070_E_Malformed UTF-8 string
@@ -318,6 +318,8 @@ scan_e_utf8_malformed=02070_E_Malformed UTF-8 string
 scan_c_switching_to_utf8=02071_C_UTF-8 signature found, using UTF-8 encoding
 % The compiler found an UTF-8 encoding signature ($ef, $bb, $bf) at the beginning of a file,
 % so it interprets it as an UTF-8 file
+scan_e_compile_time_typeerror=02072_E_Compile time expression: Wanted $1 but got $2 at $3
+% Type check of a compile time expression failed.
 % \end{description}
 #
 # Parser

compiler/msgidx.inc

@@ -87,6 +87,7 @@ const
   scan_e_utf8_bigger_than_65535=02069;
   scan_e_utf8_malformed=02070;
   scan_c_switching_to_utf8=02071;
+  scan_e_compile_time_typeerror=02072;
   parser_e_syntax_error=03000;
   parser_e_dont_nest_interrupt=03004;
   parser_w_proc_directive_ignored=03005;
@@ -658,9 +659,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 38879;
+  MsgTxtSize = 38948;
 
   MsgIdxMax : array[1..20] of longint=(
-    19,72,215,59,59,46,100,20,135,60,
+    19,73,215,59,59,46,100,20,135,60,
     40,1,1,1,1,1,1,1,1,1
   );

compiler/scanner.pas

@@ -387,9 +387,77 @@ implementation
           setfilename(paramfn^, paramallowoutput);
       end;
 
-    function parse_compiler_expr:string;
+{
+Compile time expression type check
+----------------------------------
+Each subexpression returns its type to the caller, which then can
+do type check.  Since data types of compile time expressions is
+not well defined, the type system does a best effort. The drawback is
+that some errors might not be detected.
+
+Instead of returning a particular data type, a set of possible data types
+are returned. This way ambigouos types can be handled.  For instance a
+value of 1 can be both a boolean and and integer.
+
+Booleans
+--------
+
+The following forms of boolean values are supported:
+* C coded, that is 0 is false, non-zero is true.
+* TRUE/FALSE for mac style compile time variables
+
+Thus boolean mac compile time variables are always stored as TRUE/FALSE.
+When a compile time expression is evaluated, they are then translated
+to C coded booleans (0/1), to simplify for the expression evaluator.
 
-        function read_expr : string; forward;
+Note that this scheme then also of support mac compile time variables which
+are 0/1 but with a boolean meaning.
+
+The TRUE/FALSE format is new from 22 august 2005, but the above scheme
+means that units which is not recompiled, and thus stores 
+compile time variables as the old format (0/1), continue to work.
+
+}
+
+    type
+      {Compile time expression types}
+      TCTEType = (ctetBoolean, ctetInteger, ctetString, ctetSet);
+      TCTETypeSet = set of TCTEType;
+
+    const
+      cteTypeNames : array[TCTEType] of string[10] = (
+        'BOOLEAN','INTEGER','STRING','SET');
+
+      {Subset of types which can be elements in sets.}
+      setElementTypes = [ctetBoolean, ctetInteger, ctetString];
+
+
+    function GetCTETypeName(t: TCTETypeSet): String;
+      var
+        i: TCTEType;
+      begin
+        result:= '';
+        for i:= Low(TCTEType) to High(TCTEType) do
+          if i in t then
+            if result = '' then
+              result:= cteTypeNames[i]
+            else
+              result:= result + ' or ' + cteTypeNames[i];
+      end;
+
+    procedure CTEError(actType, desiredExprType: TCTETypeSet; place: String);
+
+    begin
+      Message3(scan_e_compile_time_typeerror,
+               GetCTETypeName(desiredExprType),
+               GetCTETypeName(actType),
+               place
+              );
+    end;
+
+    function parse_compiler_expr(var compileExprType: TCTETypeSet):string;
+
+        function read_expr(var exprType: TCTETypeSet) : string; forward;
 
         procedure preproc_consume(t : ttoken);
         begin
@@ -398,14 +466,23 @@ implementation
           current_scanner.preproc_token:=current_scanner.readpreproc;
         end;
 
-        function preproc_substitutedtoken: string;
+        function preproc_substitutedtoken(var macroType: TCTETypeSet): string;
+				{ Currently this parses identifiers as well as numbers. 
+          The result from this procedure can either be that the token
+          itself is a value, or that it is a compile time variable/macro,
+          which then is substituted for another value (for macros
+          recursivelly substituted).}
+
         var
           hs: string;
           mac : tmacro;
           macrocount,
           len : integer;
+          numres : longint;
+          w: word;
         begin
           result := current_scanner.preproc_pattern;
+          mac:= nil;
           { Substitue macros and compiler variables with their content/value.
             For real macros also do recursive substitution. }
           macrocount:=0;
@@ -441,21 +518,47 @@ implementation
                 end
             else
               begin
-                (*
-                // To make this work, there must be some kind of type checking here...
-                if m_mac in aktmodeswitches then
-                  Message1(scan_e_error_macro_undefined, result)
-                else
-                *)
                   break;
               end;
 
             if mac.is_compiler_var then
               break;
           until false;
+
+          {At this point, result do contain the value. Do some decoding and
+					 determine the type.}
+  				val(result,numres,w);
+  				if (w=0) then {It is an integer}
+  				  begin
+  				    if (numres = 0) or (numres = 1) then
+  		    		  macroType := [ctetInteger, ctetBoolean]
+  		    		else
+  		    		  macroType := [ctetInteger];  		    	
+		    		end
+          else if assigned(mac) and (m_mac in aktmodeswitches) and (result='FALSE') then
+					  begin
+						  result:= '0';
+     					macroType:= [ctetBoolean];
+						end
+          else if assigned(mac) and (m_mac in aktmodeswitches) and (result='TRUE') then
+					  begin
+						  result:= '1';
+     					macroType:= [ctetBoolean];
+						end
+          else if (m_mac in aktmodeswitches) and
+                  (not assigned(mac) or not mac.defined) and
+                  (macrocount = 1) then
+            begin
+              {Errors in mode mac is issued here. For non macpas modes there is
+               more liberty, but the error will eventually be caught at a later stage.}
+              Message1(scan_e_error_macro_undefined, result);
+              macroType:= [ctetString]; {Just to have something}
+            end
+          else
+            macroType:= [ctetString];
         end;
 
-        function read_factor : string;
+        function read_factor(var factorType: TCTETypeSet) : string;
         var
            hs : string;
            mac: tmacro;
@@ -464,12 +567,14 @@ implementation
            l : longint;
            w : integer;
            hasKlammer: Boolean;
+           setElemType : TCTETypeSet;
 
         begin
            if current_scanner.preproc_token=_ID then
              begin
                 if current_scanner.preproc_pattern='DEFINED' then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                     if current_scanner.preproc_token =_LKLAMMER then
@@ -510,6 +615,7 @@ implementation
                 else
                 if (m_mac in aktmodeswitches) and (current_scanner.preproc_pattern='UNDEFINED') then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                     if current_scanner.preproc_token =_ID then
@@ -533,6 +639,7 @@ implementation
                 else
                 if (m_mac in aktmodeswitches) and (current_scanner.preproc_pattern='OPTION') then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                     if current_scanner.preproc_token =_LKLAMMER then
@@ -568,6 +675,7 @@ implementation
                 else
                 if current_scanner.preproc_pattern='SIZEOF' then
                   begin
+                    factorType:= [ctetInteger];
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                     if current_scanner.preproc_token =_LKLAMMER then
@@ -607,6 +715,7 @@ implementation
                 else
                 if current_scanner.preproc_pattern='DECLARED' then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                     if current_scanner.preproc_token =_LKLAMMER then
@@ -637,8 +746,11 @@ implementation
                 else
                 if current_scanner.preproc_pattern='NOT' then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
-                    hs:=read_factor();
+                    hs:=read_factor(factorType);
+                    if not (ctetBoolean in factorType) then
+                      CTEError(factorType, [ctetBoolean], 'NOT');
                     val(hs,l,w);
                     if l<>0 then
                       read_factor:='0'
@@ -648,21 +760,24 @@ implementation
                 else
                 if (m_mac in aktmodeswitches) and (current_scanner.preproc_pattern='TRUE') then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     read_factor:='1';
                   end
                 else
                 if (m_mac in aktmodeswitches) and (current_scanner.preproc_pattern='FALSE') then
                   begin
+                    factorType:= [ctetBoolean];
                     preproc_consume(_ID);
                     read_factor:='0';
                   end
                 else
                   begin
-                    hs:=preproc_substitutedtoken;
+                    hs:=preproc_substitutedtoken(factorType);
+
                     { Default is to return the original symbol }
                     read_factor:=hs;
-                    if (m_delphi in aktmodeswitches) then
+                    if (m_delphi in aktmodeswitches) and (ctetString in factorType) then
                       if searchsym(current_scanner.preproc_pattern,srsym,srsymtable) then
                         begin
                           case srsym.typ of
@@ -676,18 +791,34 @@ implementation
                                           case consttype.def.deftype of
                                             orddef:
                                               begin
-                                                if is_integer(consttype.def) or is_boolean(consttype.def) then
-                                                  read_factor:=tostr(value.valueord)
-                                                else
-                                                  if is_char(consttype.def) then
+                                                if is_integer(consttype.def) then
+                                                  begin
+                                                    read_factor:=tostr(value.valueord);
+                                                    factorType:= [ctetInteger];
+                                                  end
+                                                else if is_boolean(consttype.def) then
+                                                  begin
+                                                    read_factor:=tostr(value.valueord);
+                                                    factorType:= [ctetBoolean];
+                                                  end
+                                                else if is_char(consttype.def) then
+                                                  begin
                                                     read_factor:=chr(value.valueord);
+                                                    factorType:= [ctetString];
+                                                  end
                                               end;
                                             enumdef:
-                                              read_factor:=tostr(value.valueord)
+                                              begin
+                                                read_factor:=tostr(value.valueord);
+                                                factorType:= [ctetInteger];
+                                              end;
                                           end;
                                         end;
                                       conststring :
-                                        read_factor := upper(pchar(value.valueptr));
+                                        begin
+                                          read_factor := upper(pchar(value.valueptr));
+                                          factorType:= [ctetString];
+                                        end;
                                       constset :
                                         begin
                                           hs:=',';
@@ -695,15 +826,18 @@ implementation
                                             if l in pconstset(tconstsym(srsym).value.valueptr)^ then
                                               hs:=hs+tostr(l)+',';
                                           read_factor := hs;
+                                          factorType:= [ctetSet];
                                         end;
                                     end;
                                   end;
                               end;
                             enumsym :
-                              read_factor:=tostr(tenumsym(srsym).value);
+                              begin
+																read_factor:=tostr(tenumsym(srsym).value);
+																factorType:= [ctetInteger];
+														  end;
                           end;
                         end;
-
                     preproc_consume(_ID);
                     current_scanner.skipspace;
                   end
@@ -711,7 +845,7 @@ implementation
            else if current_scanner.preproc_token =_LKLAMMER then
              begin
                 preproc_consume(_LKLAMMER);
-                read_factor:=read_expr;
+                read_factor:=read_expr(factorType);
                 preproc_consume(_RKLAMMER);
              end
            else if current_scanner.preproc_token = _LECKKLAMMER then
@@ -720,30 +854,44 @@ implementation
                read_factor := ',';
                while current_scanner.preproc_token = _ID do
                begin
-                 read_factor := read_factor+read_factor()+',';
+                 read_factor := read_factor+read_factor(setElemType)+',';
                  if current_scanner.preproc_token = _COMMA then
                    preproc_consume(_COMMA);
                end;
+               // TODO Add check of setElemType
                preproc_consume(_RECKKLAMMER);
+               factorType:= [ctetSet];
              end
            else
              Message(scan_e_error_in_preproc_expr);
         end;
 
-        function read_term : string;
+        function read_term(var termType: TCTETypeSet) : string;
         var
            hs1,hs2 : string;
            l1,l2 : longint;
            w : integer;
+           termType2: TCTETypeSet;
         begin
-          hs1:=read_factor;
+          hs1:=read_factor(termType);
           repeat
             if (current_scanner.preproc_token<>_ID) then
               break;
             if current_scanner.preproc_pattern<>'AND' then
               break;
+
+            {Check if first expr is boolean. Must be done here, after we know 
+             it is an AND expression.}
+            if not (ctetBoolean in termType) then
+              CTEError(termType, [ctetBoolean], 'AND');
+            termType:= [ctetBoolean];
+
             preproc_consume(_ID);
-            hs2:=read_factor;
+            hs2:=read_factor(termType2);
+
+            if not (ctetBoolean in termType2) then
+              CTEError(termType2, [ctetBoolean], 'AND');
+
             val(hs1,l1,w);
             val(hs2,l2,w);
             if (l1<>0) and (l2<>0) then
@@ -755,20 +903,32 @@ implementation
         end;
 
 
-        function read_simple_expr : string;
+        function read_simple_expr(var simpleExprType: TCTETypeSet) : string;
         var
            hs1,hs2 : string;
            l1,l2 : longint;
            w : integer;
+           simpleExprType2: TCTETypeSet;
         begin
-          hs1:=read_term;
+          hs1:=read_term(simpleExprType);
           repeat
             if (current_scanner.preproc_token<>_ID) then
               break;
             if current_scanner.preproc_pattern<>'OR' then
               break;
+
+            {Check if first expr is boolean. Must be done here, after we know 
+             it is an OR expression.}
+            if not (ctetBoolean in simpleExprType) then
+              CTEError(simpleExprType, [ctetBoolean], 'OR');
+            simpleExprType:= [ctetBoolean];
+
             preproc_consume(_ID);
-            hs2:=read_term;
+            hs2:=read_term(simpleExprType2);
+
+            if not (ctetBoolean in simpleExprType2) then
+              CTEError(simpleExprType2, [ctetBoolean], 'OR');
+
             val(hs1,l1,w);
             val(hs2,l2,w);
             if (l1<>0) or (l2<>0) then
@@ -779,75 +939,97 @@ implementation
           read_simple_expr:=hs1;
         end;
 
-        function read_expr : string;
+        function read_expr(var exprType: TCTETypeSet) : string;
         var
            hs1,hs2 : string;
            b : boolean;
-           t : ttoken;
+           op : ttoken;
            w : integer;
            l1,l2 : longint;
+           exprType2: TCTETypeSet;
         begin
-           hs1:=read_simple_expr;
-           t:=current_scanner.preproc_token;
-           if (t = _ID) and (current_scanner.preproc_pattern = 'IN') then
-             t := _IN;
-           if not (t in [_IN,_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then
+           hs1:=read_simple_expr(exprType);
+           op:=current_scanner.preproc_token;
+           if (op = _ID) and (current_scanner.preproc_pattern = 'IN') then
+             op := _IN;
+           if not (op in [_IN,_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then
              begin
                 read_expr:=hs1;
                 exit;
              end;
-           if (t = _IN) then
+             
+           if (op = _IN) then
              preproc_consume(_ID)
            else
-             preproc_consume(t);
-           hs2:=read_simple_expr;
-           if is_number(hs1) and is_number(hs2) then
+             preproc_consume(op);
+           hs2:=read_simple_expr(exprType2);
+
+           if op = _IN then
              begin
-                val(hs1,l1,w);
-                val(hs2,l2,w);
-                case t of
-                      _IN : Message(scan_e_preproc_syntax_error);
-                   _EQUAL : b:=l1=l2;
-                 _UNEQUAL : b:=l1<>l2;
-                      _LT : b:=l1<l2;
-                      _GT : b:=l1>l2;
-                     _GTE : b:=l1>=l2;
-                     _LTE : b:=l1<=l2;
-                end;
+               if exprType2 <> [ctetSet] then
+                 CTEError(exprType2, [ctetSet], 'IN');
+               if exprType = [ctetSet] then
+                 CTEError(exprType, setElementTypes, 'IN');
+
+              if is_number(hs1) and is_number(hs2) then
+                Message(scan_e_preproc_syntax_error)
+              else if hs2[1] = ',' then
+                b:=pos(','+hs1+',', hs2) > 0   { TODO For integer sets, perhaps check for numeric equivalence so that 0 = 00 }
+              else
+                Message(scan_e_preproc_syntax_error);
              end
            else
-             begin
-                case t of
-                      _IN : if hs2[1] = ',' then
-                              b:=pos(','+hs1+',', hs2) > 0
-                            else
-                              Message(scan_e_preproc_syntax_error);
-                   _EQUAL : b:=hs1=hs2;
-                 _UNEQUAL : b:=hs1<>hs2;
-                      _LT : b:=hs1<hs2;
-                      _GT : b:=hs1>hs2;
-                     _GTE : b:=hs1>=hs2;
-                     _LTE : b:=hs1<=hs2;
-                end;
-             end;
+						 begin
+							 if (exprType * exprType2) = [] then
+									CTEError(exprType2, exprType, tokeninfo^[op].str);
+	
+							 if is_number(hs1) and is_number(hs2) then
+								 begin
+										val(hs1,l1,w);
+										val(hs2,l2,w);
+										case op of
+											 _EQUAL : b:=l1=l2;
+										 _UNEQUAL : b:=l1<>l2;
+													_LT : b:=l1<l2;
+													_GT : b:=l1>l2;
+												 _GTE : b:=l1>=l2;
+												 _LTE : b:=l1<=l2;
+										end;
+								 end
+							 else
+								 begin
+										case op of
+											 _EQUAL : b:=hs1=hs2;
+										 _UNEQUAL : b:=hs1<>hs2;
+													_LT : b:=hs1<hs2;
+													_GT : b:=hs1>hs2;
+												 _GTE : b:=hs1>=hs2;
+												 _LTE : b:=hs1<=hs2;
+										end;
+								 end;
+						 end;
+
            if b then
              read_expr:='1'
            else
              read_expr:='0';
+           exprType:= [ctetBoolean];
         end;
-
      begin
         current_scanner.skipspace;
         { start preproc expression scanner }
         current_scanner.preproc_token:=current_scanner.readpreproc;
-        parse_compiler_expr:=read_expr;
-      end;
+        parse_compiler_expr:=read_expr(compileExprType);
+     end;
 
     function boolean_compile_time_expr(var valuedescr: String): Boolean;
       var
         hs : string;
+        exprType: TCTETypeSet;
       begin
-        hs:=parse_compiler_expr;
+        hs:=parse_compiler_expr(exprType);
+        if (exprType * [ctetBoolean]) = [] then
+          CTEError(exprType, [ctetBoolean], 'IF or ELSEIF');
         boolean_compile_time_expr:= hs <> '0';
         valuedescr:= hs;
       end;
@@ -862,7 +1044,7 @@ implementation
         current_scanner.elseifpreprocstack(@boolean_compile_time_expr);
       end;
 
-    procedure dir_define;
+    procedure dir_define_impl(macstyle: boolean);
       var
         hs  : string;
         bracketcount : longint;
@@ -898,7 +1080,7 @@ implementation
              { !!!!!! handle macro params, need we this? }
              current_scanner.skipspace;
 
-             if not (m_mac in aktmodeswitches) then
+             if not macstyle then
                begin
                  { may be a macro? }
                  if c <> ':' then
@@ -964,10 +1146,23 @@ implementation
           end;
       end;
 
+    procedure dir_define;
+      begin
+			  dir_define_impl(false);
+			end;
+
+    procedure dir_definec;
+      begin
+				dir_define_impl(true);
+			end;
+
     procedure dir_setc;
       var
         hs  : string;
         mac : tmacro;
+        exprType: TCTETypeSet;
+        l : longint;
+			  w : integer;
       begin
         current_scanner.skipspace;
         hs:=current_scanner.readid;
@@ -1008,9 +1203,22 @@ implementation
         if c='=' then
           begin
              current_scanner.readchar;
-             hs:= parse_compiler_expr;
+             hs:= parse_compiler_expr(exprType);
+             if (exprType * [ctetBoolean, ctetInteger]) = [] then
+               CTEError(exprType, [ctetBoolean, ctetInteger], 'SETC');
+
              if length(hs) <> 0 then
                begin
+							   {If we are absolutely shure it is boolean, translate
+								  to TRUE/FALSE to increase possibility to do future type check}
+							   if exprType = [ctetBoolean] then
+								   begin
+							       val(hs,l,w);
+                     if l<>0 then
+                       hs:='TRUE'
+                     else
+                       hs:='FALSE';
+                   end;
                  Message2(parser_c_macro_set_to,mac.name,hs);
                  { free buffer of macro ?}
                  if assigned(mac.buftext) then
@@ -1067,13 +1275,13 @@ implementation
           hpath  : string;
 
         begin
-         { look for the include file
+         (* look for the include file
 	   If path was specified as part of {$I } then
 	    1. specified path (expanded with path of inputfile if relative)
            else
             1. path of current inputfile,current dir
             2. local includepath
-            3. global includepath }
+            3. global includepath *)
            found:=false;
            foundfile:='';
            hpath:='';
@@ -1695,8 +1903,6 @@ implementation
       end;
 
     procedure tscannerfile.elsepreprocstack;
-      var
-        valuedescr: String;
       begin
         if assigned(preprocstack) and
            (preprocstack.typ<>pp_else) then
@@ -3436,7 +3642,7 @@ exit_label:
 
         { Directives and conditionals for mode macpas: }
         AddDirective('SETC',directive_mac, @dir_setc);
-        AddDirective('DEFINEC',directive_mac, @dir_define);
+        AddDirective('DEFINEC',directive_mac, @dir_definec);
         AddDirective('UNDEFC',directive_mac, @dir_undef);
 
         AddConditional('IFC',directive_mac, @dir_if);