{ Copyright (c) 1998-2002 by Florian Klaempfl This unit implements the scanner part and handling of the switches This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. **************************************************************************** } unit scanner; {$i fpcdefs.inc} interface uses cclasses, globtype,globals,constexp,version,tokens, verbose,comphook, finput, widestr; const max_include_nesting=32; max_macro_nesting=16; preprocbufsize=32*1024; type tcommentstyle = (comment_none,comment_tp,comment_oldtp,comment_delphi,comment_c); tscannerfile = class; preproctyp = (pp_ifdef,pp_ifndef,pp_if,pp_ifopt,pp_else,pp_elseif); tpreprocstack = class typ : preproctyp; accept : boolean; next : tpreprocstack; name : TIDString; line_nb : longint; owner : tscannerfile; constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack); end; tdirectiveproc=procedure; tdirectiveitem = class(TFPHashObject) public is_conditional : boolean; proc : tdirectiveproc; constructor Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); constructor CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); end; // stack for replay buffers treplaystack = class token : ttoken; settings : tsettings; tokenbuf : tdynamicarray; next : treplaystack; constructor Create(atoken: ttoken;asettings:tsettings; atokenbuf:tdynamicarray;anext:treplaystack); end; tcompile_time_predicate = function(var valuedescr: String) : Boolean; tspecialgenerictoken = (ST_LOADSETTINGS, ST_LINE, ST_COLUMN, ST_FILEINDEX, ST_LOADMESSAGES); { tscannerfile } tscannerfile = class private procedure do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo); procedure cachenexttokenpos; procedure setnexttoken; procedure savetokenpos; procedure restoretokenpos; procedure writetoken(t: ttoken); function readtoken : ttoken; public inputfile : tinputfile; { current inputfile list } inputfilecount : longint; inputbuffer, { input buffer } inputpointer : pchar; inputstart : longint; line_no, { line } lastlinepos : longint; lasttokenpos, nexttokenpos : longint; { token } lasttoken, nexttoken : ttoken; oldlasttokenpos : longint; { temporary saving/restoring tokenpos } oldcurrent_filepos, oldcurrent_tokenpos : tfileposinfo; replaytokenbuf, recordtokenbuf : tdynamicarray; { last settings we stored } last_settings : tsettings; last_message : pmessagestaterecord; { last filepos we stored } last_filepos, { if nexttoken<>NOTOKEN, then nexttokenpos holds its filepos } next_filepos : tfileposinfo; comment_level, yylexcount : longint; lastasmgetchar : char; ignoredirectives : TFPHashList; { ignore directives, used to give warnings only once } preprocstack : tpreprocstack; replaystack : treplaystack; in_asm_string : boolean; preproc_pattern : string; preproc_token : ttoken; constructor Create(const fn:string; is_macro: boolean = false); destructor Destroy;override; { File buffer things } function openinputfile:boolean; procedure closeinputfile; function tempopeninputfile:boolean; procedure tempcloseinputfile; procedure saveinputfile; procedure restoreinputfile; procedure firstfile; procedure nextfile; procedure addfile(hp:tinputfile); procedure reload; { replaces current token with the text in p } procedure substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint); { Scanner things } procedure gettokenpos; procedure inc_comment_level; procedure dec_comment_level; procedure illegal_char(c:char); procedure end_of_file; procedure checkpreprocstack; procedure poppreprocstack; procedure ifpreprocstack(atyp:preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint); procedure elseifpreprocstack(compile_time_predicate:tcompile_time_predicate); procedure elsepreprocstack; procedure popreplaystack; procedure handleconditional(p:tdirectiveitem); procedure handledirectives; procedure linebreak; procedure recordtoken; procedure startrecordtokens(buf:tdynamicarray); procedure stoprecordtokens; procedure replaytoken; procedure startreplaytokens(buf:tdynamicarray); { bit length asizeint is target depend } procedure tokenwritesizeint(val : asizeint); procedure tokenwritelongint(val : longint); procedure tokenwritelongword(val : longword); procedure tokenwriteword(val : word); procedure tokenwriteshortint(val : shortint); procedure tokenwriteset(var b;size : longint); procedure tokenwriteenum(var b;size : longint); function tokenreadsizeint : asizeint; procedure tokenwritesettings(var asettings : tsettings; var size : asizeint); { longword/longint are 32 bits on all targets } { word/smallint are 16-bits on all targest } function tokenreadlongword : longword; function tokenreadword : word; function tokenreadlongint : longint; function tokenreadsmallint : smallint; { short int is one a signed byte } function tokenreadshortint : shortint; function tokenreadbyte : byte; { This one takes the set size as an parameter } procedure tokenreadset(var b;size : longint); function tokenreadenum(size : longint) : longword; procedure tokenreadsettings(var asettings : tsettings; expected_size : asizeint); procedure readchar; procedure readstring; procedure readnumber; function readid:string; function readval:longint; function readcomment:string; function readquotedstring:string; function readstate:char; function readstatedefault:char; procedure skipspace; procedure skipuntildirective; procedure skipcomment; procedure skipdelphicomment; procedure skipoldtpcomment; procedure readtoken(allowrecordtoken:boolean); function readpreproc:ttoken; function asmgetcharstart : char; function asmgetchar:char; end; {$ifdef PREPROCWRITE} tpreprocfile=class f : text; buf : pointer; spacefound, eolfound : boolean; constructor create(const fn:string); destructor destroy; procedure Add(const s:string); procedure AddSpace; end; {$endif PREPROCWRITE} var { read strings } c : char; orgpattern, pattern : string; cstringpattern : ansistring; patternw : pcompilerwidestring; { token } token, { current token being parsed } idtoken : ttoken; { holds the token if the pattern is a known word } current_scanner : tscannerfile; { current scanner in use } aktcommentstyle : tcommentstyle; { needed to use read_comment from directives } {$ifdef PREPROCWRITE} preprocfile : tpreprocfile; { used with only preprocessing } {$endif PREPROCWRITE} type tdirectivemode = (directive_all, directive_turbo, directive_mac); procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc); procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc); procedure InitScanner; procedure DoneScanner; { To be called when the language mode is finally determined } Function SetCompileMode(const s:string; changeInit: boolean):boolean; Function SetCompileModeSwitch(s:string; changeInit: boolean):boolean; procedure SetAppType(NewAppType:tapptype); implementation uses SysUtils, cutils,cfileutl, systems, switches, symbase,symtable,symtype,symsym,symconst,symdef,defutil, { This is needed for tcputype } cpuinfo, fmodule {$if FPC_FULLVERSION<20700} ,ccharset {$endif} ; var { dictionaries with the supported directives } turbo_scannerdirectives : TFPHashObjectList; { for other modes } mac_scannerdirectives : TFPHashObjectList; { for mode mac } {***************************************************************************** Helper routines *****************************************************************************} const { use any special name that is an invalid file name to avoid problems } preprocstring : array [preproctyp] of string[7] = ('$IFDEF','$IFNDEF','$IF','$IFOPT','$ELSE','$ELSEIF'); function is_keyword(const s:string):boolean; var low,high,mid : longint; begin if not (length(s) in [tokenlenmin..tokenlenmax]) or not (s[1] in ['a'..'z','A'..'Z']) then begin is_keyword:=false; exit; end; low:=ord(tokenidx^[length(s),s[1]].first); high:=ord(tokenidx^[length(s),s[1]].last); while low[]); end; Procedure HandleModeSwitches(switch: tmodeswitch; changeInit: boolean); begin { turn ansi/unicodestrings on by default ? (only change when this particular setting is changed, so that a random modeswitch won't change the state of $h+/$h-) } if switch in [m_none,m_default_ansistring,m_default_unicodestring] then begin if ([m_default_ansistring,m_default_unicodestring]*current_settings.modeswitches)<>[] then begin { can't have both ansistring and unicodestring as default } if switch=m_default_ansistring then begin exclude(current_settings.modeswitches,m_default_unicodestring); if changeinit then exclude(init_settings.modeswitches,m_default_unicodestring); end else if switch=m_default_unicodestring then begin exclude(current_settings.modeswitches,m_default_ansistring); if changeinit then exclude(init_settings.modeswitches,m_default_ansistring); end; { enable $h+ } include(current_settings.localswitches,cs_refcountedstrings); if changeinit then include(init_settings.localswitches,cs_refcountedstrings); if m_default_unicodestring in current_settings.modeswitches then begin def_system_macro('FPC_UNICODESTRINGS'); def_system_macro('UNICODE'); end; end else begin exclude(current_settings.localswitches,cs_refcountedstrings); if changeinit then exclude(init_settings.localswitches,cs_refcountedstrings); undef_system_macro('FPC_UNICODESTRINGS'); undef_system_macro('UNICODE'); end; end; { turn inline on by default ? } if switch in [m_none,m_default_inline] then begin if (m_default_inline in current_settings.modeswitches) then begin include(current_settings.localswitches,cs_do_inline); if changeinit then include(init_settings.localswitches,cs_do_inline); end else begin exclude(current_settings.localswitches,cs_do_inline); if changeinit then exclude(init_settings.localswitches,cs_do_inline); end; end; { turn on system codepage by default } if switch in [m_none,m_systemcodepage] then begin { both m_systemcodepage and specifying a code page via -FcXXX or "$codepage XXX" change current_settings.sourcecodepage. If we used -FcXXX and then have a sourcefile with "$mode objfpc", this routine will be called to disable m_systemcodepage (to ensure it's off in case it would have been set on the command line, or by a previous mode(switch). In that case, we have to ensure that we don't overwrite current_settings.sourcecodepage, as that would cancel out the -FcXXX. This is why we use two separate module switches (cs_explicit_codepage and cs_system_codepage) for the same setting (current_settings.sourcecodepage) } if m_systemcodepage in current_settings.modeswitches then begin { m_systemcodepage gets enabled -> disable any -FcXXX and "codepage XXX" settings (exclude cs_explicit_codepage), and overwrite the sourcecode page } current_settings.sourcecodepage:=DefaultSystemCodePage; if (current_settings.sourcecodepage<>CP_UTF8) and not cpavailable(current_settings.sourcecodepage) then begin Message2(scan_w_unavailable_system_codepage,IntToStr(current_settings.sourcecodepage),IntToStr(default_settings.sourcecodepage)); current_settings.sourcecodepage:=default_settings.sourcecodepage; end; exclude(current_settings.moduleswitches,cs_explicit_codepage); include(current_settings.moduleswitches,cs_system_codepage); if changeinit then begin init_settings.sourcecodepage:=current_settings.sourcecodepage; exclude(init_settings.moduleswitches,cs_explicit_codepage); include(init_settings.moduleswitches,cs_system_codepage); end; end else begin { m_systemcodepage gets disabled -> reset sourcecodepage only if cs_explicit_codepage is not set (it may be set in the scenario where -FcXXX was passed on the command line and then "$mode fpc" is used, because then the caller of this routine will set the "$mode fpc" modeswitches (which don't include m_systemcodepage) and call this routine with m_none). Or it can happen if -FcXXX was passed, and the sourcefile contains "$modeswitch systemcodepage-" statement. Since we unset cs_system_codepage if m_systemcodepage gets activated, we will revert to the default code page if you set a source file code page, then enable the systemcode page and finally disable it again. We don't keep a stack of settings, by design. The only thing we have to ensure is that disabling m_systemcodepage if it wasn't on in the first place doesn't overwrite the sourcecodepage } exclude(current_settings.moduleswitches,cs_system_codepage); if not(cs_explicit_codepage in current_settings.moduleswitches) then current_settings.sourcecodepage:=default_settings.sourcecodepage; if changeinit then begin exclude(init_settings.moduleswitches,cs_system_codepage); if not(cs_explicit_codepage in init_settings.moduleswitches) then init_settings.sourcecodepage:=default_settings.sourcecodepage; end; end; end; end; Function SetCompileMode(const s:string; changeInit: boolean):boolean; var b : boolean; oldmodeswitches : tmodeswitches; begin oldmodeswitches:=current_settings.modeswitches; b:=true; if s='DEFAULT' then current_settings.modeswitches:=fpcmodeswitches else if s='DELPHI' then current_settings.modeswitches:=delphimodeswitches else if s='DELPHIUNICODE' then current_settings.modeswitches:=delphiunicodemodeswitches else if s='TP' then current_settings.modeswitches:=tpmodeswitches else if s='FPC' then begin current_settings.modeswitches:=fpcmodeswitches; { TODO: enable this for 2.3/2.9 } // include(current_settings.localswitches, cs_typed_addresses); end else if s='OBJFPC' then begin current_settings.modeswitches:=objfpcmodeswitches; { TODO: enable this for 2.3/2.9 } // include(current_settings.localswitches, cs_typed_addresses); end {$ifdef gpc_mode} else if s='GPC' then current_settings.modeswitches:=gpcmodeswitches {$endif} else if s='MACPAS' then current_settings.modeswitches:=macmodeswitches else if s='ISO' then current_settings.modeswitches:=isomodeswitches else b:=false; {$ifdef jvm} { enable final fields by default for the JVM targets } include(current_settings.modeswitches,m_final_fields); {$endif jvm} if b and changeInit then init_settings.modeswitches := current_settings.modeswitches; if b then begin { resolve all postponed switch changes } flushpendingswitchesstate; HandleModeSwitches(m_none,changeinit); { turn on bitpacking for mode macpas and iso pascal } if ([m_mac,m_iso] * current_settings.modeswitches <> []) then begin include(current_settings.localswitches,cs_bitpacking); if changeinit then include(init_settings.localswitches,cs_bitpacking); end; { support goto/label by default in delphi/tp7/mac modes } if ([m_delphi,m_tp7,m_mac,m_iso] * current_settings.modeswitches <> []) then begin include(current_settings.moduleswitches,cs_support_goto); if changeinit then include(init_settings.moduleswitches,cs_support_goto); end; { support pointer math by default in fpc/objfpc modes } if ([m_fpc,m_objfpc] * current_settings.modeswitches <> []) then begin include(current_settings.localswitches,cs_pointermath); if changeinit then include(init_settings.localswitches,cs_pointermath); end else begin exclude(current_settings.localswitches,cs_pointermath); if changeinit then exclude(init_settings.localswitches,cs_pointermath); end; { Default enum and set packing for delphi/tp7 } if (m_tp7 in current_settings.modeswitches) or (m_delphi in current_settings.modeswitches) then begin current_settings.packenum:=1; current_settings.setalloc:=1; end else if (m_mac in current_settings.modeswitches) then { compatible with Metrowerks Pascal } current_settings.packenum:=2 else current_settings.packenum:=4; if changeinit then begin init_settings.packenum:=current_settings.packenum; init_settings.setalloc:=current_settings.setalloc; end; {$if defined(i386) or defined(i8086)} { Default to intel assembler for delphi/tp7 on i386/i8086 } if (m_delphi in current_settings.modeswitches) or (m_tp7 in current_settings.modeswitches) then {$ifdef i8086} current_settings.asmmode:=asmmode_i8086_intel; {$else i8086} current_settings.asmmode:=asmmode_i386_intel; {$endif i8086} if changeinit then init_settings.asmmode:=current_settings.asmmode; {$endif i386 or i8086} { Exception support explicitly turned on (mainly for macpas, to } { compensate for lack of interprocedural goto support) } if (cs_support_exceptions in current_settings.globalswitches) then include(current_settings.modeswitches,m_except); { Default strict string var checking in TP/Delphi modes } if ([m_delphi,m_tp7] * current_settings.modeswitches <> []) then begin include(current_settings.localswitches,cs_strict_var_strings); if changeinit then include(init_settings.localswitches,cs_strict_var_strings); end; { Undefine old symbol } if (m_delphi in oldmodeswitches) then undef_system_macro('FPC_DELPHI') else if (m_tp7 in oldmodeswitches) then undef_system_macro('FPC_TP') else if (m_objfpc in oldmodeswitches) then undef_system_macro('FPC_OBJFPC') {$ifdef gpc_mode} else if (m_gpc in oldmodeswitches) then undef_system_macro('FPC_GPC') {$endif} else if (m_mac in oldmodeswitches) then undef_system_macro('FPC_MACPAS'); { define new symbol in delphi,objfpc,tp,gpc,macpas mode } if (m_delphi in current_settings.modeswitches) then def_system_macro('FPC_DELPHI') else if (m_tp7 in current_settings.modeswitches) then def_system_macro('FPC_TP') else if (m_objfpc in current_settings.modeswitches) then def_system_macro('FPC_OBJFPC') {$ifdef gpc_mode} else if (m_gpc in current_settings.modeswitches) then def_system_macro('FPC_GPC') {$endif} else if (m_mac in current_settings.modeswitches) then def_system_macro('FPC_MACPAS'); end; SetCompileMode:=b; end; Function SetCompileModeSwitch(s:string; changeInit: boolean):boolean; var i : tmodeswitch; doinclude : boolean; begin s:=upper(s); { on/off? } doinclude:=true; case s[length(s)] of '+': s:=copy(s,1,length(s)-1); '-': begin s:=copy(s,1,length(s)-1); doinclude:=false; end; end; Result:=false; for i:=m_class to high(tmodeswitch) do if s=modeswitchstr[i] then begin { Objective-C is currently only supported for Darwin targets } if doinclude and (i in [m_objectivec1,m_objectivec2]) and not(target_info.system in systems_objc_supported) then begin Message1(option_unsupported_target_for_feature,'Objective-C'); break; end; if changeInit then current_settings.modeswitches:=init_settings.modeswitches; Result:=true; if doinclude then begin include(current_settings.modeswitches,i); { Objective-C 2.0 support implies 1.0 support } if (i=m_objectivec2) then include(current_settings.modeswitches,m_objectivec1); if (i in [m_objectivec1,m_objectivec2]) then include(current_settings.modeswitches,m_class); end else begin exclude(current_settings.modeswitches,i); { Objective-C 2.0 support implies 1.0 support } if (i=m_objectivec2) then exclude(current_settings.modeswitches,m_objectivec1); if (i in [m_objectivec1,m_objectivec2]) and ([m_delphi,m_objfpc]*current_settings.modeswitches=[]) then exclude(current_settings.modeswitches,m_class); end; { set other switches depending on changed mode switch } HandleModeSwitches(i,changeinit); if changeInit then init_settings.modeswitches:=current_settings.modeswitches; break; end; end; procedure SetAppType(NewAppType:tapptype); begin {$ifdef i8086} if (target_info.system=system_i8086_msdos) and (apptype<>NewAppType) then begin if NewAppType=app_com then begin targetinfos[system_i8086_msdos]^.exeext:='.com'; target_info.exeext:='.com'; end else begin targetinfos[system_i8086_msdos]^.exeext:='.exe'; target_info.exeext:='.exe'; end; end; {$endif i8086} if apptype in [app_cui,app_com] then undef_system_macro('CONSOLE'); apptype:=NewAppType; if apptype in [app_cui,app_com] then def_system_macro('CONSOLE'); end; {***************************************************************************** Conditional Directives *****************************************************************************} procedure dir_else; begin current_scanner.elsepreprocstack; end; procedure dir_endif; begin current_scanner.poppreprocstack; end; function isdef(var valuedescr: String): Boolean; var hs : string; begin current_scanner.skipspace; hs:=current_scanner.readid; valuedescr:= hs; if hs='' then Message(scan_e_error_in_preproc_expr); isdef:=defined_macro(hs); end; procedure dir_ifdef; begin current_scanner.ifpreprocstack(pp_ifdef,@isdef,scan_c_ifdef_found); end; function isnotdef(var valuedescr: String): Boolean; var hs : string; begin current_scanner.skipspace; hs:=current_scanner.readid; valuedescr:= hs; if hs='' then Message(scan_e_error_in_preproc_expr); isnotdef:=not defined_macro(hs); end; procedure dir_ifndef; begin current_scanner.ifpreprocstack(pp_ifndef,@isnotdef,scan_c_ifndef_found); end; function opt_check(var valuedescr: String): Boolean; var hs : string; state : char; begin opt_check:= false; current_scanner.skipspace; hs:=current_scanner.readid; valuedescr:= hs; if (length(hs)>1) then Message1(scan_w_illegal_switch,hs) else begin state:=current_scanner.ReadState; if state in ['-','+'] then opt_check:=CheckSwitch(hs[1],state) else Message(scan_e_error_in_preproc_expr); end; end; procedure dir_ifopt; begin flushpendingswitchesstate; current_scanner.ifpreprocstack(pp_ifopt,@opt_check,scan_c_ifopt_found); end; procedure dir_libprefix; var s : string; begin current_scanner.skipspace; if c <> '''' then Message2(scan_f_syn_expected, '''', c); s := current_scanner.readquotedstring; stringdispose(outputprefix); outputprefix := stringdup(s); with current_module do setfilename(paramfn, paramallowoutput); end; procedure dir_libsuffix; var s : string; begin current_scanner.skipspace; if c <> '''' then Message2(scan_f_syn_expected, '''', c); s := current_scanner.readquotedstring; stringdispose(outputsuffix); outputsuffix := stringdup(s); with current_module do setfilename(paramfn, paramallowoutput); end; procedure dir_extension; var s : string; begin current_scanner.skipspace; if c <> '''' then Message2(scan_f_syn_expected, '''', c); s := current_scanner.readquotedstring; if OutputFileName='' then OutputFileName:=InputFileName; OutputFileName:=ChangeFileExt(OutputFileName,'.'+s); with current_module do setfilename(paramfn, paramallowoutput); end; { 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. 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. Short circuit evaluation ------------------------ For this to work, the part of a compile time expression which is short circuited, should not be evaluated, while it still should be parsed. Therefor there is a parameter eval, telling whether evaluation is needed. In case not, the value returned can be arbitrary. } type { texprvalue } texprvalue = class private { we can't use built-in defs since they may be not created at the moment } class var sintdef,uintdef,booldef,strdef,setdef,realdef: tdef; class constructor createdefs; class destructor destroydefs; public consttyp: tconsttyp; value: tconstvalue; def: tdef; constructor create_const(c:tconstsym); constructor create_error; constructor create_ord(v: Tconstexprint); constructor create_int(v: int64); constructor create_uint(v: qword); constructor create_bool(b: boolean); constructor create_str(s: string); constructor create_set(ns: tnormalset); constructor create_real(r: bestreal); class function try_parse_number(s:string):texprvalue; static; class function try_parse_real(s:string):texprvalue; static; function evaluate(v:texprvalue;op:ttoken):texprvalue; procedure error(expecteddef, place: string); function isBoolean: Boolean; function asBool: Boolean; function asInt: Integer; function asStr: String; destructor destroy; override; end; class constructor texprvalue.createdefs; begin { do not use corddef etc here: this code is executed before those variables are initialised. Since these types are only used for compile-time evaluation of conditional expressions, it doesn't matter that we use the base types instead of the cpu-specific ones. } sintdef:=torddef.create(s64bit,low(int64),high(int64)); uintdef:=torddef.create(u64bit,low(qword),high(qword)); booldef:=torddef.create(pasbool8,0,1); strdef:=tstringdef.createansi(0); setdef:=tsetdef.create(sintdef,0,255); realdef:=tfloatdef.create(s80real); end; class destructor texprvalue.destroydefs; begin setdef.free; sintdef.free; uintdef.free; booldef.free; strdef.free; realdef.free; end; constructor texprvalue.create_const(c: tconstsym); begin consttyp:=c.consttyp; def:=c.constdef; case consttyp of conststring, constresourcestring: begin value.len:=c.value.len; getmem(value.valueptr,value.len+1); move(c.value.valueptr^,value.valueptr,value.len+1); end; constwstring: begin initwidestring(value.valueptr); copywidestring(c.value.valueptr,value.valueptr); end; constreal: begin new(pbestreal(value.valueptr)); pbestreal(value.valueptr)^:=pbestreal(c.value.valueptr)^; end; constset: begin new(pnormalset(value.valueptr)); pnormalset(value.valueptr)^:=pnormalset(c.value.valueptr)^; end; constguid: begin new(pguid(value.valueptr)); pguid(value.valueptr)^:=pguid(c.value.valueptr)^; end; else value:=c.value; end; end; constructor texprvalue.create_error; begin fillchar(value,sizeof(value),#0); consttyp:=constnone; def:=generrordef; end; constructor texprvalue.create_ord(v: Tconstexprint); begin fillchar(value,sizeof(value),#0); consttyp:=constord; value.valueord:=v; if v.signed then def:=sintdef else def:=uintdef; end; constructor texprvalue.create_int(v: int64); begin fillchar(value,sizeof(value),#0); consttyp:=constord; value.valueord:=v; def:=sintdef; end; constructor texprvalue.create_uint(v: qword); begin fillchar(value,sizeof(value),#0); consttyp:=constord; value.valueord:=v; def:=uintdef; end; constructor texprvalue.create_bool(b: boolean); begin fillchar(value,sizeof(value),#0); consttyp:=constord; value.valueord:=ord(b); def:=booldef; end; constructor texprvalue.create_str(s: string); var sp: pansichar; len: integer; begin fillchar(value,sizeof(value),#0); consttyp:=conststring; len:=length(s); getmem(sp,len+1); move(s[1],sp^,len+1); value.valueptr:=sp; value.len:=length(s); def:=strdef; end; constructor texprvalue.create_set(ns: tnormalset); begin fillchar(value,sizeof(value),#0); consttyp:=constset; new(pnormalset(value.valueptr)); pnormalset(value.valueptr)^:=ns; def:=setdef; end; constructor texprvalue.create_real(r: bestreal); begin fillchar(value,sizeof(value),#0); consttyp:=constreal; new(pbestreal(value.valueptr)); pbestreal(value.valueptr)^:=r; def:=realdef; end; class function texprvalue.try_parse_number(s:string):texprvalue; var ic: int64; qc: qword; code: integer; begin { try int64 } val(s,ic,code); if code=0 then result:=texprvalue.create_int(ic) else begin { try qword } val(s,qc,code); if code=0 then result:=texprvalue.create_uint(qc) else result:=try_parse_real(s); end; end; class function texprvalue.try_parse_real(s:string):texprvalue; var d: bestreal; code: integer; begin val(s,d,code); if code=0 then result:=texprvalue.create_real(d) else result:=nil; end; function texprvalue.evaluate(v:texprvalue;op:ttoken):texprvalue; function check_compatbile: boolean; begin result:=( (is_ordinal(v.def) or is_fpu(v.def)) and (is_ordinal(def) or is_fpu(def)) ) or (is_string(v.def) and is_string(def)); if not result then Message2(type_e_incompatible_types,def.typename,v.def.typename); end; var lv,rv: tconstexprint; lvd,rvd: bestreal; lvs,rvs: string; begin case op of _OP_IN: begin if not is_set(v.def) then begin v.error('Set', 'IN'); result:=texprvalue.create_error; end else if not is_ordinal(def) then begin error('Ordinal', 'IN'); result:=texprvalue.create_error; end else if value.valueord.signed then result:=texprvalue.create_bool(value.valueord.svalue in pnormalset(v.value.valueptr)^) else result:=texprvalue.create_bool(value.valueord.uvalue in pnormalset(v.value.valueptr)^); end; _OP_NOT: begin if isBoolean then result:=texprvalue.create_bool(not asBool) else begin error('Boolean', 'NOT'); result:=texprvalue.create_error; end; end; _OP_OR: begin if isBoolean then if v.isBoolean then result:=texprvalue.create_bool(asBool or v.asBool) else begin v.error('Boolean','OR'); result:=texprvalue.create_error; end else begin error('Boolean','OR'); result:=texprvalue.create_error; end; end; _OP_XOR: begin if isBoolean then if v.isBoolean then result:=texprvalue.create_bool(asBool xor v.asBool) else begin v.error('Boolean','XOR'); result:=texprvalue.create_error; end else begin error('Boolean','XOR'); result:=texprvalue.create_error; end; end; _OP_AND: begin if isBoolean then if v.isBoolean then result:=texprvalue.create_bool(asBool and v.asBool) else begin v.error('Boolean','AND'); result:=texprvalue.create_error; end else begin error('Boolean','AND'); result:=texprvalue.create_error; end; end; _EQ,_NE,_LT,_GT,_GTE,_LTE,_PLUS,_MINUS,_STAR,_SLASH,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR: if check_compatbile then begin if (is_ordinal(def) and is_ordinal(v.def)) then begin lv:=value.valueord; rv:=v.value.valueord; case op of _EQ: result:=texprvalue.create_bool(lv=rv); _NE: result:=texprvalue.create_bool(lv<>rv); _LT: result:=texprvalue.create_bool(lvrv); _GTE: result:=texprvalue.create_bool(lv>=rv); _LTE: result:=texprvalue.create_bool(lv<=rv); _PLUS: result:=texprvalue.create_ord(lv+rv); _MINUS: result:=texprvalue.create_ord(lv-rv); _STAR: result:=texprvalue.create_ord(lv*rv); _SLASH: result:=texprvalue.create_real(lv/rv); _OP_DIV: result:=texprvalue.create_ord(lv div rv); _OP_MOD: result:=texprvalue.create_ord(lv mod rv); _OP_SHL: result:=texprvalue.create_ord(lv shl rv); _OP_SHR: result:=texprvalue.create_ord(lv shr rv); else begin { actually we should never get here but this avoids a warning } Message(parser_e_illegal_expression); result:=texprvalue.create_error; end; end; end else if (is_fpu(def) or is_ordinal(def)) and (is_fpu(v.def) or is_ordinal(v.def)) then begin if is_fpu(def) then lvd:=pbestreal(value.valueptr)^ else lvd:=value.valueord; if is_fpu(v.def) then rvd:=pbestreal(v.value.valueptr)^ else rvd:=v.value.valueord; case op of _EQ: result:=texprvalue.create_bool(lvd=rvd); _NE: result:=texprvalue.create_bool(lvd<>rvd); _LT: result:=texprvalue.create_bool(lvdrvd); _GTE: result:=texprvalue.create_bool(lvd>=rvd); _LTE: result:=texprvalue.create_bool(lvd<=rvd); _PLUS: result:=texprvalue.create_real(lvd+rvd); _MINUS: result:=texprvalue.create_real(lvd-rvd); _STAR: result:=texprvalue.create_real(lvd*rvd); _SLASH: result:=texprvalue.create_real(lvd/rvd); else begin Message(parser_e_illegal_expression); result:=texprvalue.create_error; end; end; end else begin lvs:=asStr; rvs:=v.asStr; case op of _EQ: result:=texprvalue.create_bool(lvs=rvs); _NE: result:=texprvalue.create_bool(lvs<>rvs); _LT: result:=texprvalue.create_bool(lvsrvs); _GTE: result:=texprvalue.create_bool(lvs>=rvs); _LTE: result:=texprvalue.create_bool(lvs<=rvs); _PLUS: result:=texprvalue.create_str(lvs+rvs); else begin Message(parser_e_illegal_expression); result:=texprvalue.create_error; end; end; end; end else result:=texprvalue.create_error; else result:=texprvalue.create_error; end; end; procedure texprvalue.error(expecteddef, place: string); begin Message3(scan_e_compile_time_typeerror, expecteddef, def.typename, place ); end; function texprvalue.isBoolean: Boolean; var i: integer; begin result:=is_boolean(def); if not result and is_integer(def) then begin i:=asInt; result:=(i=0)or(i=1); end; end; function texprvalue.asBool: Boolean; begin result:=value.valueord<>0; end; function texprvalue.asInt: Integer; begin result:=value.valueord.svalue; end; function texprvalue.asStr: String; var b:byte; begin case consttyp of constord: result:=tostr(value.valueord); conststring, constresourcestring: SetString(result,pchar(value.valueptr),value.len); constreal: str(pbestreal(value.valueptr)^,result); constset: begin result:=','; for b:=0 to 255 do if b in pconstset(value.valueptr)^ then result:=result+tostr(b)+','; end; { error values } constnone: result:=''; else internalerror(2013112801); end; end; destructor texprvalue.destroy; begin case consttyp of conststring, constresourcestring : freemem(pchar(value.valueptr),value.len+1); constwstring : donewidestring(pcompilerwidestring(value.valueptr)); constreal : dispose(pbestreal(value.valueptr)); constset : dispose(pnormalset(value.valueptr)); constguid : dispose(pguid(value.valueptr)); constord, { error values } constnone: ; else internalerror(2013112802); end; inherited destroy; end; const preproc_operators=[_EQ,_NE,_LT,_GT,_LTE,_GTE,_MINUS,_PLUS,_STAR,_SLASH,_OP_DIV,_OP_MOD,_OP_SHL,_OP_SHR,_OP_IN,_OP_AND,_OP_OR,_OP_XOR]; function preproc_comp_expr:texprvalue; function preproc_sub_expr(pred_level:Toperator_precedence;eval:Boolean):texprvalue; forward; procedure preproc_consume(t:ttoken); begin if t<>current_scanner.preproc_token then Message(scan_e_preproc_syntax_error); current_scanner.preproc_token:=current_scanner.readpreproc; end; function try_consume_unitsym(var srsym:tsym;var srsymtable:TSymtable;out tokentoconsume:ttoken):boolean; var hmodule: tmodule; ns:ansistring; nssym:tsym; begin result:=false; tokentoconsume:=_ID; if assigned(srsym) and (srsym.typ in [unitsym,namespacesym]) then begin if not(srsym.owner.symtabletype in [staticsymtable,globalsymtable]) then internalerror(200501154); { only allow unit.symbol access if the name was found in the current module we can use iscurrentunit because generic specializations does not change current_unit variable } hmodule:=find_module_from_symtable(srsym.Owner); if not Assigned(hmodule) then internalerror(201001120); if hmodule.unit_index=current_filepos.moduleindex then begin preproc_consume(_POINT); current_scanner.skipspace; if srsym.typ=namespacesym then begin ns:=srsym.name; nssym:=srsym; while assigned(srsym) and (srsym.typ=namespacesym) do begin { we have a namespace. the next identifier should be either a namespace or a unit } searchsym_in_module(hmodule,ns+'.'+current_scanner.preproc_pattern,srsym,srsymtable); if assigned(srsym) and (srsym.typ in [namespacesym,unitsym]) then begin ns:=ns+'.'+current_scanner.preproc_pattern; nssym:=srsym; preproc_consume(_ID); current_scanner.skipspace; preproc_consume(_POINT); current_scanner.skipspace; end; end; { check if there is a hidden unit with this pattern in the namespace } if not assigned(srsym) and assigned(nssym) and (nssym.typ=namespacesym) and assigned(tnamespacesym(nssym).unitsym) then srsym:=tnamespacesym(nssym).unitsym; if assigned(srsym) and (srsym.typ<>unitsym) then internalerror(201108260); if not assigned(srsym) then begin result:=true; srsymtable:=nil; exit; end; end; case current_scanner.preproc_token of _ID: { system.char? (char=widechar comes from the implicit uuchar unit -> override) } if (current_scanner.preproc_pattern='CHAR') and (tmodule(tunitsym(srsym).module).globalsymtable=systemunit) then begin if m_default_unicodestring in current_settings.modeswitches then searchsym_in_module(tunitsym(srsym).module,'WIDECHAR',srsym,srsymtable) else searchsym_in_module(tunitsym(srsym).module,'ANSICHAR',srsym,srsymtable) end else searchsym_in_module(tunitsym(srsym).module,current_scanner.preproc_pattern,srsym,srsymtable); _STRING: begin { system.string? } if tmodule(tunitsym(srsym).module).globalsymtable=systemunit then begin if cs_refcountedstrings in current_settings.localswitches then begin if m_default_unicodestring in current_settings.modeswitches then searchsym_in_module(tunitsym(srsym).module,'UNICODESTRING',srsym,srsymtable) else searchsym_in_module(tunitsym(srsym).module,'ANSISTRING',srsym,srsymtable) end else searchsym_in_module(tunitsym(srsym).module,'SHORTSTRING',srsym,srsymtable); tokentoconsume:=_STRING; end; end end; end else begin srsym:=nil; srsymtable:=nil; end; result:=true; end; end; procedure try_consume_nestedsym(var srsym:tsym;var srsymtable:TSymtable); var def:tdef; tokentoconsume:ttoken; found:boolean; begin found:=try_consume_unitsym(srsym,srsymtable,tokentoconsume); if found then begin preproc_consume(tokentoconsume); current_scanner.skipspace; end; while (current_scanner.preproc_token=_POINT) do begin if assigned(srsym)and(srsym.typ=typesym) then begin def:=ttypesym(srsym).typedef; if is_class_or_object(def) or is_record(def) or is_java_class_or_interface(def) then begin preproc_consume(_POINT); current_scanner.skipspace; if def.typ=objectdef then found:=searchsym_in_class(tobjectdef(def),tobjectdef(def),current_scanner.preproc_pattern,srsym,srsymtable,[ssf_search_helper]) else found:=searchsym_in_record(trecorddef(def),current_scanner.preproc_pattern,srsym,srsymtable); if not found then begin Message1(sym_e_id_not_found,current_scanner.preproc_pattern); exit; end; preproc_consume(_ID); current_scanner.skipspace; end else begin Message(sym_e_type_must_be_rec_or_object_or_class); exit; end; end else begin Message(type_e_type_id_expected); exit; end; end; end; function preproc_substitutedtoken(searchstr:string;eval:Boolean):texprvalue; { 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; begin if not eval then begin result:=texprvalue.create_str(searchstr); exit; end; mac:=nil; { Substitue macros and compiler variables with their content/value. For real macros also do recursive substitution. } macrocount:=0; repeat mac:=tmacro(search_macro(searchstr)); inc(macrocount); if macrocount>max_macro_nesting then begin Message(scan_w_macro_too_deep); break; end; if assigned(mac) and mac.defined then if assigned(mac.buftext) then begin if mac.buflen>255 then begin len:=255; Message(scan_w_macro_cut_after_255_chars); end else len:=mac.buflen; hs[0]:=char(len); move(mac.buftext^,hs[1],len); searchstr:=upcase(hs); mac.is_used:=true; end else begin Message1(scan_e_error_macro_lacks_value,searchstr); break; end else break; if mac.is_compiler_var then break; until false; { At this point, result do contain the value. Do some decoding and determine the type.} result:=texprvalue.try_parse_number(searchstr); if not assigned(result) then begin if assigned(mac) and (searchstr='FALSE') then result:=texprvalue.create_bool(false) else if assigned(mac) and (searchstr='TRUE') then result:=texprvalue.create_bool(true) else if (m_mac in current_settings.modeswitches) 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,searchstr); result:=texprvalue.create_str(searchstr); { just to have something } end else result:=texprvalue.create_str(searchstr); end; end; function preproc_factor(eval: Boolean):texprvalue; var hs,countstr,storedpattern: string; mac: tmacro; srsym : tsym; srsymtable : TSymtable; hdef : TDef; l : longint; hasKlammer: Boolean; exprvalue:texprvalue; ns:tnormalset; begin result:=nil; hasKlammer:=false; if current_scanner.preproc_token=_ID then begin if current_scanner.preproc_pattern='DEFINED' then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; hasKlammer:= true; end else if (m_mac in current_settings.modeswitches) then hasKlammer:= false else Message(scan_e_error_in_preproc_expr); if current_scanner.preproc_token =_ID then begin hs := current_scanner.preproc_pattern; mac := tmacro(search_macro(hs)); if assigned(mac) and mac.defined then begin result:=texprvalue.create_bool(true); mac.is_used:=true; end else result:=texprvalue.create_bool(false); preproc_consume(_ID); current_scanner.skipspace; end else Message(scan_e_error_in_preproc_expr); if hasKlammer then if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_error_in_preproc_expr); end else if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='UNDEFINED') then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_ID then begin hs := current_scanner.preproc_pattern; mac := tmacro(search_macro(hs)); if assigned(mac) then begin result:=texprvalue.create_bool(false); mac.is_used:=true; end else result:=texprvalue.create_bool(true); preproc_consume(_ID); current_scanner.skipspace; end else Message(scan_e_error_in_preproc_expr); end else if (m_mac in current_settings.modeswitches) and (current_scanner.preproc_pattern='OPTION') then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; end else Message(scan_e_error_in_preproc_expr); if not (current_scanner.preproc_token = _ID) then Message(scan_e_error_in_preproc_expr); hs:=current_scanner.preproc_pattern; if (length(hs) > 1) then {This is allowed in Metrowerks Pascal} Message(scan_e_error_in_preproc_expr) else begin if CheckSwitch(hs[1],'+') then result:=texprvalue.create_bool(true) else result:=texprvalue.create_bool(false); end; preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_error_in_preproc_expr); end else if current_scanner.preproc_pattern='SIZEOF' then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; end else Message(scan_e_preproc_syntax_error); storedpattern:=current_scanner.preproc_pattern; preproc_consume(_ID); current_scanner.skipspace; if eval then if searchsym(storedpattern,srsym,srsymtable) then begin try_consume_nestedsym(srsym,srsymtable); l:=0; if assigned(srsym) then case srsym.typ of staticvarsym, localvarsym, paravarsym : l:=tabstractvarsym(srsym).getsize; typesym: l:=ttypesym(srsym).typedef.size; else Message(scan_e_error_in_preproc_expr); end; result:=texprvalue.create_int(l); end else Message1(sym_e_id_not_found,storedpattern); if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_preproc_syntax_error); end else if current_scanner.preproc_pattern='HIGH' then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; end else Message(scan_e_preproc_syntax_error); storedpattern:=current_scanner.preproc_pattern; preproc_consume(_ID); current_scanner.skipspace; if eval then if searchsym(storedpattern,srsym,srsymtable) then begin try_consume_nestedsym(srsym,srsymtable); hdef:=nil; hs:=''; l:=0; if assigned(srsym) then case srsym.typ of staticvarsym, localvarsym, paravarsym : hdef:=tabstractvarsym(srsym).vardef; typesym: hdef:=ttypesym(srsym).typedef; else Message(scan_e_error_in_preproc_expr); end; if assigned(hdef) then begin if hdef.typ=setdef then hdef:=tsetdef(hdef).elementdef; case hdef.typ of orddef: with torddef(hdef).high do if signed then result:=texprvalue.create_int(svalue) else result:=texprvalue.create_uint(uvalue); enumdef: result:=texprvalue.create_int(tenumdef(hdef).maxval); arraydef: if is_open_array(hdef) or is_array_of_const(hdef) or is_dynamic_array(hdef) then Message(type_e_mismatch) else result:=texprvalue.create_int(tarraydef(hdef).highrange); stringdef: if is_open_string(hdef) or is_ansistring(hdef) or is_wide_or_unicode_string(hdef) then Message(type_e_mismatch) else result:=texprvalue.create_int(tstringdef(hdef).len); else Message(type_e_mismatch); end; end; end else Message1(sym_e_id_not_found,storedpattern); if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_preproc_syntax_error); end else if current_scanner.preproc_pattern='DECLARED' then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; end else Message(scan_e_error_in_preproc_expr); if current_scanner.preproc_token =_ID then begin hs := upper(current_scanner.preproc_pattern); preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token in [_LT,_LSHARPBRACKET] then begin l:=1; preproc_consume(current_scanner.preproc_token); current_scanner.skipspace; while current_scanner.preproc_token=_COMMA do begin inc(l); preproc_consume(_COMMA); current_scanner.skipspace; end; if not (current_scanner.preproc_token in [_GT,_RSHARPBRACKET]) then Message(scan_e_error_in_preproc_expr) else preproc_consume(current_scanner.preproc_token); str(l,countstr); hs:=hs+'$'+countstr; end else { special case: <> } if current_scanner.preproc_token=_NE then begin hs:=hs+'$1'; preproc_consume(_NE); end; current_scanner.skipspace; if searchsym(hs,srsym,srsymtable) then begin { TSomeGeneric<...> also adds a TSomeGeneric symbol } if (sp_generic_dummy in srsym.symoptions) and (srsym.typ=typesym) and ( { mode delphi} (ttypesym(srsym).typedef.typ in [undefineddef,errordef]) or { non-delphi modes } (df_generic in ttypesym(srsym).typedef.defoptions) ) then result:=texprvalue.create_bool(false) else result:=texprvalue.create_bool(true); end else result:=texprvalue.create_bool(false); end else Message(scan_e_error_in_preproc_expr); if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_error_in_preproc_expr); end else if current_scanner.preproc_pattern='ORD' then begin preproc_consume(_ID); current_scanner.skipspace; if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; end else Message(scan_e_preproc_syntax_error); exprvalue:=preproc_factor(eval); if eval then begin if is_ordinal(exprvalue.def) then result:=texprvalue.create_int(exprvalue.asInt) else begin exprvalue.error('Ordinal','ORD'); result:=texprvalue.create_int(0); end; end else result:=texprvalue.create_int(0); exprvalue.free; if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_error_in_preproc_expr); end else if current_scanner.preproc_pattern='NOT' then begin preproc_consume(_ID); exprvalue:=preproc_factor(eval); if eval then result:=exprvalue.evaluate(nil,_OP_NOT) else result:=texprvalue.create_bool(false); {Just to have something} exprvalue.free; end else if (current_scanner.preproc_pattern='TRUE') then begin result:=texprvalue.create_bool(true); preproc_consume(_ID); end else if (current_scanner.preproc_pattern='FALSE') then begin result:=texprvalue.create_bool(false); preproc_consume(_ID); end else begin storedpattern:=current_scanner.preproc_pattern; preproc_consume(_ID); current_scanner.skipspace; { first look for a macros/int/float } result:=preproc_substitutedtoken(storedpattern,eval); if eval and (result.consttyp=conststring) then begin if searchsym(storedpattern,srsym,srsymtable) then begin try_consume_nestedsym(srsym,srsymtable); if assigned(srsym) then case srsym.typ of constsym: begin result.free; result:=texprvalue.create_const(tconstsym(srsym)); end; enumsym: begin result.free; result:=texprvalue.create_int(tenumsym(srsym).value); end; end; end end { skip id() if expression must not be evaluated } else if not(eval) and (result.consttyp=conststring) then begin if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); current_scanner.skipspace; result:=preproc_factor(false); if current_scanner.preproc_token =_RKLAMMER then preproc_consume(_RKLAMMER) else Message(scan_e_error_in_preproc_expr); end; end; end end else if current_scanner.preproc_token =_LKLAMMER then begin preproc_consume(_LKLAMMER); result:=preproc_sub_expr(opcompare,eval); preproc_consume(_RKLAMMER); end else if current_scanner.preproc_token = _LECKKLAMMER then begin preproc_consume(_LECKKLAMMER); ns:=[]; while current_scanner.preproc_token in [_ID,_INTCONST] do begin exprvalue:=preproc_factor(eval); include(ns,exprvalue.asInt); if current_scanner.preproc_token = _COMMA then preproc_consume(_COMMA); end; // TODO Add check of setElemType preproc_consume(_RECKKLAMMER); result:=texprvalue.create_set(ns); end else if current_scanner.preproc_token = _INTCONST then begin result:=texprvalue.try_parse_number(current_scanner.preproc_pattern); if not assigned(result) then begin Message(parser_e_invalid_integer); result:=texprvalue.create_int(1); end; preproc_consume(_INTCONST); end else if current_scanner.preproc_token = _REALNUMBER then begin result:=texprvalue.try_parse_real(current_scanner.preproc_pattern); if not assigned(result) then begin Message(parser_e_error_in_real); result:=texprvalue.create_real(1.0); end; preproc_consume(_REALNUMBER); end else Message(scan_e_error_in_preproc_expr); if not assigned(result) then result:=texprvalue.create_error; end; function preproc_sub_expr(pred_level:Toperator_precedence;eval:Boolean): texprvalue; var hs1,hs2: texprvalue; op: ttoken; begin if pred_level=highest_precedence then result:=preproc_factor(eval) else result:=preproc_sub_expr(succ(pred_level),eval); repeat op:=current_scanner.preproc_token; if (op in preproc_operators) and (op in operator_levels[pred_level]) then begin hs1:=result; preproc_consume(op); if (op=_OP_OR) and hs1.isBoolean and hs1.asBool then begin { stop evaluation the rest of expression } result:=texprvalue.create_bool(true); if pred_level=highest_precedence then hs2:=preproc_factor(false) else hs2:=preproc_sub_expr(succ(pred_level),false); end else if (op=_OP_AND) and hs1.isBoolean and not hs1.asBool then begin { stop evaluation the rest of expression } result:=texprvalue.create_bool(false); if pred_level=highest_precedence then hs2:=preproc_factor(false) else hs2:=preproc_sub_expr(succ(pred_level),false); end else begin if pred_level=highest_precedence then hs2:=preproc_factor(eval) else hs2:=preproc_sub_expr(succ(pred_level),eval); if eval then result:=hs1.evaluate(hs2,op) else result:=texprvalue.create_bool(false); {Just to have something} end; hs1.free; hs2.free; end else break; until false; end; begin current_scanner.skipspace; { start preproc expression scanner } current_scanner.preproc_token:=current_scanner.readpreproc; preproc_comp_expr:=preproc_sub_expr(opcompare,true); end; function boolean_compile_time_expr(var valuedescr: string): Boolean; var hs: texprvalue; begin hs:=preproc_comp_expr; if hs.isBoolean then result:=hs.asBool else begin hs.error('Boolean', 'IF or ELSEIF'); result:=false; end; valuedescr:=hs.asStr; hs.free; end; procedure dir_if; begin current_scanner.ifpreprocstack(pp_if,@boolean_compile_time_expr, scan_c_if_found); end; procedure dir_elseif; begin current_scanner.elseifpreprocstack(@boolean_compile_time_expr); end; procedure dir_define_impl(macstyle: boolean); var hs : string; bracketcount : longint; mac : tmacro; macropos : longint; macrobuffer : pmacrobuffer; begin current_scanner.skipspace; hs:=current_scanner.readid; mac:=tmacro(search_macro(hs)); if not assigned(mac) or (mac.owner <> current_module.localmacrosymtable) then begin mac:=tmacro.create(hs); mac.defined:=true; current_module.localmacrosymtable.insert(mac); end else begin mac.defined:=true; mac.is_compiler_var:=false; { delete old definition } if assigned(mac.buftext) then begin freemem(mac.buftext,mac.buflen); mac.buftext:=nil; end; end; Message1(parser_c_macro_defined,mac.name); mac.is_used:=true; if (cs_support_macro in current_settings.moduleswitches) then begin current_scanner.skipspace; if not macstyle then begin { may be a macro? } if c <> ':' then exit; current_scanner.readchar; if c <> '=' then exit; current_scanner.readchar; current_scanner.skipspace; end; { key words are never substituted } if is_keyword(hs) then Message(scan_e_keyword_cant_be_a_macro); new(macrobuffer); macropos:=0; { parse macro, brackets are counted so it's possible to have a $ifdef etc. in the macro } bracketcount:=0; repeat case c of '}' : if (bracketcount=0) then break else dec(bracketcount); '{' : inc(bracketcount); #10,#13 : current_scanner.linebreak; #26 : current_scanner.end_of_file; end; macrobuffer^[macropos]:=c; inc(macropos); if macropos>=maxmacrolen then Message(scan_f_macro_buffer_overflow); current_scanner.readchar; until false; { free buffer of macro ?} if assigned(mac.buftext) then freemem(mac.buftext,mac.buflen); { get new mem } getmem(mac.buftext,macropos); mac.buflen:=macropos; { copy the text } move(macrobuffer^,mac.buftext^,macropos); dispose(macrobuffer); end else begin { check if there is an assignment, then we need to give a warning } current_scanner.skipspace; if c=':' then begin current_scanner.readchar; if c='=' then Message(scan_w_macro_support_turned_off); end; 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; l : longint; w : integer; exprvalue: texprvalue; begin current_scanner.skipspace; hs:=current_scanner.readid; mac:=tmacro(search_macro(hs)); if not assigned(mac) or (mac.owner <> current_module.localmacrosymtable) then begin mac:=tmacro.create(hs); mac.defined:=true; mac.is_compiler_var:=true; current_module.localmacrosymtable.insert(mac); end else begin mac.defined:=true; mac.is_compiler_var:=true; { delete old definition } if assigned(mac.buftext) then begin freemem(mac.buftext,mac.buflen); mac.buftext:=nil; end; end; Message1(parser_c_macro_defined,mac.name); mac.is_used:=true; { key words are never substituted } if is_keyword(hs) then Message(scan_e_keyword_cant_be_a_macro); { macro assignment can be both := and = } current_scanner.skipspace; if c=':' then current_scanner.readchar; if c='=' then begin current_scanner.readchar; exprvalue:=preproc_comp_expr; if not is_boolean(exprvalue.def) and not is_integer(exprvalue.def) then exprvalue.error('Boolean, Integer', 'SETC'); hs:=exprvalue.asStr; 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 exprvalue.isBoolean then begin if exprvalue.asBool 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 freemem(mac.buftext,mac.buflen); { get new mem } getmem(mac.buftext,length(hs)); mac.buflen:=length(hs); { copy the text } move(hs[1],mac.buftext^,mac.buflen); end else Message(scan_e_preproc_syntax_error); exprvalue.free; end else Message(scan_e_preproc_syntax_error); end; procedure dir_undef; var hs : string; mac : tmacro; begin current_scanner.skipspace; hs:=current_scanner.readid; mac:=tmacro(search_macro(hs)); if not assigned(mac) or (mac.owner <> current_module.localmacrosymtable) then begin mac:=tmacro.create(hs); mac.defined:=false; current_module.localmacrosymtable.insert(mac); end else begin mac.defined:=false; mac.is_compiler_var:=false; { delete old definition } if assigned(mac.buftext) then begin freemem(mac.buftext,mac.buflen); mac.buftext:=nil; end; end; Message1(parser_c_macro_undefined,mac.name); mac.is_used:=true; end; procedure dir_include; function findincludefile(const path,name:TCmdStr;var foundfile:TCmdStr):boolean; var found : boolean; hpath : TCmdStr; begin (* look for the include file If path was absolute and specified as part of {$I } then 1. specified path else 1. path of current inputfile,current dir 2. local includepath 3. global includepath -- Check mantis #13461 before changing this *) found:=false; foundfile:=''; hpath:=''; if path_absolute(path) then begin found:=FindFile(name,path,true,foundfile); end else begin hpath:=current_scanner.inputfile.path+';'+CurDirRelPath(source_info); found:=FindFile(path+name, hpath,true,foundfile); if not found then found:=current_module.localincludesearchpath.FindFile(path+name,true,foundfile); if not found then found:=includesearchpath.FindFile(path+name,true,foundfile); end; result:=found; end; var foundfile : TCmdStr; path, name, hs : tpathstr; args : string; hp : tinputfile; found : boolean; macroIsString : boolean; begin current_scanner.skipspace; args:=current_scanner.readcomment; hs:=GetToken(args,' '); if hs='' then exit; if (hs[1]='%') then begin { case insensitive } hs:=upper(hs); { remove %'s } Delete(hs,1,1); if hs[length(hs)]='%' then Delete(hs,length(hs),1); { save old } path:=hs; { first check for internal macros } macroIsString:=true; if hs='TIME' then hs:=gettimestr else if hs='DATE' then hs:=getdatestr else if hs='FILE' then hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex) else if hs='LINE' then hs:=tostr(current_filepos.line) else if hs='LINENUM' then begin hs:=tostr(current_filepos.line); macroIsString:=false; end else if hs='FPCVERSION' then hs:=version_string else if hs='FPCDATE' then hs:=date_string else if hs='FPCTARGET' then hs:=target_cpu_string else if hs='FPCTARGETCPU' then hs:=target_cpu_string else if hs='FPCTARGETOS' then hs:=target_info.shortname else hs:=GetEnvironmentVariable(hs); if hs='' then Message1(scan_w_include_env_not_found,path); { make it a stringconst } if macroIsString then hs:=''''+hs+''''; current_scanner.substitutemacro(path,@hs[1],length(hs), current_scanner.line_no,current_scanner.inputfile.ref_index); end else begin hs:=FixFileName(hs); path:=ExtractFilePath(hs); name:=ExtractFileName(hs); { Special case for Delphi compatibility: '*' has to be replaced by the file name of the current source file. } if (length(name)>=1) and (name[1]='*') then name:=ChangeFileExt(current_module.sourcefiles.get_file_name(current_filepos.fileindex),'')+ExtractFileExt(name); { try to find the file } found:=findincludefile(path,name,foundfile); if (not found) and (ExtractFileExt(name)='') then begin { try default extensions .inc , .pp and .pas } if (not found) then found:=findincludefile(path,ChangeFileExt(name,'.inc'),foundfile); if (not found) then found:=findincludefile(path,ChangeFileExt(name,sourceext),foundfile); if (not found) then found:=findincludefile(path,ChangeFileExt(name,pasext),foundfile); end; if current_scanner.inputfilecount0 then Comment(V_Fatal,'can''t create file '+fn); getmem(buf,preprocbufsize); settextbuf(f,buf^,preprocbufsize); { reset } eolfound:=false; spacefound:=false; end; destructor tpreprocfile.destroy; begin close(f); freemem(buf,preprocbufsize); end; procedure tpreprocfile.add(const s:string); begin write(f,s); end; procedure tpreprocfile.addspace; begin if eolfound then begin writeln(f,''); eolfound:=false; spacefound:=false; end else if spacefound then begin write(f,' '); spacefound:=false; end; end; {$endif PREPROCWRITE} {***************************************************************************** TPreProcStack *****************************************************************************} constructor tpreprocstack.create(atyp : preproctyp;a:boolean;n:tpreprocstack); begin accept:=a; typ:=atyp; next:=n; end; {***************************************************************************** TReplayStack *****************************************************************************} constructor treplaystack.Create(atoken:ttoken;asettings:tsettings; atokenbuf:tdynamicarray;anext:treplaystack); begin token:=atoken; settings:=asettings; tokenbuf:=atokenbuf; next:=anext; end; {***************************************************************************** TDirectiveItem *****************************************************************************} constructor TDirectiveItem.Create(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); begin inherited Create(AList,n); is_conditional:=false; proc:=p; end; constructor TDirectiveItem.CreateCond(AList:TFPHashObjectList;const n:string;p:tdirectiveproc); begin inherited Create(AList,n); is_conditional:=true; proc:=p; end; {**************************************************************************** TSCANNERFILE ****************************************************************************} constructor tscannerfile.create(const fn:string; is_macro: boolean = false); begin inputfile:=do_openinputfile(fn); if is_macro then inputfile.is_macro:=true; if assigned(current_module) then current_module.sourcefiles.register_file(inputfile); { reset localinput } c:=#0; inputbuffer:=nil; inputpointer:=nil; inputstart:=0; { reset scanner } preprocstack:=nil; replaystack:=nil; comment_level:=0; yylexcount:=0; block_type:=bt_general; line_no:=0; lastlinepos:=0; lasttokenpos:=0; nexttokenpos:=0; lasttoken:=NOTOKEN; nexttoken:=NOTOKEN; lastasmgetchar:=#0; ignoredirectives:=TFPHashList.Create; in_asm_string:=false; end; procedure tscannerfile.firstfile; begin { load block } if not openinputfile then Message1(scan_f_cannot_open_input,inputfile.name); reload; end; destructor tscannerfile.destroy; begin if assigned(current_module) and (current_module.state=ms_compiled) and (status.errorcount=0) then checkpreprocstack else begin while assigned(preprocstack) do poppreprocstack; end; while assigned(replaystack) do popreplaystack; if not inputfile.closed then closeinputfile; if inputfile.is_macro then inputfile.free; ignoredirectives.free; end; function tscannerfile.openinputfile:boolean; begin openinputfile:=inputfile.open; { load buffer } inputbuffer:=inputfile.buf; inputpointer:=inputfile.buf; inputstart:=inputfile.bufstart; { line } line_no:=0; lastlinepos:=0; lasttokenpos:=0; nexttokenpos:=0; end; procedure tscannerfile.closeinputfile; begin inputfile.close; { reset buffer } inputbuffer:=nil; inputpointer:=nil; inputstart:=0; { reset line } line_no:=0; lastlinepos:=0; lasttokenpos:=0; nexttokenpos:=0; end; function tscannerfile.tempopeninputfile:boolean; begin tempopeninputfile:=false; if inputfile.is_macro then exit; tempopeninputfile:=inputfile.tempopen; { reload buffer } inputbuffer:=inputfile.buf; inputpointer:=inputfile.buf; inputstart:=inputfile.bufstart; end; procedure tscannerfile.tempcloseinputfile; begin if inputfile.closed or inputfile.is_macro then exit; inputfile.setpos(inputstart+(inputpointer-inputbuffer)); inputfile.tempclose; { reset buffer } inputbuffer:=nil; inputpointer:=nil; inputstart:=0; end; procedure tscannerfile.saveinputfile; begin inputfile.saveinputpointer:=inputpointer; inputfile.savelastlinepos:=lastlinepos; inputfile.saveline_no:=line_no; end; procedure tscannerfile.restoreinputfile; begin inputbuffer:=inputfile.buf; inputpointer:=inputfile.saveinputpointer; lastlinepos:=inputfile.savelastlinepos; line_no:=inputfile.saveline_no; if not inputfile.is_macro then parser_current_file:=inputfile.name; end; procedure tscannerfile.nextfile; var to_dispose : tinputfile; begin if assigned(inputfile.next) then begin if inputfile.is_macro then to_dispose:=inputfile else begin to_dispose:=nil; dec(inputfilecount); end; { we can allways close the file, no ? } inputfile.close; inputfile:=inputfile.next; if assigned(to_dispose) then to_dispose.free; restoreinputfile; end; end; procedure tscannerfile.startrecordtokens(buf:tdynamicarray); begin if not assigned(buf) then internalerror(200511172); if assigned(recordtokenbuf) then internalerror(200511173); recordtokenbuf:=buf; fillchar(last_settings,sizeof(last_settings),0); last_message:=nil; fillchar(last_filepos,sizeof(last_filepos),0); end; procedure tscannerfile.stoprecordtokens; begin if not assigned(recordtokenbuf) then internalerror(200511174); recordtokenbuf:=nil; end; procedure tscannerfile.writetoken(t : ttoken); var b : byte; begin if ord(t)>$7f then begin b:=(ord(t) shr 8) or $80; recordtokenbuf.write(b,1); end; b:=ord(t) and $ff; recordtokenbuf.write(b,1); end; procedure tscannerfile.tokenwritesizeint(val : asizeint); begin {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} recordtokenbuf.write(val,sizeof(asizeint)); end; procedure tscannerfile.tokenwritelongint(val : longint); begin {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} recordtokenbuf.write(val,sizeof(longint)); end; procedure tscannerfile.tokenwriteshortint(val : shortint); begin recordtokenbuf.write(val,sizeof(shortint)); end; procedure tscannerfile.tokenwriteword(val : word); begin {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} recordtokenbuf.write(val,sizeof(word)); end; procedure tscannerfile.tokenwritelongword(val : longword); begin {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} recordtokenbuf.write(val,sizeof(longword)); end; function tscannerfile.tokenreadsizeint : asizeint; var val : asizeint; begin replaytokenbuf.read(val,sizeof(asizeint)); {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} result:=val; end; function tscannerfile.tokenreadlongword : longword; var val : longword; begin replaytokenbuf.read(val,sizeof(longword)); {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} result:=val; end; function tscannerfile.tokenreadlongint : longint; var val : longint; begin replaytokenbuf.read(val,sizeof(longint)); {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} result:=val; end; function tscannerfile.tokenreadshortint : shortint; var val : shortint; begin replaytokenbuf.read(val,sizeof(shortint)); result:=val; end; function tscannerfile.tokenreadbyte : byte; var val : byte; begin replaytokenbuf.read(val,sizeof(byte)); result:=val; end; function tscannerfile.tokenreadsmallint : smallint; var val : smallint; begin replaytokenbuf.read(val,sizeof(smallint)); {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} result:=val; end; function tscannerfile.tokenreadword : word; var val : word; begin replaytokenbuf.read(val,sizeof(word)); {$ifdef FPC_BIG_ENDIAN} val:=swapendian(val); {$endif} result:=val; end; function tscannerfile.tokenreadenum(size : longint) : longword; begin if size=1 then result:=tokenreadbyte else if size=2 then result:=tokenreadword else if size=4 then result:=tokenreadlongword else internalerror(2013112901); end; procedure tscannerfile.tokenreadset(var b;size : longint); {$ifdef FPC_BIG_ENDIAN} var i : longint; {$endif} begin replaytokenbuf.read(b,size); {$ifdef FPC_BIG_ENDIAN} for i:=0 to size-1 do Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]); {$endif} end; procedure tscannerfile.tokenwriteenum(var b;size : longint); begin recordtokenbuf.write(b,size); end; procedure tscannerfile.tokenwriteset(var b;size : longint); {$ifdef FPC_BIG_ENDIAN} var i: longint; tmpset: array[0..31] of byte; {$endif} begin {$ifdef FPC_BIG_ENDIAN} { satisfy DFA because it assumes that size may be 0 and doesn't know that recordtokenbuf.write wouldn't use tmpset in that case } tmpset[0]:=0; for i:=0 to size-1 do tmpset[i]:=reverse_byte(Pbyte(@b)[i]); recordtokenbuf.write(tmpset,size); {$else} recordtokenbuf.write(b,size); {$endif} end; procedure tscannerfile.tokenreadsettings(var asettings : tsettings; expected_size : asizeint); { This procedure needs to be changed whenever globals.tsettings type is changed, the problem is that no error will appear before tests with generics are tested. PM } var startpos, endpos : longword; begin { WARNING all those fields need to be in the correct order otherwise cross_endian PPU reading will fail } startpos:=replaytokenbuf.pos; with asettings do begin alignment.procalign:=tokenreadlongint; alignment.loopalign:=tokenreadlongint; alignment.jumpalign:=tokenreadlongint; alignment.constalignmin:=tokenreadlongint; alignment.constalignmax:=tokenreadlongint; alignment.varalignmin:=tokenreadlongint; alignment.varalignmax:=tokenreadlongint; alignment.localalignmin:=tokenreadlongint; alignment.localalignmax:=tokenreadlongint; alignment.recordalignmin:=tokenreadlongint; alignment.recordalignmax:=tokenreadlongint; alignment.maxCrecordalign:=tokenreadlongint; tokenreadset(globalswitches,sizeof(globalswitches)); tokenreadset(targetswitches,sizeof(targetswitches)); tokenreadset(moduleswitches,sizeof(moduleswitches)); tokenreadset(localswitches,sizeof(localswitches)); tokenreadset(modeswitches,sizeof(modeswitches)); tokenreadset(optimizerswitches,sizeof(optimizerswitches)); tokenreadset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches)); tokenreadset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches)); tokenreadset(debugswitches,sizeof(debugswitches)); { 0: old behaviour for sets <=256 elements >0: round to this size } setalloc:=tokenreadshortint; packenum:=tokenreadshortint; packrecords:=tokenreadshortint; maxfpuregisters:=tokenreadshortint; cputype:=tcputype(tokenreadenum(sizeof(tcputype))); optimizecputype:=tcputype(tokenreadenum(sizeof(tcputype))); fputype:=tfputype(tokenreadenum(sizeof(tfputype))); asmmode:=tasmmode(tokenreadenum(sizeof(tasmmode))); interfacetype:=tinterfacetypes(tokenreadenum(sizeof(tinterfacetypes))); defproccall:=tproccalloption(tokenreadenum(sizeof(tproccalloption))); { tstringencoding is word type, thus this should be OK here } sourcecodepage:=tstringEncoding(tokenreadword); minfpconstprec:=tfloattype(tokenreadenum(sizeof(tfloattype))); disabledircache:=boolean(tokenreadbyte); { TH: Since the field was conditional originally, it was not stored in PPUs. } { While adding ControllerSupport constant, I decided not to store ct_none } { on targets not supporting controllers, but this might be changed here and } { in tokenwritesettings in the future to unify the PPU structure and handling } { of this field in the compiler. } {$PUSH} {$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *) if ControllerSupport then controllertype:=tcontrollertype(tokenreadenum(sizeof(tcontrollertype))) else ControllerType:=ct_none; {$POP} endpos:=replaytokenbuf.pos; if endpos-startpos<>expected_size then Comment(V_Error,'Wrong size of Settings read-in'); end; end; procedure tscannerfile.tokenwritesettings(var asettings : tsettings; var size : asizeint); { This procedure needs to be changed whenever globals.tsettings type is changed, the problem is that no error will appear before tests with generics are tested. PM } var sizepos, startpos, endpos : longword; begin { WARNING all those fields need to be in the correct order otherwise cross_endian PPU reading will fail } sizepos:=recordtokenbuf.pos; size:=0; tokenwritesizeint(size); startpos:=recordtokenbuf.pos; with asettings do begin tokenwritelongint(alignment.procalign); tokenwritelongint(alignment.loopalign); tokenwritelongint(alignment.jumpalign); tokenwritelongint(alignment.constalignmin); tokenwritelongint(alignment.constalignmax); tokenwritelongint(alignment.varalignmin); tokenwritelongint(alignment.varalignmax); tokenwritelongint(alignment.localalignmin); tokenwritelongint(alignment.localalignmax); tokenwritelongint(alignment.recordalignmin); tokenwritelongint(alignment.recordalignmax); tokenwritelongint(alignment.maxCrecordalign); tokenwriteset(globalswitches,sizeof(globalswitches)); tokenwriteset(targetswitches,sizeof(targetswitches)); tokenwriteset(moduleswitches,sizeof(moduleswitches)); tokenwriteset(localswitches,sizeof(localswitches)); tokenwriteset(modeswitches,sizeof(modeswitches)); tokenwriteset(optimizerswitches,sizeof(optimizerswitches)); tokenwriteset(genwpoptimizerswitches,sizeof(genwpoptimizerswitches)); tokenwriteset(dowpoptimizerswitches,sizeof(dowpoptimizerswitches)); tokenwriteset(debugswitches,sizeof(debugswitches)); { 0: old behaviour for sets <=256 elements >0: round to this size } tokenwriteshortint(setalloc); tokenwriteshortint(packenum); tokenwriteshortint(packrecords); tokenwriteshortint(maxfpuregisters); tokenwriteenum(cputype,sizeof(tcputype)); tokenwriteenum(optimizecputype,sizeof(tcputype)); tokenwriteenum(fputype,sizeof(tfputype)); tokenwriteenum(asmmode,sizeof(tasmmode)); tokenwriteenum(interfacetype,sizeof(tinterfacetypes)); tokenwriteenum(defproccall,sizeof(tproccalloption)); { tstringencoding is word type, thus this should be OK here } tokenwriteword(sourcecodepage); tokenwriteenum(minfpconstprec,sizeof(tfloattype)); recordtokenbuf.write(byte(disabledircache),1); { TH: See note about controllertype field in tokenreadsettings. } {$PUSH} {$WARN 6018 OFF} (* Unreachable code due to compile time evaluation *) if ControllerSupport then tokenwriteenum(controllertype,sizeof(tcontrollertype)); {$POP} endpos:=recordtokenbuf.pos; size:=endpos-startpos; recordtokenbuf.seek(sizepos); tokenwritesizeint(size); recordtokenbuf.seek(endpos); end; end; procedure tscannerfile.recordtoken; var t : ttoken; s : tspecialgenerictoken; len,msgnb,copy_size : asizeint; val : longint; b : byte; pmsg : pmessagestaterecord; begin if not assigned(recordtokenbuf) then internalerror(200511176); t:=_GENERICSPECIALTOKEN; { settings changed? } { last field pmessage is handled separately below in ST_LOADMESSAGES } if CompareByte(current_settings,last_settings, sizeof(current_settings)-sizeof(pointer))<>0 then begin { use a special token to record it } s:=ST_LOADSETTINGS; writetoken(t); recordtokenbuf.write(s,1); copy_size:=sizeof(current_settings)-sizeof(pointer); tokenwritesettings(current_settings,copy_size); last_settings:=current_settings; end; if current_settings.pmessage<>last_message then begin { use a special token to record it } s:=ST_LOADMESSAGES; writetoken(t); recordtokenbuf.write(s,1); msgnb:=0; pmsg:=current_settings.pmessage; while assigned(pmsg) do begin if msgnb=high(asizeint) then { Too many messages } internalerror(2011090401); inc(msgnb); pmsg:=pmsg^.next; end; tokenwritesizeint(msgnb); pmsg:=current_settings.pmessage; while assigned(pmsg) do begin { What about endianess here?} { SB: this is handled by tokenreadlongint } val:=pmsg^.value; tokenwritelongint(val); val:=ord(pmsg^.state); tokenwritelongint(val); pmsg:=pmsg^.next; end; last_message:=current_settings.pmessage; end; { file pos changes? } if current_tokenpos.line<>last_filepos.line then begin s:=ST_LINE; writetoken(t); recordtokenbuf.write(s,1); tokenwritelongint(current_tokenpos.line); last_filepos.line:=current_tokenpos.line; end; if current_tokenpos.column<>last_filepos.column then begin s:=ST_COLUMN; writetoken(t); { can the column be written packed? } if current_tokenpos.column<$80 then begin b:=$80 or current_tokenpos.column; recordtokenbuf.write(b,1); end else begin recordtokenbuf.write(s,1); tokenwriteword(current_tokenpos.column); end; last_filepos.column:=current_tokenpos.column; end; if current_tokenpos.fileindex<>last_filepos.fileindex then begin s:=ST_FILEINDEX; writetoken(t); recordtokenbuf.write(s,1); tokenwriteword(current_tokenpos.fileindex); last_filepos.fileindex:=current_tokenpos.fileindex; end; writetoken(token); if token<>_GENERICSPECIALTOKEN then writetoken(idtoken); case token of _CWCHAR, _CWSTRING : begin tokenwritesizeint(patternw^.len); if patternw^.len>0 then recordtokenbuf.write(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar)); end; _CSTRING: begin len:=length(cstringpattern); tokenwritesizeint(len); if len>0 then recordtokenbuf.write(cstringpattern[1],len); end; _CCHAR, _INTCONST, _REALNUMBER : begin { pexpr.pas messes with pattern in case of negative integer consts, see around line 2562 the comment of JM; remove the - before recording it (FK) } if (token=_INTCONST) and (pattern[1]='-') then delete(pattern,1,1); recordtokenbuf.write(pattern[0],1); recordtokenbuf.write(pattern[1],length(pattern)); end; _ID : begin recordtokenbuf.write(orgpattern[0],1); recordtokenbuf.write(orgpattern[1],length(orgpattern)); end; end; end; procedure tscannerfile.startreplaytokens(buf:tdynamicarray); begin if not assigned(buf) then internalerror(200511175); { save current token } if token in [_CWCHAR,_CWSTRING,_CCHAR,_CSTRING,_INTCONST,_REALNUMBER,_ID] then internalerror(200511178); replaystack:=treplaystack.create(token,current_settings, replaytokenbuf,replaystack); if assigned(inputpointer) then dec(inputpointer); { install buffer } replaytokenbuf:=buf; { reload next token } replaytokenbuf.seek(0); replaytoken; end; function tscannerfile.readtoken: ttoken; var b,b2 : byte; begin replaytokenbuf.read(b,1); if (b and $80)<>0 then begin replaytokenbuf.read(b2,1); result:=ttoken(((b and $7f) shl 8) or b2); end else result:=ttoken(b); end; procedure tscannerfile.replaytoken; var wlen,mesgnb,copy_size : asizeint; specialtoken : tspecialgenerictoken; i : byte; pmsg,prevmsg : pmessagestaterecord; begin if not assigned(replaytokenbuf) then internalerror(200511177); { End of replay buffer? Then load the next char from the file again } if replaytokenbuf.pos>=replaytokenbuf.size then begin token:=replaystack.token; replaytokenbuf:=replaystack.tokenbuf; { restore compiler settings } current_settings:=replaystack.settings; popreplaystack; if assigned(inputpointer) then begin c:=inputpointer^; inc(inputpointer); end; exit; end; repeat { load token from the buffer } token:=readtoken; if token<>_GENERICSPECIALTOKEN then idtoken:=readtoken else idtoken:=_NOID; case token of _CWCHAR, _CWSTRING : begin wlen:=tokenreadsizeint; setlengthwidestring(patternw,wlen); if wlen>0 then replaytokenbuf.read(patternw^.data^,patternw^.len*sizeof(tcompilerwidechar)); orgpattern:=''; pattern:=''; cstringpattern:=''; end; _CSTRING: begin wlen:=tokenreadsizeint; if wlen>0 then begin setlength(cstringpattern,wlen); replaytokenbuf.read(cstringpattern[1],wlen); end else cstringpattern:=''; orgpattern:=''; pattern:=''; end; _CCHAR, _INTCONST, _REALNUMBER : begin replaytokenbuf.read(pattern[0],1); replaytokenbuf.read(pattern[1],length(pattern)); orgpattern:=''; end; _ID : begin replaytokenbuf.read(orgpattern[0],1); replaytokenbuf.read(orgpattern[1],length(orgpattern)); pattern:=upper(orgpattern); end; _GENERICSPECIALTOKEN: begin replaytokenbuf.read(specialtoken,1); { packed column? } if (ord(specialtoken) and $80)<>0 then begin current_tokenpos.column:=ord(specialtoken) and $7f; current_filepos:=current_tokenpos; end else case specialtoken of ST_LOADSETTINGS: begin copy_size:=tokenreadsizeint; //if copy_size <> sizeof(current_settings)-sizeof(pointer) then // internalerror(2011090501); { replaytokenbuf.read(current_settings,copy_size); } tokenreadsettings(current_settings,copy_size); end; ST_LOADMESSAGES: begin current_settings.pmessage:=nil; mesgnb:=tokenreadsizeint; if mesgnb>0 then Comment(V_Error,'Message recordind not yet supported'); prevmsg:=nil; for i:=1 to mesgnb do begin new(pmsg); if i=1 then current_settings.pmessage:=pmsg else prevmsg^.next:=pmsg; pmsg^.value:=tokenreadlongint; pmsg^.state:=tmsgstate(tokenreadlongint); pmsg^.next:=nil; prevmsg:=pmsg; end; end; ST_LINE: begin current_tokenpos.line:=tokenreadlongint; current_filepos:=current_tokenpos; end; ST_COLUMN: begin current_tokenpos.column:=tokenreadword; current_filepos:=current_tokenpos; end; ST_FILEINDEX: begin current_tokenpos.fileindex:=tokenreadword; current_filepos:=current_tokenpos; end; else internalerror(2006103010); end; continue; end; end; break; until false; end; procedure tscannerfile.addfile(hp:tinputfile); begin saveinputfile; { add to list } hp.next:=inputfile; inputfile:=hp; { load new inputfile } restoreinputfile; end; procedure tscannerfile.reload; begin with inputfile do begin { when nothing more to read then leave immediatly, so we don't change the current_filepos and leave it point to the last char } if (c=#26) and (not assigned(next)) then exit; repeat { still more to read?, then change the #0 to a space so its seen as a seperator, this can't be used for macro's which can change the place of the #0 in the buffer with tempopen } if (c=#0) and (bufsize>0) and not(inputfile.is_macro) and (inputpointer-inputbuffer#26) and (not endoffile) then begin readbuf; inputpointer:=buf; inputbuffer:=buf; inputstart:=bufstart; { first line? } if line_no=0 then begin c:=inputpointer^; { eat utf-8 signature? } if (ord(inputpointer^)=$ef) and (ord((inputpointer+1)^)=$bb) and (ord((inputpointer+2)^)=$bf) then begin (* we don't support including files with an UTF-8 bom inside another file that wasn't encoded as UTF-8 already (we don't support {$codepage xxx} switches in the middle of a file either) *) if (current_settings.sourcecodepage<>CP_UTF8) and not current_module.in_global then Message(scanner_f_illegal_utf8_bom); inc(inputpointer,3); message(scan_c_switching_to_utf8); current_settings.sourcecodepage:=CP_UTF8; exclude(current_settings.moduleswitches,cs_system_codepage); include(current_settings.moduleswitches,cs_explicit_codepage); end; line_no:=1; if cs_asm_source in current_settings.globalswitches then inputfile.setline(line_no,inputstart+inputpointer-inputbuffer); end; end else begin { load eof position in tokenpos/current_filepos } gettokenpos; { close file } closeinputfile; { no next module, than EOF } if not assigned(inputfile.next) then begin c:=#26; exit; end; { load next file and reopen it } nextfile; tempopeninputfile; { status } Message1(scan_t_back_in,inputfile.name); end; { load next char } c:=inputpointer^; inc(inputpointer); until c<>#0; { if also end, then reload again } end; end; procedure tscannerfile.substitutemacro(const macname:string;p:pchar;len,line,fileindex:longint); var hp : tinputfile; begin { save old postion } dec(inputpointer); tempcloseinputfile; { create macro 'file' } { use special name to dispose after !! } hp:=do_openinputfile('_Macro_.'+macname); addfile(hp); with inputfile do begin setmacro(p,len); { local buffer } inputbuffer:=buf; inputpointer:=buf; inputstart:=bufstart; ref_index:=fileindex; end; { reset line } line_no:=line; lastlinepos:=0; lasttokenpos:=0; nexttokenpos:=0; { load new c } c:=inputpointer^; inc(inputpointer); end; procedure tscannerfile.do_gettokenpos(out tokenpos: longint; out filepos: tfileposinfo); begin tokenpos:=inputstart+(inputpointer-inputbuffer); filepos.line:=line_no; filepos.column:=tokenpos-lastlinepos; filepos.fileindex:=inputfile.ref_index; filepos.moduleindex:=current_module.unit_index; end; procedure tscannerfile.gettokenpos; { load the values of tokenpos and lasttokenpos } begin do_gettokenpos(lasttokenpos,current_tokenpos); current_filepos:=current_tokenpos; end; procedure tscannerfile.cachenexttokenpos; begin do_gettokenpos(nexttokenpos,next_filepos); end; procedure tscannerfile.setnexttoken; begin token:=nexttoken; nexttoken:=NOTOKEN; lasttokenpos:=nexttokenpos; current_tokenpos:=next_filepos; current_filepos:=current_tokenpos; nexttokenpos:=0; end; procedure tscannerfile.savetokenpos; begin oldlasttokenpos:=lasttokenpos; oldcurrent_filepos:=current_filepos; oldcurrent_tokenpos:=current_tokenpos; end; procedure tscannerfile.restoretokenpos; begin lasttokenpos:=oldlasttokenpos; current_filepos:=oldcurrent_filepos; current_tokenpos:=oldcurrent_tokenpos; end; procedure tscannerfile.inc_comment_level; begin if (m_nested_comment in current_settings.modeswitches) then inc(comment_level) else comment_level:=1; if (comment_level>1) then begin savetokenpos; gettokenpos; { update for warning } Message1(scan_w_comment_level,tostr(comment_level)); restoretokenpos; end; end; procedure tscannerfile.dec_comment_level; begin if (m_nested_comment in current_settings.modeswitches) then dec(comment_level) else comment_level:=0; end; procedure tscannerfile.linebreak; var cur : char; begin with inputfile do begin if (byte(inputpointer^)=0) and not(endoffile) then begin cur:=c; reload; if byte(cur)+byte(c)<>23 then dec(inputpointer); end else begin { Support all combination of #10 and #13 as line break } if (byte(inputpointer^)+byte(c)=23) then inc(inputpointer); end; { Always return #10 as line break } c:=#10; { increase line counters } lastlinepos:=inputstart+(inputpointer-inputbuffer); inc(line_no); { update linebuffer } if cs_asm_source in current_settings.globalswitches then inputfile.setline(line_no,lastlinepos); { update for status and call the show status routine, but don't touch current_filepos ! } savetokenpos; gettokenpos; { update for v_status } inc(status.compiledlines); ShowStatus; restoretokenpos; end; end; procedure tscannerfile.illegal_char(c:char); var s : string; begin if c in [#32..#255] then s:=''''+c+'''' else s:='#'+tostr(ord(c)); Message2(scan_f_illegal_char,s,'$'+hexstr(ord(c),2)); end; procedure tscannerfile.end_of_file; begin checkpreprocstack; Message(scan_f_end_of_file); end; {------------------------------------------- IF Conditional Handling -------------------------------------------} procedure tscannerfile.checkpreprocstack; begin { check for missing ifdefs } while assigned(preprocstack) do begin Message4(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name, preprocstack.owner.inputfile.name,tostr(preprocstack.line_nb)); poppreprocstack; end; end; procedure tscannerfile.poppreprocstack; var hp : tpreprocstack; begin if assigned(preprocstack) then begin Message1(scan_c_endif_found,preprocstack.name); hp:=preprocstack.next; preprocstack.free; preprocstack:=hp; end else Message(scan_e_endif_without_if); end; procedure tscannerfile.ifpreprocstack(atyp:preproctyp;compile_time_predicate:tcompile_time_predicate;messid:longint); var condition: Boolean; valuedescr: String; begin if (preprocstack=nil) or preprocstack.accept then condition:=compile_time_predicate(valuedescr) else begin condition:= false; valuedescr:= ''; end; preprocstack:=tpreprocstack.create(atyp, condition, preprocstack); preprocstack.name:=valuedescr; preprocstack.line_nb:=line_no; preprocstack.owner:=self; if preprocstack.accept then Message2(messid,preprocstack.name,'accepted') else Message2(messid,preprocstack.name,'rejected'); end; procedure tscannerfile.elsepreprocstack; begin if assigned(preprocstack) and (preprocstack.typ<>pp_else) then begin if (preprocstack.typ=pp_elseif) then preprocstack.accept:=false else if (not(assigned(preprocstack.next)) or (preprocstack.next.accept)) then preprocstack.accept:=not preprocstack.accept; preprocstack.typ:=pp_else; preprocstack.line_nb:=line_no; if preprocstack.accept then Message2(scan_c_else_found,preprocstack.name,'accepted') else Message2(scan_c_else_found,preprocstack.name,'rejected'); end else Message(scan_e_endif_without_if); end; procedure tscannerfile.elseifpreprocstack(compile_time_predicate:tcompile_time_predicate); var valuedescr: String; begin if assigned(preprocstack) and (preprocstack.typ in [pp_if,pp_elseif]) then begin { when the branch is accepted we use pp_elseif so we know that all the next branches need to be rejected. when this branch is still not accepted then leave it at pp_if } if (preprocstack.typ=pp_elseif) then preprocstack.accept:=false else if (preprocstack.typ=pp_if) and preprocstack.accept then begin preprocstack.accept:=false; preprocstack.typ:=pp_elseif; end else if (not(assigned(preprocstack.next)) or (preprocstack.next.accept)) and compile_time_predicate(valuedescr) then begin preprocstack.name:=valuedescr; preprocstack.accept:=true; preprocstack.typ:=pp_elseif; end; preprocstack.line_nb:=line_no; if preprocstack.accept then Message2(scan_c_else_found,preprocstack.name,'accepted') else Message2(scan_c_else_found,preprocstack.name,'rejected'); end else Message(scan_e_endif_without_if); end; procedure tscannerfile.popreplaystack; var hp : treplaystack; begin if assigned(replaystack) then begin hp:=replaystack.next; replaystack.free; replaystack:=hp; end; end; procedure tscannerfile.handleconditional(p:tdirectiveitem); begin savetokenpos; repeat current_scanner.gettokenpos; Message1(scan_d_handling_switch,'$'+p.name); p.proc(); { accept the text ? } if (current_scanner.preprocstack=nil) or current_scanner.preprocstack.accept then break else begin current_scanner.gettokenpos; Message(scan_c_skipping_until); repeat current_scanner.skipuntildirective; if not (m_mac in current_settings.modeswitches) then p:=tdirectiveitem(turbo_scannerdirectives.Find(current_scanner.readid)) else p:=tdirectiveitem(mac_scannerdirectives.Find(current_scanner.readid)); until assigned(p) and (p.is_conditional); current_scanner.gettokenpos; end; until false; restoretokenpos; end; procedure tscannerfile.handledirectives; var t : tdirectiveitem; hs : string; begin gettokenpos; readchar; {Remove the $} hs:=readid; { handle empty directive } if hs='' then begin Message1(scan_w_illegal_switch,'$'); exit; end; {$ifdef PREPROCWRITE} if parapreprocess then begin t:=Get_Directive(hs); if not(is_conditional(t) or (t=_DIR_DEFINE) or (t=_DIR_UNDEF)) then begin preprocfile^.AddSpace; preprocfile^.Add('{$'+hs+current_scanner.readcomment+'}'); exit; end; end; {$endif PREPROCWRITE} { skip this directive? } if (ignoredirectives.find(hs)<>nil) then begin if (comment_level>0) then readcomment; { we've read the whole comment } aktcommentstyle:=comment_none; exit; end; { Check for compiler switches } while (length(hs)=1) and (c in ['-','+']) do begin Message1(scan_d_handling_switch,'$'+hs+c); HandleSwitch(hs[1],c); current_scanner.readchar; {Remove + or -} if c=',' then begin current_scanner.readchar; {Remove , } { read next switch, support $v+,$+} hs:=current_scanner.readid; if (hs='') then begin if (c='$') and (m_fpc in current_settings.modeswitches) then begin current_scanner.readchar; { skip $ } hs:=current_scanner.readid; end; if (hs='') then Message1(scan_w_illegal_directive,'$'+c); end; end else hs:=''; end; { directives may follow switches after a , } if hs<>'' then begin if not (m_mac in current_settings.modeswitches) then t:=tdirectiveitem(turbo_scannerdirectives.Find(hs)) else t:=tdirectiveitem(mac_scannerdirectives.Find(hs)); if assigned(t) then begin if t.is_conditional then handleconditional(t) else begin Message1(scan_d_handling_switch,'$'+hs); t.proc(); end; end else begin current_scanner.ignoredirectives.Add(hs,nil); Message1(scan_w_illegal_directive,'$'+hs); end; { conditionals already read the comment } if (current_scanner.comment_level>0) then current_scanner.readcomment; { we've read the whole comment } aktcommentstyle:=comment_none; end; end; procedure tscannerfile.readchar; begin c:=inputpointer^; if c=#0 then reload else inc(inputpointer); end; procedure tscannerfile.readstring; var i : longint; err : boolean; begin err:=false; i:=0; repeat case c of '_', '0'..'9', 'A'..'Z' : begin if i<255 then begin inc(i); orgpattern[i]:=c; pattern[i]:=c; end else begin if not err then begin Message(scan_e_string_exceeds_255_chars); err:=true; end; end; c:=inputpointer^; inc(inputpointer); end; 'a'..'z' : begin if i<255 then begin inc(i); orgpattern[i]:=c; pattern[i]:=chr(ord(c)-32) end else begin if not err then begin Message(scan_e_string_exceeds_255_chars); err:=true; end; end; c:=inputpointer^; inc(inputpointer); end; #0 : reload; else break; end; until false; orgpattern[0]:=chr(i); pattern[0]:=chr(i); end; procedure tscannerfile.readnumber; var base, i : longint; begin case c of '%' : begin readchar; base:=2; pattern[1]:='%'; i:=1; end; '&' : begin readchar; base:=8; pattern[1]:='&'; i:=1; end; '$' : begin readchar; base:=16; pattern[1]:='$'; i:=1; end; else begin base:=10; i:=0; end; end; while ((base>=10) and (c in ['0'..'9'])) or ((base=16) and (c in ['A'..'F','a'..'f'])) or ((base=8) and (c in ['0'..'7'])) or ((base=2) and (c in ['0'..'1'])) do begin if i<255 then begin inc(i); pattern[i]:=c; end; readchar; end; pattern[0]:=chr(i); end; function tscannerfile.readid:string; begin readstring; readid:=pattern; end; function tscannerfile.readval:longint; var l : longint; w : integer; begin readnumber; val(pattern,l,w); readval:=l; end; function tscannerfile.readcomment:string; var i : longint; begin i:=0; repeat case c of '{' : begin if aktcommentstyle=comment_tp then inc_comment_level; end; '}' : begin if aktcommentstyle=comment_tp then begin readchar; dec_comment_level; if comment_level=0 then break else continue; end; end; '*' : begin if aktcommentstyle=comment_oldtp then begin readchar; if c=')' then begin readchar; dec_comment_level; break; end else { Add both characters !!} if (i<255) then begin inc(i); readcomment[i]:='*'; if (i<255) then begin inc(i); readcomment[i]:=c; end; end; end else { Not old TP comment, so add...} begin if (i<255) then begin inc(i); readcomment[i]:='*'; end; end; end; #10,#13 : linebreak; #26 : end_of_file; else begin if (i<255) then begin inc(i); readcomment[i]:=c; end; end; end; readchar; until false; readcomment[0]:=chr(i); end; function tscannerfile.readquotedstring:string; var i : longint; msgwritten : boolean; begin i:=0; msgwritten:=false; if (c='''') then begin repeat readchar; case c of #26 : end_of_file; #10,#13 : Message(scan_f_string_exceeds_line); '''' : begin readchar; if c<>'''' then break; end; end; if i<255 then begin inc(i); result[i]:=c; end else begin if not msgwritten then begin Message(scan_e_string_exceeds_255_chars); msgwritten:=true; end; end; until false; end; result[0]:=chr(i); end; function tscannerfile.readstate:char; var state : char; begin state:=' '; if c=' ' then begin current_scanner.skipspace; current_scanner.readid; if pattern='ON' then state:='+' else if pattern='OFF' then state:='-'; end else state:=c; if not (state in ['+','-']) then Message(scan_e_wrong_switch_toggle); readstate:=state; end; function tscannerfile.readstatedefault:char; var state : char; begin state:=' '; if c=' ' then begin current_scanner.skipspace; current_scanner.readid; if pattern='ON' then state:='+' else if pattern='OFF' then state:='-' else if pattern='DEFAULT' then state:='*'; end else state:=c; if not (state in ['+','-','*']) then Message(scan_e_wrong_switch_toggle_default); readstatedefault:=state; end; procedure tscannerfile.skipspace; begin repeat case c of #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then break; continue; end; #10, #13 : linebreak; #9,#11,#12,' ' : ; else break; end; readchar; until false; end; procedure tscannerfile.skipuntildirective; var found : longint; next_char_loaded : boolean; begin found:=0; next_char_loaded:=false; repeat case c of #10, #13 : linebreak; #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then end_of_file; continue; end; '{' : begin if (aktcommentstyle in [comment_tp,comment_none]) then begin aktcommentstyle:=comment_tp; if (comment_level=0) then found:=1; inc_comment_level; end; end; '*' : begin if (aktcommentstyle=comment_oldtp) then begin readchar; if c=')' then begin dec_comment_level; found:=0; aktcommentstyle:=comment_none; end else next_char_loaded:=true; end else found := 0; end; '}' : begin if (aktcommentstyle=comment_tp) then begin dec_comment_level; if (comment_level=0) then aktcommentstyle:=comment_none; found:=0; end; end; '$' : begin if found=1 then found:=2; end; '''' : if (aktcommentstyle=comment_none) then begin repeat readchar; case c of #26 : end_of_file; #10,#13 : break; '''' : begin readchar; if c<>'''' then begin next_char_loaded:=true; break; end; end; end; until false; end; '(' : begin if (aktcommentstyle=comment_none) then begin readchar; if c='*' then begin readchar; if c='$' then begin found:=2; inc_comment_level; aktcommentstyle:=comment_oldtp; end else begin skipoldtpcomment; next_char_loaded:=true; end; end else next_char_loaded:=true; end else found:=0; end; '/' : begin if (aktcommentstyle=comment_none) then begin readchar; if c='/' then skipdelphicomment; next_char_loaded:=true; end else found:=0; end; else found:=0; end; if next_char_loaded then next_char_loaded:=false else readchar; until (found=2); end; {**************************************************************************** Comment Handling ****************************************************************************} procedure tscannerfile.skipcomment; begin aktcommentstyle:=comment_tp; readchar; inc_comment_level; { handle compiler switches } if (c='$') then handledirectives; { handle_switches can dec comment_level, } while (comment_level>0) do begin case c of '{' : inc_comment_level; '}' : dec_comment_level; #10,#13 : linebreak; #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then end_of_file; continue; end; end; readchar; end; aktcommentstyle:=comment_none; end; procedure tscannerfile.skipdelphicomment; begin aktcommentstyle:=comment_delphi; inc_comment_level; readchar; { this is not supported } if c='$' then Message(scan_w_wrong_styled_switch); { skip comment } while not (c in [#10,#13,#26]) do readchar; dec_comment_level; aktcommentstyle:=comment_none; end; procedure tscannerfile.skipoldtpcomment; var found : longint; begin aktcommentstyle:=comment_oldtp; inc_comment_level; { only load a char if last already processed, was cause of bug1634 PM } if c=#0 then readchar; { this is now supported } if (c='$') then handledirectives; { skip comment } while (comment_level>0) do begin found:=0; repeat case c of #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then end_of_file; continue; end; #10,#13 : begin if found=4 then inc_comment_level; linebreak; found:=0; end; '*' : begin if found=3 then found:=4 else found:=1; end; ')' : begin if found in [1,4] then begin dec_comment_level; if comment_level=0 then found:=2 else found:=0; end else found:=0; end; '(' : begin if found=4 then inc_comment_level; found:=3; end; else begin if found=4 then inc_comment_level; found:=0; end; end; readchar; until (found=2); end; aktcommentstyle:=comment_none; end; {**************************************************************************** Token Scanner ****************************************************************************} procedure tscannerfile.readtoken(allowrecordtoken:boolean); var code : integer; len, low,high,mid : longint; w : word; m : longint; mac : tmacro; asciinr : string[33]; iswidestring : boolean; label exit_label; begin flushpendingswitchesstate; { record tokens? } if allowrecordtoken and assigned(recordtokenbuf) then recordtoken; { replay tokens? } if assigned(replaytokenbuf) then begin replaytoken; goto exit_label; end; { was there already a token read, then return that token } if nexttoken<>NOTOKEN then begin setnexttoken; goto exit_label; end; { Skip all spaces and comments } repeat case c of '{' : skipcomment; #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then break; end; ' ',#9..#13 : begin {$ifdef PREPROCWRITE} if parapreprocess then begin if c=#10 then preprocfile.eolfound:=true else preprocfile.spacefound:=true; end; {$endif PREPROCWRITE} skipspace; end else break; end; until false; { Save current token position, for EOF its already loaded } if c<>#26 then gettokenpos; { Check first for a identifier/keyword, this is 20+% faster (PFV) } if c in ['A'..'Z','a'..'z','_'] then begin readstring; token:=_ID; idtoken:=_ID; { keyword or any other known token, pattern is always uppercased } if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then begin low:=ord(tokenidx^[length(pattern),pattern[1]].first); high:=ord(tokenidx^[length(pattern),pattern[1]].last); while low[] then if op=NOTOKEN then token:=ttoken(high) else token:=op; idtoken:=ttoken(high); end; end; { Only process identifiers and not keywords } if token=_ID then begin { this takes some time ... } if (cs_support_macro in current_settings.moduleswitches) then begin mac:=tmacro(search_macro(pattern)); if assigned(mac) and (not mac.is_compiler_var) and (assigned(mac.buftext)) then begin if yylexcount [] then begin readnumber; if length(pattern)=1 then begin { does really an identifier follow? } if not (c in ['_','A'..'Z','a'..'z']) then message2(scan_f_syn_expected,tokeninfo^[_ID].str,c); readstring; token:=_ID; idtoken:=_ID; end else token:=_INTCONST; goto exit_label; end else if m_mac in current_settings.modeswitches then begin readchar; token:=_AMPERSAND; goto exit_label; end else Illegal_Char(c); end; '0'..'9' : begin readnumber; if (c in ['.','e','E']) then begin { first check for a . } if c='.' then begin cachenexttokenpos; readchar; { is it a .. from a range? } case c of '.' : begin readchar; token:=_INTCONST; nexttoken:=_POINTPOINT; goto exit_label; end; ')' : begin readchar; token:=_INTCONST; nexttoken:=_RECKKLAMMER; goto exit_label; end; '0'..'9' : begin { insert the number after the . } pattern:=pattern+'.'; while c in ['0'..'9'] do begin pattern:=pattern+c; readchar; end; end; else begin token:=_INTCONST; nexttoken:=_POINT; goto exit_label; end; end; end; { E can also follow after a point is scanned } if c in ['e','E'] then begin pattern:=pattern+'E'; readchar; if c in ['-','+'] then begin pattern:=pattern+c; readchar; end; if not(c in ['0'..'9']) then Illegal_Char(c); while c in ['0'..'9'] do begin pattern:=pattern+c; readchar; end; end; token:=_REALNUMBER; goto exit_label; end; token:=_INTCONST; goto exit_label; end; ';' : begin readchar; token:=_SEMICOLON; goto exit_label; end; '[' : begin readchar; token:=_LECKKLAMMER; goto exit_label; end; ']' : begin readchar; token:=_RECKKLAMMER; goto exit_label; end; '(' : begin readchar; case c of '*' : begin c:=#0;{Signal skipoldtpcomment to reload a char } skipoldtpcomment; readtoken(false); exit; end; '.' : begin readchar; token:=_LECKKLAMMER; goto exit_label; end; end; token:=_LKLAMMER; goto exit_label; end; ')' : begin readchar; token:=_RKLAMMER; goto exit_label; end; '+' : begin readchar; if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then begin readchar; token:=_PLUSASN; goto exit_label; end; token:=_PLUS; goto exit_label; end; '-' : begin readchar; if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then begin readchar; token:=_MINUSASN; goto exit_label; end; token:=_MINUS; goto exit_label; end; ':' : begin readchar; if c='=' then begin readchar; token:=_ASSIGNMENT; goto exit_label; end; token:=_COLON; goto exit_label; end; '*' : begin readchar; if (c='=') and (cs_support_c_operators in current_settings.moduleswitches) then begin readchar; token:=_STARASN; end else if c='*' then begin readchar; token:=_STARSTAR; end else token:=_STAR; goto exit_label; end; '/' : begin readchar; case c of '=' : begin if (cs_support_c_operators in current_settings.moduleswitches) then begin readchar; token:=_SLASHASN; goto exit_label; end; end; '/' : begin skipdelphicomment; readtoken(false); exit; end; end; token:=_SLASH; goto exit_label; end; '|' : if m_mac in current_settings.modeswitches then begin readchar; token:=_PIPE; goto exit_label; end else Illegal_Char(c); '=' : begin readchar; token:=_EQ; goto exit_label; end; '.' : begin readchar; case c of '.' : begin readchar; case c of '.' : begin readchar; token:=_POINTPOINTPOINT; goto exit_label; end; else begin token:=_POINTPOINT; goto exit_label; end; end; end; ')' : begin readchar; token:=_RECKKLAMMER; goto exit_label; end; end; token:=_POINT; goto exit_label; end; '@' : begin readchar; token:=_KLAMMERAFFE; goto exit_label; end; ',' : begin readchar; token:=_COMMA; goto exit_label; end; '''','#','^' : begin len:=0; cstringpattern:=''; iswidestring:=false; if c='^' then begin readchar; c:=upcase(c); if (block_type in [bt_type,bt_const_type,bt_var_type]) or (lasttoken=_ID) or (lasttoken=_NIL) or (lasttoken=_OPERATOR) or (lasttoken=_RKLAMMER) or (lasttoken=_RECKKLAMMER) or (lasttoken=_CARET) then begin token:=_CARET; goto exit_label; end else begin inc(len); setlength(cstringpattern,256); if c<#64 then cstringpattern[len]:=chr(ord(c)+64) else cstringpattern[len]:=chr(ord(c)-64); readchar; end; end; repeat case c of '#' : begin readchar; { read # } case c of '$': begin readchar; { read leading $ } asciinr:='$'; while (upcase(c) in ['A'..'F','0'..'9']) and (length(asciinr)<=5) do begin asciinr:=asciinr+c; readchar; end; end; '&': begin readchar; { read leading $ } asciinr:='&'; while (upcase(c) in ['0'..'7']) and (length(asciinr)<=7) do begin asciinr:=asciinr+c; readchar; end; end; '%': begin readchar; { read leading $ } asciinr:='%'; while (upcase(c) in ['0','1']) and (length(asciinr)<=17) do begin asciinr:=asciinr+c; readchar; end; end; else begin asciinr:=''; while (c in ['0'..'9']) and (length(asciinr)<=5) do begin asciinr:=asciinr+c; readchar; end; end; end; val(asciinr,m,code); if (asciinr='') or (code<>0) then Message(scan_e_illegal_char_const) else if (m<0) or (m>255) or (length(asciinr)>3) then begin if (m>=0) and (m<=65535) then begin if not iswidestring then begin if len>0 then ascii2unicode(@cstringpattern[1],len,current_settings.sourcecodepage,patternw) else ascii2unicode(nil,len,current_settings.sourcecodepage,patternw); iswidestring:=true; len:=0; end; concatwidestringchar(patternw,tcompilerwidechar(m)); end else Message(scan_e_illegal_char_const) end else if iswidestring then concatwidestringchar(patternw,asciichar2unicode(char(m))) else begin if len>=length(cstringpattern) then setlength(cstringpattern,length(cstringpattern)+256); inc(len); cstringpattern[len]:=chr(m); end; end; '''' : begin repeat readchar; case c of #26 : end_of_file; #10,#13 : Message(scan_f_string_exceeds_line); '''' : begin readchar; if c<>'''' then break; end; end; { interpret as utf-8 string? } if (ord(c)>=$80) and (current_settings.sourcecodepage=CP_UTF8) then begin { convert existing string to an utf-8 string } if not iswidestring then begin if len>0 then ascii2unicode(@cstringpattern[1],len,current_settings.sourcecodepage,patternw) else ascii2unicode(nil,len,current_settings.sourcecodepage,patternw); iswidestring:=true; len:=0; end; { four or more chars aren't handled } if (ord(c) and $f0)=$f0 then message(scan_e_utf8_bigger_than_65535) { three chars } else if (ord(c) and $e0)=$e0 then begin w:=ord(c) and $f; readchar; if (ord(c) and $c0)<>$80 then message(scan_e_utf8_malformed); w:=(w shl 6) or (ord(c) and $3f); readchar; if (ord(c) and $c0)<>$80 then message(scan_e_utf8_malformed); w:=(w shl 6) or (ord(c) and $3f); concatwidestringchar(patternw,w); end { two chars } else if (ord(c) and $c0)<>0 then begin w:=ord(c) and $1f; readchar; if (ord(c) and $c0)<>$80 then message(scan_e_utf8_malformed); w:=(w shl 6) or (ord(c) and $3f); concatwidestringchar(patternw,w); end { illegal } else if (ord(c) and $80)<>0 then message(scan_e_utf8_malformed) else concatwidestringchar(patternw,tcompilerwidechar(c)) end else if iswidestring then begin if current_settings.sourcecodepage=CP_UTF8 then concatwidestringchar(patternw,ord(c)) else concatwidestringchar(patternw,asciichar2unicode(c)) end else begin if len>=length(cstringpattern) then setlength(cstringpattern,length(cstringpattern)+256); inc(len); cstringpattern[len]:=c; end; until false; end; '^' : begin readchar; c:=upcase(c); if c<#64 then c:=chr(ord(c)+64) else c:=chr(ord(c)-64); if iswidestring then concatwidestringchar(patternw,asciichar2unicode(c)) else begin if len>=length(cstringpattern) then setlength(cstringpattern,length(cstringpattern)+256); inc(len); cstringpattern[len]:=c; end; readchar; end; else break; end; until false; { strings with length 1 become const chars } if iswidestring then begin if patternw^.len=1 then token:=_CWCHAR else token:=_CWSTRING; end else begin setlength(cstringpattern,len); if length(cstringpattern)=1 then begin token:=_CCHAR; pattern:=cstringpattern; end else token:=_CSTRING; end; goto exit_label; end; '>' : begin readchar; if (block_type in [bt_type,bt_var_type,bt_const_type]) then token:=_RSHARPBRACKET else begin case c of '=' : begin readchar; token:=_GTE; goto exit_label; end; '>' : begin readchar; token:=_OP_SHR; goto exit_label; end; '<' : begin { >< is for a symetric diff for sets } readchar; token:=_SYMDIF; goto exit_label; end; end; token:=_GT; end; goto exit_label; end; '<' : begin readchar; if (block_type in [bt_type,bt_var_type,bt_const_type]) then token:=_LSHARPBRACKET else begin case c of '>' : begin readchar; token:=_NE; goto exit_label; end; '=' : begin readchar; token:=_LTE; goto exit_label; end; '<' : begin readchar; token:=_OP_SHL; goto exit_label; end; end; token:=_LT; end; goto exit_label; end; #26 : begin token:=_EOF; checkpreprocstack; goto exit_label; end; else Illegal_Char(c); end; end; exit_label: lasttoken:=token; end; function tscannerfile.readpreproc:ttoken; var low,high,mid: longint; optoken: ttoken; begin skipspace; case c of '_', 'A'..'Z', 'a'..'z' : begin readstring; optoken:=_ID; if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then begin low:=ord(tokenidx^[length(pattern),pattern[1]].first); high:=ord(tokenidx^[length(pattern),pattern[1]].last); while low[] then if op=NOTOKEN then optoken:=ttoken(high) else optoken:=op; end; if not (optoken in preproc_operators) then optoken:=_ID; end; current_scanner.preproc_pattern:=pattern; readpreproc:=optoken; end; '0'..'9' : begin readnumber; if (c in ['.','e','E']) then begin { first check for a . } if c='.' then begin readchar; if c in ['0'..'9'] then begin { insert the number after the . } pattern:=pattern+'.'; while c in ['0'..'9'] do begin pattern:=pattern+c; readchar; end; end else Illegal_Char(c); end; { E can also follow after a point is scanned } if c in ['e','E'] then begin pattern:=pattern+'E'; readchar; if c in ['-','+'] then begin pattern:=pattern+c; readchar; end; if not(c in ['0'..'9']) then Illegal_Char(c); while c in ['0'..'9'] do begin pattern:=pattern+c; readchar; end; end; readpreproc:=_REALNUMBER; end else readpreproc:=_INTCONST; current_scanner.preproc_pattern:=pattern; end; '$','%': begin readnumber; current_scanner.preproc_pattern:=pattern; readpreproc:=_INTCONST; end; '&' : begin readnumber; if length(pattern)=1 then begin readstring; readpreproc:=_ID; end else readpreproc:=_INTCONST; current_scanner.preproc_pattern:=pattern; end; '.' : begin readchar; readpreproc:=_POINT; end; ',' : begin readchar; readpreproc:=_COMMA; end; '}' : begin readpreproc:=_END; end; '(' : begin readchar; readpreproc:=_LKLAMMER; end; ')' : begin readchar; readpreproc:=_RKLAMMER; end; '[' : begin readchar; readpreproc:=_LECKKLAMMER; end; ']' : begin readchar; readpreproc:=_RECKKLAMMER; end; '+' : begin readchar; readpreproc:=_PLUS; end; '-' : begin readchar; readpreproc:=_MINUS; end; '*' : begin readchar; readpreproc:=_STAR; end; '/' : begin readchar; readpreproc:=_SLASH; end; '=' : begin readchar; readpreproc:=_EQ; end; '>' : begin readchar; if c='=' then begin readchar; readpreproc:=_GTE; end else readpreproc:=_GT; end; '<' : begin readchar; case c of '>' : begin readchar; readpreproc:=_NE; end; '=' : begin readchar; readpreproc:=_LTE; end; else readpreproc:=_LT; end; end; #26 : begin readpreproc:=_EOF; checkpreprocstack; end; else begin Illegal_Char(c); readpreproc:=NOTOKEN; end; end; end; function tscannerfile.asmgetcharstart : char; begin { return first the character already available in c } lastasmgetchar:=c; result:=asmgetchar; end; function tscannerfile.asmgetchar : char; begin if lastasmgetchar<>#0 then begin c:=lastasmgetchar; lastasmgetchar:=#0; end else readchar; if in_asm_string then begin asmgetchar:=c; exit; end; repeat case c of // the { ... } is used in ARM assembler to define register sets, so we can't used // it as comment, either (* ... *), /* ... */ or // ... should be used instead. // But compiler directives {$...} are allowed in ARM assembler. '{' : begin {$ifdef arm} readchar; dec(inputpointer); if c<>'$' then begin asmgetchar:='{'; exit; end else {$endif arm} skipcomment; end; #10,#13 : begin linebreak; asmgetchar:=c; exit; end; #26 : begin reload; if (c=#26) and not assigned(inputfile.next) then end_of_file; continue; end; '/' : begin readchar; if c='/' then skipdelphicomment else begin asmgetchar:='/'; lastasmgetchar:=c; exit; end; end; '(' : begin readchar; if c='*' then begin c:=#0;{Signal skipoldtpcomment to reload a char } skipoldtpcomment; end else begin asmgetchar:='('; lastasmgetchar:=c; exit; end; end; else begin asmgetchar:=c; exit; end; end; until false; end; {***************************************************************************** Helpers *****************************************************************************} procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc); begin if dm in [directive_all, directive_turbo] then tdirectiveitem.create(turbo_scannerdirectives,s,p); if dm in [directive_all, directive_mac] then tdirectiveitem.create(mac_scannerdirectives,s,p); end; procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc); begin if dm in [directive_all, directive_turbo] then tdirectiveitem.createcond(turbo_scannerdirectives,s,p); if dm in [directive_all, directive_mac] then tdirectiveitem.createcond(mac_scannerdirectives,s,p); end; {***************************************************************************** Initialization *****************************************************************************} procedure InitScanner; begin InitWideString(patternw); turbo_scannerdirectives:=TFPHashObjectList.Create; mac_scannerdirectives:=TFPHashObjectList.Create; { Common directives and conditionals } AddDirective('I',directive_all, @dir_include); AddDirective('DEFINE',directive_all, @dir_define); AddDirective('UNDEF',directive_all, @dir_undef); AddConditional('IF',directive_all, @dir_if); AddConditional('IFDEF',directive_all, @dir_ifdef); AddConditional('IFNDEF',directive_all, @dir_ifndef); AddConditional('ELSE',directive_all, @dir_else); AddConditional('ELSEIF',directive_all, @dir_elseif); AddConditional('ENDIF',directive_all, @dir_endif); { Directives and conditionals for all modes except mode macpas} AddDirective('INCLUDE',directive_turbo, @dir_include); AddDirective('LIBPREFIX',directive_turbo, @dir_libprefix); AddDirective('LIBSUFFIX',directive_turbo, @dir_libsuffix); AddDirective('EXTENSION',directive_turbo, @dir_extension); AddConditional('IFEND',directive_turbo, @dir_endif); AddConditional('IFOPT',directive_turbo, @dir_ifopt); { Directives and conditionals for mode macpas: } AddDirective('SETC',directive_mac, @dir_setc); AddDirective('DEFINEC',directive_mac, @dir_definec); AddDirective('UNDEFC',directive_mac, @dir_undef); AddConditional('IFC',directive_mac, @dir_if); AddConditional('ELSEC',directive_mac, @dir_else); AddConditional('ELIFC',directive_mac, @dir_elseif); AddConditional('ENDC',directive_mac, @dir_endif); end; procedure DoneScanner; begin turbo_scannerdirectives.Free; mac_scannerdirectives.Free; DoneWideString(patternw); end; end.