scandir.pas 59 KB

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