{
$Id: scanner.pas,v 1.66 2003/11/12 16:57:59 peter Exp $
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,version,tokens,
verbose,comphook,
finput,
widestr,cpuinfo;
const
max_include_nesting=32;
max_macro_nesting=16;
maxmacrolen=16*1024;
preprocbufsize=32*1024;
type
tcommentstyle = (comment_none,comment_tp,comment_oldtp,comment_delphi,comment_c);
pmacrobuffer = ^tmacrobuffer;
tmacrobuffer = array[0..maxmacrolen-1] of char;
tscannerfile = class;
tmacro = class(TNamedIndexItem)
defined,
defined_at_startup,
is_used : boolean;
buftext : pchar;
buflen : longint;
fileinfo : tfileposinfo;
constructor Create(const n : string);
destructor destroy;override;
end;
preproctyp = (pp_ifdef,pp_ifndef,pp_if,pp_ifopt,pp_else);
tpreprocstack = class
typ : preproctyp;
accept : boolean;
next : tpreprocstack;
name : stringid;
line_nb : longint;
owner : tscannerfile;
constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack);
end;
tdirectiveproc=procedure;
tdirectiveitem = class(TNamedIndexItem)
public
is_conditional : boolean;
proc : tdirectiveproc;
constructor Create(const n:string;p:tdirectiveproc);
constructor CreateCond(const n:string;p:tdirectiveproc);
end;
tscannerfile = class
public
inputfile : tinputfile; { current inputfile list }
inputfilecount : longint;
inputbuffer, { input buffer }
inputpointer : pchar;
inputstart : longint;
line_no, { line }
lastlinepos : longint;
lasttokenpos : longint; { token }
lasttoken,
nexttoken : ttoken;
comment_level,
yylexcount : longint;
lastasmgetchar : char;
ignoredirectives : tstringlist; { ignore directives, used to give warnings only once }
preprocstack : tpreprocstack;
macros : Tdictionary;
in_asm_string : boolean;
preproc_pattern : string;
preproc_token : ttoken;
constructor Create(const fn:string);
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;
procedure insertmacro(const macname:string;p:pchar;len,line,fileindex:longint);
{ Scanner things }
procedure def_macro(const s : string);
procedure set_macro(const s : string;value : string);
procedure gettokenpos;
procedure inc_comment_level;
procedure dec_comment_level;
procedure illegal_char(c:char);
procedure end_of_file;
procedure checkpreprocstack;
procedure poppreprocstack;
procedure addpreprocstack(atyp : preproctyp;a:boolean;const s:string;w:longint);
procedure elsepreprocstack;
procedure handleconditional(p:tdirectiveitem);
procedure handledirectives;
procedure linebreak;
procedure readchar;
procedure readstring;
procedure readnumber;
function readid:string;
function readval:longint;
function readcomment:string;
function readstate:char;
procedure skipspace;
procedure skipuntildirective;
procedure skipcomment;
procedure skipdelphicomment;
procedure skipoldtpcomment;
procedure readtoken;
function readpreproc:ttoken;
function asmgetcharstart : char;
function asmgetchar:char;
end;
{$ifdef PREPROCWRITE}
tpreprocfile=class
f : text;
buf : pointer;
spacefound,
eolfound : boolean;
constructor create(const fn:string);
destructor destroy;
procedure Add(const s:string);
procedure AddSpace;
end;
{$endif PREPROCWRITE}
var
{ read strings }
c : char;
orgpattern,
pattern : string;
patternw : pcompilerwidestring;
{ token }
token, { current token being parsed }
idtoken : ttoken; { holds the token if the pattern is a known word }
current_scanner : tscannerfile; { current scanner in use }
aktcommentstyle : tcommentstyle; { needed to use read_comment from directives }
{$ifdef PREPROCWRITE}
preprocfile : tpreprocfile; { used with only preprocessing }
{$endif PREPROCWRITE}
type
tdirectivemode = (directive_all, directive_turbo, directive_mac);
procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc);
procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc);
procedure InitScanner;
procedure DoneScanner;
implementation
uses
{$ifdef delphi}
dmisc,
{$else}
dos,
{$endif delphi}
cutils,
systems,
switches,
symbase,symtable,symtype,
fmodule;
var
{ dictionaries with the supported directives }
turbo_scannerdirectives : tdictionary; { for other modes }
mac_scannerdirectives : tdictionary; { 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');
function is_keyword(const s:string):boolean;
var
low,high,mid : longint;
begin
if not (length(s) in [tokenlenmin..tokenlenmax]) 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 in aktmodeswitches);
end;
{*****************************************************************************
Conditional Directives
*****************************************************************************}
procedure dir_else;
begin
current_scanner.elsepreprocstack;
end;
procedure dir_endif;
begin
current_scanner.poppreprocstack;
end;
procedure dir_ifdef;
var
hs : string;
mac : tmacro;
begin
current_scanner.skipspace;
hs:=current_scanner.readid;
if hs='' then
Message(scan_e_error_in_preproc_expr);
mac:=tmacro(current_scanner.macros.search(hs));
if assigned(mac) then
mac.is_used:=true;
current_scanner.addpreprocstack(pp_ifdef,assigned(mac) and mac.defined,hs,scan_c_ifdef_found);
end;
procedure dir_ifndef;
var
hs : string;
mac : tmacro;
begin
current_scanner.skipspace;
hs:=current_scanner.readid;
if hs='' then
Message(scan_e_error_in_preproc_expr);
mac:=tmacro(current_scanner.macros.search(hs));
if assigned(mac) then
mac.is_used:=true;
current_scanner.addpreprocstack(pp_ifndef,not(assigned(mac) and mac.defined),hs,scan_c_ifndef_found);
end;
procedure dir_ifopt;
var
hs : string;
found : boolean;
state : char;
begin
current_scanner.skipspace;
hs:=current_scanner.readid;
if (length(hs)>1) then
Message1(scan_w_illegal_switch,hs)
else
begin
state:=current_scanner.ReadState;
if state in ['-','+'] then
found:=CheckSwitch(hs[1],state);
end;
current_scanner.addpreprocstack(pp_ifopt,found,hs,scan_c_ifopt_found);
end;
function parse_compiler_expr:string;
function read_expr : string; 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 readpreproc: string;
var
hs: string;
mac : tmacro;
len : integer;
begin
hs := current_scanner.preproc_pattern;
mac:=tmacro(current_scanner.macros.search(hs));
if assigned(mac) then
begin
if mac.defined and 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);
end;
end;
readpreproc := hs;
end;
function read_factor : string;
var
hs : string;
mac: tmacro;
srsym : tsym;
srsymtable : tsymtable;
begin
if current_scanner.preproc_token=_ID then
begin
if readpreproc='DEFINED' 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 := current_scanner.preproc_pattern;
mac := tmacro(current_scanner.macros.search(hs));
if assigned(mac) then
hs := '1'
else
hs := '0';
read_factor := hs;
preproc_consume(_ID);
current_scanner.skipspace;
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 readpreproc='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);
if searchsym(hs,srsym,srsymtable) then
hs := '1'
else
hs := '0';
read_factor := hs;
preproc_consume(_ID);
current_scanner.skipspace;
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 readpreproc='NOT' then
begin
preproc_consume(_ID);
hs:=read_expr;
if hs='0' then
read_factor:='1'
else
read_factor:='0';
end
else
begin
hs:=readpreproc;
preproc_consume(_ID);
read_factor:=hs;
end
end
else if current_scanner.preproc_token =_LKLAMMER then
begin
preproc_consume(_LKLAMMER);
read_factor:=read_expr;
preproc_consume(_RKLAMMER);
end
else
Message(scan_e_error_in_preproc_expr);
end;
function read_term : string;
var
hs1,hs2 : string;
l1,l2 : longint;
w : integer;
begin
hs1:=read_factor;
while true do
begin
if (current_scanner.preproc_token=_ID) then
begin
if readpreproc='AND' then
begin
preproc_consume(_ID);
hs2:=read_expr;
valint(hs1,l1,w); valint(hs2,l2,w);
if (l1>0) and (l2>0) then
hs1:='1'
else
hs1:='0';
read_term := hs1;
exit;
end
else
break;
end
else
break;
end;
read_term:=hs1;
end;
function read_simple_expr : string;
var
hs1,hs2 : string;
l1,l2 : longint;
w : integer;
begin
hs1:=read_term;
while true do
begin
if (current_scanner.preproc_token=_ID) then
begin
if readpreproc='OR' then
begin
preproc_consume(_ID);
hs2:=read_expr;
valint(hs1,l1,w); valint(hs2,l2,w);
if (l1>0) or (l2>0) then
hs1:='1'
else
hs1:='0';
read_simple_expr := hs1;
exit;
end
else
break;
end
else
break;
end;
read_simple_expr:=hs1;
end;
function read_expr : string;
var
hs1,hs2 : string;
b : boolean;
t : ttoken;
w : integer;
l1,l2 : longint;
begin
hs1:=read_simple_expr;
t:=current_scanner.preproc_token;
if not(t in [_EQUAL,_UNEQUAL,_LT,_GT,_LTE,_GTE]) then
begin
read_expr:=hs1;
exit;
end;
preproc_consume(t);
hs2:=read_simple_expr;
if is_number(hs1) and is_number(hs2) then
begin
valint(hs1,l1,w);
valint(hs2,l2,w);
case t of
_EQUAL : b:=l1=l2;
_UNEQUAL : b:=l1<>l2;
_LT : b:=l1<l2;
_GT : b:=l1>l2;
_GTE : b:=l1>=l2;
_LTE : b:=l1<=l2;
end;
end
else
begin
case t of
_EQUAL : b:=hs1=hs2;
_UNEQUAL : b:=hs1<>hs2;
_LT : b:=hs1<hs2;
_GT : b:=hs1>hs2;
_GTE : b:=hs1>=hs2;
_LTE : b:=hs1<=hs2;
end;
end;
if b then
read_expr:='1'
else
read_expr:='0';
end;
begin
current_scanner.skipspace;
{ start preproc expression scanner }
current_scanner.preproc_token:=current_scanner.readpreproc;
parse_compiler_expr:=read_expr;
end;
procedure dir_if;
var
hs : string;
begin
hs:=parse_compiler_expr;
current_scanner.addpreprocstack(pp_if,hs<>'0',hs,scan_c_if_found);
end;
procedure dir_define;
var
hs : string;
bracketcount : longint;
mac : tmacro;
macropos : longint;
macrobuffer : pmacrobuffer;
begin
current_scanner.skipspace;
hs:=current_scanner.readid;
mac:=tmacro(current_scanner.macros.search(hs));
if not assigned(mac) then
begin
mac:=tmacro.create(hs);
mac.defined:=true;
Message1(parser_c_macro_defined,mac.name);
current_scanner.macros.insert(mac);
end
else
begin
Message1(parser_c_macro_defined,mac.name);
mac.defined:=true;
{ delete old definition }
if assigned(mac.buftext) then
begin
freemem(mac.buftext,mac.buflen);
mac.buftext:=nil;
end;
end;
mac.is_used:=true;
if (cs_support_macro in aktmoduleswitches) then
begin
{ key words are never substituted }
if is_keyword(hs) then
Message(scan_e_keyword_cant_be_a_macro);
{ !!!!!! handle macro params, need we this? }
current_scanner.skipspace;
{ may be a macro? }
if c=':' then
begin
current_scanner.readchar;
if c='=' then
begin
new(macrobuffer);
macropos:=0;
{ parse macro, brackets are counted so it's possible
to have a $ifdef etc. in the macro }
bracketcount:=0;
repeat
current_scanner.readchar;
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);
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;
end;
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_setc;
var
hs : string;
mac : tmacro;
begin
current_scanner.skipspace;
hs:=current_scanner.readid;
mac:=tmacro(current_scanner.macros.search(hs));
if not assigned(mac) then
begin
mac:=tmacro.create(hs);
mac.defined:=true;
Message1(parser_c_macro_defined,mac.name);
current_scanner.macros.insert(mac);
end
else
begin
Message1(parser_c_macro_defined,mac.name);
mac.defined:=true;
{ delete old definition }
if assigned(mac.buftext) then
begin
freemem(mac.buftext,mac.buflen);
mac.buftext:=nil;
end;
end;
mac.is_used:=true;
{ key words are never substituted }
if is_keyword(hs) then
Message(scan_e_keyword_cant_be_a_macro);
{ !!!!!! handle macro params, need we this? }
current_scanner.skipspace;
{ may be a macro? }
//both versions with := and = are allowed
if c=':' then
current_scanner.readchar;
if c='=' then
begin
current_scanner.readchar;
hs:= parse_compiler_expr;
if length(hs) <> 0 then
begin
{ 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);
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(current_scanner.macros.search(hs));
if not assigned(mac) then
begin
mac:=tmacro.create(hs);
Message1(parser_c_macro_undefined,mac.name);
mac.defined:=false;
current_scanner.macros.insert(mac);
end
else
begin
Message1(parser_c_macro_undefined,mac.name);
mac.defined:=false;
{ delete old definition }
if assigned(mac.buftext) then
begin
freemem(mac.buftext,mac.buflen);
mac.buftext:=nil;
end;
end;
mac.is_used:=true;
end;
procedure dir_include;
function findincludefile(const path,name,ext:string;var foundfile:string):boolean;
var
found : boolean;
hpath : string;
begin
{ look for the include file
1. specified path,path of current inputfile,current dir
2. local includepath
3. global includepath }
found:=false;
foundfile:='';
hpath:='';
if path<>'' then
begin
if not path_absolute(path) then
hpath:=current_scanner.inputfile.path^+path
else
hpath:=path+';'+current_scanner.inputfile.path^;
end
else
hpath:=current_scanner.inputfile.path^;
found:=FindFile(name+ext,hpath+';.'+source_info.DirSep,foundfile);
if (not found) then
found:=current_module.localincludesearchpath.FindFile(name+ext,foundfile);
if (not found) then
found:=includesearchpath.FindFile(name+ext,foundfile);
findincludefile:=found;
end;
var
args,
foundfile,
hs : string;
path : dirstr;
name : namestr;
ext : extstr;
hp : tinputfile;
found : 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 }
if hs='TIME' then
hs:=gettimestr
else
if hs='DATE' then
hs:=getdatestr
else
if hs='FILE' then
hs:=current_module.sourcefiles.get_file_name(aktfilepos.fileindex)
else
if hs='LINE' then
hs:=tostr(aktfilepos.line)
else
if hs='FPCVERSION' then
hs:=version_string
else
if hs='FPCTARGET' then
hs:=target_cpu_string
else
if hs='FPCTARGETCPU' then
hs:=target_cpu_string
else
if hs='FPCTARGETOS' then
hs:=target_info.shortname
else
hs:=getenv(hs);
if hs='' then
Message1(scan_w_include_env_not_found,path);
{ make it a stringconst }
hs:=''''+hs+'''';
current_scanner.insertmacro(path,@hs[1],length(hs),
current_scanner.line_no,current_scanner.inputfile.ref_index);
end
else
begin
hs:=FixFileName(hs);
fsplit(hs,path,name,ext);
{ try to find the file }
found:=findincludefile(path,name,ext,foundfile);
if (ext='') then
begin
{ try default extensions .inc , .pp and .pas }
if (not found) then
found:=findincludefile(path,name,'.inc',foundfile);
if (not found) then
found:=findincludefile(path,name,target_info.sourceext,foundfile);
if (not found) then
found:=findincludefile(path,name,target_info.pasext,foundfile);
end;
if current_scanner.inputfilecount<max_include_nesting then
begin
inc(current_scanner.inputfilecount);
{ we need to reread the current char }
dec(current_scanner.inputpointer);
{ shutdown current file }
current_scanner.tempcloseinputfile;
{ load new file }
hp:=do_openinputfile(foundfile);
current_scanner.addfile(hp);
current_module.sourcefiles.register_file(hp);
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;
{*****************************************************************************
TMacro
*****************************************************************************}
constructor tmacro.create(const n : string);
begin
inherited createname(n);
defined:=true;
defined_at_startup:=false;
fileinfo:=akttokenpos;
is_used:=false;
buftext:=nil;
buflen:=0;
end;
destructor tmacro.destroy;
begin
if assigned(buftext) then
freemem(buftext,buflen);
inherited destroy;
end;
{*****************************************************************************
Preprocessor writting
*****************************************************************************}
{$ifdef PREPROCWRITE}
constructor tpreprocfile.create(const fn:string);
begin
{ open outputfile }
assign(f,fn);
{$I-}
rewrite(f);
{$I+}
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;
{*****************************************************************************
TDirectiveItem
*****************************************************************************}
constructor TDirectiveItem.Create(const n:string;p:tdirectiveproc);
begin
inherited CreateName(n);
is_conditional:=false;
proc:={$ifndef FPCPROCVAR}@{$endif}p;
end;
constructor TDirectiveItem.CreateCond(const n:string;p:tdirectiveproc);
begin
inherited CreateName(n);
is_conditional:=true;
proc:={$ifndef FPCPROCVAR}@{$endif}p;
end;
{****************************************************************************
TSCANNERFILE
****************************************************************************}
constructor tscannerfile.create(const fn:string);
begin
inputfile:=do_openinputfile(fn);
if assigned(current_module) then
current_module.sourcefiles.register_file(inputfile);
{ reset localinput }
inputbuffer:=nil;
inputpointer:=nil;
inputstart:=0;
{ reset scanner }
preprocstack:=nil;
comment_level:=0;
yylexcount:=0;
block_type:=bt_general;
line_no:=0;
lastlinepos:=0;
lasttokenpos:=0;
lasttoken:=NOTOKEN;
nexttoken:=NOTOKEN;
lastasmgetchar:=#0;
ignoredirectives:=TStringList.Create;
in_asm_string:=false;
macros:=tdictionary.create;
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;
if not inputfile.closed then
closeinputfile;
ignoredirectives.free;
macros.free;
end;
procedure tscannerfile.def_macro(const s : string);
var
mac : tmacro;
begin
mac:=tmacro(macros.search(s));
if mac=nil then
begin
mac:=tmacro.create(s);
Message1(parser_c_macro_defined,mac.name);
macros.insert(mac);
end;
mac.defined:=true;
mac.defined_at_startup:=true;
end;
procedure tscannerfile.set_macro(const s : string;value : string);
var
mac : tmacro;
begin
mac:=tmacro(macros.search(s));
if mac=nil then
begin
mac:=tmacro.create(s);
macros.insert(mac);
end
else
begin
if assigned(mac.buftext) then
freemem(mac.buftext,mac.buflen);
end;
Message2(parser_c_macro_set_to,mac.name,value);
mac.buflen:=length(value);
getmem(mac.buftext,mac.buflen);
move(value[1],mac.buftext^,mac.buflen);
mac.defined:=true;
mac.defined_at_startup:=true;
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;
end;
procedure tscannerfile.closeinputfile;
begin
inputfile.close;
{ reset buffer }
inputbuffer:=nil;
inputpointer:=nil;
inputstart:=0;
{ reset line }
line_no:=0;
lastlinepos:=0;
lasttokenpos:=0;
end;
function tscannerfile.tempopeninputfile:boolean;
begin
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
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.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 aktfilepos 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
line_no:=1;
if cs_asm_source in aktglobalswitches then
inputfile.setline(line_no,bufstart);
end;
end
else
begin
{ load eof position in tokenpos/aktfilepos }
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.insertmacro(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;
{ load new c }
c:=inputpointer^;
inc(inputpointer);
end;
procedure tscannerfile.gettokenpos;
{ load the values of tokenpos and lasttokenpos }
begin
lasttokenpos:=inputstart+(inputpointer-inputbuffer);
akttokenpos.line:=line_no;
akttokenpos.column:=lasttokenpos-lastlinepos;
akttokenpos.fileindex:=inputfile.ref_index;
aktfilepos:=akttokenpos;
end;
procedure tscannerfile.inc_comment_level;
var
oldaktfilepos : tfileposinfo;
begin
if (m_nested_comment in aktmodeswitches) then
inc(comment_level)
else
comment_level:=1;
if (comment_level>1) then
begin
oldaktfilepos:=aktfilepos;
gettokenpos; { update for warning }
Message1(scan_w_comment_level,tostr(comment_level));
aktfilepos:=oldaktfilepos;
end;
end;
procedure tscannerfile.dec_comment_level;
begin
if (m_nested_comment in aktmodeswitches) then
dec(comment_level)
else
comment_level:=0;
end;
procedure tscannerfile.linebreak;
var
cur : char;
oldtokenpos,
oldaktfilepos : tfileposinfo;
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:=bufstart+(inputpointer-inputbuffer);
inc(line_no);
{ update linebuffer }
if cs_asm_source in aktglobalswitches then
inputfile.setline(line_no,lastlinepos);
{ update for status and call the show status routine,
but don't touch aktfilepos ! }
oldaktfilepos:=aktfilepos;
oldtokenpos:=akttokenpos;
gettokenpos; { update for v_status }
inc(status.compiledlines);
ShowStatus;
aktfilepos:=oldaktfilepos;
akttokenpos:=oldtokenpos;
end;
end;
procedure tscannerfile.illegal_char(c:char);
var
s : string;
begin
if c in [#32..#255] then
s:=''''+c+''''
else
s:='#'+tostr(ord(c));
Message2(scan_f_illegal_char,s,'$'+hexstr(ord(c),2));
end;
procedure tscannerfile.end_of_file;
begin
checkpreprocstack;
Message(scan_f_end_of_file);
end;
{-------------------------------------------
IF Conditional Handling
-------------------------------------------}
procedure tscannerfile.checkpreprocstack;
begin
{ check for missing ifdefs }
while assigned(preprocstack) do
begin
Message4(scan_e_endif_expected,preprocstring[preprocstack.typ],preprocstack.name,
preprocstack.owner.inputfile.name^,tostr(preprocstack.line_nb));
poppreprocstack;
end;
end;
procedure tscannerfile.poppreprocstack;
var
hp : tpreprocstack;
begin
if assigned(preprocstack) then
begin
Message1(scan_c_endif_found,preprocstack.name);
hp:=preprocstack.next;
preprocstack.free;
preprocstack:=hp;
end
else
Message(scan_e_endif_without_if);
end;
procedure tscannerfile.addpreprocstack(atyp : preproctyp;a:boolean;const s:string;w:longint);
begin
preprocstack:=tpreprocstack.create(atyp,((preprocstack=nil) or preprocstack.accept) and a,preprocstack);
preprocstack.name:=s;
preprocstack.line_nb:=line_no;
preprocstack.owner:=self;
if preprocstack.accept then
Message2(w,preprocstack.name,'accepted')
else
Message2(w,preprocstack.name,'rejected');
end;
procedure tscannerfile.elsepreprocstack;
begin
if assigned(preprocstack) then
begin
preprocstack.typ:=pp_else;
preprocstack.line_nb:=line_no;
if not(assigned(preprocstack.next)) or (preprocstack.next.accept) then
preprocstack.accept:=not preprocstack.accept;
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.handleconditional(p:tdirectiveitem);
var
oldaktfilepos : tfileposinfo;
begin
oldaktfilepos:=aktfilepos;
repeat
current_scanner.gettokenpos;
p.proc{$ifdef FPCPROCVAR}(){$endif};
{ 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 aktmodeswitches) then
p:=tdirectiveitem(turbo_scannerdirectives.search(current_scanner.readid))
else
p:=tdirectiveitem(mac_scannerdirectives.search(current_scanner.readid));
until assigned(p) and (p.is_conditional);
current_scanner.gettokenpos;
Message1(scan_d_handling_switch,'$'+p.name);
end;
until false;
aktfilepos:=oldaktfilepos;
end;
procedure tscannerfile.handledirectives;
var
t : tdirectiveitem;
hs : string;
begin
gettokenpos;
readchar; {Remove the $}
hs:=readid;
{$ifdef PREPROCWRITE}
if parapreprocess then
begin
t:=Get_Directive(hs);
if not(is_conditional(t) or (t=_DIR_DEFINE) or (t=_DIR_UNDEF)) then
begin
preprocfile^.AddSpace;
preprocfile^.Add('{$'+hs+current_scanner.readcomment+'}');
exit;
end;
end;
{$endif PREPROCWRITE}
{ skip this directive? }
if (ignoredirectives.find(hs)<>nil) then
begin
if (comment_level>0) then
readcomment;
{ we've read the whole comment }
aktcommentstyle:=comment_none;
exit;
end;
if hs='' then
begin
Message1(scan_w_illegal_switch,'$'+hs);
end;
{ Check for compiler switches }
while (length(hs)=1) and (c in ['-','+']) do
begin
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 aktmodeswitches) then
begin
current_scanner.readchar; { skip $ }
hs:=current_scanner.readid;
end;
if (hs='') then
Message1(scan_w_illegal_directive,'$'+c);
end
else
Message1(scan_d_handling_switch,'$'+hs);
end
else
hs:='';
end;
{ directives may follow switches after a , }
if hs<>'' then
begin
if not (m_mac in aktmodeswitches) then
t:=tdirectiveitem(turbo_scannerdirectives.search(hs))
else
t:=tdirectiveitem(mac_scannerdirectives.search(hs));
if assigned(t) then
begin
if t.is_conditional then
handleconditional(t)
else
begin
Message1(scan_d_handling_switch,'$'+hs);
t.proc{$ifdef FPCPROCVAR}(){$endif};
end;
end
else
begin
current_scanner.ignoredirectives.insert(hs);
Message1(scan_w_illegal_directive,'$'+hs);
end;
{ conditionals already read the comment }
if (current_scanner.comment_level>0) then
current_scanner.readcomment;
{ we've read the whole comment }
aktcommentstyle:=comment_none;
end;
end;
procedure tscannerfile.readchar;
begin
c:=inputpointer^;
if c=#0 then
reload
else
inc(inputpointer);
end;
procedure tscannerfile.readstring;
var
i : longint;
begin
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;
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;
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;
valint(pattern,l,w);
readval:=l;
end;
function tscannerfile.readcomment:string;
var
i : longint;
begin
i:=0;
repeat
case c of
'{' :
begin
if aktcommentstyle=comment_tp then
inc_comment_level;
end;
'}' :
begin
if aktcommentstyle=comment_tp then
begin
readchar;
dec_comment_level;
if comment_level=0 then
break
else
continue;
end;
end;
'*' :
begin
if aktcommentstyle=comment_oldtp then
begin
readchar;
if c=')' then
begin
readchar;
dec_comment_level;
break;
end
else
{ Add both characters !!}
if (i<255) then
begin
inc(i);
readcomment[i]:='*';
if (i<255) then
begin
inc(i);
readcomment[i]:='*';
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.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;
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
incomment : boolean;
found : longint;
next_char_loaded : boolean;
oldcommentstyle : tcommentstyle;
begin
found:=0;
next_char_loaded:=false;
incomment:=true;
oldcommentstyle:=aktcommentstyle;
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 not(m_nested_comment in aktmodeswitches) or
(comment_level=0) then
begin
found:=1;
aktcommentstyle:=comment_tp;
end;
inc_comment_level;
incomment:=true;
end;
'*' :
begin
if incomment then
begin
readchar;
if c=')' then
begin
dec_comment_level;
found:=0;
incomment:=false;
end
else
next_char_loaded:=true;
end
else
found := 0;
end;
'}' :
begin
dec_comment_level;
found:=0;
incomment:=false;
end;
'$' :
begin
if found=1 then
found:=2;
end;
'''' :
if not incomment 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 not incomment then
begin
readchar;
if c='*' then
begin
readchar;
if c='$' then
begin
found:=2;
inc_comment_level;
aktcommentstyle:=comment_oldtp;
end
else
begin
skipoldtpcomment;
aktcommentstyle:=oldcommentstyle;
end;
end;
next_char_loaded:=true;
end
else
found:=0;
end;
'/' :
begin
if not incomment then
begin
readchar;
if c='/' then
begin
skipdelphicomment;
aktcommentstyle:=oldcommentstyle;
end;
next_char_loaded:=true;
end
else
found:=0;
end;
else
found:=0;
end;
if next_char_loaded then
next_char_loaded:=false
else
readchar;
until (found=2);
end;
{****************************************************************************
Comment Handling
****************************************************************************}
procedure tscannerfile.skipcomment;
begin
aktcommentstyle:=comment_tp;
readchar;
inc_comment_level;
{ handle compiler switches }
if (c='$') then
handledirectives;
{ handle_switches can dec comment_level, }
while (comment_level>0) do
begin
case c of
'{' :
inc_comment_level;
'}' :
dec_comment_level;
#10,#13 :
linebreak;
#26 :
begin
reload;
if (c=#26) and not assigned(inputfile.next) then
end_of_file;
continue;
end;
end;
readchar;
end;
aktcommentstyle:=comment_none;
end;
procedure tscannerfile.skipdelphicomment;
begin
aktcommentstyle:=comment_delphi;
inc_comment_level;
readchar;
{ this is not supported }
if c='$' then
Message(scan_e_wrong_styled_switch);
{ skip comment }
while not (c in [#10,#13,#26]) do
readchar;
dec_comment_level;
aktcommentstyle:=comment_none;
end;
procedure tscannerfile.skipoldtpcomment;
var
found : longint;
begin
aktcommentstyle:=comment_oldtp;
inc_comment_level;
{ only load a char if last already processed,
was cause of bug1634 PM }
if c=#0 then
readchar;
{ this is now supported }
if (c='$') then
handledirectives;
{ skip comment }
while (comment_level>0) do
begin
found:=0;
repeat
case c of
#26 :
begin
reload;
if (c=#26) and not assigned(inputfile.next) then
end_of_file;
continue;
end;
#10,#13 :
linebreak;
'*' :
begin
if found=3 then
found:=4
else
found:=1;
end;
')' :
begin
if found in [1,4] then
begin
dec_comment_level;
if comment_level=0 then
found:=2
else
found:=0;
end;
end;
'(' :
begin
if found=4 then
inc_comment_level;
found:=3;
end;
else
begin
if found=4 then
inc_comment_level;
found:=0;
end;
end;
readchar;
until (found=2);
end;
aktcommentstyle:=comment_none;
end;
{****************************************************************************
Token Scanner
****************************************************************************}
procedure tscannerfile.readtoken;
var
code : integer;
len,
low,high,mid : longint;
m : longint;
mac : tmacro;
asciinr : string[6];
msgwritten,
iswidestring : boolean;
label
exit_label;
begin
if localswitcheschanged then
begin
aktlocalswitches:=nextaktlocalswitches;
localswitcheschanged:=false;
end;
{ was there already a token read, then return that token }
if nexttoken<>NOTOKEN then
begin
token:=nexttoken;
nexttoken:=NOTOKEN;
goto exit_label;
end;
{ Skip all spaces and comments }
repeat
case c of
'{' :
skipcomment;
#26 :
begin
reload;
if (c=#26) and not assigned(inputfile.next) then
break;
end;
' ',#9..#13 :
begin
{$ifdef PREPROCWRITE}
if parapreprocess then
begin
if c=#10 then
preprocfile.eolfound:=true
else
preprocfile.spacefound:=true;
end;
{$endif PREPROCWRITE}
skipspace;
end
else
break;
end;
until false;
{ Save current token position, for EOF its already loaded }
if c<>#26 then
gettokenpos;
{ Check first for a identifier/keyword, this is 20+% faster (PFV) }
if c in ['A'..'Z','a'..'z','_'] then
begin
readstring;
token:=_ID;
idtoken:=_ID;
{ keyword or any other known token,
pattern is always uppercased }
if (pattern[1]<>'_') and (length(pattern) in [tokenlenmin..tokenlenmax]) then
begin
low:=ord(tokenidx^[length(pattern),pattern[1]].first);
high:=ord(tokenidx^[length(pattern),pattern[1]].last);
while low<high do
begin
mid:=(high+low+1) shr 1;
if pattern<tokeninfo^[ttoken(mid)].str then
high:=mid-1
else
low:=mid;
end;
if pattern=tokeninfo^[ttoken(high)].str then
begin
if tokeninfo^[ttoken(high)].keyword in aktmodeswitches then
if tokeninfo^[ttoken(high)].op=NOTOKEN then
token:=ttoken(high)
else
token:=tokeninfo^[ttoken(high)].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 aktmoduleswitches) then
begin
mac:=tmacro(macros.search(pattern));
if assigned(mac) and (assigned(mac.buftext)) then
begin
if yylexcount<max_macro_nesting then
begin
inc(yylexcount);
insertmacro(pattern,mac.buftext,mac.buflen,
mac.fileinfo.line,mac.fileinfo.fileindex);
{ handle empty macros }
if c=#0 then
reload;
readtoken;
{ that's all folks }
dec(yylexcount);
exit;
end
else
Message(scan_w_macro_deep_ten);
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 aktmodeswitches) then
Illegal_Char(c)
else
begin
readnumber;
token:=_INTCONST;
goto exit_label;
end;
end;
'&' :
begin
if not(m_fpc in aktmodeswitches) then
Illegal_Char(c)
else
begin
readnumber;
token:=_INTCONST;
goto exit_label;
end;
end;
'0'..'9' :
begin
readnumber;
if (c in ['.','e','E']) then
begin
{ first check for a . }
if c='.' then
begin
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;
end;
{ insert the number after the . }
pattern:=pattern+'.';
while c in ['0'..'9'] do
begin
pattern:=pattern+c;
readchar;
end;
end;
{ E can also follow after a point is scanned }
if c in ['e','E'] then
begin
pattern:=pattern+'E';
readchar;
if c in ['-','+'] then
begin
pattern:=pattern+c;
readchar;
end;
if not(c in ['0'..'9']) then
Illegal_Char(c);
while c in ['0'..'9'] do
begin
pattern:=pattern+c;
readchar;
end;
end;
token:=_REALNUMBER;
goto exit_label;
end;
token:=_INTCONST;
goto exit_label;
end;
';' :
begin
readchar;
token:=_SEMICOLON;
goto exit_label;
end;
'[' :
begin
readchar;
token:=_LECKKLAMMER;
goto exit_label;
end;
']' :
begin
readchar;
token:=_RECKKLAMMER;
goto exit_label;
end;
'(' :
begin
readchar;
case c of
'*' :
begin
c:=#0;{Signal skipoldtpcomment to reload a char }
skipoldtpcomment;
readtoken;
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 aktmoduleswitches) 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 aktmoduleswitches) 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 aktmoduleswitches) 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 aktmoduleswitches) then
begin
readchar;
token:=_SLASHASN;
goto exit_label;
end;
end;
'/' :
begin
skipdelphicomment;
readtoken;
exit;
end;
end;
token:=_SLASH;
goto exit_label;
end;
'=' :
begin
readchar;
token:=_EQUAL;
goto exit_label;
end;
'.' :
begin
readchar;
case c of
'.' :
begin
readchar;
token:=_POINTPOINT;
goto exit_label;
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;
msgwritten:=false;
pattern:='';
iswidestring:=false;
if c='^' then
begin
readchar;
c:=upcase(c);
if (block_type=bt_type) or
(lasttoken=_ID) or (lasttoken=_NIL) or
(lasttoken=_RKLAMMER) or (lasttoken=_RECKKLAMMER) or (lasttoken=_CARET) then
begin
token:=_CARET;
goto exit_label;
end
else
begin
inc(len);
if c<#64 then
pattern[len]:=chr(ord(c)+64)
else
pattern[len]:=chr(ord(c)-64);
readchar;
end;
end;
repeat
case c of
'#' :
begin
readchar; { read # }
if c='$' then
begin
readchar; { read leading $ }
asciinr:='$';
while (upcase(c) in ['A'..'F','0'..'9']) and (length(asciinr)<6) do
begin
asciinr:=asciinr+c;
readchar;
end;
end
else
begin
asciinr:='';
while (c in ['0'..'9']) and (length(asciinr)<6) do
begin
asciinr:=asciinr+c;
readchar;
end;
end;
valint(asciinr,m,code);
if (asciinr='') or (code<>0) then
Message(scan_e_illegal_char_const)
else if (m<0) or (m>255) or (length(asciinr)>3) then
begin
if (m>=0) and (m<=65535) then
begin
if not iswidestring then
begin
ascii2unicode(@pattern[1],len,patternw);
iswidestring:=true;
len:=0;
end;
concatwidestringchar(patternw,tcompilerwidechar(m));
end
else
Message(scan_e_illegal_char_const)
end
else if iswidestring then
concatwidestringchar(patternw,asciichar2unicode(char(m)))
else
begin
if len<255 then
begin
inc(len);
pattern[len]:=chr(m);
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
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;
if iswidestring then
concatwidestringchar(patternw,asciichar2unicode(c))
else
begin
if len<255 then
begin
inc(len);
pattern[len]:=c;
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
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<255 then
begin
inc(len);
pattern[len]:=c;
end
else
begin
if not msgwritten then
begin
Message(scan_e_string_exceeds_255_chars);
msgwritten:=true;
end;
end;
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
pattern[0]:=chr(len);
if len=1 then
token:=_CCHAR
else
token:=_CSTRING;
end;
goto exit_label;
end;
'>' :
begin
readchar;
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;
goto exit_label;
end;
'<' :
begin
readchar;
case c of
'>' :
begin
readchar;
token:=_UNEQUAL;
goto exit_label;
end;
'=' :
begin
readchar;
token:=_LTE;
goto exit_label;
end;
'<' :
begin
readchar;
token:=_OP_SHL;
goto exit_label;
end;
end;
token:=_LT;
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;
begin
skipspace;
case c of
'A'..'Z',
'a'..'z',
'_','0'..'9' : begin
current_scanner.preproc_pattern:=readid;
readpreproc:=_ID;
end;
'}' : begin
readpreproc:=_END;
end;
'(' : begin
readchar;
readpreproc:=_LKLAMMER;
end;
')' : begin
readchar;
readpreproc:=_RKLAMMER;
end;
'+' : begin
readchar;
readpreproc:=_PLUS;
end;
'-' : begin
readchar;
readpreproc:=_MINUS;
end;
'*' : begin
readchar;
readpreproc:=_STAR;
end;
'/' : begin
readchar;
readpreproc:=_SLASH;
end;
'=' : begin
readchar;
readpreproc:=_EQUAL;
end;
'>' : begin
readchar;
if c='=' then
begin
readchar;
readpreproc:=_GTE;
end
else
readpreproc:=_GT;
end;
'<' : begin
readchar;
case c of
'>' : begin
readchar;
readpreproc:=_UNEQUAL;
end;
'=' : begin
readchar;
readpreproc:=_LTE;
end;
else readpreproc:=_LT;
end;
end;
#26 :
end_of_file;
else
begin
readpreproc:=_EOF;
checkpreprocstack;
end;
end;
end;
function tscannerfile.asmgetcharstart : char;
begin
{ return first the character already
available in c }
lastasmgetchar:=c;
result:=asmgetchar;
end;
function tscannerfile.asmgetchar : char;
begin
if lastasmgetchar<>#0 then
begin
c:=lastasmgetchar;
lastasmgetchar:=#0;
end
else
readchar;
if in_asm_string then
begin
asmgetchar:=c;
exit;
end;
repeat
case c of
{$ifndef arm}
// the { ... } is used in ARM assembler to define register sets, so we can't used
// it as comment, either (* ... *), /* ... */ or // ... should be used instead
'{' :
skipcomment;
{$endif arm}
#10,#13 :
begin
linebreak;
asmgetchar:=c;
exit;
end;
#26 :
begin
reload;
if (c=#26) and not assigned(inputfile.next) then
end_of_file;
continue;
end;
'/' :
begin
readchar;
if c='/' then
skipdelphicomment
else
begin
asmgetchar:='/';
lastasmgetchar:=c;
exit;
end;
end;
'(' :
begin
readchar;
if c='*' then
begin
c:=#0;{Signal skipoldtpcomment to reload a char }
skipoldtpcomment;
end
else
begin
asmgetchar:='(';
lastasmgetchar:=c;
exit;
end;
end;
else
begin
asmgetchar:=c;
exit;
end;
end;
until false;
end;
{*****************************************************************************
Helpers
*****************************************************************************}
procedure AddDirective(const s:string; dm: tdirectivemode; p:tdirectiveproc);
begin
if dm in [directive_all, directive_turbo] then
turbo_scannerdirectives.insert(tdirectiveitem.create(s,p));
if dm in [directive_all, directive_mac] then
mac_scannerdirectives.insert(tdirectiveitem.create(s,p));
end;
procedure AddConditional(const s:string; dm: tdirectivemode; p:tdirectiveproc);
begin
if dm in [directive_all, directive_turbo] then
turbo_scannerdirectives.insert(tdirectiveitem.createcond(s,p));
if dm in [directive_all, directive_mac] then
mac_scannerdirectives.insert(tdirectiveitem.createcond(s,p));
end;
{*****************************************************************************
Initialization
*****************************************************************************}
procedure InitScanner;
begin
InitWideString(patternw);
turbo_scannerdirectives:=TDictionary.Create;
mac_scannerdirectives:=TDictionary.Create;
{ Default Turbo directives and conditionals }
AddDirective('DEFINE',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_define);
AddDirective('UNDEF',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_undef);
AddDirective('I',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_include);
AddDirective('INCLUDE',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_include);
AddConditional('ELSE',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_else);
AddConditional('ENDIF',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_endif);
AddConditional('IFEND',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_endif);
AddConditional('IF',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_if);
AddConditional('IFDEF',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_ifdef);
AddConditional('IFNDEF',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_ifndef);
AddConditional('IFOPT',directive_turbo, {$ifdef FPCPROCVAR}@{$endif}dir_ifopt);
{ Default Mac directives and conditionals: }
AddDirective('SETC',directive_mac, {$ifdef FPCPROCVAR}@{$endif}dir_setc);
AddConditional('IFC',directive_mac, {$ifdef FPCPROCVAR}@{$endif}dir_if);
AddConditional('ELSEC',directive_mac, {$ifdef FPCPROCVAR}@{$endif}dir_else);
AddConditional('ENDC',directive_mac, {$ifdef FPCPROCVAR}@{$endif}dir_endif);
end;
procedure DoneScanner;
begin
turbo_scannerdirectives.Free;
mac_scannerdirectives.Free;
DoneWideString(patternw);
end;
end.
{
$Log: scanner.pas,v $
Revision 1.66 2003/11/12 16:57:59 peter
* do nothing for macro's in tempcloseinput,tempopeninput
Revision 1.65 2003/11/10 19:08:59 peter
+ $IF DECLARED() added
Revision 1.64 2003/11/10 19:08:32 peter
* line numbering is now only done when #10, #10#13 is really parsed
instead of when it is the next character
Revision 1.63 2003/10/29 21:02:51 peter
* set ms_compiled after the program/unit is parsed
* check for ms_compiled before checking preproc matches
Revision 1.62 2003/09/17 22:30:19 olle
+ support for a different set of compiler directives under $MODE MAC
+ added mac directives $SETC $IFC $ELSEC $ENDC
Revision 1.61 2003/09/03 11:18:37 florian
* fixed arm concatcopy
+ arm support in the common compiler sources added
* moved some generic cg code around
+ tfputype added
* ...
Revision 1.60 2003/08/10 17:25:23 peter
* fixed some reported bugs
Revision 1.59 2003/05/25 10:26:43 peter
* recursive include depth check
Revision 1.58 2003/04/26 00:30:27 peter
* don't close inputfile when still closed
Revision 1.57 2003/01/09 21:52:37 peter
* merged some verbosity options.
* V_LineInfo is a verbosity flag to include line info
Revision 1.56 2002/12/29 14:57:50 peter
* unit loading changed to first register units and load them
afterwards. This is needed to support uses xxx in yyy correctly
* unit dependency check fixed
Revision 1.55 2002/12/27 18:05:58 peter
* use gettoken to get filename for include
Revision 1.54 2002/12/27 16:45:50 peter
* fix delphi comment parsing when skipping preproc directive
Revision 1.53 2002/12/27 15:26:43 peter
* give an error when no symbol is specified after $if(n)def
Revision 1.52 2002/12/24 23:32:02 peter
* support quotes around include filenames
Revision 1.51 2002/12/05 19:27:00 carl
* remove a stupid thing that i commited
Revision 1.50 2002/11/29 22:31:19 carl
+ unimplemented hint directive added
* hint directive parsing implemented
* warning on these directives
Revision 1.49 2002/11/26 22:56:40 peter
* fix macro nesting check
Revision 1.48 2002/09/16 19:05:48 peter
* parse ^ after nil as caret
Revision 1.47 2002/09/06 14:58:42 carl
* bugfix of bug report 2072 (merged)
Revision 1.46 2002/09/05 19:27:05 peter
* fixed crash when current_module becomes nil
Revision 1.45 2002/09/05 14:17:27 pierre
* fix for bug 2004 merged
Revision 1.44 2002/08/12 16:46:04 peter
* tscannerfile is now destroyed in tmodule.reset and current_scanner
is updated accordingly. This removes all the loading and saving of
the old scanner and the invalid flag marking
Revision 1.43 2002/08/11 14:28:19 peter
* TScannerFile.SetInvalid added that will also reset inputfile
Revision 1.42 2002/08/10 14:46:31 carl
+ moved target_cpu_string to cpuinfo
* renamed asmmode enum.
* assembler reader has now less ifdef's
* move from nppcmem.pas -> ncgmem.pas vec. node.
Revision 1.41 2002/08/06 21:12:16 florian
+ support for octal constants, they are specified by a leading &
Revision 1.40 2002/07/20 17:35:52 florian
+ char constants specified with #.. with more than 3 digits are handled as widechar
Revision 1.39 2002/05/18 13:34:17 peter
* readded missing revisions
Revision 1.38 2002/05/16 19:46:44 carl
+ defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
+ try to fix temp allocation (still in ifdef)
+ generic constructor calls
+ start of tassembler / tmodulebase class cleanup
Revision 1.36 2002/04/21 18:57:23 peter
* fixed memleaks when file can't be opened
Revision 1.35 2002/04/21 15:22:26 carl
* first check .inc file extension
Revision 1.34 2002/04/21 07:24:09 carl
- remove my fixes until Peter agrees on the fix (sorry Peter)
Revision 1.32 2002/04/19 15:42:11 peter
* default extension checking for include files
Revision 1.31 2002/03/01 14:39:44 peter
* fixed // and (* parsing to not be done when already parsing a
tp comment in skipuntildirective
Revision 1.30 2002/03/01 12:39:26 peter
* support // parsing in skipuntildirective
Revision 1.29 2002/01/27 21:44:26 peter
* FPCTARGETOS/FPCTARGETCPU added as internal environment variable
Revision 1.28 2002/01/24 18:25:50 peter
* implicit result variable generation for assembler routines
* removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
}
syntax highlighted by Code2HTML, v. 0.9.1