scandir.pas 60 KB

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