{ $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; var hs : string; begin current_scanner.skipspace; if not(c in ['0'..'9']) then begin { Support also the ON and OFF as switch } hs:=current_scanner.readid; if (hs='ON') then aktpackrecords:=packrecord_4 else if (hs='OFF') then aktpackrecords:=packrecord_1 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; 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_screenname; {ad} begin if target_info.target <> target_i386_netware then {Message(scan_w_decription_not_support);} comment (V_Warning,'Screenname only supported for target netware'); current_scanner.skipspace; nwscreenname:=current_scanner.readcomment; end; procedure dir_threadname; {ad} begin if target_info.target <> target_i386_netware then {Message(scan_w_decription_not_support);} comment (V_Warning,'Threadname only supported for target netware'); current_scanner.skipspace; nwthreadname:=current_scanner.readcomment; end; procedure dir_copyright; {ad} begin if target_info.target <> target_i386_netware then {Message(scan_w_decription_not_support);} comment (V_Warning,'Copyright only supported for target netware'); current_scanner.skipspace; nwcopyright:=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('COPYRIGHT',{$ifdef FPCPROCVAR}@{$endif}dir_copyright); 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); {ad 18.05.2001: Screen and Threadname for Netware} AddDirective('SCREENNAME',{$ifdef FPCPROCVAR}@{$endif}dir_screenname); 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); {ad 18.05.2001: Screen and Threadname for Netware} AddDirective('THREADNAME',{$ifdef FPCPROCVAR}@{$endif}dir_threadname); 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.4 2001-06-03 20:20:27 peter * Align directive supports also values to be Kylix compatible. It's strange because the help of kylix still shows only On and Off as possible values, so still support those. On means 4 bytes and Off means 1 byte alignment. Revision 1.3 2001/05/30 21:35:49 peter * netware patches for copyright, screenname, threadname directives 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 }