mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-22 08:29:29 +02:00
* easier registration of directives
This commit is contained in:
peter
parent
11dfe5637e
commit
316523ca15
1462
compiler/scandir.inc
1462
compiler/scandir.inc
File diff suppressed because it is too large
Load Diff
879
compiler/scandir.pas
Normal file
879
compiler/scandir.pas
Normal file
@ -0,0 +1,879 @@
|
||||
{
|
||||
$Id$
|
||||
Copyright (c) 1998-2000 by Peter Vreman
|
||||
|
||||
This unit implements directive parsing for the scanner
|
||||
|
||||
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 scandir;
|
||||
|
||||
{$i defines.inc}
|
||||
|
||||
interface
|
||||
|
||||
|
||||
procedure InitScannerDirectives;
|
||||
|
||||
implementation
|
||||
|
||||
uses
|
||||
dos,
|
||||
cutils,
|
||||
version,globtype,globals,systems,
|
||||
verbose,comphook,
|
||||
scanner,switches,
|
||||
finput,fmodule;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Helpers
|
||||
*****************************************************************************}
|
||||
|
||||
procedure do_delphiswitch(sw:char);
|
||||
var
|
||||
state : char;
|
||||
begin
|
||||
{ c contains the next char, a + or - would be fine }
|
||||
state:=current_scanner.readstate;
|
||||
if state in ['-','+'] then
|
||||
HandleSwitch(sw,state);
|
||||
end;
|
||||
|
||||
|
||||
procedure do_setverbose(flag:char);
|
||||
var
|
||||
state : char;
|
||||
begin
|
||||
{ support ON/OFF }
|
||||
state:=current_scanner.ReadState;
|
||||
SetVerbosity(flag+state);
|
||||
end;
|
||||
|
||||
|
||||
procedure do_moduleswitch(sw:tmoduleswitch);
|
||||
var
|
||||
state : char;
|
||||
begin
|
||||
state:=current_scanner.readstate;
|
||||
if (sw<>cs_modulenone) and (state in ['-','+']) then
|
||||
begin
|
||||
if state='-' then
|
||||
exclude(aktmoduleswitches,sw)
|
||||
else
|
||||
include(aktmoduleswitches,sw);
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure do_localswitch(sw:tlocalswitch);
|
||||
var
|
||||
state : char;
|
||||
begin
|
||||
state:=current_scanner.readstate;
|
||||
if (sw<>cs_localnone) and (state in ['-','+']) then
|
||||
begin
|
||||
if not localswitcheschanged then
|
||||
nextaktlocalswitches:=aktlocalswitches;
|
||||
if state='-' then
|
||||
nextaktlocalswitches:=nextaktlocalswitches-[sw]
|
||||
else
|
||||
nextaktlocalswitches:=nextaktlocalswitches+[sw];
|
||||
localswitcheschanged:=true;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
procedure do_message(w:integer);
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
Message1(w,current_scanner.readcomment);
|
||||
end;
|
||||
|
||||
{*****************************************************************************
|
||||
Directive Callbacks
|
||||
*****************************************************************************}
|
||||
|
||||
procedure dir_align;
|
||||
begin
|
||||
do_delphiswitch('A');
|
||||
end;
|
||||
|
||||
procedure dir_asmmode;
|
||||
var
|
||||
s : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
s:=current_scanner.readid;
|
||||
If Inside_asm_statement then
|
||||
Message1(scan_w_no_asm_reader_switch_inside_asm,s);
|
||||
if s='DEFAULT' then
|
||||
aktasmmode:=initasmmode
|
||||
else
|
||||
if not set_string_asmmode(s,aktasmmode) then
|
||||
Message1(scan_w_unsupported_asmmode_specifier,s);
|
||||
end;
|
||||
|
||||
procedure dir_apptype;
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
if (target_info.target<>target_i386_win32)
|
||||
and (target_info.target<>target_i386_os2) then
|
||||
Message(scan_w_app_type_not_support);
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
hs:=current_scanner.readid;
|
||||
if hs='GUI' then
|
||||
apptype:=app_gui
|
||||
else if hs='CONSOLE' then
|
||||
apptype:=app_cui
|
||||
else if (hs='FS') and (target_info.target=target_i386_os2) then
|
||||
apptype:=app_fs
|
||||
else
|
||||
Message1(scan_w_unsupported_app_type,hs);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_assertions;
|
||||
begin
|
||||
do_delphiswitch('C');
|
||||
end;
|
||||
|
||||
procedure dir_booleval;
|
||||
begin
|
||||
do_delphiswitch('B');
|
||||
end;
|
||||
|
||||
procedure dir_debuginfo;
|
||||
begin
|
||||
do_delphiswitch('D');
|
||||
end;
|
||||
|
||||
procedure dir_description;
|
||||
begin
|
||||
if not (target_info.target in [target_i386_os2,target_i386_win32,target_i386_netware]) then
|
||||
Message(scan_w_decription_not_support);
|
||||
{ change description global var in all cases }
|
||||
{ it not used but in win32, os2 and netware }
|
||||
current_scanner.skipspace;
|
||||
description:=current_scanner.readcomment;
|
||||
end;
|
||||
|
||||
procedure dir_error;
|
||||
begin
|
||||
do_message(scan_e_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_extendedsyntax;
|
||||
begin
|
||||
do_delphiswitch('X');
|
||||
end;
|
||||
|
||||
procedure dir_fatal;
|
||||
begin
|
||||
do_message(scan_f_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_goto;
|
||||
begin
|
||||
do_moduleswitch(cs_support_goto);
|
||||
end;
|
||||
|
||||
procedure dir_hint;
|
||||
begin
|
||||
do_message(scan_h_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_hints;
|
||||
begin
|
||||
do_setverbose('H');
|
||||
end;
|
||||
|
||||
procedure dir_includepath;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
current_module.localincludesearchpath.AddPath(current_scanner.readcomment,false);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_info;
|
||||
begin
|
||||
do_message(scan_i_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_inline;
|
||||
begin
|
||||
do_moduleswitch(cs_support_inline);
|
||||
end;
|
||||
|
||||
procedure dir_interfaces;
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
{corba/com/default}
|
||||
current_scanner.skipspace;
|
||||
hs:=current_scanner.readid;
|
||||
if (hs='CORBA') then
|
||||
aktinterfacetype:=it_interfacecorba
|
||||
else if (hs='COM') then
|
||||
aktinterfacetype:=it_interfacecom
|
||||
else if (hs='DEFAULT') then
|
||||
aktinterfacetype:=initinterfacetype
|
||||
else
|
||||
Message(scan_e_invalid_interface_type);
|
||||
end;
|
||||
|
||||
procedure dir_iochecks;
|
||||
begin
|
||||
do_delphiswitch('I');
|
||||
end;
|
||||
|
||||
procedure dir_librarypath;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
current_module.locallibrarysearchpath.AddPath(current_scanner.readcomment,false);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_link;
|
||||
var
|
||||
s : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
s:=AddExtension(FixFileName(current_scanner.readcomment),target_info.objext);
|
||||
current_module.linkotherofiles.add(s,link_allways);
|
||||
end;
|
||||
|
||||
procedure dir_linklib;
|
||||
type
|
||||
tLinkMode=(lm_shared,lm_static);
|
||||
var
|
||||
s : string;
|
||||
quote : char;
|
||||
libname,
|
||||
linkmodestr : string;
|
||||
p : longint;
|
||||
linkMode : tLinkMode;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
s:=current_scanner.readcomment;
|
||||
p:=pos(',',s);
|
||||
if p=0 then
|
||||
begin
|
||||
libname:=TrimSpace(s);
|
||||
linkmodeStr:='';
|
||||
end
|
||||
else
|
||||
begin
|
||||
libname:=TrimSpace(copy(s,1,p-1));
|
||||
linkmodeStr:=Upper(TrimSpace(copy(s,p+1,255)));
|
||||
end;
|
||||
if (libname='') or (libname='''''') or (libname='""') then
|
||||
exit;
|
||||
{ get linkmode, default is shared linking }
|
||||
if linkModeStr='STATIC' then
|
||||
linkmode:=lm_static
|
||||
else if (LinkModeStr='SHARED') or (LinkModeStr='') then
|
||||
linkmode:=lm_shared
|
||||
else
|
||||
begin
|
||||
Comment(V_Error,'Wrong link mode specified: "'+Linkmodestr+'"');
|
||||
exit;
|
||||
end;
|
||||
{ create library name }
|
||||
if libname[1] in ['''','"'] then
|
||||
begin
|
||||
quote:=libname[1];
|
||||
Delete(libname,1,1);
|
||||
p:=pos(quote,libname);
|
||||
if p>0 then
|
||||
Delete(libname,p,1);
|
||||
end;
|
||||
{ add to the list of libraries to link }
|
||||
if linkMode=lm_static then
|
||||
current_module.linkOtherStaticLibs.add(FixFileName(libname),link_allways)
|
||||
else
|
||||
current_module.linkOtherSharedLibs.add(FixFileName(libname),link_allways);
|
||||
end;
|
||||
|
||||
procedure dir_localsymbols;
|
||||
begin
|
||||
do_delphiswitch('L');
|
||||
end;
|
||||
|
||||
procedure dir_longstrings;
|
||||
begin
|
||||
do_delphiswitch('H');
|
||||
end;
|
||||
|
||||
procedure dir_macro;
|
||||
begin
|
||||
do_moduleswitch(cs_support_macro);
|
||||
end;
|
||||
|
||||
procedure dir_maxfpuregisters;
|
||||
var
|
||||
l : integer;
|
||||
hs : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
if not(c in ['0'..'9']) then
|
||||
begin
|
||||
hs:=current_scanner.readid;
|
||||
if (hs='NORMAL') or (hs='DEFAULT') then
|
||||
aktmaxfpuregisters:=-1
|
||||
else
|
||||
Message(scan_e_invalid_maxfpureg_value);
|
||||
end
|
||||
else
|
||||
begin
|
||||
l:=current_scanner.readval;
|
||||
case l of
|
||||
0..8:
|
||||
aktmaxfpuregisters:=l;
|
||||
else
|
||||
Message(scan_e_invalid_maxfpureg_value);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_memory;
|
||||
var
|
||||
l : longint;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
l:=current_scanner.readval;
|
||||
if l>1024 then
|
||||
stacksize:=l;
|
||||
current_scanner.skipspace;
|
||||
if c=',' then
|
||||
begin
|
||||
current_scanner.readchar;
|
||||
current_scanner.skipspace;
|
||||
l:=current_scanner.readval;
|
||||
if l>1024 then
|
||||
heapsize:=l;
|
||||
end;
|
||||
if c=',' then
|
||||
begin
|
||||
current_scanner.readchar;
|
||||
current_scanner.skipspace;
|
||||
l:=current_scanner.readval;
|
||||
{ Ignore this value, because the limit is set by the OS
|
||||
info and shouldn't be changed by the user (PFV) }
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_message;
|
||||
begin
|
||||
do_message(scan_i_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_mode;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
current_scanner.readstring;
|
||||
if not SetCompileMode(pattern,false) then
|
||||
Message1(scan_w_illegal_switch,pattern);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_mmx;
|
||||
begin
|
||||
do_localswitch(cs_mmx);
|
||||
end;
|
||||
|
||||
procedure dir_note;
|
||||
begin
|
||||
do_message(scan_n_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_notes;
|
||||
begin
|
||||
do_setverbose('N');
|
||||
end;
|
||||
|
||||
procedure dir_objectpath;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
current_module.localobjectsearchpath.AddPath(current_scanner.readcomment,false);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_openstrings;
|
||||
begin
|
||||
do_delphiswitch('P');
|
||||
end;
|
||||
|
||||
procedure dir_output_format;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
if set_string_asm(current_scanner.readid) then
|
||||
aktoutputformat:=target_asm.id
|
||||
else
|
||||
Message1(scan_w_illegal_switch,pattern);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_overflowchecks;
|
||||
begin
|
||||
do_delphiswitch('Q');
|
||||
end;
|
||||
|
||||
procedure dir_packenum;
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
if not(c in ['0'..'9']) then
|
||||
begin
|
||||
hs:=current_scanner.readid;
|
||||
if (hs='NORMAL') or (hs='DEFAULT') then
|
||||
aktpackenum:=4
|
||||
else
|
||||
Message(scan_w_only_pack_enum);
|
||||
end
|
||||
else
|
||||
begin
|
||||
case current_scanner.readval of
|
||||
1 : aktpackenum:=1;
|
||||
2 : aktpackenum:=2;
|
||||
4 : aktpackenum:=4;
|
||||
else
|
||||
Message(scan_w_only_pack_enum);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_packrecords;
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
if not(c in ['0'..'9']) then
|
||||
begin
|
||||
hs:=current_scanner.readid;
|
||||
if (hs='C') then
|
||||
aktpackrecords:=packrecord_C
|
||||
else
|
||||
if (hs='NORMAL') or (hs='DEFAULT') then
|
||||
aktpackrecords:=packrecord_2
|
||||
else
|
||||
Message(scan_w_only_pack_records);
|
||||
end
|
||||
else
|
||||
begin
|
||||
case current_scanner.readval of
|
||||
1 : aktpackrecords:=packrecord_1;
|
||||
2 : aktpackrecords:=packrecord_2;
|
||||
4 : aktpackrecords:=packrecord_4;
|
||||
8 : aktpackrecords:=packrecord_8;
|
||||
16 : aktpackrecords:=packrecord_16;
|
||||
32 : aktpackrecords:=packrecord_32;
|
||||
else
|
||||
Message(scan_w_only_pack_records);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
{$ifdef testvarsets}
|
||||
procedure dir_packset;
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
if not(c in ['1','2','4']) then
|
||||
begin
|
||||
hs:=current_scanner.readid;
|
||||
if (hs='FIXED') or ((hs='DEFAULT') OR (hs='NORMAL')) then
|
||||
aktsetalloc:=0 {Fixed mode, sets are 4 or 32 bytes}
|
||||
else
|
||||
Message(scan_w_only_packset);
|
||||
end
|
||||
else
|
||||
begin
|
||||
case current_scanner.readval of
|
||||
1 : aktsetalloc:=1;
|
||||
2 : aktsetalloc:=2;
|
||||
4 : aktsetalloc:=4;
|
||||
else
|
||||
Message(scan_w_only_packset);
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
{$ENDIF}
|
||||
|
||||
procedure dir_rangechecks;
|
||||
begin
|
||||
do_delphiswitch('R');
|
||||
end;
|
||||
|
||||
procedure dir_referenceinfo;
|
||||
begin
|
||||
do_delphiswitch('Y');
|
||||
end;
|
||||
|
||||
procedure dir_resource;
|
||||
var
|
||||
s : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
s:=current_scanner.readcomment;
|
||||
{ replace * with current module name.
|
||||
This should always be defined. }
|
||||
if s[1]='*' then
|
||||
if Assigned(Current_Module) then
|
||||
begin
|
||||
delete(S,1,1);
|
||||
insert(lower(current_module.modulename^),S,1);
|
||||
end;
|
||||
s:=AddExtension(FixFileName(s),target_info.resext);
|
||||
if target_info.res<>res_none then
|
||||
if (target_info.res = res_i386_emx) and
|
||||
not (Current_module.ResourceFiles.Empty) then
|
||||
Message(scan_w_only_one_resourcefile_supported)
|
||||
else
|
||||
current_module.resourcefiles.insert(FixFileName(s))
|
||||
else
|
||||
Message(scan_e_resourcefiles_not_supported);
|
||||
end;
|
||||
|
||||
procedure dir_saturation;
|
||||
begin
|
||||
do_localswitch(cs_mmx_saturation);
|
||||
end;
|
||||
|
||||
procedure dir_smartlink;
|
||||
begin
|
||||
do_moduleswitch(cs_create_smart);
|
||||
end;
|
||||
|
||||
procedure dir_stackframes;
|
||||
begin
|
||||
do_delphiswitch('W');
|
||||
end;
|
||||
|
||||
procedure dir_static;
|
||||
begin
|
||||
do_moduleswitch(cs_static_keyword);
|
||||
end;
|
||||
|
||||
procedure dir_stop;
|
||||
begin
|
||||
do_message(scan_f_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_typedaddress;
|
||||
begin
|
||||
do_delphiswitch('T');
|
||||
end;
|
||||
|
||||
procedure dir_typeinfo;
|
||||
begin
|
||||
do_delphiswitch('M');
|
||||
end;
|
||||
|
||||
procedure dir_unitpath;
|
||||
begin
|
||||
if not current_module.in_global then
|
||||
Message(scan_w_switch_is_global)
|
||||
else
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
current_module.localunitsearchpath.AddPath(current_scanner.readcomment,false);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_varstringchecks;
|
||||
begin
|
||||
do_delphiswitch('V');
|
||||
end;
|
||||
|
||||
procedure dir_version;
|
||||
var
|
||||
major, minor, revision : longint;
|
||||
error : integer;
|
||||
begin
|
||||
if not (target_info.target in [target_i386_os2,target_i386_win32,target_i386_netware]) then // AD
|
||||
begin
|
||||
Message(scan_n_version_not_support);
|
||||
exit;
|
||||
end;
|
||||
if (compile_level<>1) then
|
||||
Message(scan_n_only_exe_version)
|
||||
else
|
||||
begin
|
||||
{ change description global var in all cases }
|
||||
{ it not used but in win32, os2 and netware }
|
||||
current_scanner.skipspace;
|
||||
{ we should only accept Major.Minor format for win32 and os2 }
|
||||
current_scanner.readnumber;
|
||||
major:=0;
|
||||
minor:=0;
|
||||
revision:=0;
|
||||
valint(pattern,major,error);
|
||||
if error<>0 then
|
||||
begin
|
||||
Message1(scan_w_wrong_version_ignored,pattern);
|
||||
exit;
|
||||
end;
|
||||
if c='.' then
|
||||
begin
|
||||
current_scanner.readchar;
|
||||
current_scanner.readnumber;
|
||||
valint(pattern,minor,error);
|
||||
if error<>0 then
|
||||
begin
|
||||
Message1(scan_w_wrong_version_ignored,tostr(major)+'.'+pattern);
|
||||
exit;
|
||||
end;
|
||||
if (c='.') and
|
||||
(target_info.target = target_i386_netware) then // AD
|
||||
begin
|
||||
current_scanner.readchar;
|
||||
current_scanner.readnumber;
|
||||
valint(pattern,revision,error);
|
||||
if error<>0 then
|
||||
begin
|
||||
Message1(scan_w_wrong_version_ignored,tostr(revision)+'.'+pattern);
|
||||
exit;
|
||||
end;
|
||||
dllmajor:=major;
|
||||
dllminor:=minor;
|
||||
dllrevision:=revision;
|
||||
dllversion:=tostr(major)+','+tostr(minor)+','+tostr(revision);
|
||||
end
|
||||
else
|
||||
begin
|
||||
dllmajor:=major;
|
||||
dllminor:=minor;
|
||||
dllversion:=tostr(major)+'.'+tostr(minor);
|
||||
end;
|
||||
end
|
||||
else
|
||||
dllversion:=tostr(major);
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure dir_wait;
|
||||
var
|
||||
had_info : boolean;
|
||||
begin
|
||||
had_info:=(status.verbosity and V_Info)<>0;
|
||||
{ this message should allways appear !! }
|
||||
status.verbosity:=status.verbosity or V_Info;
|
||||
Message(scan_i_press_enter);
|
||||
readln;
|
||||
If not(had_info) then
|
||||
status.verbosity:=status.verbosity and (not V_Info);
|
||||
end;
|
||||
|
||||
procedure dir_warning;
|
||||
begin
|
||||
do_message(scan_w_user_defined);
|
||||
end;
|
||||
|
||||
procedure dir_warnings;
|
||||
begin
|
||||
do_setverbose('W');
|
||||
end;
|
||||
|
||||
procedure dir_z1;
|
||||
begin
|
||||
aktpackenum:=1;
|
||||
end;
|
||||
|
||||
procedure dir_z2;
|
||||
begin
|
||||
aktpackenum:=2;
|
||||
end;
|
||||
|
||||
procedure dir_z4;
|
||||
begin
|
||||
aktpackenum:=4;
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Initialize Directives
|
||||
****************************************************************************}
|
||||
|
||||
procedure InitScannerDirectives;
|
||||
begin
|
||||
AddDirective('ALIGN',{$ifdef FPCPROCVAR}@{$endif}dir_align);
|
||||
AddDirective('APPTYPE',{$ifdef FPCPROCVAR}@{$endif}dir_apptype);
|
||||
AddDirective('ASMMODE',{$ifdef FPCPROCVAR}@{$endif}dir_asmmode);
|
||||
AddDirective('ASSERTIONS',{$ifdef FPCPROCVAR}@{$endif}dir_assertions);
|
||||
AddDirective('BOOLEVAL',{$ifdef FPCPROCVAR}@{$endif}dir_booleval);
|
||||
AddDirective('D',{$ifdef FPCPROCVAR}@{$endif}dir_description);
|
||||
AddDirective('DEBUGINFO',{$ifdef FPCPROCVAR}@{$endif}dir_debuginfo);
|
||||
AddDirective('DESCRIPTION',{$ifdef FPCPROCVAR}@{$endif}dir_description);
|
||||
AddDirective('ERROR',{$ifdef FPCPROCVAR}@{$endif}dir_error);
|
||||
AddDirective('EXTENDEDSYNTAX',{$ifdef FPCPROCVAR}@{$endif}dir_extendedsyntax);
|
||||
AddDirective('FATAL',{$ifdef FPCPROCVAR}@{$endif}dir_fatal);
|
||||
AddDirective('GOTO',{$ifdef FPCPROCVAR}@{$endif}dir_goto);
|
||||
AddDirective('HINT',{$ifdef FPCPROCVAR}@{$endif}dir_hint);
|
||||
AddDirective('HINTS',{$ifdef FPCPROCVAR}@{$endif}dir_hints);
|
||||
AddDirective('IOCHECKS',{$ifdef FPCPROCVAR}@{$endif}dir_iochecks);
|
||||
AddDirective('INCLUDEPATH',{$ifdef FPCPROCVAR}@{$endif}dir_includepath);
|
||||
AddDirective('INFO',{$ifdef FPCPROCVAR}@{$endif}dir_info);
|
||||
AddDirective('INLINE',{$ifdef FPCPROCVAR}@{$endif}dir_inline);
|
||||
AddDirective('INTERFACES',{$ifdef FPCPROCVAR}@{$endif}dir_interfaces);
|
||||
AddDirective('L',{$ifdef FPCPROCVAR}@{$endif}dir_link);
|
||||
AddDirective('LIBRARYPATH',{$ifdef FPCPROCVAR}@{$endif}dir_librarypath);
|
||||
AddDirective('LINK',{$ifdef FPCPROCVAR}@{$endif}dir_link);
|
||||
AddDirective('LINKLIB',{$ifdef FPCPROCVAR}@{$endif}dir_linklib);
|
||||
AddDirective('LOCALSYMBOLS',{$ifdef FPCPROCVAR}@{$endif}dir_localsymbols);
|
||||
AddDirective('LONGSTRINGS',{$ifdef FPCPROCVAR}@{$endif}dir_longstrings);
|
||||
AddDirective('M',{$ifdef FPCPROCVAR}@{$endif}dir_memory);
|
||||
AddDirective('MACRO',{$ifdef FPCPROCVAR}@{$endif}dir_macro);
|
||||
AddDirective('MAXFPUREGISTERS',{$ifdef FPCPROCVAR}@{$endif}dir_maxfpuregisters);
|
||||
AddDirective('MEMORY',{$ifdef FPCPROCVAR}@{$endif}dir_memory);
|
||||
AddDirective('MESSAGE',{$ifdef FPCPROCVAR}@{$endif}dir_message);
|
||||
AddDirective('MINENUMSIZE',{$ifdef FPCPROCVAR}@{$endif}dir_packenum);
|
||||
AddDirective('MMX',{$ifdef FPCPROCVAR}@{$endif}dir_mmx);
|
||||
AddDirective('MODE',{$ifdef FPCPROCVAR}@{$endif}dir_mode);
|
||||
AddDirective('NOTE',{$ifdef FPCPROCVAR}@{$endif}dir_note);
|
||||
AddDirective('NOTES',{$ifdef FPCPROCVAR}@{$endif}dir_notes);
|
||||
AddDirective('OBJECTPATH',{$ifdef FPCPROCVAR}@{$endif}dir_objectpath);
|
||||
AddDirective('OPENSTRINGS',{$ifdef FPCPROCVAR}@{$endif}dir_openstrings);
|
||||
AddDirective('OUTPUT_FORMAT',{$ifdef FPCPROCVAR}@{$endif}dir_output_format);
|
||||
AddDirective('OVERFLOWCHECKS',{$ifdef FPCPROCVAR}@{$endif}dir_overflowchecks);
|
||||
AddDirective('PACKENUM',{$ifdef FPCPROCVAR}@{$endif}dir_packenum);
|
||||
AddDirective('PACKRECORDS',{$ifdef FPCPROCVAR}@{$endif}dir_packrecords);
|
||||
{$IFDEF TestVarsets}
|
||||
AddDirective('PACKSET',{$ifdef FPCPROCVAR}@{$endif}dir_packset);
|
||||
{$ENDIF}
|
||||
AddDirective('R',{$ifdef FPCPROCVAR}@{$endif}dir_resource);
|
||||
AddDirective('RANGECHECKS',{$ifdef FPCPROCVAR}@{$endif}dir_rangechecks);
|
||||
AddDirective('REFERENCEINFO',{$ifdef FPCPROCVAR}@{$endif}dir_referenceinfo);
|
||||
AddDirective('SATURATION',{$ifdef FPCPROCVAR}@{$endif}dir_saturation);
|
||||
AddDirective('SMARTLINK',{$ifdef FPCPROCVAR}@{$endif}dir_smartlink);
|
||||
AddDirective('STACKFRAMES',{$ifdef FPCPROCVAR}@{$endif}dir_stackframes);
|
||||
AddDirective('STATIC',{$ifdef FPCPROCVAR}@{$endif}dir_static);
|
||||
AddDirective('STOP',{$ifdef FPCPROCVAR}@{$endif}dir_stop);
|
||||
AddDirective('TYPEDADDRESS',{$ifdef FPCPROCVAR}@{$endif}dir_typedaddress);
|
||||
AddDirective('TYPEINFO',{$ifdef FPCPROCVAR}@{$endif}dir_typeinfo);
|
||||
AddDirective('UNITPATH',{$ifdef FPCPROCVAR}@{$endif}dir_unitpath);
|
||||
AddDirective('VARSTRINGCHECKS',{$ifdef FPCPROCVAR}@{$endif}dir_varstringchecks);
|
||||
AddDirective('VERSION',{$ifdef FPCPROCVAR}@{$endif}dir_version);
|
||||
AddDirective('WAIT',{$ifdef FPCPROCVAR}@{$endif}dir_wait);
|
||||
AddDirective('WARNING',{$ifdef FPCPROCVAR}@{$endif}dir_warning);
|
||||
AddDirective('WARNINGS',{$ifdef FPCPROCVAR}@{$endif}dir_warnings);
|
||||
AddDirective('Z1',{$ifdef FPCPROCVAR}@{$endif}dir_z1);
|
||||
AddDirective('Z2',{$ifdef FPCPROCVAR}@{$endif}dir_z2);
|
||||
AddDirective('Z4',{$ifdef FPCPROCVAR}@{$endif}dir_z4);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2001-04-13 18:00:36 peter
|
||||
* easier registration of directives
|
||||
|
||||
Revision 1.20 2001/04/13 01:22:13 peter
|
||||
* symtable change to classes
|
||||
* range check generation and errors fixed, make cycle DEBUG=1 works
|
||||
* memory leaks fixed
|
||||
|
||||
Revision 1.19 2001/03/13 18:45:07 peter
|
||||
* fixed some memory leaks
|
||||
|
||||
Revision 1.18 2001/02/20 21:41:18 peter
|
||||
* new fixfilename, findfile for unix. Look first for lowercase, then
|
||||
NormalCase and last for UPPERCASE names.
|
||||
|
||||
Revision 1.17 2001/01/20 18:32:52 hajny
|
||||
+ APPTYPE support under OS/2, app_fs, GetEnvPChar for OS/2
|
||||
|
||||
Revision 1.16 2001/01/13 00:09:21 peter
|
||||
* made Pavel O. happy ;)
|
||||
|
||||
Revision 1.15 2000/12/25 00:07:28 peter
|
||||
+ new tlinkedlist class (merge of old tstringqueue,tcontainer and
|
||||
tlinkedlist objects)
|
||||
|
||||
Revision 1.14 2000/12/24 12:24:38 peter
|
||||
* moved preprocessfile into a conditional
|
||||
|
||||
Revision 1.13 2000/12/12 19:48:52 peter
|
||||
* fixed lost char after $I directive (merged)
|
||||
|
||||
Revision 1.12 2000/11/12 22:17:47 peter
|
||||
* some realname updates for messages
|
||||
|
||||
Revision 1.11 2000/11/04 14:25:21 florian
|
||||
+ merged Attila's changes for interfaces, not tested yet
|
||||
|
||||
Revision 1.10 2000/10/31 22:02:51 peter
|
||||
* symtable splitted, no real code changes
|
||||
|
||||
Revision 1.9 2000/09/26 10:50:41 jonas
|
||||
* initmodeswitches is changed is you change the compiler mode from the
|
||||
command line (the -S<x> switches didn't work anymore for changing the
|
||||
compiler mode) (merged from fixes branch)
|
||||
|
||||
Revision 1.8 2000/09/24 21:33:47 peter
|
||||
* message updates merges
|
||||
|
||||
Revision 1.7 2000/09/24 15:06:27 peter
|
||||
* use defines.inc
|
||||
|
||||
Revision 1.6 2000/09/11 17:00:23 florian
|
||||
+ first implementation of Netware Module support, thanks to
|
||||
Armin Diehl (diehl@nordrhein.de) for providing the patches
|
||||
|
||||
Revision 1.5 2000/09/10 21:18:15 peter
|
||||
* macro warning (merged)
|
||||
|
||||
Revision 1.4 2000/08/12 15:30:44 peter
|
||||
* IDE patch for stream reading (merged)
|
||||
|
||||
Revision 1.3 2000/08/08 19:28:57 peter
|
||||
* memdebug/memory patches (merged)
|
||||
* only once illegal directive (merged)
|
||||
|
||||
Revision 1.2 2000/07/13 11:32:49 michael
|
||||
+ removed logs
|
||||
|
||||
}
|
||||
@ -66,8 +66,17 @@ interface
|
||||
constructor Create(atyp:preproctyp;a:boolean;n:tpreprocstack);
|
||||
end;
|
||||
|
||||
pscannerfile = ^tscannerfile;
|
||||
tscannerfile = object
|
||||
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
|
||||
inputfile : tinputfile; { current inputfile list }
|
||||
|
||||
inputbuffer, { input buffer }
|
||||
@ -90,8 +99,11 @@ interface
|
||||
macros : Tdictionary;
|
||||
in_asm_string : boolean;
|
||||
|
||||
constructor init(const fn:string);
|
||||
destructor done;
|
||||
preproc_pattern : string;
|
||||
preproc_token : ttoken;
|
||||
|
||||
constructor Create(const fn:string);
|
||||
destructor Destroy;override;
|
||||
{ File buffer things }
|
||||
function openinputfile:boolean;
|
||||
procedure closeinputfile;
|
||||
@ -115,6 +127,8 @@ interface
|
||||
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;
|
||||
@ -134,14 +148,13 @@ interface
|
||||
end;
|
||||
|
||||
{$ifdef PREPROCWRITE}
|
||||
tpreprocfile=^tpreprocfile;
|
||||
tpreprocfile=object
|
||||
tpreprocfile=class
|
||||
f : text;
|
||||
buf : pointer;
|
||||
spacefound,
|
||||
eolfound : boolean;
|
||||
constructor init(const fn:string);
|
||||
destructor done;
|
||||
constructor create(const fn:string);
|
||||
destructor destroy;
|
||||
procedure Add(const s:string);
|
||||
procedure AddSpace;
|
||||
end;
|
||||
@ -152,18 +165,27 @@ interface
|
||||
c : char;
|
||||
orgpattern,
|
||||
pattern : string;
|
||||
patternw : tcompilerwidestring;
|
||||
patternw : tcompilerwidestring;
|
||||
|
||||
{ token }
|
||||
token, { current token being parsed }
|
||||
idtoken : ttoken; { holds the token if the pattern is a known word }
|
||||
|
||||
current_scanner : pscannerfile;
|
||||
current_scanner : tscannerfile; { current scanner in use }
|
||||
|
||||
scannerdirectives : tdictionary; { dictionary with the supported directives }
|
||||
|
||||
aktcommentstyle : tcommentstyle; { needed to use read_comment from directives }
|
||||
{$ifdef PREPROCWRITE}
|
||||
preprocfile : tpreprocfile; { used with only preprocessing }
|
||||
preprocfile : tpreprocfile; { used with only preprocessing }
|
||||
{$endif PREPROCWRITE}
|
||||
|
||||
procedure adddirective(const s:string;p:tdirectiveproc);
|
||||
procedure addconditional(const s:string;p:tdirectiveproc);
|
||||
|
||||
procedure InitScanner;
|
||||
procedure DoneScanner;
|
||||
|
||||
|
||||
implementation
|
||||
|
||||
@ -212,6 +234,462 @@ implementation
|
||||
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;
|
||||
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;
|
||||
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;
|
||||
|
||||
|
||||
procedure dir_if;
|
||||
|
||||
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 read_factor : string;
|
||||
var
|
||||
hs : string;
|
||||
mac : tmacro;
|
||||
len : byte;
|
||||
begin
|
||||
if current_scanner.preproc_token=_ID then
|
||||
begin
|
||||
if current_scanner.preproc_pattern='NOT' then
|
||||
begin
|
||||
preproc_consume(_ID);
|
||||
hs:=read_expr;
|
||||
if hs='0' then
|
||||
read_factor:='1'
|
||||
else
|
||||
read_factor:='0';
|
||||
end
|
||||
else
|
||||
begin
|
||||
mac:=tmacro(current_scanner.macros.search(hs));
|
||||
hs:=current_scanner.preproc_pattern;
|
||||
preproc_consume(_ID);
|
||||
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
|
||||
else
|
||||
read_factor:='';
|
||||
end
|
||||
else
|
||||
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;
|
||||
begin
|
||||
hs1:=read_factor;
|
||||
while true do
|
||||
begin
|
||||
if (current_scanner.preproc_token=_ID) then
|
||||
begin
|
||||
if current_scanner.preproc_pattern='AND' then
|
||||
begin
|
||||
preproc_consume(_ID);
|
||||
hs2:=read_factor;
|
||||
if (hs1<>'0') and (hs2<>'0') then
|
||||
hs1:='1';
|
||||
end
|
||||
else
|
||||
break;
|
||||
end
|
||||
else
|
||||
break;
|
||||
end;
|
||||
read_term:=hs1;
|
||||
end;
|
||||
|
||||
|
||||
function read_simple_expr : string;
|
||||
var
|
||||
hs1,hs2 : string;
|
||||
begin
|
||||
hs1:=read_term;
|
||||
while true do
|
||||
begin
|
||||
if (current_scanner.preproc_token=_ID) then
|
||||
begin
|
||||
if current_scanner.preproc_pattern='OR' then
|
||||
begin
|
||||
preproc_consume(_ID);
|
||||
hs2:=read_term;
|
||||
if (hs1<>'0') or (hs2<>'0') then
|
||||
hs1:='1';
|
||||
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;
|
||||
|
||||
var
|
||||
hs : string;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
{ start preproc expression scanner }
|
||||
current_scanner.preproc_token:=current_scanner.readpreproc;
|
||||
hs:=read_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_m_macro_defined,mac.name);
|
||||
current_scanner.macros.insert(mac);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Message1(parser_m_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);
|
||||
#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_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_m_macro_undefined,mac.name);
|
||||
mac.defined:=false;
|
||||
current_scanner.macros.insert(mac);
|
||||
end
|
||||
else
|
||||
begin
|
||||
Message1(parser_m_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;
|
||||
var
|
||||
foundfile,
|
||||
hs : string;
|
||||
path : dirstr;
|
||||
name : namestr;
|
||||
ext : extstr;
|
||||
hp : tinputfile;
|
||||
i : longint;
|
||||
found : boolean;
|
||||
begin
|
||||
current_scanner.skipspace;
|
||||
hs:=current_scanner.readcomment;
|
||||
i:=length(hs);
|
||||
while (i>0) and (hs[i]=' ') do
|
||||
dec(i);
|
||||
Delete(hs,i+1,length(hs)-i);
|
||||
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
|
||||
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));
|
||||
end
|
||||
else
|
||||
begin
|
||||
hs:=FixFileName(hs);
|
||||
fsplit(hs,path,name,ext);
|
||||
{ look for the include file
|
||||
1. specified path,path of current inputfile,current dir
|
||||
2. local includepath
|
||||
3. global includepath }
|
||||
found:=false;
|
||||
foundfile:='';
|
||||
if path<>'' then
|
||||
path:=path+';';
|
||||
found:=FindFile(name+ext,path+current_scanner.inputfile.path^+';.'+DirSep,foundfile);
|
||||
if (not found) then
|
||||
found:=current_module.localincludesearchpath.FindFile(name+ext,foundfile);
|
||||
if (not found) then
|
||||
found:=includesearchpath.FindFile(name+ext,foundfile);
|
||||
{ save old postion and decrease linebreak }
|
||||
if c=newline then
|
||||
dec(current_scanner.line_no);
|
||||
dec(longint(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;
|
||||
{ process first read char }
|
||||
case c of
|
||||
#26 : current_scanner.reload;
|
||||
#10,
|
||||
#13 : current_scanner.linebreak;
|
||||
end;
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
TMacro
|
||||
*****************************************************************************}
|
||||
@ -240,7 +718,7 @@ implementation
|
||||
*****************************************************************************}
|
||||
|
||||
{$ifdef PREPROCWRITE}
|
||||
constructor tpreprocfile.init(const fn:string);
|
||||
constructor tpreprocfile.create(const fn:string);
|
||||
begin
|
||||
{ open outputfile }
|
||||
assign(f,fn);
|
||||
@ -257,7 +735,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
destructor tpreprocfile.done;
|
||||
destructor tpreprocfile.destroy;
|
||||
begin
|
||||
close(f);
|
||||
freemem(buf,preprocbufsize);
|
||||
@ -299,11 +777,30 @@ implementation
|
||||
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.init(const fn:string);
|
||||
constructor tscannerfile.create(const fn:string);
|
||||
begin
|
||||
inputfile:=do_openinputfile(fn);
|
||||
if assigned(current_module) then
|
||||
@ -340,7 +837,7 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
destructor tscannerfile.done;
|
||||
destructor tscannerfile.destroy;
|
||||
begin
|
||||
if not invalid then
|
||||
begin
|
||||
@ -692,6 +1189,9 @@ implementation
|
||||
Message(scan_f_end_of_file);
|
||||
end;
|
||||
|
||||
{-------------------------------------------
|
||||
IF Conditional Handling
|
||||
-------------------------------------------}
|
||||
|
||||
procedure tscannerfile.checkpreprocstack;
|
||||
begin
|
||||
@ -750,6 +1250,117 @@ implementation
|
||||
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;
|
||||
p:=tdirectiveitem(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
|
||||
t:=tdirectiveitem(scannerdirectives.search(hs));
|
||||
if assigned(t) then
|
||||
begin
|
||||
if t.is_conditional then
|
||||
handleconditional(t)
|
||||
else
|
||||
t.proc{$ifdef FPCPROCVAR}(){$endif};
|
||||
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^;
|
||||
@ -963,8 +1574,8 @@ implementation
|
||||
state:=' ';
|
||||
if c=' ' then
|
||||
begin
|
||||
current_scanner^.skipspace;
|
||||
current_scanner^.readid;
|
||||
current_scanner.skipspace;
|
||||
current_scanner.readid;
|
||||
if pattern='ON' then
|
||||
state:='+'
|
||||
else
|
||||
@ -1101,13 +1712,6 @@ implementation
|
||||
end;
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Include directive scanning/parsing
|
||||
****************************************************************************}
|
||||
|
||||
{$i scandir.inc}
|
||||
|
||||
|
||||
{****************************************************************************
|
||||
Comment Handling
|
||||
****************************************************************************}
|
||||
@ -1817,7 +2421,7 @@ exit_label:
|
||||
'A'..'Z',
|
||||
'a'..'z',
|
||||
'_','0'..'9' : begin
|
||||
preprocpat:=readid;
|
||||
current_scanner.preproc_pattern:=readid;
|
||||
readpreproc:=_ID;
|
||||
end;
|
||||
'}' : begin
|
||||
@ -1941,10 +2545,58 @@ exit_label:
|
||||
end;
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Helpers
|
||||
*****************************************************************************}
|
||||
|
||||
procedure adddirective(const s:string;p:tdirectiveproc);
|
||||
begin
|
||||
scannerdirectives.insert(tdirectiveitem.create(s,p));
|
||||
end;
|
||||
|
||||
|
||||
procedure addconditional(const s:string;p:tdirectiveproc);
|
||||
begin
|
||||
scannerdirectives.insert(tdirectiveitem.createcond(s,p));
|
||||
end;
|
||||
|
||||
|
||||
{*****************************************************************************
|
||||
Initialization
|
||||
*****************************************************************************}
|
||||
|
||||
procedure InitScanner;
|
||||
begin
|
||||
scannerdirectives:=TDictionary.Create;
|
||||
{ Default directives }
|
||||
AddDirective('DEFINE',{$ifdef FPCPROCVAR}@{$endif}dir_define);
|
||||
AddDirective('UNDEF',{$ifdef FPCPROCVAR}@{$endif}dir_undef);
|
||||
AddDirective('I',{$ifdef FPCPROCVAR}@{$endif}dir_include);
|
||||
AddDirective('INCLUDE',{$ifdef FPCPROCVAR}@{$endif}dir_include);
|
||||
{ Default conditionals }
|
||||
AddConditional('ELSE',{$ifdef FPCPROCVAR}@{$endif}dir_else);
|
||||
AddConditional('ENDIF',{$ifdef FPCPROCVAR}@{$endif}dir_endif);
|
||||
AddConditional('IF',{$ifdef FPCPROCVAR}@{$endif}dir_if);
|
||||
AddConditional('IFDEF',{$ifdef FPCPROCVAR}@{$endif}dir_ifdef);
|
||||
AddConditional('IFNDEF',{$ifdef FPCPROCVAR}@{$endif}dir_ifndef);
|
||||
AddConditional('IFOPT',{$ifdef FPCPROCVAR}@{$endif}dir_ifopt);
|
||||
end;
|
||||
|
||||
|
||||
procedure DoneScanner;
|
||||
begin
|
||||
scannerdirectives.Free;
|
||||
end;
|
||||
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.14 2001-04-13 01:22:13 peter
|
||||
Revision 1.15 2001-04-13 18:00:36 peter
|
||||
* easier registration of directives
|
||||
|
||||
Revision 1.14 2001/04/13 01:22:13 peter
|
||||
* symtable change to classes
|
||||
* range check generation and errors fixed, make cycle DEBUG=1 works
|
||||
* memory leaks fixed
|
||||
|
||||
Loading…
Reference in New Issue
Block a user