paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-14 02:19:30 +02:00
Code Issues Packages Projects Releases Wiki Activity
09e568fb0f
fpc/compiler/scanner.pas
pierre 1f20cfe991 Merge of several commits related to enhancements in PPU writing 
and more precisely to cross reading/writing fixes.

------------------------------------------------------------------------
r41896 | pierre | 2019-04-18 14:08:03 +0000 (Thu, 18 Apr 2019) | 15 lines

  Integrate patch from bug report 35409.
  Add possibiliy to throw InternalError
  for unhandled case values inside tentryfile,
  But avoid adding dependency on verbose unit
  as this would break ppudump handling of ppu files.

  Add RaiseAssertion virtual method to tentryfile class.
  Call RaiseAssertion in tentryfile methods
  where an internal error is wanted.
  Override RaiseAssertion method in symtype.pas unit
  to call InternalError.
  Add new class tppudumpfile to override RaiseAssertion
  in utils/ppuutils/ppudump.pp unit.


------------------------------------------------------------------------
--- Merging r41896 into '.':
U    compiler/entfile.pas
U    compiler/pcp.pas
U    compiler/symtype.pas
U    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r41896 into '.':
 U   .
------------------------------------------------------------------------
r42111 | pierre | 2019-05-20 22:06:57 +0000 (Mon, 20 May 2019) | 1 line

 List TSettings partially and improve generic output
------------------------------------------------------------------------
--- Merging r42111 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42111 into '.':
 G   .
------------------------------------------------------------------------
r42322 | pierre | 2019-07-03 13:35:05 +0000 (Wed, 03 Jul 2019) | 1 line

 Systematically include fpcdefs.inc at sart of all units used by compiler
------------------------------------------------------------------------
--- Merging r42322 into '.':
U    compiler/aarch64/cpuinfo.pas
U    compiler/arm/cpuinfo.pas
U    compiler/avr/cpuinfo.pas
U    compiler/ccharset.pas
U    compiler/generic/cpuinfo.pas
U    compiler/jvm/cpuinfo.pas
U    compiler/m68k/cpuinfo.pas
U    compiler/macho.pas
U    compiler/machoutils.pas
U    compiler/mips/cpuinfo.pas
G    compiler/pcp.pas
U    compiler/powerpc/cpuinfo.pas
U    compiler/powerpc64/cpuinfo.pas
U    compiler/systems/i_wii.pas
--- Recording mergeinfo for merge of r42322 into '.':
 G   .

------------------------------------------------------------------------
r42323 | pierre | 2019-07-04 15:24:49 +0000 (Thu, 04 Jul 2019) | 7 lines

  * Set ControllerSupport to false for sparc/sparc64 and x86_64 CPUs.
    This boolean must only be set to true if TControllerType is not simply (ct_none)
  * ppu.pas: Increment CurrentPPULongVersion constant as the above modification
    changes the number of fields of the TSettings record that is saved to
    PPU in ST_LOADSETTINGS field. { not mereged }


------------------------------------------------------------------------
--- Merging r42323 into '.':
C    compiler/ppu.pas { not mereged }
U    compiler/sparc/cpuinfo.pas
U    compiler/sparc64/cpuinfo.pas
U    compiler/x86_64/cpuinfo.pas
--- Recording mergeinfo for merge of r42323 into '.':
 G   .

------------------------------------------------------------------------
r42324 | pierre | 2019-07-04 15:25:40 +0000 (Thu, 04 Jul 2019) | 1 line

 Correctly read saved tsettings
------------------------------------------------------------------------
--- Merging r42324 into '.':
C    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42324 into '.':
 G   .
Summary of conflicts:
  Text conflicts: 1
------------------------------------------------------------------------
r42325 | marcus | 2019-07-04 16:49:26 +0000 (Thu, 04 Jul 2019) | 1 line

Fixed ppudump compilation on big endian platforms after r42324
------------------------------------------------------------------------
--- Merging r42325 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42325 into '.':
 G   .
