{ $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 exclude(nextaktlocalswitches,sw) else include(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_asmmode_by_string(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_target_asm_by_string(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_emxbind) 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.2 2001-04-18 22:01:58 peter * registration of targets and assemblers 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 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 }