scandir.pas 60 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887
  1. {
  2. Copyright (c) 1998-2002 by Peter Vreman
  3. This unit implements directive parsing for the scanner
  4. This program is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 2 of the License, or
  7. (at your option) any later version.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. You should have received a copy of the GNU General Public License
  13. along with this program; if not, write to the Free Software
  14. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  15. ****************************************************************************
  16. }
  17. unit scandir;
  18. {$i fpcdefs.inc}
  19. interface
  20. uses
  21. globtype;
  22. const
  23. switchesstatestackmax = 20;
  24. type
  25. tsavedswitchesstate = record
  26. localsw: tlocalswitches;
  27. verbosity: longint;
  28. pmessage : pmessagestaterecord;
  29. end;
  30. type
  31. tswitchesstatestack = array[0..switchesstatestackmax] of tsavedswitchesstate;
  32. var
  33. switchesstatestack:tswitchesstatestack;
  34. switchesstatestackpos: Integer;
  35. procedure InitScannerDirectives;
  36. implementation
  37. uses
  38. SysUtils,
  39. cutils,cfileutl,
  40. globals,systems,widestr,cpuinfo,
  41. verbose,comphook,ppu,
  42. scanner,switches,
  43. fmodule,
  44. defutil,
  45. dirparse,link,
  46. symconst,symtable,symbase,symtype,symsym,
  47. rabase;
  48. {*****************************************************************************
  49. Helpers
  50. *****************************************************************************}
  51. procedure do_delphiswitch(sw:char);
  52. var
  53. state : char;
  54. begin
  55. { c contains the next char, a + or - would be fine }
  56. state:=current_scanner.readstate;
  57. if state in ['-','+'] then
  58. HandleSwitch(sw,state);
  59. end;
  60. procedure do_setverbose(flag:char);
  61. var
  62. state : char;
  63. begin
  64. { support ON/OFF }
  65. state:=current_scanner.ReadState;
  66. recordpendingverbosityswitch(flag,state);
  67. end;
  68. procedure do_moduleswitch(sw:tmoduleswitch);
  69. var
  70. state : char;
  71. begin
  72. state:=current_scanner.readstate;
  73. if (sw<>cs_modulenone) and (state in ['-','+']) then
  74. begin
  75. if state='-' then
  76. exclude(current_settings.moduleswitches,sw)
  77. else
  78. include(current_settings.moduleswitches,sw);
  79. end;
  80. end;
  81. procedure do_localswitch(sw:tlocalswitch);
  82. var
  83. state : char;
  84. begin
  85. state:=current_scanner.readstate;
  86. if (sw<>cs_localnone) and (state in ['-','+']) then
  87. recordpendinglocalswitch(sw,state);
  88. end;
  89. function do_localswitchdefault(sw:tlocalswitch): char;
  90. begin
  91. result:=current_scanner.readstatedefault;
  92. if (sw<>cs_localnone) and (result in ['-','+','*']) then
  93. recordpendinglocalswitch(sw,result);
  94. end;
  95. procedure do_moduleflagswitch(flag:cardinal;optional:boolean);
  96. var
  97. state : char;
  98. begin
  99. if optional then
  100. state:=current_scanner.readoptionalstate('+')
  101. else
  102. state:=current_scanner.readstate;
  103. if state='-' then
  104. current_module.flags:=current_module.flags and not flag
  105. else
  106. current_module.flags:=current_module.flags or flag;
  107. end;
  108. procedure do_message(w:integer);
  109. begin
  110. current_scanner.skipspace;
  111. Message1(w,current_scanner.readcomment);
  112. end;
  113. {*****************************************************************************
  114. Directive Callbacks
  115. *****************************************************************************}
  116. procedure dir_align;
  117. var
  118. hs : string;
  119. b : byte;
  120. begin
  121. current_scanner.skipspace;
  122. if not(c in ['0'..'9']) then
  123. begin
  124. { Support also the ON and OFF as switch }
  125. hs:=current_scanner.readid;
  126. if (hs='ON') then
  127. current_settings.packrecords:=4
  128. else if (hs='OFF') then
  129. current_settings.packrecords:=1
  130. else if m_mac in current_settings.modeswitches then
  131. begin
  132. { Support switches used in Apples Universal Interfaces}
  133. if (hs='MAC68K') then
  134. current_settings.packrecords:=mac68k_alignment
  135. { "power" alignment is the default C packrecords setting on
  136. Mac OS X }
  137. else if (hs='POWER') or (hs='POWERPC') then
  138. current_settings.packrecords:=C_alignment
  139. else if (hs='RESET') then
  140. current_settings.packrecords:=default_settings.packrecords
  141. else
  142. Message1(scan_e_illegal_pack_records,hs);
  143. end
  144. else
  145. Message1(scan_e_illegal_pack_records,hs);
  146. end
  147. else
  148. begin
  149. b:=current_scanner.readval;
  150. case b of
  151. 1 : current_settings.packrecords:=1;
  152. 2 : current_settings.packrecords:=2;
  153. 4 : current_settings.packrecords:=4;
  154. 8 : current_settings.packrecords:=8;
  155. 16 : current_settings.packrecords:=16;
  156. 32 : current_settings.packrecords:=32;
  157. else
  158. Message1(scan_e_illegal_pack_records,tostr(b));
  159. end;
  160. end;
  161. end;
  162. procedure dir_a1;
  163. begin
  164. current_settings.packrecords:=1;
  165. end;
  166. procedure dir_a2;
  167. begin
  168. current_settings.packrecords:=2;
  169. end;
  170. procedure dir_a4;
  171. begin
  172. current_settings.packrecords:=4;
  173. end;
  174. procedure dir_a8;
  175. begin
  176. current_settings.packrecords:=8;
  177. end;
  178. procedure dir_asmcpu;
  179. var
  180. s : string;
  181. cpu: tcputype;
  182. found: Boolean;
  183. begin
  184. current_scanner.skipspace;
  185. s:=current_scanner.readid;
  186. If Inside_asm_statement then
  187. Message1(scan_w_no_asm_reader_switch_inside_asm,s);
  188. if s='ANY' then
  189. current_settings.asmcputype:=cpu_none
  190. else if s='CURRENT' then
  191. current_settings.asmcputype:=current_settings.cputype
  192. else
  193. begin
  194. found:=false;
  195. for cpu:=succ(low(tcputype)) to high(tcputype) do
  196. if s=cputypestr[cpu] then
  197. begin
  198. found:=true;
  199. current_settings.asmcputype:=cpu;
  200. break;
  201. end;
  202. if not found then
  203. Message1(scan_e_illegal_asmcpu_specifier,s);
  204. end;
  205. end;
  206. procedure dir_asmmode;
  207. var
  208. s : string;
  209. begin
  210. current_scanner.skipspace;
  211. s:=current_scanner.readid;
  212. If Inside_asm_statement then
  213. Message1(scan_w_no_asm_reader_switch_inside_asm,s);
  214. if s='DEFAULT' then
  215. current_settings.asmmode:=init_settings.asmmode
  216. else
  217. if not SetAsmReadMode(s,current_settings.asmmode) then
  218. Message1(scan_e_illegal_asmmode_specifier,s);
  219. end;
  220. {$if defined(m68k) or defined(arm)}
  221. procedure dir_appid;
  222. begin
  223. if target_info.system<>system_m68k_palmos then
  224. Message(scan_w_appid_not_support);
  225. { change description global var in all cases }
  226. { it not used but in win32 and os2 }
  227. current_scanner.skipspace;
  228. palmos_applicationid:=current_scanner.readcomment;
  229. end;
  230. procedure dir_appname;
  231. begin
  232. if target_info.system<>system_m68k_palmos then
  233. Message(scan_w_appname_not_support);
  234. { change description global var in all cases }
  235. { it not used but in win32 and os2 }
  236. current_scanner.skipspace;
  237. palmos_applicationname:=current_scanner.readcomment;
  238. end;
  239. {$endif defined(m68k) or defined(arm)}
  240. procedure dir_apptype;
  241. var
  242. hs : string;
  243. begin
  244. if not (target_info.system in systems_all_windows + [system_i386_os2,
  245. system_i386_emx, system_powerpc_macos,
  246. system_arm_nds, system_i8086_msdos] +
  247. systems_nativent) then
  248. begin
  249. if m_delphi in current_settings.modeswitches then
  250. Message(scan_n_app_type_not_support)
  251. else
  252. Message(scan_w_app_type_not_support);
  253. end
  254. else
  255. begin
  256. if not current_module.in_global then
  257. Message(scan_w_switch_is_global)
  258. else
  259. begin
  260. current_scanner.skipspace;
  261. hs:=current_scanner.readid;
  262. if (hs='GUI') and not (target_info.system in [system_i8086_msdos]) then
  263. SetApptype(app_gui)
  264. else if (hs='CONSOLE') and not (target_info.system in [system_i8086_msdos]) then
  265. SetApptype(app_cui)
  266. else if (hs='NATIVE') and (target_info.system in systems_windows + systems_nativent) then
  267. SetApptype(app_native)
  268. else if (hs='FS') and (target_info.system in [system_i386_os2,
  269. system_i386_emx]) then
  270. SetApptype(app_fs)
  271. else if (hs='TOOL') and (target_info.system in [system_powerpc_macos]) then
  272. SetApptype(app_tool)
  273. else if (hs='ARM9') and (target_info.system in [system_arm_nds]) then
  274. SetApptype(app_arm9)
  275. else if (hs='ARM7') and (target_info.system in [system_arm_nds]) then
  276. SetApptype(app_arm7)
  277. else if (hs='COM') and (target_info.system in [system_i8086_msdos]) then
  278. SetApptype(app_com)
  279. else if (hs='EXE') and (target_info.system in [system_i8086_msdos]) then
  280. SetApptype(app_cui)
  281. else
  282. Message1(scan_w_unsupported_app_type,hs);
  283. end;
  284. end;
  285. end;
  286. procedure dir_calling;
  287. var
  288. hs : string;
  289. begin
  290. current_scanner.skipspace;
  291. hs:=current_scanner.readid;
  292. if (hs='') then
  293. Message(parser_e_proc_directive_expected)
  294. else
  295. recordpendingcallingswitch(hs);
  296. end;
  297. procedure dir_checklowaddrloads;
  298. begin
  299. do_localswitchdefault(cs_check_low_addr_load);
  300. end;
  301. procedure dir_checkpointer;
  302. var
  303. switch: char;
  304. begin
  305. switch:=do_localswitchdefault(cs_checkpointer);
  306. if (switch='+') and
  307. not(target_info.system in systems_support_checkpointer) then
  308. Message1(scan_e_unsupported_switch,'CHECKPOINTER+');
  309. end;
  310. procedure dir_objectchecks;
  311. begin
  312. do_localswitch(cs_check_object);
  313. end;
  314. procedure dir_ieeeerrors;
  315. begin
  316. do_localswitch(cs_ieee_errors);
  317. end;
  318. procedure dir_assertions;
  319. begin
  320. do_delphiswitch('C');
  321. end;
  322. procedure dir_booleval;
  323. begin
  324. do_delphiswitch('B');
  325. end;
  326. procedure dir_debuginfo;
  327. begin
  328. do_delphiswitch('D');
  329. end;
  330. procedure dir_denypackageunit;
  331. begin
  332. do_moduleflagswitch(uf_package_deny,true);
  333. end;
  334. procedure dir_description;
  335. begin
  336. if not (target_info.system in systems_all_windows+[system_i386_os2,system_i386_emx,
  337. system_i386_netware,system_i386_wdosx,system_i386_netwlibc]) then
  338. Message(scan_w_description_not_support);
  339. { change description global var in all cases }
  340. { it not used but in win32, os2 and netware }
  341. current_scanner.skipspace;
  342. description:=current_scanner.readcomment;
  343. DescriptionSetExplicity:=true;
  344. end;
  345. procedure dir_screenname; {ad}
  346. begin
  347. if not (target_info.system in [system_i386_netware,system_i386_netwlibc]) then
  348. {Message(scan_w_decription_not_support);}
  349. comment (V_Warning,'Screenname only supported for target netware');
  350. current_scanner.skipspace;
  351. nwscreenname:=current_scanner.readcomment;
  352. end;
  353. procedure dir_threadname; {ad}
  354. begin
  355. if not (target_info.system in [system_i386_netware,system_i386_netwlibc]) then
  356. {Message(scan_w_decription_not_support);}
  357. comment (V_Warning,'Threadname only supported for target netware');
  358. current_scanner.skipspace;
  359. nwthreadname:=current_scanner.readcomment;
  360. end;
  361. procedure dir_copyright; {ad}
  362. begin
  363. if not (target_info.system in [system_i386_netware,system_i386_netwlibc]) then
  364. {Message(scan_w_decription_not_support);}
  365. comment (V_Warning,'Copyright only supported for target netware');
  366. current_scanner.skipspace;
  367. nwcopyright:=current_scanner.readcomment;
  368. end;
  369. procedure dir_error;
  370. begin
  371. do_message(scan_e_user_defined);
  372. end;
  373. procedure dir_extendedsyntax;
  374. begin
  375. do_delphiswitch('X');
  376. end;
  377. procedure dir_forcefarcalls;
  378. begin
  379. if (target_info.system<>system_i8086_msdos)
  380. {$ifdef i8086}
  381. or (current_settings.x86memorymodel in x86_near_code_models)
  382. {$endif i8086}
  383. then
  384. begin
  385. Message1(scan_n_ignored_switch,pattern);
  386. exit;
  387. end;
  388. do_localswitch(cs_force_far_calls);
  389. end;
  390. procedure dir_fatal;
  391. begin
  392. do_message(scan_f_user_defined);
  393. end;
  394. procedure dir_fputype;
  395. begin
  396. current_scanner.skipspace;
  397. undef_system_macro('FPU'+fputypestr[current_settings.fputype]);
  398. if not(SetFPUType(upper(current_scanner.readcomment),current_settings.fputype)) then
  399. comment(V_Error,'Illegal FPU type');
  400. def_system_macro('FPU'+fputypestr[current_settings.fputype]);
  401. end;
  402. procedure dir_frameworkpath;
  403. begin
  404. if not current_module.in_global then
  405. Message(scan_w_switch_is_global)
  406. else if not(target_info.system in systems_darwin) then
  407. begin
  408. Message(scan_w_frameworks_darwin_only);
  409. current_scanner.skipspace;
  410. current_scanner.readcomment
  411. end
  412. else
  413. begin
  414. current_scanner.skipspace;
  415. current_module.localframeworksearchpath.AddPath(current_scanner.readcomment,false);
  416. end;
  417. end;
  418. procedure dir_goto;
  419. begin
  420. do_moduleswitch(cs_support_goto);
  421. end;
  422. procedure dir_hint;
  423. begin
  424. do_message(scan_h_user_defined);
  425. end;
  426. procedure dir_hints;
  427. begin
  428. do_setverbose('H');
  429. end;
  430. procedure dir_imagebase;
  431. begin
  432. if not (target_info.system in (systems_windows+systems_wince)) then
  433. Message(scan_w_imagebase_not_support);
  434. current_scanner.skipspace;
  435. imagebase:=current_scanner.readval;
  436. ImageBaseSetExplicity:=true
  437. end;
  438. procedure dir_implicitexceptions;
  439. begin
  440. do_moduleswitch(cs_implicit_exceptions);
  441. end;
  442. procedure dir_importeddata;
  443. begin
  444. do_delphiswitch('G');
  445. end;
  446. procedure dir_includepath;
  447. begin
  448. if not current_module.in_global then
  449. Message(scan_w_switch_is_global)
  450. else
  451. begin
  452. current_scanner.skipspace;
  453. current_module.localincludesearchpath.AddPath(current_scanner.readcomment,false);
  454. end;
  455. end;
  456. procedure dir_info;
  457. begin
  458. do_message(scan_i_user_defined);
  459. end;
  460. procedure dir_inline;
  461. begin
  462. do_localswitch(cs_do_inline);
  463. end;
  464. procedure dir_interfaces;
  465. var
  466. hs : string;
  467. begin
  468. {corba/com/default}
  469. current_scanner.skipspace;
  470. hs:=current_scanner.readid;
  471. {$ifndef jvm}
  472. if (hs='CORBA') then
  473. current_settings.interfacetype:=it_interfacecorba
  474. else if (hs='COM') then
  475. current_settings.interfacetype:=it_interfacecom
  476. else
  477. {$endif jvm}
  478. if (hs='DEFAULT') then
  479. current_settings.interfacetype:=init_settings.interfacetype
  480. else
  481. Message(scan_e_invalid_interface_type);
  482. end;
  483. procedure dir_iochecks;
  484. begin
  485. do_delphiswitch('I');
  486. end;
  487. procedure dir_libexport;
  488. begin
  489. {not implemented}
  490. end;
  491. procedure dir_librarypath;
  492. begin
  493. if not current_module.in_global then
  494. Message(scan_w_switch_is_global)
  495. else
  496. begin
  497. current_scanner.skipspace;
  498. current_module.locallibrarysearchpath.AddPath(current_scanner.readcomment,false);
  499. end;
  500. end;
  501. procedure dir_link;
  502. var
  503. s : string;
  504. begin
  505. current_scanner.skipspace;
  506. if scanner.c = '''' then
  507. begin
  508. s:= current_scanner.readquotedstring;
  509. current_scanner.readcomment
  510. end
  511. else
  512. s:= trimspace(current_scanner.readcomment);
  513. s:=FixFileName(s);
  514. if ExtractFileExt(s)='' then
  515. s:=ChangeFileExt(s,target_info.objext);
  516. current_module.linkotherofiles.add(s,link_always);
  517. end;
  518. procedure dir_linkframework;
  519. var
  520. s : string;
  521. begin
  522. current_scanner.skipspace;
  523. if scanner.c = '''' then
  524. begin
  525. s:= current_scanner.readquotedstring;
  526. current_scanner.readcomment
  527. end
  528. else
  529. s:= trimspace(current_scanner.readcomment);
  530. s:=FixFileName(s);
  531. if (target_info.system in systems_darwin) then
  532. current_module.linkotherframeworks.add(s,link_always)
  533. else
  534. Message(scan_w_frameworks_darwin_only);
  535. end;
  536. procedure dir_linklib;
  537. type
  538. tLinkMode=(lm_shared,lm_static);
  539. var
  540. s : string;
  541. quote : char;
  542. libext,
  543. libname,
  544. linkmodestr : string;
  545. p : longint;
  546. linkMode : tLinkMode;
  547. begin
  548. current_scanner.skipspace;
  549. if scanner.c = '''' then
  550. begin
  551. libname:= current_scanner.readquotedstring;
  552. s:= current_scanner.readcomment;
  553. p:=pos(',',s);
  554. end
  555. else
  556. begin
  557. s:= current_scanner.readcomment;
  558. p:=pos(',',s);
  559. if p=0 then
  560. libname:=TrimSpace(s)
  561. else
  562. libname:=TrimSpace(copy(s,1,p-1));
  563. end;
  564. if p=0 then
  565. linkmodeStr:=''
  566. else
  567. linkmodeStr:=Upper(TrimSpace(copy(s,p+1,255)));
  568. if (libname='') or (libname='''''') or (libname='""') then
  569. exit;
  570. { create library name }
  571. if libname[1] in ['''','"'] then
  572. begin
  573. quote:=libname[1];
  574. Delete(libname,1,1);
  575. p:=pos(quote,libname);
  576. if p>0 then
  577. Delete(libname,p,1);
  578. end;
  579. libname:=FixFileName(libname);
  580. { get linkmode, default is to check the extension for
  581. the static library, otherwise shared linking is assumed }
  582. linkmode:=lm_shared;
  583. if linkModeStr='' then
  584. begin
  585. libext:=ExtractFileExt(libname);
  586. if libext=target_info.staticClibext then
  587. linkMode:=lm_static;
  588. end
  589. else if linkModeStr='STATIC' then
  590. linkmode:=lm_static
  591. else if (LinkModeStr='SHARED') or (LinkModeStr='') then
  592. linkmode:=lm_shared
  593. else
  594. Comment(V_Error,'Wrong link mode specified: "'+Linkmodestr+'"');
  595. { add to the list of other libraries }
  596. if linkMode=lm_static then
  597. current_module.linkOtherStaticLibs.add(libname,link_always)
  598. else
  599. current_module.linkOtherSharedLibs.add(libname,link_always);
  600. end;
  601. procedure dir_localsymbols;
  602. begin
  603. do_delphiswitch('L');
  604. end;
  605. procedure dir_longstrings;
  606. begin
  607. do_delphiswitch('H');
  608. end;
  609. procedure dir_macro;
  610. begin
  611. do_moduleswitch(cs_support_macro);
  612. end;
  613. procedure dir_pascalmainname;
  614. var
  615. s: string;
  616. begin
  617. current_scanner.skipspace;
  618. s:=trimspace(current_scanner.readcomment);
  619. if assigned(current_module.mainname) and
  620. (s<>current_module.mainname^) then
  621. begin
  622. Message1(scan_w_multiple_main_name_overrides,current_module.mainname^);
  623. stringdispose(current_module.mainname)
  624. end
  625. else if (mainaliasname<>defaultmainaliasname) and
  626. (mainaliasname<>s) then
  627. Message1(scan_w_multiple_main_name_overrides,mainaliasname);
  628. mainaliasname:=s;
  629. if (mainaliasname<>defaultmainaliasname) then
  630. current_module.mainname:=stringdup(mainaliasname);
  631. end;
  632. procedure dir_maxfpuregisters;
  633. var
  634. l : integer;
  635. hs : string;
  636. begin
  637. current_scanner.skipspace;
  638. if not(c in ['0'..'9']) then
  639. begin
  640. hs:=current_scanner.readid;
  641. if (hs='NORMAL') or (hs='DEFAULT') then
  642. current_settings.maxfpuregisters:=-1
  643. else
  644. Message(scan_e_invalid_maxfpureg_value);
  645. end
  646. else
  647. begin
  648. l:=current_scanner.readval;
  649. case l of
  650. 0..8:
  651. current_settings.maxfpuregisters:=l;
  652. else
  653. Message(scan_e_invalid_maxfpureg_value);
  654. end;
  655. end;
  656. end;
  657. procedure dir_maxstacksize;
  658. begin
  659. if not (target_info.system in (systems_windows+systems_wince)) then
  660. Message(scan_w_maxstacksize_not_support);
  661. current_scanner.skipspace;
  662. maxstacksize:=current_scanner.readval;
  663. MaxStackSizeSetExplicity:=true;
  664. end;
  665. procedure dir_memory;
  666. var
  667. l : longint;
  668. heapsize_limit: longint;
  669. maxheapsize_limit: longint;
  670. begin
  671. {$if defined(i8086)}
  672. if current_settings.x86memorymodel in x86_far_data_models then
  673. begin
  674. heapsize_limit:=655360;
  675. maxheapsize_limit:=655360;
  676. end
  677. else
  678. begin
  679. heapsize_limit:=65520;
  680. maxheapsize_limit:=65520;
  681. end;
  682. {$elseif defined(cpu16bitaddr)}
  683. heapsize_limit:=65520;
  684. maxheapsize_limit:=65520;
  685. {$else}
  686. heapsize_limit:=high(heapsize);
  687. maxheapsize_limit:=high(maxheapsize);
  688. {$endif}
  689. current_scanner.skipspace;
  690. l:=current_scanner.readval;
  691. if (l>=1024)
  692. {$ifdef cpu16bitaddr}
  693. and (l<=65521) { TP7's $M directive allows specifying a stack size of
  694. 65521, but it actually sets the stack size to 65520 }
  695. {$else cpu16bitaddr}
  696. and (l<67107840)
  697. {$endif cpu16bitaddr}
  698. then
  699. stacksize:=min(l,{$ifdef cpu16bitaddr}65520{$else}67107839{$endif})
  700. else
  701. Message(scan_w_invalid_stacksize);
  702. if c=',' then
  703. begin
  704. current_scanner.readchar;
  705. current_scanner.skipspace;
  706. l:=current_scanner.readval;
  707. if l>=1024 then
  708. heapsize:=min(l,heapsize_limit);
  709. if c=',' then
  710. begin
  711. current_scanner.readchar;
  712. current_scanner.skipspace;
  713. l:=current_scanner.readval;
  714. if l>=heapsize then
  715. maxheapsize:=min(l,maxheapsize_limit)
  716. else
  717. Message(scan_w_heapmax_lessthan_heapmin);
  718. end;
  719. end;
  720. end;
  721. procedure dir_message;
  722. var
  723. hs : string;
  724. w : longint;
  725. begin
  726. w:=0;
  727. current_scanner.skipspace;
  728. { Message level specified? }
  729. if c='''' then
  730. w:=scan_n_user_defined
  731. else
  732. begin
  733. hs:=current_scanner.readid;
  734. if (hs='WARN') or (hs='WARNING') then
  735. w:=scan_w_user_defined
  736. else
  737. if (hs='ERROR') then
  738. w:=scan_e_user_defined
  739. else
  740. if (hs='FATAL') then
  741. w:=scan_f_user_defined
  742. else
  743. if (hs='HINT') then
  744. w:=scan_h_user_defined
  745. else
  746. if (hs='NOTE') then
  747. w:=scan_n_user_defined
  748. else
  749. Message1(scan_w_illegal_directive,hs);
  750. end;
  751. { Only print message when there was no error }
  752. if w<>0 then
  753. begin
  754. current_scanner.skipspace;
  755. if c='''' then
  756. hs:=current_scanner.readquotedstring
  757. else
  758. hs:=current_scanner.readcomment;
  759. Message1(w,hs);
  760. end
  761. else
  762. current_scanner.readcomment;
  763. end;
  764. procedure dir_minstacksize;
  765. begin
  766. if not (target_info.system in (systems_windows+systems_wince)) then
  767. Message(scan_w_minstacksize_not_support);
  768. current_scanner.skipspace;
  769. minstacksize:=current_scanner.readval;
  770. MinStackSizeSetExplicity:=true;
  771. end;
  772. procedure dir_mode;
  773. begin
  774. if not current_module.in_global then
  775. Message(scan_w_switch_is_global)
  776. else
  777. begin
  778. current_scanner.skipspace;
  779. current_scanner.readstring;
  780. if not current_module.mode_switch_allowed and
  781. not ((m_mac in current_settings.modeswitches) and (pattern='MACPAS')) then
  782. Message1(scan_e_mode_switch_not_allowed,pattern)
  783. else if not SetCompileMode(pattern,false) then
  784. Message1(scan_w_illegal_switch,pattern)
  785. end;
  786. current_module.mode_switch_allowed:= false;
  787. end;
  788. procedure dir_modeswitch;
  789. var
  790. s : string;
  791. begin
  792. if not current_module.in_global then
  793. Message(scan_w_switch_is_global)
  794. else
  795. begin
  796. current_scanner.skipspace;
  797. current_scanner.readstring;
  798. s:=pattern;
  799. if c in ['+','-'] then
  800. s:=s+current_scanner.readstate;
  801. if not SetCompileModeSwitch(s,false) then
  802. Message1(scan_w_illegal_switch,s)
  803. end;
  804. end;
  805. procedure dir_namespace;
  806. var
  807. s : string;
  808. begin
  809. { used to define Java package names for all types declared in the
  810. current unit }
  811. if not current_module.in_global then
  812. Message(scan_w_switch_is_global)
  813. else
  814. begin
  815. current_scanner.skipspace;
  816. current_scanner.readstring;
  817. s:=orgpattern;
  818. while c='.' do
  819. begin
  820. current_scanner.readchar;
  821. current_scanner.readstring;
  822. s:=s+'.'+orgpattern;
  823. end;
  824. disposestr(current_module.namespace);
  825. current_module.namespace:=stringdup(s);
  826. end;
  827. end;
  828. procedure dir_mmx;
  829. begin
  830. do_localswitch(cs_mmx);
  831. end;
  832. procedure dir_note;
  833. begin
  834. do_message(scan_n_user_defined);
  835. end;
  836. procedure dir_notes;
  837. begin
  838. do_setverbose('N');
  839. end;
  840. procedure dir_objectpath;
  841. begin
  842. if not current_module.in_global then
  843. Message(scan_w_switch_is_global)
  844. else
  845. begin
  846. current_scanner.skipspace;
  847. current_module.localobjectsearchpath.AddPath(current_scanner.readcomment,false);
  848. end;
  849. end;
  850. procedure dir_openstrings;
  851. begin
  852. do_delphiswitch('P');
  853. end;
  854. procedure dir_optimization;
  855. var
  856. hs : string;
  857. begin
  858. current_scanner.skipspace;
  859. { Support also the ON and OFF as switch }
  860. hs:=current_scanner.readid;
  861. if (hs='ON') then
  862. current_settings.optimizerswitches:=level2optimizerswitches
  863. else if (hs='OFF') then
  864. current_settings.optimizerswitches:=[]
  865. else if (hs='DEFAULT') then
  866. current_settings.optimizerswitches:=init_settings.optimizerswitches
  867. else
  868. begin
  869. if not UpdateOptimizerStr(hs,current_settings.optimizerswitches) then
  870. Message1(scan_e_illegal_optimization_specifier,hs);
  871. end;
  872. end;
  873. procedure dir_overflowchecks;
  874. begin
  875. do_delphiswitch('Q');
  876. end;
  877. procedure dir_packenum;
  878. var
  879. hs : string;
  880. begin
  881. current_scanner.skipspace;
  882. if not(c in ['0'..'9']) then
  883. begin
  884. hs:=current_scanner.readid;
  885. if (hs='NORMAL') or (hs='DEFAULT') then
  886. current_settings.packenum:=4
  887. else
  888. Message1(scan_e_illegal_pack_enum, hs);
  889. end
  890. else
  891. begin
  892. case current_scanner.readval of
  893. 1 : current_settings.packenum:=1;
  894. 2 : current_settings.packenum:=2;
  895. 4 : current_settings.packenum:=4;
  896. else
  897. Message1(scan_e_illegal_pack_enum, pattern);
  898. end;
  899. end;
  900. end;
  901. procedure dir_minfpconstprec;
  902. begin
  903. current_scanner.skipspace;
  904. if not SetMinFPConstPrec(current_scanner.readid,current_settings.minfpconstprec) then
  905. Message1(scan_e_illegal_minfpconstprec, pattern);
  906. end;
  907. procedure dir_packrecords;
  908. var
  909. hs : string;
  910. begin
  911. { can't change packrecords setting on managed vm targets }
  912. if target_info.system in systems_managed_vm then
  913. Message1(scanner_w_directive_ignored_on_target, 'PACKRECORDS');
  914. current_scanner.skipspace;
  915. if not(c in ['0'..'9']) then
  916. begin
  917. hs:=current_scanner.readid;
  918. { C has the special recordalignmax of C_alignment }
  919. if (hs='C') then
  920. current_settings.packrecords:=C_alignment
  921. else
  922. if (hs='NORMAL') or (hs='DEFAULT') then
  923. current_settings.packrecords:=default_settings.packrecords
  924. else
  925. Message1(scan_e_illegal_pack_records,hs);
  926. end
  927. else
  928. begin
  929. case current_scanner.readval of
  930. 1 : current_settings.packrecords:=1;
  931. 2 : current_settings.packrecords:=2;
  932. 4 : current_settings.packrecords:=4;
  933. 8 : current_settings.packrecords:=8;
  934. 16 : current_settings.packrecords:=16;
  935. 32 : current_settings.packrecords:=32;
  936. else
  937. Message1(scan_e_illegal_pack_records,pattern);
  938. end;
  939. end;
  940. end;
  941. procedure dir_packset;
  942. var
  943. hs : string;
  944. begin
  945. current_scanner.skipspace;
  946. if not(c in ['1','2','4','8']) then
  947. begin
  948. hs:=current_scanner.readid;
  949. if (hs='FIXED') or (hs='DEFAULT') OR (hs='NORMAL') then
  950. current_settings.setalloc:=0 {Fixed mode, sets are 4 or 32 bytes}
  951. else
  952. Message(scan_e_only_packset);
  953. end
  954. else
  955. begin
  956. case current_scanner.readval of
  957. 1 : current_settings.setalloc:=1;
  958. 2 : current_settings.setalloc:=2;
  959. 4 : current_settings.setalloc:=4;
  960. 8 : current_settings.setalloc:=8;
  961. else
  962. Message(scan_e_only_packset);
  963. end;
  964. end;
  965. end;
  966. procedure dir_pic;
  967. begin
  968. { windows doesn't need/support pic }
  969. if tf_no_pic_supported in target_info.flags then
  970. message(scan_w_pic_ignored)
  971. else
  972. do_moduleswitch(cs_create_pic);
  973. end;
  974. procedure dir_pop;
  975. begin
  976. if switchesstatestackpos < 1 then
  977. Message(scan_e_too_many_pop);
  978. Dec(switchesstatestackpos);
  979. recordpendinglocalfullswitch(switchesstatestack[switchesstatestackpos].localsw);
  980. recordpendingverbosityfullswitch(switchesstatestack[switchesstatestackpos].verbosity);
  981. pendingstate.nextmessagerecord:=switchesstatestack[switchesstatestackpos].pmessage;
  982. { Reset verbosity and forget previous pmeesage }
  983. RestoreLocalVerbosity(nil);
  984. current_settings.pmessage:=nil;
  985. { Do not yet activate these changes, as otherwise
  986. you get problem idf you put a $pop just right after
  987. a addition for instance fro which you explicitly truned the overflow check
  988. out by using $Q- after a $push PM 2012-08-29 }
  989. // flushpendingswitchesstate;
  990. end;
  991. procedure dir_pointermath;
  992. begin
  993. do_localswitch(cs_pointermath);
  994. end;
  995. procedure dir_profile;
  996. begin
  997. do_moduleswitch(cs_profile);
  998. { defined/undefine FPC_PROFILE }
  999. if cs_profile in current_settings.moduleswitches then
  1000. def_system_macro('FPC_PROFILE')
  1001. else
  1002. undef_system_macro('FPC_PROFILE');
  1003. end;
  1004. procedure dir_push;
  1005. begin
  1006. if switchesstatestackpos > switchesstatestackmax then
  1007. Message(scan_e_too_many_push);
  1008. flushpendingswitchesstate;
  1009. switchesstatestack[switchesstatestackpos].localsw:= current_settings.localswitches;
  1010. switchesstatestack[switchesstatestackpos].pmessage:= current_settings.pmessage;
  1011. switchesstatestack[switchesstatestackpos].verbosity:=status.verbosity;
  1012. Inc(switchesstatestackpos);
  1013. end;
  1014. procedure dir_rangechecks;
  1015. begin
  1016. do_delphiswitch('R');
  1017. end;
  1018. procedure dir_referenceinfo;
  1019. begin
  1020. do_delphiswitch('Y');
  1021. end;
  1022. procedure dir_resource;
  1023. var
  1024. s : string;
  1025. begin
  1026. current_scanner.skipspace;
  1027. if scanner.c = '''' then
  1028. begin
  1029. s:= current_scanner.readquotedstring;
  1030. current_scanner.readcomment
  1031. end
  1032. else
  1033. s:= trimspace(current_scanner.readcomment);
  1034. { replace * with the name of the main source.
  1035. This should always be defined. }
  1036. if s[1]='*' then
  1037. if Assigned(Current_Module) then
  1038. begin
  1039. delete(S,1,1);
  1040. insert(ChangeFileExt(ExtractFileName(current_module.mainsource),''),S,1 );
  1041. end;
  1042. s:=FixFileName(s);
  1043. if ExtractFileExt(s)='' then
  1044. s:=ChangeFileExt(s,target_info.resext);
  1045. if target_info.res<>res_none then
  1046. begin
  1047. current_module.flags:=current_module.flags or uf_has_resourcefiles;
  1048. if (res_single_file in target_res.resflags) and
  1049. not (Current_module.ResourceFiles.Empty) then
  1050. Message(scan_w_only_one_resourcefile_supported)
  1051. else
  1052. current_module.resourcefiles.insert(FixFileName(s));
  1053. end
  1054. else
  1055. Message(scan_e_resourcefiles_not_supported);
  1056. end;
  1057. procedure dir_saturation;
  1058. begin
  1059. do_localswitch(cs_mmx_saturation);
  1060. end;
  1061. procedure dir_safefpuexceptions;
  1062. begin
  1063. do_localswitch(cs_fpu_fwait);
  1064. end;
  1065. procedure dir_scopedenums;
  1066. begin
  1067. do_localswitch(cs_scopedenums);
  1068. end;
  1069. function get_peflag_const(const ident:string;error:longint):longint;
  1070. var
  1071. srsym : tsym;
  1072. srsymtable : tsymtable;
  1073. begin
  1074. result:=0;
  1075. if searchsym(ident,srsym,srsymtable) then
  1076. if (srsym.typ=constsym) and
  1077. (tconstsym(srsym).consttyp=constord) and
  1078. is_integer(tconstsym(srsym).constdef) then
  1079. with tconstsym(srsym).value.valueord do
  1080. if signed then
  1081. result:=tconstsym(srsym).value.valueord.svalue
  1082. else
  1083. result:=tconstsym(srsym).value.valueord.uvalue
  1084. else
  1085. message(error)
  1086. else
  1087. message1(sym_e_id_not_found,ident);
  1088. end;
  1089. procedure dir_setpeflags;
  1090. var
  1091. ident : string;
  1092. begin
  1093. if not (target_info.system in (systems_all_windows)) then
  1094. Message(scan_w_setpeflags_not_support);
  1095. current_scanner.skipspace;
  1096. ident:=current_scanner.readid;
  1097. if ident<>'' then
  1098. peflags:=peflags or get_peflag_const(ident,scan_e_illegal_peflag)
  1099. else
  1100. peflags:=peflags or current_scanner.readval;
  1101. SetPEFlagsSetExplicity:=true;
  1102. end;
  1103. procedure dir_setpeoptflags;
  1104. var
  1105. ident : string;
  1106. begin
  1107. if not (target_info.system in (systems_all_windows)) then
  1108. Message(scan_w_setpeoptflags_not_support);
  1109. current_scanner.skipspace;
  1110. ident:=current_scanner.readid;
  1111. if ident<>'' then
  1112. peoptflags:=peoptflags or get_peflag_const(ident,scan_e_illegal_peoptflag)
  1113. else
  1114. peoptflags:=peoptflags or current_scanner.readval;
  1115. SetPEOptFlagsSetExplicity:=true;
  1116. end;
  1117. procedure dir_smartlink;
  1118. begin
  1119. do_moduleswitch(cs_create_smart);
  1120. if (target_dbg.id in [dbg_dwarf2,dbg_dwarf3]) and
  1121. not(target_info.system in (systems_darwin+[system_i8086_msdos])) and
  1122. { smart linking does not yet work with DWARF debug info on most targets }
  1123. (cs_create_smart in current_settings.moduleswitches) and
  1124. not (af_outputbinary in target_asm.flags) then
  1125. begin
  1126. Message(option_dwarf_smart_linking);
  1127. Exclude(current_settings.moduleswitches,cs_create_smart);
  1128. end;
  1129. { Also create a smartlinked version, on an assembler that
  1130. does not support smartlink sections like nasm?
  1131. This is not compatible with using internal linker. }
  1132. if ((cs_link_smart in current_settings.globalswitches) or
  1133. (cs_create_smart in current_settings.moduleswitches)) and
  1134. (af_needar in target_asm.flags) and
  1135. not (af_smartlink_sections in target_asm.flags) and
  1136. not (cs_link_extern in current_settings.globalswitches) then
  1137. begin
  1138. DoneLinker;
  1139. Message(option_smart_link_requires_external_linker);
  1140. include(current_settings.globalswitches,cs_link_extern);
  1141. InitLinker;
  1142. end
  1143. end;
  1144. procedure dir_stackframes;
  1145. begin
  1146. do_delphiswitch('W');
  1147. end;
  1148. procedure dir_stop;
  1149. begin
  1150. do_message(scan_f_user_defined);
  1151. end;
  1152. procedure dir_stringchecks;
  1153. begin
  1154. // Delphi adds checks that ansistring and unicodestring are correct in
  1155. // different places. Skip it for now.
  1156. end;
  1157. {$ifdef powerpc}
  1158. procedure dir_syscall;
  1159. var
  1160. sctype : string;
  1161. begin
  1162. { not needed on amiga/m68k for now, because there's only one }
  1163. { syscall convention (legacy) (KB) }
  1164. { not needed on amiga/powerpc because there's only one }
  1165. { syscall convention (sysv) (KB) }
  1166. if not (target_info.system in [system_powerpc_morphos]) then
  1167. comment (V_Warning,'Syscall directive is useless on this target.');
  1168. current_scanner.skipspace;
  1169. sctype:=current_scanner.readid;
  1170. if (sctype='LEGACY') or (sctype='SYSV') or (sctype='SYSVBASE') or
  1171. (sctype='BASESYSV') or (sctype='R12BASE') then
  1172. syscall_convention:=sctype
  1173. else
  1174. comment (V_Warning,'Invalid Syscall directive ignored.');
  1175. end;
  1176. {$endif}
  1177. procedure dir_targetswitch;
  1178. var
  1179. name, value: string;
  1180. begin
  1181. { note: *not* recorded in the tokenstream, so not replayed for generics }
  1182. current_scanner.skipspace;
  1183. name:=current_scanner.readid;
  1184. if c='=' then
  1185. begin
  1186. current_scanner.readchar;
  1187. current_scanner.readid;
  1188. value:=orgpattern;
  1189. UpdateTargetSwitchStr(name+'='+value,current_settings.targetswitches,current_module.in_global);
  1190. end
  1191. else if c='-' then
  1192. begin
  1193. current_scanner.readchar;
  1194. UpdateTargetSwitchStr(name+'-',current_settings.targetswitches,current_module.in_global);
  1195. end
  1196. else
  1197. UpdateTargetSwitchStr(name,current_settings.targetswitches,current_module.in_global);
  1198. end;
  1199. procedure dir_typedaddress;
  1200. begin
  1201. do_delphiswitch('T');
  1202. end;
  1203. procedure dir_typeinfo;
  1204. begin
  1205. do_delphiswitch('M');
  1206. end;
  1207. procedure dir_unitpath;
  1208. begin
  1209. if not current_module.in_global then
  1210. Message(scan_w_switch_is_global)
  1211. else
  1212. with current_scanner,current_module,localunitsearchpath do
  1213. begin
  1214. skipspace;
  1215. AddPath(path,readcomment,false);
  1216. end;
  1217. end;
  1218. procedure dir_varparacopyoutcheck;
  1219. begin
  1220. if not(target_info.system in systems_jvm) then
  1221. begin
  1222. Message1(scan_w_illegal_switch,pattern);
  1223. exit;
  1224. end;
  1225. do_localswitch(cs_check_var_copyout);
  1226. end;
  1227. procedure dir_varpropsetter;
  1228. begin
  1229. do_localswitch(cs_varpropsetter);
  1230. end;
  1231. procedure dir_varstringchecks;
  1232. begin
  1233. do_delphiswitch('V');
  1234. end;
  1235. procedure dir_version;
  1236. var
  1237. major, minor, revision : longint;
  1238. error : integer;
  1239. begin
  1240. if not (target_info.system in systems_all_windows+[system_i386_os2,system_i386_emx,
  1241. system_i386_netware,system_i386_wdosx,
  1242. system_i386_netwlibc]) then
  1243. begin
  1244. Message(scan_n_version_not_support);
  1245. exit;
  1246. end;
  1247. if (compile_level<>1) then
  1248. Message(scan_n_only_exe_version)
  1249. else
  1250. begin
  1251. { change description global var in all cases }
  1252. { it not used but in win32, os2 and netware }
  1253. current_scanner.skipspace;
  1254. { we should only accept Major.Minor format for win32 and os2 }
  1255. current_scanner.readnumber;
  1256. major:=0;
  1257. minor:=0;
  1258. revision:=0;
  1259. val(pattern,major,error);
  1260. if (error<>0) or (major > high(word)) or (major < 0) then
  1261. begin
  1262. Message1(scan_w_wrong_version_ignored,pattern);
  1263. exit;
  1264. end;
  1265. if c='.' then
  1266. begin
  1267. current_scanner.readchar;
  1268. current_scanner.readnumber;
  1269. val(pattern,minor,error);
  1270. if (error<>0) or (minor > high(word)) or (minor < 0) then
  1271. begin
  1272. Message1(scan_w_wrong_version_ignored,tostr(major)+'.'+pattern);
  1273. exit;
  1274. end;
  1275. if (c='.') and
  1276. (target_info.system in [system_i386_netware,system_i386_netwlibc]) then
  1277. begin
  1278. current_scanner.readchar;
  1279. current_scanner.readnumber;
  1280. val(pattern,revision,error);
  1281. if (error<>0) or (revision > high(word)) or (revision < 0) then
  1282. begin
  1283. Message1(scan_w_wrong_version_ignored,tostr(revision)+'.'+pattern);
  1284. exit;
  1285. end;
  1286. dllmajor:=word(major);
  1287. dllminor:=word(minor);
  1288. dllrevision:=word(revision);
  1289. dllversion:=tostr(major)+','+tostr(minor)+','+tostr(revision);
  1290. end
  1291. else
  1292. begin
  1293. dllmajor:=word(major);
  1294. dllminor:=word(minor);
  1295. dllversion:=tostr(major)+'.'+tostr(minor);
  1296. end;
  1297. end
  1298. else
  1299. dllversion:=tostr(major);
  1300. end;
  1301. end;
  1302. procedure dir_wait;
  1303. var
  1304. had_info : boolean;
  1305. begin
  1306. had_info:=(status.verbosity and V_Info)<>0;
  1307. { this message should allways appear !! }
  1308. status.verbosity:=status.verbosity or V_Info;
  1309. Message(scan_i_press_enter);
  1310. readln;
  1311. If not(had_info) then
  1312. status.verbosity:=status.verbosity and (not V_Info);
  1313. end;
  1314. { delphi compatible warn directive:
  1315. $warn <identifier> on
  1316. $warn <identifier> off
  1317. $warn <identifier> error
  1318. }
  1319. procedure dir_warn;
  1320. var
  1321. ident : string;
  1322. state : string;
  1323. msgstate : tmsgstate;
  1324. i : integer;
  1325. begin
  1326. current_scanner.skipspace;
  1327. ident:=current_scanner.readid;
  1328. current_scanner.skipspace;
  1329. state:=current_scanner.readid;
  1330. { support both delphi and fpc switches }
  1331. { use local ms_on/off/error tmsgstate values }
  1332. if (state='ON') or (state='+') then
  1333. msgstate:=ms_on
  1334. else
  1335. if (state='OFF') or (state='-') then
  1336. msgstate:=ms_off
  1337. else
  1338. if (state='ERROR') then
  1339. msgstate:=ms_error
  1340. else
  1341. begin
  1342. Message1(scanner_e_illegal_warn_state,state);
  1343. exit;
  1344. end;
  1345. if ident='CONSTRUCTING_ABSTRACT' then
  1346. begin
  1347. recordpendingmessagestate(type_w_instance_with_abstract, msgstate);
  1348. recordpendingmessagestate(type_w_instance_abstract_class, msgstate);
  1349. end
  1350. else
  1351. if ident='IMPLICIT_VARIANTS' then
  1352. recordpendingmessagestate(parser_w_implicit_uses_of_variants_unit, msgstate)
  1353. else
  1354. if ident='NO_RETVAL' then
  1355. recordpendingmessagestate(sym_w_function_result_not_set, msgstate)
  1356. else
  1357. if ident='SYMBOL_DEPRECATED' then
  1358. begin
  1359. recordpendingmessagestate(sym_w_deprecated_symbol, msgstate);
  1360. recordpendingmessagestate(sym_w_deprecated_symbol_with_msg, msgstate);
  1361. end
  1362. else
  1363. if ident='SYMBOL_EXPERIMENTAL' then
  1364. recordpendingmessagestate(sym_w_experimental_symbol, msgstate)
  1365. else
  1366. if ident='SYMBOL_LIBRARY' then
  1367. recordpendingmessagestate(sym_w_library_symbol, msgstate)
  1368. else
  1369. if ident='SYMBOL_PLATFORM' then
  1370. recordpendingmessagestate(sym_w_non_portable_symbol, msgstate)
  1371. else
  1372. if ident='SYMBOL_UNIMPLEMENTED' then
  1373. recordpendingmessagestate(sym_w_non_implemented_symbol, msgstate)
  1374. else
  1375. if ident='UNIT_DEPRECATED' then
  1376. begin
  1377. recordpendingmessagestate(sym_w_deprecated_unit, msgstate);
  1378. recordpendingmessagestate(sym_w_deprecated_unit_with_msg, msgstate);
  1379. end
  1380. else
  1381. if ident='UNIT_EXPERIMENTAL' then
  1382. recordpendingmessagestate(sym_w_experimental_unit, msgstate)
  1383. else
  1384. if ident='UNIT_LIBRARY' then
  1385. recordpendingmessagestate(sym_w_library_unit, msgstate)
  1386. else
  1387. if ident='UNIT_PLATFORM' then
  1388. recordpendingmessagestate(sym_w_non_portable_unit, msgstate)
  1389. else
  1390. if ident='UNIT_UNIMPLEMENTED' then
  1391. recordpendingmessagestate(sym_w_non_implemented_unit, msgstate)
  1392. else
  1393. if ident='ZERO_NIL_COMPAT' then
  1394. recordpendingmessagestate(type_w_zero_to_nil, msgstate)
  1395. else
  1396. if ident='IMPLICIT_STRING_CAST' then
  1397. recordpendingmessagestate(type_w_implicit_string_cast, msgstate)
  1398. else
  1399. if ident='IMPLICIT_STRING_CAST_LOSS' then
  1400. recordpendingmessagestate(type_w_implicit_string_cast_loss, msgstate)
  1401. else
  1402. if ident='EXPLICIT_STRING_CAST' then
  1403. recordpendingmessagestate(type_w_explicit_string_cast, msgstate)
  1404. else
  1405. if ident='EXPLICIT_STRING_CAST_LOSS' then
  1406. recordpendingmessagestate(type_w_explicit_string_cast_loss, msgstate)
  1407. else
  1408. if ident='CVT_NARROWING_STRING_LOST' then
  1409. recordpendingmessagestate(type_w_unicode_data_loss, msgstate)
  1410. else
  1411. if ident='INTF_RAISE_VISIBILITY' then
  1412. recordpendingmessagestate(type_w_interface_lower_visibility, msgstate)
  1413. else
  1414. begin
  1415. i:=0;
  1416. if not ChangeMessageVerbosity(ident,i,msgstate) then
  1417. Message1(scanner_w_illegal_warn_identifier,ident);
  1418. end;
  1419. end;
  1420. procedure dir_warning;
  1421. begin
  1422. do_message(scan_w_user_defined);
  1423. end;
  1424. procedure dir_warnings;
  1425. begin
  1426. do_setverbose('W');
  1427. end;
  1428. procedure dir_weakpackageunit;
  1429. begin
  1430. { old Delphi versions seem to use merely $WEAKPACKAGEUNIT while newer
  1431. Delphis have $WEAPACKAGEUNIT ON... :/ }
  1432. do_moduleflagswitch(uf_package_weak, true);
  1433. end;
  1434. procedure dir_writeableconst;
  1435. begin
  1436. do_delphiswitch('J');
  1437. end;
  1438. procedure dir_z1;
  1439. begin
  1440. current_settings.packenum:=1;
  1441. end;
  1442. procedure dir_z2;
  1443. begin
  1444. current_settings.packenum:=2;
  1445. end;
  1446. procedure dir_z4;
  1447. begin
  1448. current_settings.packenum:=4;
  1449. end;
  1450. procedure dir_externalsym;
  1451. begin
  1452. end;
  1453. procedure dir_nodefine;
  1454. begin
  1455. end;
  1456. procedure dir_hppemit;
  1457. begin
  1458. end;
  1459. procedure dir_hugecode;
  1460. begin
  1461. if (target_info.system<>system_i8086_msdos)
  1462. {$ifdef i8086}
  1463. or (current_settings.x86memorymodel in x86_near_code_models)
  1464. {$endif i8086}
  1465. then
  1466. begin
  1467. Message1(scan_n_ignored_switch,pattern);
  1468. exit;
  1469. end;
  1470. do_moduleswitch(cs_huge_code);
  1471. end;
  1472. procedure dir_hugepointernormalization;
  1473. var
  1474. hs : string;
  1475. begin
  1476. if target_info.system<>system_i8086_msdos then
  1477. begin
  1478. Message1(scanner_w_directive_ignored_on_target, 'HUGEPOINTERNORMALIZATION');
  1479. exit;
  1480. end;
  1481. current_scanner.skipspace;
  1482. hs:=current_scanner.readid;
  1483. case hs of
  1484. 'BORLANDC':
  1485. begin
  1486. recordpendinglocalswitch(cs_hugeptr_arithmetic_normalization,'+');
  1487. recordpendinglocalswitch(cs_hugeptr_comparison_normalization,'+');
  1488. end;
  1489. 'MICROSOFTC':
  1490. begin
  1491. recordpendinglocalswitch(cs_hugeptr_arithmetic_normalization,'-');
  1492. recordpendinglocalswitch(cs_hugeptr_comparison_normalization,'-');
  1493. end;
  1494. 'WATCOMC':
  1495. begin
  1496. recordpendinglocalswitch(cs_hugeptr_arithmetic_normalization,'-');
  1497. recordpendinglocalswitch(cs_hugeptr_comparison_normalization,'+');
  1498. end;
  1499. else
  1500. Message(scan_e_illegal_hugepointernormalization);
  1501. end;
  1502. end;
  1503. procedure dir_hugepointerarithmeticnormalization;
  1504. begin
  1505. if target_info.system<>system_i8086_msdos then
  1506. begin
  1507. Message1(scanner_w_directive_ignored_on_target, 'HUGEPOINTERARITHMETICNORMALIZATION');
  1508. exit;
  1509. end;
  1510. do_localswitch(cs_hugeptr_arithmetic_normalization);
  1511. end;
  1512. procedure dir_hugepointercomparisonnormalization;
  1513. begin
  1514. if target_info.system<>system_i8086_msdos then
  1515. begin
  1516. Message1(scanner_w_directive_ignored_on_target, 'HUGEPOINTERCOMPARISONNORMALIZATION');
  1517. exit;
  1518. end;
  1519. do_localswitch(cs_hugeptr_comparison_normalization);
  1520. end;
  1521. procedure dir_codealign;
  1522. var
  1523. s : string;
  1524. begin
  1525. current_scanner.skipspace;
  1526. s:=current_scanner.readcomment;
  1527. if not(UpdateAlignmentStr(s,current_settings.alignment)) then
  1528. message(scanner_e_illegal_alignment_directive);
  1529. end;
  1530. procedure dir_codepage;
  1531. var
  1532. s : string;
  1533. begin
  1534. if not current_module.in_global then
  1535. Message(scan_w_switch_is_global)
  1536. else
  1537. begin
  1538. current_scanner.skipspace;
  1539. s:=current_scanner.readcomment;
  1540. if (upper(s)='UTF8') or (upper(s)='UTF-8') then
  1541. current_settings.sourcecodepage:=CP_UTF8
  1542. else if not cpavailable(s) then
  1543. Message1(option_code_page_not_available,s)
  1544. else
  1545. current_settings.sourcecodepage:=codepagebyname(s);
  1546. { we're not using the system code page now }
  1547. exclude(current_settings.modeswitches,m_systemcodepage);
  1548. exclude(current_settings.moduleswitches,cs_system_codepage);
  1549. include(current_settings.moduleswitches,cs_explicit_codepage);
  1550. end;
  1551. end;
  1552. procedure dir_coperators;
  1553. begin
  1554. do_moduleswitch(cs_support_c_operators);
  1555. end;
  1556. procedure dir_bitpacking;
  1557. begin
  1558. do_localswitch(cs_bitpacking);
  1559. end;
  1560. procedure dir_region;
  1561. begin
  1562. end;
  1563. procedure dir_endregion;
  1564. begin
  1565. end;
  1566. procedure dir_zerobasesstrings;
  1567. begin
  1568. do_localswitch(cs_zerobasedstrings);
  1569. end;
  1570. {****************************************************************************
  1571. Initialize Directives
  1572. ****************************************************************************}
  1573. procedure InitScannerDirectives;
  1574. begin
  1575. AddDirective('A1',directive_all, @dir_a1);
  1576. AddDirective('A2',directive_all, @dir_a2);
  1577. AddDirective('A4',directive_all, @dir_a4);
  1578. AddDirective('A8',directive_all, @dir_a8);
  1579. AddDirective('ALIGN',directive_all, @dir_align);
  1580. {$ifdef m68k}
  1581. AddDirective('APPID',directive_all, @dir_appid);
  1582. AddDirective('APPNAME',directive_all, @dir_appname);
  1583. {$endif m68k}
  1584. AddDirective('APPTYPE',directive_all, @dir_apptype);
  1585. AddDirective('ASMCPU',directive_all, @dir_asmcpu);
  1586. AddDirective('ASMMODE',directive_all, @dir_asmmode);
  1587. AddDirective('ASSERTIONS',directive_all, @dir_assertions);
  1588. AddDirective('BOOLEVAL',directive_all, @dir_booleval);
  1589. AddDirective('BITPACKING',directive_all, @dir_bitpacking);
  1590. AddDirective('CALLING',directive_all, @dir_calling);
  1591. AddDirective('CHECKLOWADDRLOADS',directive_all, @dir_checklowaddrloads);
  1592. AddDirective('CHECKPOINTER',directive_all, @dir_checkpointer);
  1593. AddDirective('CODEALIGN',directive_all, @dir_codealign);
  1594. AddDirective('CODEPAGE',directive_all, @dir_codepage);
  1595. AddDirective('COPERATORS',directive_all, @dir_coperators);
  1596. AddDirective('COPYRIGHT',directive_all, @dir_copyright);
  1597. AddDirective('D',directive_all, @dir_description);
  1598. AddDirective('DEBUGINFO',directive_all, @dir_debuginfo);
  1599. AddDirective('DENYPACKAGEUNIT',directive_all,@dir_denypackageunit);
  1600. AddDirective('DESCRIPTION',directive_all, @dir_description);
  1601. AddDirective('ENDREGION',directive_all, @dir_endregion);
  1602. AddDirective('ERROR',directive_all, @dir_error);
  1603. AddDirective('ERRORC',directive_mac, @dir_error);
  1604. AddDirective('EXTENDEDSYNTAX',directive_all, @dir_extendedsyntax);
  1605. AddDirective('EXTERNALSYM',directive_all, @dir_externalsym);
  1606. AddDirective('F',directive_all, @dir_forcefarcalls);
  1607. AddDirective('FATAL',directive_all, @dir_fatal);
  1608. AddDirective('FPUTYPE',directive_all, @dir_fputype);
  1609. AddDirective('FRAMEWORKPATH',directive_all, @dir_frameworkpath);
  1610. AddDirective('GOTO',directive_all, @dir_goto);
  1611. AddDirective('HINT',directive_all, @dir_hint);
  1612. AddDirective('HINTS',directive_all, @dir_hints);
  1613. AddDirective('HPPEMIT',directive_all, @dir_hppemit);
  1614. AddDirective('HUGECODE',directive_all, @dir_hugecode);
  1615. AddDirective('HUGEPOINTERNORMALIZATION',directive_all,@dir_hugepointernormalization);
  1616. AddDirective('HUGEPOINTERARITHMETICNORMALIZATION',directive_all,@dir_hugepointerarithmeticnormalization);
  1617. AddDirective('HUGEPOINTERCOMPARISONNORMALIZATION',directive_all,@dir_hugepointercomparisonnormalization);
  1618. AddDirective('IEEEERRORS',directive_all,@dir_ieeeerrors);
  1619. AddDirective('IOCHECKS',directive_all, @dir_iochecks);
  1620. AddDirective('IMAGEBASE',directive_all, @dir_imagebase);
  1621. AddDirective('IMPLICITEXCEPTIONS',directive_all, @dir_implicitexceptions);
  1622. AddDirective('IMPORTEDDATA',directive_all, @dir_importeddata);
  1623. AddDirective('INCLUDEPATH',directive_all, @dir_includepath);
  1624. AddDirective('INFO',directive_all, @dir_info);
  1625. AddDirective('INLINE',directive_all, @dir_inline);
  1626. AddDirective('INTERFACES',directive_all, @dir_interfaces);
  1627. AddDirective('L',directive_all, @dir_link);
  1628. AddDirective('LIBEXPORT',directive_mac, @dir_libexport);
  1629. AddDirective('LIBRARYPATH',directive_all, @dir_librarypath);
  1630. AddDirective('LINK',directive_all, @dir_link);
  1631. AddDirective('LINKFRAMEWORK',directive_all, @dir_linkframework);
  1632. AddDirective('LINKLIB',directive_all, @dir_linklib);
  1633. AddDirective('LOCALSYMBOLS',directive_all, @dir_localsymbols);
  1634. AddDirective('LONGSTRINGS',directive_all, @dir_longstrings);
  1635. AddDirective('M',directive_all, @dir_memory);
  1636. AddDirective('MACRO',directive_all, @dir_macro);
  1637. AddDirective('MAXFPUREGISTERS',directive_all, @dir_maxfpuregisters);
  1638. AddDirective('MAXSTACKSIZE',directive_all, @dir_maxstacksize);
  1639. AddDirective('MEMORY',directive_all, @dir_memory);
  1640. AddDirective('MESSAGE',directive_all, @dir_message);
  1641. AddDirective('MINENUMSIZE',directive_all, @dir_packenum);
  1642. AddDirective('MINFPCONSTPREC',directive_all, @dir_minfpconstprec);
  1643. AddDirective('MINSTACKSIZE',directive_all, @dir_minstacksize);
  1644. AddDirective('MMX',directive_all, @dir_mmx);
  1645. AddDirective('MODE',directive_all, @dir_mode);
  1646. AddDirective('MODESWITCH',directive_all, @dir_modeswitch);
  1647. AddDirective('NAMESPACE',directive_all, @dir_namespace);
  1648. AddDirective('NODEFINE',directive_all, @dir_nodefine);
  1649. AddDirective('NOTE',directive_all, @dir_note);
  1650. AddDirective('NOTES',directive_all, @dir_notes);
  1651. AddDirective('OBJECTCHECKS',directive_all, @dir_objectchecks);
  1652. AddDirective('OBJECTPATH',directive_all, @dir_objectpath);
  1653. AddDirective('OPENSTRINGS',directive_all, @dir_openstrings);
  1654. AddDirective('OPTIMIZATION',directive_all, @dir_optimization);
  1655. AddDirective('OV',directive_mac, @dir_overflowchecks);
  1656. AddDirective('OVERFLOWCHECKS',directive_all, @dir_overflowchecks);
  1657. AddDirective('PACKENUM',directive_all, @dir_packenum);
  1658. AddDirective('PACKRECORDS',directive_all, @dir_packrecords);
  1659. AddDirective('PACKSET',directive_all, @dir_packset);
  1660. AddDirective('PASCALMAINNAME',directive_all, @dir_pascalmainname);
  1661. AddDirective('PIC',directive_all, @dir_pic);
  1662. AddDirective('POINTERMATH',directive_all, @dir_pointermath);
  1663. AddDirective('POP',directive_all, @dir_pop);
  1664. AddDirective('PROFILE',directive_all, @dir_profile);
  1665. AddDirective('PUSH',directive_all, @dir_push);
  1666. AddDirective('R',directive_all, @dir_resource);
  1667. AddDirective('RANGECHECKS',directive_all, @dir_rangechecks);
  1668. AddDirective('REFERENCEINFO',directive_all, @dir_referenceinfo);
  1669. AddDirective('REGION',directive_all, @dir_region);
  1670. AddDirective('RESOURCE',directive_all, @dir_resource);
  1671. AddDirective('SATURATION',directive_all, @dir_saturation);
  1672. AddDirective('SAFEFPUEXCEPTIONS',directive_all, @dir_safefpuexceptions);
  1673. AddDirective('SCOPEDENUMS',directive_all, @dir_scopedenums);
  1674. AddDirective('SETPEFLAGS', directive_all, @dir_setpeflags);
  1675. AddDirective('SETPEOPTFLAGS', directive_all, @dir_setpeoptflags);
  1676. AddDirective('SCREENNAME',directive_all, @dir_screenname);
  1677. AddDirective('SMARTLINK',directive_all, @dir_smartlink);
  1678. AddDirective('STACKFRAMES',directive_all, @dir_stackframes);
  1679. AddDirective('STOP',directive_all, @dir_stop);
  1680. AddDirective('STRINGCHECKS', directive_all, @dir_stringchecks);
  1681. {$ifdef powerpc}
  1682. AddDirective('SYSCALL',directive_all, @dir_syscall);
  1683. {$endif powerpc}
  1684. AddDirective('TARGETSWITCH',directive_all, @dir_targetswitch);
  1685. AddDirective('THREADNAME',directive_all, @dir_threadname);
  1686. AddDirective('TYPEDADDRESS',directive_all, @dir_typedaddress);
  1687. AddDirective('TYPEINFO',directive_all, @dir_typeinfo);
  1688. AddDirective('UNITPATH',directive_all, @dir_unitpath);
  1689. AddDirective('VARPARACOPYOUTCHECK',directive_all, @dir_varparacopyoutcheck);
  1690. AddDirective('VARPROPSETTER',directive_all, @dir_varpropsetter);
  1691. AddDirective('VARSTRINGCHECKS',directive_all, @dir_varstringchecks);
  1692. AddDirective('VERSION',directive_all, @dir_version);
  1693. AddDirective('WAIT',directive_all, @dir_wait);
  1694. AddDirective('WARN',directive_all, @dir_warn);
  1695. AddDirective('WARNING',directive_all, @dir_warning);
  1696. AddDirective('WARNINGS',directive_all, @dir_warnings);
  1697. AddDirective('WEAKPACKAGEUNIT',directive_all, @dir_weakpackageunit);
  1698. AddDirective('WRITEABLECONST',directive_all, @dir_writeableconst);
  1699. AddDirective('Z1',directive_all, @dir_z1);
  1700. AddDirective('Z2',directive_all, @dir_z2);
  1701. AddDirective('Z4',directive_all, @dir_z4);
  1702. AddDirective('ZEROBASEDSTRINGS',directive_all, @dir_zerobasesstrings);
  1703. end;
  1704. end.