------------------------------------------------------------------------
r42353 | svenbarth | 2019-07-12 16:25:33 +0000 (Fri, 12 Jul 2019) | 1 line

* write an entry name for the property options
------------------------------------------------------------------------
--- Merging r42353 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42353 into '.':
 G   .
------------------------------------------------------------------------
r42354 | svenbarth | 2019-07-12 16:25:36 +0000 (Fri, 12 Jul 2019) | 1 line

* write a name for the none property access entry (looks nicer than a "(Nil)" at the start of the line)
------------------------------------------------------------------------
--- Merging r42354 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42354 into '.':
 G   .
------------------------------------------------------------------------
r42527 | pierre | 2019-07-29 05:33:00 +0000 (Mon, 29 Jul 2019) | 22 lines

  Fix recordtoken writing into ppu files to allow correct
  handling in cross-configuration with different endianess.

  The code has been modified to use the same scheme as the writing of
  the other parts of the ppu, i.e. change_endian filed has been
  added also to tscannerfile class of scanner unit.
  This field is then used to swap values that required endianess
  conversion.

  * scanner.pas: change_endian filed added to tscannerfile class.
    The value of this field is set as the same field in tentryfile class of entfile unit.
    Token read and write methods converted to use change_endian field.

  * ppu.pas: Increase CurrentPPILongVersion

  * utils/ppuutils/ppudump.pp: Remove unneeded FPC_BIG_ENDIAN code
    which was needed because tokens were previously written using a
    different rule.




------------------------------------------------------------------------
--- Merging r42527 into '.':
C    compiler/ppu.pas
U    compiler/scanner.pas
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42527 into '.':
 G   .
Summary of conflicts:
  Text conflicts: 1
------------------------------------------------------------------------
r42528 | pierre | 2019-07-29 11:54:27 +0000 (Mon, 29 Jul 2019) | 1 line
Changed paths:
   M /trunk/compiler/scanner.pas

Try to fix bug introduced in previous commit #42527, hopefully fixing bug report 35902
------------------------------------------------------------------------

--- Merging r42528 into '.':
G    compiler/scanner.pas
--- Recording mergeinfo for merge of r42528 into '.':
 G   .------------------------------------------------------------------------
r42530 | pierre | 2019-07-29 16:40:58 +0000 (Mon, 29 Jul 2019) | 8 lines

   Try to fix ppudump for generic/inline.

   * entfile.pas: Differenciate ibsymtableoptions and ibrecsymtableoptions.
   * ppu.pas: Increase ppu unit CurrentPPULongVersion value.
   * utils/ppuutils/ppudump.pp: Add current_symtable_options variable.
     Change readsymtableoptions from procedure to function returning
     the new tsymtableoptions.

------------------------------------------------------------------------
--- Merging r42530 into '.':
G    compiler/entfile.pas
G    compiler/ppu.pas
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42530 into '.':
 G   .
------------------------------------------------------------------------
r42583 | pierre | 2019-08-05 09:15:12 +0000 (Mon, 05 Aug 2019) | 1 line

 Reorganize token buffer output to be able to use it for generics and inlined functions
------------------------------------------------------------------------
--- Merging r42583 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42583 into '.':
 G   .
------------------------------------------------------------------------
r42591 | pierre | 2019-08-06 06:32:52 +0000 (Tue, 06 Aug 2019) | 1 line

 Add mode and optimizer switches names, and check that no unknown switch is set
------------------------------------------------------------------------
--- Merging r42591 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42591 into '.':
 G   .
------------------------------------------------------------------------
r42596 | pierre | 2019-08-06 21:32:51 +0000 (Tue, 06 Aug 2019) | 1 line

 Fix gettokenbufshortint, as shortint is one byte long, not two
------------------------------------------------------------------------
--- Merging r42596 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42596 into '.':
 G   .
------------------------------------------------------------------------
r42609 | pierre | 2019-08-09 09:29:50 +0000 (Fri, 09 Aug 2019) | 1 line

 Correct size of asizeint, which is still 4-byte long even when CpuAddrBitSize is 16 as for avr and i8086
------------------------------------------------------------------------
--- Merging r42609 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42609 into '.':
 G   .
------------------------------------------------------------------------
r42670 | pierre | 2019-08-13 06:20:23 +0000 (Tue, 13 Aug 2019) | 1 line

 Reduce cpu-os dependency on real constant printout by using system.str
------------------------------------------------------------------------
--- Merging r42670 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42670 into '.':
 G   .
------------------------------------------------------------------------
r42906 | pierre | 2019-09-02 16:00:15 +0000 (Mon, 02 Sep 2019) | 1 line

 Fix problems with big endian systems without 80-bit floating point support
------------------------------------------------------------------------
--- Merging r42906 into '.':
G    compiler/utils/ppuutils/ppudump.pp
--- Recording mergeinfo for merge of r42906 into '.':
 G   .

git-svn-id: branches/fixes_3_2@43387 -
2019-11-04 08:50:42 +00:00

5698 lines
192 KiB
ObjectPascal
Raw Blame History

{
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;
fileindex : longint;
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;
idtoken : ttoken;
orgpattern,
pattern : string;
cstringpattern: ansistring;
patternw : pcompilerwidestring;
settings : tsettings;
tokenbuf : tdynamicarray;
next : treplaystack;
constructor Create(atoken: ttoken;aidtoken:ttoken;
const aorgpattern,apattern:string;const acstringpattern:ansistring;
apatternw:pcompilerwidestring;asettings:tsettings;
atokenbuf:tdynamicarray;anext:treplaystack);
destructor destroy;override;
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;
ignoredirectives : TFPHashList; { ignore directives, used to give warnings only once }
preprocstack : tpreprocstack;
replaystack : treplaystack;
preproc_pattern : string;
preproc_token : ttoken;
{ true, if we are parsing preprocessor expressions }
in_preproc_comp_expr : boolean;
{ true if cross-compiling for a CPU in opposite endianess}
change_endian_for_tokens : boolean;
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;
function replay_stack_depth:longint;
procedure handleconditional(p:tdirectiveitem);
procedure handledirectives;
procedure linebreak;
procedure recordtoken;
procedure startrecordtokens(buf:tdynamicarray);
procedure stoprecordtokens;
function is_recording_tokens:boolean;
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 readoptionalstate(fallback:char):char;
function readstatedefault:char;
procedure skipspace;
procedure skipuntildirective;
procedure skipcomment(read_first_char:boolean);
procedure skipdelphicomment;
procedure skipoldtpcomment(read_first_char:boolean);
procedure readtoken(allowrecordtoken:boolean);
function readpreproc:ttoken;
function asmgetchar:char;
end;
{$ifdef PREPROCWRITE}
tpreprocfile=class
f : text;
buf : pointer;
spacefound,
eolfound : boolean;
constructor create(const fn:string);
destructor destroy; override;
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 }
current_commentstyle : 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,fppu,
{ this is needed for $I %CURRENTROUTINE%}
procinfo
{$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<high do
begin
mid:=(high+low+1) shr 1;
if pattern<tokeninfo^[ttoken(mid)].str then
high:=mid-1
else
low:=mid;
end;
is_keyword:=(pattern=tokeninfo^[ttoken(high)].str) and
((tokeninfo^[ttoken(high)].keyword*current_settings.modeswitches)<>[]);
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
if s='EXTENDEDPASCAL' then
current_settings.modeswitches:=extpasmodeswitches
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 as well as extended pascal }
if ([m_mac,m_iso,m_extpas] * 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/iso/extpas modes }
if ([m_delphi,m_tp7,m_mac,m_iso,m_extpas] * 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
begin
{$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;
end;
{$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;
{ Blocks supported? }
if doinclude and
(i = m_blocks) and
not(target_info.system in systems_blocks_supported) then
begin
Message1(option_unsupported_target_for_feature,'Blocks');
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 in [system_i8086_msdos,system_i8086_embedded]) and (apptype<>NewAppType) then
begin
if NewAppType=app_com then
begin
targetinfos[target_info.system]^.exeext:='.com';
target_info.exeext:='.com';
end
else
begin
targetinfos[target_info.system]^.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),false);
uintdef:=torddef.create(u64bit,low(qword),high(qword),false);
booldef:=torddef.create(pasbool1,0,1,false);
strdef:=tstringdef.createansi(0,false);
setdef:=tsetdef.create(sintdef,0,255,false);
realdef:=tfloatdef.create(s80real,false);
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:=len;
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_stringlike(v.def) and is_stringlike(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(lv<rv);
_GT:
result:=texprvalue.create_bool(lv>rv);
_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(lvd<rvd);
_GT:
result:=texprvalue.create_bool(lvd>rvd);
_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(lvs<rvs);
_GT:
result:=texprvalue.create_bool(lvs>rvs);
_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(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(<expr>) 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 = _CSTRING then
begin
result:=texprvalue.create_str(current_scanner.preproc_pattern);
preproc_consume(_CSTRING);
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.in_preproc_comp_expr:=true;
current_scanner.skipspace;
{ start preproc expression scanner }
current_scanner.preproc_token:=current_scanner.readpreproc;
preproc_comp_expr:=preproc_sub_expr(opcompare,true);
current_scanner.in_preproc_comp_expr:=false;
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;
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;
case hs of
'TIME':
hs:=gettimestr;
'DATE':
hs:=getdatestr;
'DATEYEAR':
begin
hs:=tostr(startsystime.Year);
macroIsString:=false;
end;
'DATEMONTH':
begin
hs:=tostr(startsystime.Month);
macroIsString:=false;
end;
'DATEDAY':
begin
hs:=tostr(startsystime.Day);
macroIsString:=false;
end;
'TIMEHOUR':
begin
hs:=tostr(startsystime.Hour);
macroIsString:=false;
end;
'TIMEMINUTE':
begin
hs:=tostr(startsystime.Minute);
macroIsString:=false;
end;
'TIMESECOND':
begin
hs:=tostr(startsystime.Second);
macroIsString:=false;
end;
'FILE':
hs:=current_module.sourcefiles.get_file_name(current_filepos.fileindex);
'LINE':
hs:=tostr(current_filepos.line);
'LINENUM':
begin
hs:=tostr(current_filepos.line);
macroIsString:=false;
end;
'FPCVERSION':
hs:=version_string;
'FPCDATE':
hs:=date_string;
'FPCTARGET':
hs:=target_cpu_string;
'FPCTARGETCPU':
hs:=target_cpu_string;
'FPCTARGETOS':
hs:=target_info.shortname;
'CURRENTROUTINE':
hs:=current_procinfo.procdef.procsym.RealName;
else
hs:=GetEnvironmentVariable(hs);
end;
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 the name ends in dot, try without the dot }
if (not found) and (ExtractFileExt(name)=ExtensionSeparator) and (Length(name)>=2) then
found:=findincludefile(path,Copy(name,1,Length(name)-1),foundfile);
if current_scanner.inputfilecount<max_include_nesting then
begin
inc(current_scanner.inputfilecount);
{ we need to reread the current char }
dec(current_scanner.inputpointer);
{ reset c }
c:=#0;
{ shutdown current file }
current_scanner.tempcloseinputfile;
{ load new file }
hp:=do_openinputfile(foundfile);
hp.inc_path:=path;
current_scanner.addfile(hp);
current_module.sourcefiles.register_file(hp);
if (not found) then
Message1(scan_f_cannot_open_includefile,hs);
if (not current_scanner.openinputfile) then
Message1(scan_f_cannot_open_includefile,hs);
Message1(scan_t_start_include_file,current_scanner.inputfile.path+current_scanner.inputfile.name);
current_scanner.reload;
end
else
Message(scan_f_include_deep_ten);
end;
end;
{*****************************************************************************
Preprocessor writing
*****************************************************************************}
{$ifdef PREPROCWRITE}
constructor tpreprocfile.create(const fn:string);
begin
inherited create;
{ open outputfile }
assign(f,fn);
{$push}{$I-}
rewrite(f);
{$pop}
if ioresult<>0 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;aidtoken:ttoken;
const aorgpattern,apattern:string;const acstringpattern:ansistring;
apatternw:pcompilerwidestring;asettings:tsettings;
atokenbuf:tdynamicarray;anext:treplaystack);
begin
token:=atoken;
idtoken:=aidtoken;
orgpattern:=aorgpattern;
pattern:=apattern;
cstringpattern:=acstringpattern;
initwidestring(patternw);
if assigned(apatternw) then
begin
setlengthwidestring(patternw,apatternw^.len);
move(apatternw^.data^,patternw^.data^,apatternw^.len*sizeof(tcompilerwidechar));
end;
settings:=asettings;
tokenbuf:=atokenbuf;
next:=anext;
end;
destructor treplaystack.destroy;
begin
donewidestring(patternw);
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;
ignoredirectives:=TFPHashList.Create;
if (current_module is tppumodule) and assigned(tppumodule(current_module).ppufile) then
change_endian_for_tokens:=tppumodule(current_module).ppufile.change_endian
else
change_endian_for_tokens:=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;
function tscannerfile.is_recording_tokens: boolean;
begin
result:=assigned(recordtokenbuf);
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
recordtokenbuf.write(val,sizeof(asizeint));
end;
procedure tscannerfile.tokenwritelongint(val : longint);
begin
recordtokenbuf.write(val,sizeof(longint));
end;
procedure tscannerfile.tokenwriteshortint(val : shortint);
begin
recordtokenbuf.write(val,sizeof(shortint));
end;
procedure tscannerfile.tokenwriteword(val : word);
begin
recordtokenbuf.write(val,sizeof(word));
end;
procedure tscannerfile.tokenwritelongword(val : longword);
begin
recordtokenbuf.write(val,sizeof(longword));
end;
function tscannerfile.tokenreadsizeint : asizeint;
var
val : asizeint;
begin
replaytokenbuf.read(val,sizeof(asizeint));
if change_endian_for_tokens then
val:=swapendian(val);
result:=val;
end;
function tscannerfile.tokenreadlongword : longword;
var
val : longword;
begin
replaytokenbuf.read(val,sizeof(longword));
if change_endian_for_tokens then
val:=swapendian(val);
result:=val;
end;
function tscannerfile.tokenreadlongint : longint;
var
val : longint;
begin
replaytokenbuf.read(val,sizeof(longint));
if change_endian_for_tokens then
val:=swapendian(val);
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));
if change_endian_for_tokens then
val:=swapendian(val);
result:=val;
end;
function tscannerfile.tokenreadword : word;
var
val : word;
begin
replaytokenbuf.read(val,sizeof(word));
if change_endian_for_tokens then
val:=swapendian(val);
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);
var
i : longint;
begin
replaytokenbuf.read(b,size);
if change_endian_for_tokens then
for i:=0 to size-1 do
Pbyte(@b)[i]:=reverse_byte(Pbyte(@b)[i]);
end;
procedure tscannerfile.tokenwriteenum(var b;size : longint);
begin
recordtokenbuf.write(b,size);
end;
procedure tscannerfile.tokenwriteset(var b;size : longint);
begin
recordtokenbuf.write(b,size);
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 scanner state }
replaystack:=treplaystack.create(token,idtoken,orgpattern,pattern,
cstringpattern,patternw,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;
idtoken:=replaystack.idtoken;
pattern:=replaystack.pattern;
orgpattern:=replaystack.orgpattern;
setlengthwidestring(patternw,replaystack.patternw^.len);
move(replaystack.patternw^.data^,patternw^.data^,replaystack.patternw^.len*sizeof(tcompilerwidechar));
cstringpattern:=replaystack.cstringpattern;
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;
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<bufsize) then
begin
c:=' ';
inc(inputpointer);
exit;
end;
{ can we read more from this file ? }
if (c<>#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,
current_module.sourcefiles.get_file_name(preprocstack.fileindex),
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.fileindex:=current_filepos.fileindex;
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;
preprocstack.fileindex:=current_filepos.fileindex;
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;
preprocstack.fileindex:=current_filepos.fileindex;
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;
function tscannerfile.replay_stack_depth:longint;
var
tmp: treplaystack;
begin
result:=0;
tmp:=replaystack;
while assigned(tmp) do
begin
inc(result);
tmp:=tmp.next;
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
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) and not(t.is_conditional) 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 }
current_commentstyle:=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 }
current_commentstyle:=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 current_commentstyle=comment_tp then
inc_comment_level;
end;
'}' :
begin
if current_commentstyle=comment_tp then
begin
readchar;
dec_comment_level;
if comment_level=0 then
break
else
continue;
end;
end;
'*' :
begin
if current_commentstyle=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.readoptionalstate(fallback:char):char;
var
state : char;
begin
state:=' ';
if c=' ' then
begin
current_scanner.skipspace;
if c in ['*','}'] then
state:=fallback
else
begin
current_scanner.readid;
if pattern='ON' then
state:='+'
else
if pattern='OFF' then
state:='-';
end;
end
else
if c in ['*','}'] then
state:=fallback
else
state:=c;
if not (state in ['+','-']) then
Message(scan_e_wrong_switch_toggle);
readoptionalstate:=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 (current_commentstyle in [comment_tp,comment_none]) then
begin
current_commentstyle:=comment_tp;
if (comment_level=0) then
found:=1;
inc_comment_level;
end;
end;
'*' :
begin
if (current_commentstyle=comment_oldtp) then
begin
readchar;
if c=')' then
begin
dec_comment_level;
found:=0;
current_commentstyle:=comment_none;
end
else
next_char_loaded:=true;
end
else
found := 0;
end;
'}' :
begin
if (current_commentstyle=comment_tp) then
begin
dec_comment_level;
if (comment_level=0) then
current_commentstyle:=comment_none;
found:=0;
end;
end;
'$' :
begin
if found=1 then
found:=2;
end;
'''' :
if (current_commentstyle=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 (current_commentstyle=comment_none) then
begin
readchar;
if c='*' then
begin
readchar;
if c='$' then
begin
found:=2;
inc_comment_level;
current_commentstyle:=comment_oldtp;
end
else
begin
skipoldtpcomment(false);
next_char_loaded:=true;
end;
end
else
next_char_loaded:=true;
end
else
found:=0;
end;
'/' :
begin
if (current_commentstyle=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(read_first_char:boolean);
begin
current_commentstyle:=comment_tp;
if read_first_char then
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;
current_commentstyle:=comment_none;
end;
procedure tscannerfile.skipdelphicomment;
begin
current_commentstyle:=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;
current_commentstyle:=comment_none;
end;
procedure tscannerfile.skipoldtpcomment(read_first_char:boolean);
var
found : longint;
begin
current_commentstyle:=comment_oldtp;
inc_comment_level;
{ only load a char if last already processed,
was cause of bug1634 PM }
if read_first_char 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
begin
if found=4 then
inc_comment_level;
found:=1;
end;
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;
current_commentstyle:=comment_none;
end;
{****************************************************************************
Token Scanner
****************************************************************************}
procedure tscannerfile.readtoken(allowrecordtoken:boolean);
var
code : integer;
d : cardinal;
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(true);
#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<high do
begin
mid:=(high+low+1) shr 1;
if pattern<tokeninfo^[ttoken(mid)].str then
high:=mid-1
else
low:=mid;
end;
with tokeninfo^[ttoken(high)] do
if pattern=str then
begin
if (keyword*current_settings.modeswitches)<>[] 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<max_macro_nesting then
begin
mac.is_used:=true;
inc(yylexcount);
substitutemacro(pattern,mac.buftext,mac.buflen,
mac.fileinfo.line,mac.fileinfo.fileindex);
{ handle empty macros }
if c=#0 then
reload;
readtoken(false);
{ that's all folks }
dec(yylexcount);
exit;
end
else
Message(scan_w_macro_too_deep);
end;
end;
end;
{ return token }
goto exit_label;
end
else
begin
idtoken:=_NOID;
case c of
'$' :
begin
readnumber;
token:=_INTCONST;
goto exit_label;
end;
'%' :
begin
if not(m_fpc in current_settings.modeswitches) then
Illegal_Char(c)
else
begin
readnumber;
token:=_INTCONST;
goto exit_label;
end;
end;
'&' :
begin
if [m_fpc,m_delphi] * current_settings.modeswitches <> [] 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
skipoldtpcomment(true);
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)<=7) do
begin
asciinr:=asciinr+c;
readchar;
end;
end;
'&':
begin
readchar; { read leading $ }
asciinr:='&';
while (upcase(c) in ['0'..'7']) and (length(asciinr)<=8) do
begin
asciinr:=asciinr+c;
readchar;
end;
end;
'%':
begin
readchar; { read leading $ }
asciinr:='%';
while (upcase(c) in ['0','1']) and (length(asciinr)<=22) do
begin
asciinr:=asciinr+c;
readchar;
end;
end;
else
begin
asciinr:='';
while (c in ['0'..'9']) and (length(asciinr)<=8) 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<=$10FFFF) 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;
if m<=$FFFF then
concatwidestringchar(patternw,tcompilerwidechar(m))
else
begin
{ split into surrogate pair }
dec(m,$10000);
concatwidestringchar(patternw,tcompilerwidechar((m shr 10) + $D800));
concatwidestringchar(patternw,tcompilerwidechar((m and $3FF) + $DC00));
end;
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 chars }
if (ord(c) and $f0)=$f0 then
begin
{ this always represents a surrogate pair, so
read as 32-bit value and then split into
the corresponding pair of two wchars }
d:=ord(c) and $f;
readchar;
if (ord(c) and $c0)<>$80 then
message(scan_e_utf8_malformed);
d:=(d shl 6) or (ord(c) and $3f);
readchar;
if (ord(c) and $c0)<>$80 then
message(scan_e_utf8_malformed);
d:=(d shl 6) or (ord(c) and $3f);
readchar;
if (ord(c) and $c0)<>$80 then
message(scan_e_utf8_malformed);
d:=(d shl 6) or (ord(c) and $3f);
if d<$10000 then
message(scan_e_utf8_malformed);
d:=d-$10000;
{ high surrogate }
w:=$d800+(d shr 10);
concatwidestringchar(patternw,w);
{ low surrogate }
w:=$dc00+(d and $3ff);
concatwidestringchar(patternw,w);
end
{ 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<high do
begin
mid:=(high+low+1) shr 1;
if pattern<tokeninfo^[ttoken(mid)].str then
high:=mid-1
else
low:=mid;
end;
with tokeninfo^[ttoken(high)] do
if pattern=str then
begin
if (keyword*current_settings.modeswitches)<>[] 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;
'''' :
begin
readquotedstring;
current_scanner.preproc_pattern:=cstringpattern;
readpreproc:=_CSTRING;
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.asmgetchar : char;
begin
readchar;
repeat
case c of
#26 :
begin
reload;
if (c=#26) and not assigned(inputfile.next) then
end_of_file;
continue;
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.
Reference in New Issue View Git Blame Copy Permalink