scandir.pas 34 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Peter Vreman
  4. This unit implements directive parsing for the scanner
  5. This program is free software; you can redistribute it and/or modify
  6. it under the terms of the GNU General Public License as published by
  7. the Free Software Foundation; either version 2 of the License, or
  8. (at your option) any later version.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  12. GNU General Public License for more details.
  13. You should have received a copy of the GNU General Public License
  14. along with this program; if not, write to the Free Software
  15. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  16. ****************************************************************************
  17. }
  18. unit scandir;
  19. {$i fpcdefs.inc}
  20. interface
  21. procedure InitScannerDirectives;
  22. implementation
  23. uses
  24. cutils,
  25. globtype,globals,systems,widestr,
  26. verbose,comphook,
  27. scanner,switches,
  28. fmodule,
  29. rabase;
  30. {*****************************************************************************
  31. Helpers
  32. *****************************************************************************}
  33. procedure do_delphiswitch(sw:char);
  34. var
  35. state : char;
  36. begin
  37. { c contains the next char, a + or - would be fine }
  38. state:=current_scanner.readstate;
  39. if state in ['-','+'] then
  40. HandleSwitch(sw,state);
  41. end;
  42. procedure do_setverbose(flag:char);
  43. var
  44. state : char;
  45. begin
  46. { support ON/OFF }
  47. state:=current_scanner.ReadState;
  48. SetVerbosity(flag+state);
  49. end;
  50. procedure do_moduleswitch(sw:tmoduleswitch);
  51. var
  52. state : char;
  53. begin
  54. state:=current_scanner.readstate;
  55. if (sw<>cs_modulenone) and (state in ['-','+']) then
  56. begin
  57. if state='-' then
  58. exclude(aktmoduleswitches,sw)
  59. else
  60. include(aktmoduleswitches,sw);
  61. end;
  62. end;
  63. procedure do_localswitch(sw:tlocalswitch);
  64. var
  65. state : char;
  66. begin
  67. state:=current_scanner.readstate;
  68. if (sw<>cs_localnone) and (state in ['-','+']) then
  69. begin
  70. if not localswitcheschanged then
  71. nextaktlocalswitches:=aktlocalswitches;
  72. if state='-' then
  73. exclude(nextaktlocalswitches,sw)
  74. else
  75. include(nextaktlocalswitches,sw);
  76. localswitcheschanged:=true;
  77. end;
  78. end;
  79. procedure do_message(w:integer);
  80. begin
  81. current_scanner.skipspace;
  82. Message1(w,current_scanner.readcomment);
  83. end;
  84. {*****************************************************************************
  85. Directive Callbacks
  86. *****************************************************************************}
  87. procedure dir_align;
  88. var
  89. hs : string;
  90. begin
  91. current_scanner.skipspace;
  92. if not(c in ['0'..'9']) then
  93. begin
  94. { Support also the ON and OFF as switch }
  95. hs:=current_scanner.readid;
  96. if (hs='ON') then
  97. aktpackrecords:=4
  98. else if (hs='OFF') then
  99. aktpackrecords:=1
  100. else if m_mac in aktmodeswitches then
  101. begin
  102. { Support switches used in Apples Universal Interfaces}
  103. if (hs='MAC68K') then
  104. aktpackrecords:=2
  105. else if (hs='POWER') then
  106. aktpackrecords:=4
  107. else if (hs='RESET') then
  108. aktpackrecords:=0
  109. end
  110. else
  111. Message(scan_w_only_pack_records);
  112. end
  113. else
  114. begin
  115. case current_scanner.readval of
  116. 1 : aktpackrecords:=1;
  117. 2 : aktpackrecords:=2;
  118. 4 : aktpackrecords:=4;
  119. 8 : aktpackrecords:=8;
  120. 16 : aktpackrecords:=16;
  121. 32 : aktpackrecords:=32;
  122. else
  123. Message(scan_w_only_pack_records);
  124. end;
  125. end;
  126. end;
  127. procedure dir_asmmode;
  128. var
  129. s : string;
  130. begin
  131. current_scanner.skipspace;
  132. s:=current_scanner.readid;
  133. If Inside_asm_statement then
  134. Message1(scan_w_no_asm_reader_switch_inside_asm,s);
  135. if s='DEFAULT' then
  136. aktasmmode:=initasmmode
  137. else
  138. if not SetAsmReadMode(s,aktasmmode) then
  139. Message1(scan_e_illegal_asmmode_specifier,s);
  140. end;
  141. {$ifdef m68k}
  142. procedure dir_appid;
  143. begin
  144. if target_info.system<>system_m68k_palmos then
  145. Message(scan_w_appid_not_support);
  146. { change description global var in all cases }
  147. { it not used but in win32 and os2 }
  148. current_scanner.skipspace;
  149. palmos_applicationid:=current_scanner.readcomment;
  150. end;
  151. procedure dir_appname;
  152. begin
  153. if target_info.system<>system_m68k_palmos then
  154. Message(scan_w_appname_not_support);
  155. { change description global var in all cases }
  156. { it not used but in win32 and os2 }
  157. current_scanner.skipspace;
  158. palmos_applicationname:=current_scanner.readcomment;
  159. end;
  160. {$endif m68k}
  161. procedure dir_apptype;
  162. var
  163. hs : string;
  164. begin
  165. if not (target_info.system in [system_i386_win32,system_i386_os2,
  166. system_i386_emx, system_powerpc_macos]) then
  167. Message(scan_w_app_type_not_support);
  168. if not current_module.in_global then
  169. Message(scan_w_switch_is_global)
  170. else
  171. begin
  172. current_scanner.skipspace;
  173. hs:=current_scanner.readid;
  174. if hs='GUI' then
  175. apptype:=app_gui
  176. else if hs='CONSOLE' then
  177. apptype:=app_cui
  178. else if (hs='FS') and (target_info.system in [system_i386_os2,
  179. system_i386_emx]) then
  180. apptype:=app_fs
  181. else if (hs='TOOL') and (target_info.system in [system_powerpc_macos]) then
  182. apptype:=app_tool
  183. else
  184. Message1(scan_w_unsupported_app_type,hs);
  185. end;
  186. end;
  187. procedure dir_calling;
  188. var
  189. hs : string;
  190. begin
  191. current_scanner.skipspace;
  192. hs:=current_scanner.readid;
  193. if not SetAktProcCall(hs,false) then
  194. Message1(parser_w_unknown_proc_directive_ignored,hs);
  195. end;
  196. procedure dir_objectchecks;
  197. begin
  198. do_localswitch(cs_check_object);
  199. end;
  200. procedure dir_assertions;
  201. begin
  202. do_delphiswitch('C');
  203. end;
  204. procedure dir_booleval;
  205. begin
  206. do_delphiswitch('B');
  207. end;
  208. procedure dir_debuginfo;
  209. begin
  210. do_delphiswitch('D');
  211. end;
  212. procedure dir_description;
  213. begin
  214. if not (target_info.system in [system_i386_os2,system_i386_emx,
  215. system_i386_win32,system_i386_netware,system_i386_wdosx]) then
  216. Message(scan_w_description_not_support);
  217. { change description global var in all cases }
  218. { it not used but in win32, os2 and netware }
  219. current_scanner.skipspace;
  220. description:=current_scanner.readcomment;
  221. end;
  222. procedure dir_screenname; {ad}
  223. begin
  224. if target_info.system <> system_i386_netware then
  225. {Message(scan_w_decription_not_support);}
  226. comment (V_Warning,'Screenname only supported for target netware');
  227. current_scanner.skipspace;
  228. nwscreenname:=current_scanner.readcomment;
  229. end;
  230. procedure dir_threadname; {ad}
  231. begin
  232. if target_info.system <> system_i386_netware then
  233. {Message(scan_w_decription_not_support);}
  234. comment (V_Warning,'Threadname only supported for target netware');
  235. current_scanner.skipspace;
  236. nwthreadname:=current_scanner.readcomment;
  237. end;
  238. procedure dir_copyright; {ad}
  239. begin
  240. if target_info.system <> system_i386_netware then
  241. {Message(scan_w_decription_not_support);}
  242. comment (V_Warning,'Copyright only supported for target netware');
  243. current_scanner.skipspace;
  244. nwcopyright:=current_scanner.readcomment;
  245. end;
  246. procedure dir_error;
  247. begin
  248. do_message(scan_e_user_defined);
  249. end;
  250. procedure dir_extendedsyntax;
  251. begin
  252. do_delphiswitch('X');
  253. end;
  254. procedure dir_fatal;
  255. begin
  256. do_message(scan_f_user_defined);
  257. end;
  258. procedure dir_fputype;
  259. begin
  260. current_scanner.skipspace;
  261. if not(SetFPUType(upper(current_scanner.readcomment),false)) then
  262. comment(V_Error,'Illegal FPU type');
  263. end;
  264. procedure dir_goto;
  265. begin
  266. do_moduleswitch(cs_support_goto);
  267. end;
  268. procedure dir_hint;
  269. begin
  270. do_message(scan_h_user_defined);
  271. end;
  272. procedure dir_hints;
  273. begin
  274. do_setverbose('H');
  275. end;
  276. procedure dir_implicitexceptions;
  277. begin
  278. do_moduleswitch(cs_implicit_exceptions);
  279. end;
  280. procedure dir_includepath;
  281. begin
  282. if not current_module.in_global then
  283. Message(scan_w_switch_is_global)
  284. else
  285. begin
  286. current_scanner.skipspace;
  287. current_module.localincludesearchpath.AddPath(current_scanner.readcomment,false);
  288. end;
  289. end;
  290. procedure dir_info;
  291. begin
  292. do_message(scan_i_user_defined);
  293. end;
  294. procedure dir_inline;
  295. begin
  296. do_moduleswitch(cs_support_inline);
  297. end;
  298. procedure dir_interfaces;
  299. var
  300. hs : string;
  301. begin
  302. {corba/com/default}
  303. current_scanner.skipspace;
  304. hs:=current_scanner.readid;
  305. if (hs='CORBA') then
  306. aktinterfacetype:=it_interfacecorba
  307. else if (hs='COM') then
  308. aktinterfacetype:=it_interfacecom
  309. else if (hs='DEFAULT') then
  310. aktinterfacetype:=initinterfacetype
  311. else
  312. Message(scan_e_invalid_interface_type);
  313. end;
  314. procedure dir_iochecks;
  315. begin
  316. do_delphiswitch('I');
  317. end;
  318. procedure dir_librarypath;
  319. begin
  320. if not current_module.in_global then
  321. Message(scan_w_switch_is_global)
  322. else
  323. begin
  324. current_scanner.skipspace;
  325. current_module.locallibrarysearchpath.AddPath(current_scanner.readcomment,false);
  326. end;
  327. end;
  328. procedure dir_link;
  329. var
  330. s : string;
  331. begin
  332. current_scanner.skipspace;
  333. s:=AddExtension(FixFileName(current_scanner.readcomment),target_info.objext);
  334. current_module.linkotherofiles.add(s,link_allways);
  335. end;
  336. procedure dir_linklib;
  337. type
  338. tLinkMode=(lm_shared,lm_static);
  339. var
  340. s : string;
  341. quote : char;
  342. libname,
  343. linkmodestr : string;
  344. p : longint;
  345. linkMode : tLinkMode;
  346. begin
  347. current_scanner.skipspace;
  348. s:=current_scanner.readcomment;
  349. p:=pos(',',s);
  350. if p=0 then
  351. begin
  352. libname:=TrimSpace(s);
  353. linkmodeStr:='';
  354. end
  355. else
  356. begin
  357. libname:=TrimSpace(copy(s,1,p-1));
  358. linkmodeStr:=Upper(TrimSpace(copy(s,p+1,255)));
  359. end;
  360. if (libname='') or (libname='''''') or (libname='""') then
  361. exit;
  362. { get linkmode, default is shared linking }
  363. if linkModeStr='STATIC' then
  364. linkmode:=lm_static
  365. else if (LinkModeStr='SHARED') or (LinkModeStr='') then
  366. linkmode:=lm_shared
  367. else
  368. begin
  369. Comment(V_Error,'Wrong link mode specified: "'+Linkmodestr+'"');
  370. exit;
  371. end;
  372. { create library name }
  373. if libname[1] in ['''','"'] then
  374. begin
  375. quote:=libname[1];
  376. Delete(libname,1,1);
  377. p:=pos(quote,libname);
  378. if p>0 then
  379. Delete(libname,p,1);
  380. end;
  381. { add to the list of libraries to link }
  382. if linkMode=lm_static then
  383. current_module.linkOtherStaticLibs.add(FixFileName(libname),link_allways)
  384. else
  385. current_module.linkOtherSharedLibs.add(FixFileName(libname),link_allways);
  386. end;
  387. procedure dir_localsymbols;
  388. begin
  389. do_delphiswitch('L');
  390. end;
  391. procedure dir_longstrings;
  392. begin
  393. do_delphiswitch('H');
  394. end;
  395. procedure dir_macro;
  396. begin
  397. do_moduleswitch(cs_support_macro);
  398. end;
  399. procedure dir_maxfpuregisters;
  400. var
  401. l : integer;
  402. hs : string;
  403. begin
  404. current_scanner.skipspace;
  405. if not(c in ['0'..'9']) then
  406. begin
  407. hs:=current_scanner.readid;
  408. if (hs='NORMAL') or (hs='DEFAULT') then
  409. aktmaxfpuregisters:=-1
  410. else
  411. Message(scan_e_invalid_maxfpureg_value);
  412. end
  413. else
  414. begin
  415. l:=current_scanner.readval;
  416. case l of
  417. 0..8:
  418. aktmaxfpuregisters:=l;
  419. else
  420. Message(scan_e_invalid_maxfpureg_value);
  421. end;
  422. end;
  423. end;
  424. procedure dir_memory;
  425. var
  426. l : longint;
  427. begin
  428. current_scanner.skipspace;
  429. l:=current_scanner.readval;
  430. if l>1024 then
  431. stacksize:=l;
  432. current_scanner.skipspace;
  433. if c=',' then
  434. begin
  435. current_scanner.readchar;
  436. current_scanner.skipspace;
  437. l:=current_scanner.readval;
  438. if l>1024 then
  439. heapsize:=l;
  440. end;
  441. if c=',' then
  442. begin
  443. current_scanner.readchar;
  444. current_scanner.skipspace;
  445. l:=current_scanner.readval;
  446. { Ignore this value, because the limit is set by the OS
  447. info and shouldn't be changed by the user (PFV) }
  448. end;
  449. end;
  450. procedure dir_message;
  451. begin
  452. do_message(scan_i_user_defined);
  453. end;
  454. procedure dir_mode;
  455. begin
  456. if not current_module.in_global then
  457. Message(scan_w_switch_is_global)
  458. else
  459. begin
  460. current_scanner.skipspace;
  461. current_scanner.readstring;
  462. if not SetCompileMode(pattern,false) then
  463. Message1(scan_w_illegal_switch,pattern);
  464. end;
  465. end;
  466. procedure dir_mmx;
  467. begin
  468. do_localswitch(cs_mmx);
  469. end;
  470. procedure dir_note;
  471. begin
  472. do_message(scan_n_user_defined);
  473. end;
  474. procedure dir_notes;
  475. begin
  476. do_setverbose('N');
  477. end;
  478. procedure dir_objectpath;
  479. begin
  480. if not current_module.in_global then
  481. Message(scan_w_switch_is_global)
  482. else
  483. begin
  484. current_scanner.skipspace;
  485. current_module.localobjectsearchpath.AddPath(current_scanner.readcomment,false);
  486. end;
  487. end;
  488. procedure dir_openstrings;
  489. begin
  490. do_delphiswitch('P');
  491. end;
  492. procedure dir_output_format;
  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. if set_target_asm_by_string(current_scanner.readid) then
  500. aktoutputformat:=target_asm.id
  501. else
  502. Message1(scan_w_illegal_switch,pattern);
  503. end;
  504. end;
  505. procedure dir_overflowchecks;
  506. begin
  507. do_delphiswitch('Q');
  508. end;
  509. procedure dir_packenum;
  510. var
  511. hs : string;
  512. begin
  513. current_scanner.skipspace;
  514. if not(c in ['0'..'9']) then
  515. begin
  516. hs:=current_scanner.readid;
  517. if (hs='NORMAL') or (hs='DEFAULT') then
  518. aktpackenum:=4
  519. else
  520. Message(scan_w_only_pack_enum);
  521. end
  522. else
  523. begin
  524. case current_scanner.readval of
  525. 1 : aktpackenum:=1;
  526. 2 : aktpackenum:=2;
  527. 4 : aktpackenum:=4;
  528. else
  529. Message(scan_w_only_pack_enum);
  530. end;
  531. end;
  532. end;
  533. procedure dir_packrecords;
  534. var
  535. hs : string;
  536. begin
  537. current_scanner.skipspace;
  538. if not(c in ['0'..'9']) then
  539. begin
  540. hs:=current_scanner.readid;
  541. { C has the special recordalignmax of -1 }
  542. if (hs='C') then
  543. aktpackrecords:=-1
  544. else
  545. if (hs='NORMAL') or (hs='DEFAULT') then
  546. aktpackrecords:=0
  547. else
  548. Message(scan_w_only_pack_records);
  549. end
  550. else
  551. begin
  552. case current_scanner.readval of
  553. 1 : aktpackrecords:=1;
  554. 2 : aktpackrecords:=2;
  555. 4 : aktpackrecords:=4;
  556. 8 : aktpackrecords:=8;
  557. 16 : aktpackrecords:=16;
  558. 32 : aktpackrecords:=32;
  559. else
  560. Message(scan_w_only_pack_records);
  561. end;
  562. end;
  563. end;
  564. {$ifdef testvarsets}
  565. procedure dir_packset;
  566. var
  567. hs : string;
  568. begin
  569. current_scanner.skipspace;
  570. if not(c in ['1','2','4']) then
  571. begin
  572. hs:=current_scanner.readid;
  573. if (hs='FIXED') or ((hs='DEFAULT') OR (hs='NORMAL')) then
  574. aktsetalloc:=0 {Fixed mode, sets are 4 or 32 bytes}
  575. else
  576. Message(scan_w_only_packset);
  577. end
  578. else
  579. begin
  580. case current_scanner.readval of
  581. 1 : aktsetalloc:=1;
  582. 2 : aktsetalloc:=2;
  583. 4 : aktsetalloc:=4;
  584. else
  585. Message(scan_w_only_packset);
  586. end;
  587. end;
  588. end;
  589. {$ENDIF}
  590. procedure dir_profile;
  591. var
  592. mac : tmacro;
  593. begin
  594. do_moduleswitch(cs_profile);
  595. { defined/undefine FPC_PROFILE }
  596. mac:=tmacro(current_scanner.macros.search('FPC_PROFILE'));
  597. if not assigned(mac) then
  598. begin
  599. mac:=tmacro.create('FPC_PROFILE');
  600. current_scanner.macros.insert(mac);
  601. end;
  602. mac.defined:=(cs_profile in aktmoduleswitches);
  603. end;
  604. procedure dir_rangechecks;
  605. begin
  606. do_delphiswitch('R');
  607. end;
  608. procedure dir_referenceinfo;
  609. begin
  610. do_delphiswitch('Y');
  611. end;
  612. procedure dir_resource;
  613. var
  614. s : string;
  615. begin
  616. current_scanner.skipspace;
  617. s:=current_scanner.readcomment;
  618. { replace * with current module name.
  619. This should always be defined. }
  620. if s[1]='*' then
  621. if Assigned(Current_Module) then
  622. begin
  623. delete(S,1,1);
  624. insert(lower(current_module.modulename^),S,1);
  625. end;
  626. s:=AddExtension(FixFileName(s),target_info.resext);
  627. if target_info.res<>res_none then
  628. if (target_info.res = res_emxbind) and
  629. not (Current_module.ResourceFiles.Empty) then
  630. Message(scan_w_only_one_resourcefile_supported)
  631. else
  632. current_module.resourcefiles.insert(FixFileName(s))
  633. else
  634. Message(scan_e_resourcefiles_not_supported);
  635. end;
  636. procedure dir_saturation;
  637. begin
  638. do_localswitch(cs_mmx_saturation);
  639. end;
  640. procedure dir_smartlink;
  641. begin
  642. do_moduleswitch(cs_create_smart);
  643. end;
  644. procedure dir_stackframes;
  645. begin
  646. do_delphiswitch('W');
  647. end;
  648. procedure dir_static;
  649. begin
  650. do_moduleswitch(cs_static_keyword);
  651. end;
  652. procedure dir_stop;
  653. begin
  654. do_message(scan_f_user_defined);
  655. end;
  656. procedure dir_threading;
  657. var
  658. mac : tmacro;
  659. begin
  660. do_moduleswitch(cs_threading);
  661. { defined/undefine FPC_THREADING }
  662. mac:=tmacro(current_scanner.macros.search('FPC_THREADING'));
  663. if not assigned(mac) then
  664. begin
  665. mac:=tmacro.create('FPC_THREADING');
  666. current_scanner.macros.insert(mac);
  667. end;
  668. mac.defined:=(cs_threading in aktmoduleswitches);
  669. end;
  670. procedure dir_typedaddress;
  671. begin
  672. do_delphiswitch('T');
  673. end;
  674. procedure dir_typeinfo;
  675. begin
  676. do_delphiswitch('M');
  677. end;
  678. procedure dir_unitpath;
  679. begin
  680. if not current_module.in_global then
  681. Message(scan_w_switch_is_global)
  682. else
  683. with current_scanner,current_module,localunitsearchpath do
  684. begin
  685. skipspace;
  686. AddPath(path^,readcomment,false);
  687. end;
  688. end;
  689. procedure dir_varstringchecks;
  690. begin
  691. do_delphiswitch('V');
  692. end;
  693. procedure dir_version;
  694. var
  695. major, minor, revision : longint;
  696. error : integer;
  697. begin
  698. if not (target_info.system in [system_i386_os2,system_i386_emx,
  699. system_i386_win32,system_i386_netware,system_i386_wdosx]) then
  700. begin
  701. Message(scan_n_version_not_support);
  702. exit;
  703. end;
  704. if (compile_level<>1) then
  705. Message(scan_n_only_exe_version)
  706. else
  707. begin
  708. { change description global var in all cases }
  709. { it not used but in win32, os2 and netware }
  710. current_scanner.skipspace;
  711. { we should only accept Major.Minor format for win32 and os2 }
  712. current_scanner.readnumber;
  713. major:=0;
  714. minor:=0;
  715. revision:=0;
  716. valint(pattern,major,error);
  717. if (error<>0) or (major > high(word)) or (major < 0) then
  718. begin
  719. Message1(scan_w_wrong_version_ignored,pattern);
  720. exit;
  721. end;
  722. if c='.' then
  723. begin
  724. current_scanner.readchar;
  725. current_scanner.readnumber;
  726. valint(pattern,minor,error);
  727. if (error<>0) or (minor > high(word)) or (minor < 0) then
  728. begin
  729. Message1(scan_w_wrong_version_ignored,tostr(major)+'.'+pattern);
  730. exit;
  731. end;
  732. if (c='.') and
  733. (target_info.system = system_i386_netware) then
  734. begin
  735. current_scanner.readchar;
  736. current_scanner.readnumber;
  737. valint(pattern,revision,error);
  738. if (error<>0) or (revision > high(word)) or (revision < 0) then
  739. begin
  740. Message1(scan_w_wrong_version_ignored,tostr(revision)+'.'+pattern);
  741. exit;
  742. end;
  743. dllmajor:=word(major);
  744. dllminor:=word(minor);
  745. dllrevision:=word(revision);
  746. dllversion:=tostr(major)+','+tostr(minor)+','+tostr(revision);
  747. end
  748. else
  749. begin
  750. dllmajor:=word(major);
  751. dllminor:=word(minor);
  752. dllversion:=tostr(major)+'.'+tostr(minor);
  753. end;
  754. end
  755. else
  756. dllversion:=tostr(major);
  757. end;
  758. end;
  759. procedure dir_wait;
  760. var
  761. had_info : boolean;
  762. begin
  763. had_info:=(status.verbosity and V_Info)<>0;
  764. { this message should allways appear !! }
  765. status.verbosity:=status.verbosity or V_Info;
  766. Message(scan_i_press_enter);
  767. readln;
  768. If not(had_info) then
  769. status.verbosity:=status.verbosity and (not V_Info);
  770. end;
  771. procedure dir_warning;
  772. begin
  773. do_message(scan_w_user_defined);
  774. end;
  775. procedure dir_warnings;
  776. begin
  777. do_setverbose('W');
  778. end;
  779. procedure dir_writeableconst;
  780. begin
  781. do_delphiswitch('J');
  782. end;
  783. procedure dir_z1;
  784. begin
  785. aktpackenum:=1;
  786. end;
  787. procedure dir_z2;
  788. begin
  789. aktpackenum:=2;
  790. end;
  791. procedure dir_z4;
  792. begin
  793. aktpackenum:=4;
  794. end;
  795. procedure dir_externalsym;
  796. begin
  797. end;
  798. procedure dir_codepage;
  799. var
  800. s : string;
  801. begin
  802. if not current_module.in_global then
  803. Message(scan_w_switch_is_global)
  804. else
  805. begin
  806. current_scanner.skipspace;
  807. s:=current_scanner.readcomment;
  808. if not(cpavailable(s)) then
  809. Message1(option_code_page_not_available,s)
  810. else
  811. aktsourcecodepage:=s;
  812. end;
  813. end;
  814. {****************************************************************************
  815. Initialize Directives
  816. ****************************************************************************}
  817. procedure InitScannerDirectives;
  818. begin
  819. AddDirective('ALIGN',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_align);
  820. {$ifdef m68k}
  821. AddDirective('APPID',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_appid);
  822. AddDirective('APPNAME',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_appname);
  823. {$endif m68k}
  824. AddDirective('APPTYPE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_apptype);
  825. AddDirective('ASMMODE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_asmmode);
  826. AddDirective('ASSERTIONS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_assertions);
  827. AddDirective('BOOLEVAL',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_booleval);
  828. AddDirective('CALLING',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_calling);
  829. AddDirective('CODEPAGE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_codepage);
  830. AddDirective('COPYRIGHT',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_copyright);
  831. AddDirective('D',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_description);
  832. AddDirective('DEBUGINFO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_debuginfo);
  833. AddDirective('DESCRIPTION',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_description);
  834. AddDirective('ERROR',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_error);
  835. AddDirective('EXTENDEDSYNTAX',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_extendedsyntax);
  836. AddDirective('EXTERNALSYM',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_externalsym);
  837. AddDirective('FATAL',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_fatal);
  838. AddDirective('FPUTYPE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_fputype);
  839. AddDirective('GOTO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_goto);
  840. AddDirective('HINT',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_hint);
  841. AddDirective('HINTS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_hints);
  842. AddDirective('IOCHECKS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_iochecks);
  843. AddDirective('IMPLICITEXCEPTIONS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_implicitexceptions);
  844. AddDirective('INCLUDEPATH',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_includepath);
  845. AddDirective('INFO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_info);
  846. AddDirective('INLINE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_inline);
  847. AddDirective('INTERFACES',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_interfaces);
  848. AddDirective('L',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_link);
  849. AddDirective('LIBRARYPATH',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_librarypath);
  850. AddDirective('LINK',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_link);
  851. AddDirective('LINKLIB',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_linklib);
  852. AddDirective('LOCALSYMBOLS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_localsymbols);
  853. AddDirective('LONGSTRINGS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_longstrings);
  854. AddDirective('M',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_memory);
  855. AddDirective('MACRO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_macro);
  856. AddDirective('MAXFPUREGISTERS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_maxfpuregisters);
  857. AddDirective('MEMORY',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_memory);
  858. AddDirective('MESSAGE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_message);
  859. AddDirective('MINENUMSIZE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_packenum);
  860. AddDirective('MMX',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_mmx);
  861. AddDirective('MODE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_mode);
  862. AddDirective('NOTE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_note);
  863. AddDirective('NOTES',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_notes);
  864. AddDirective('OBJECTCHECKS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_objectchecks);
  865. AddDirective('OBJECTPATH',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_objectpath);
  866. AddDirective('OPENSTRINGS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_openstrings);
  867. AddDirective('OUTPUT_FORMAT',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_output_format);
  868. AddDirective('OVERFLOWCHECKS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_overflowchecks);
  869. AddDirective('PACKENUM',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_packenum);
  870. AddDirective('PACKRECORDS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_packrecords);
  871. {$IFDEF TestVarsets}
  872. AddDirective('PACKSET',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_packset);
  873. {$ENDIF}
  874. AddDirective('PROFILE',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_profile);
  875. AddDirective('R',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_resource);
  876. AddDirective('RANGECHECKS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_rangechecks);
  877. AddDirective('REFERENCEINFO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_referenceinfo);
  878. AddDirective('SATURATION',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_saturation);
  879. AddDirective('SCREENNAME',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_screenname);
  880. AddDirective('SMARTLINK',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_smartlink);
  881. AddDirective('STACKFRAMES',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_stackframes);
  882. AddDirective('STATIC',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_static);
  883. AddDirective('STOP',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_stop);
  884. AddDirective('THREADING',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_threading);
  885. AddDirective('THREADNAME',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_threadname);
  886. AddDirective('TYPEDADDRESS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_typedaddress);
  887. AddDirective('TYPEINFO',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_typeinfo);
  888. AddDirective('UNITPATH',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_unitpath);
  889. AddDirective('VARSTRINGCHECKS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_varstringchecks);
  890. AddDirective('VERSION',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_version);
  891. AddDirective('WAIT',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_wait);
  892. AddDirective('WARNING',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_warning);
  893. AddDirective('WARNINGS',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_warnings);
  894. AddDirective('WRITEABLECONST',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_writeableconst);
  895. AddDirective('Z1',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_z1);
  896. AddDirective('Z2',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_z2);
  897. AddDirective('Z4',directive_all, {$ifdef FPCPROCVAR}@{$endif}dir_z4);
  898. end;
  899. end.
  900. {
  901. $Log$
  902. Revision 1.34 2004-05-11 22:51:34 olle
  903. * Performanceimprovement
  904. Revision 1.33 2004/05/11 18:30:50 olle
  905. + mode macpas: support for Apples align directives
  906. Revision 1.32 2004/04/04 18:46:09 olle
  907. + added $APPTYPE TOOL for MPW tools on MacOS
  908. Revision 1.31 2004/03/14 20:08:37 peter
  909. * packrecords fixed for settings from $PACKRECORDS
  910. * default packrecords now uses value 0 and uses info from aligment
  911. structure only, initpackrecords removed
  912. Revision 1.30 2004/01/28 22:16:31 peter
  913. * more record alignment fixes
  914. Revision 1.29 2003/12/25 01:07:09 florian
  915. + $fputype directive support
  916. + single data type operations with sse unit
  917. * fixed more x86-64 stuff
  918. Revision 1.28 2003/11/12 16:05:39 florian
  919. * assembler readers OOPed
  920. + typed currency constants
  921. + typed 128 bit float constants if the CPU supports it
  922. Revision 1.27 2003/11/07 15:58:32 florian
  923. * Florian's culmutative nr. 1; contains:
  924. - invalid calling conventions for a certain cpu are rejected
  925. - arm softfloat calling conventions
  926. - -Sp for cpu dependend code generation
  927. - several arm fixes
  928. - remaining code for value open array paras on heap
  929. Revision 1.26 2003/09/17 22:30:19 olle
  930. + support for a different set of compiler directives under $MODE MAC
  931. + added mac directives $SETC $IFC $ELSEC $ENDC
  932. Revision 1.25 2003/03/23 23:20:38 hajny
  933. + emx target added
  934. Revision 1.24 2003/01/03 21:25:01 peter
  935. * OBJECTCHECKS added, equivalent of -CR
  936. * WRITEABLECONST added, equivalent of $J
  937. Revision 1.23 2002/12/07 14:06:20 carl
  938. * stricter version / revision checking (also remove some warnings)
  939. Revision 1.22 2002/11/20 11:12:46 mazen
  940. + module path is now passed to AddPath to fix relative unit path
  941. Revision 1.21 2002/10/16 19:01:43 peter
  942. + $IMPLICITEXCEPTIONS switch to turn on/off generation of the
  943. implicit exception frames for procedures with initialized variables
  944. and for constructors. The default is on for compatibility
  945. Revision 1.20 2002/10/14 19:43:41 peter
  946. * threading switch, defines the symbol FPC_THREADING
  947. Revision 1.19 2002/08/13 18:01:52 carl
  948. * rename swatoperands to swapoperands
  949. + m68k first compilable version (still needs a lot of testing):
  950. assembler generator, system information , inline
  951. assembler reader.
  952. Revision 1.18 2002/07/26 21:15:42 florian
  953. * rewrote the system handling
  954. Revision 1.17 2002/07/20 17:16:03 florian
  955. + source code page support
  956. Revision 1.16 2002/07/16 15:37:58 florian
  957. + Directive $EXTERNALSYM added, it is ignored for now
  958. Revision 1.15 2002/05/18 13:34:17 peter
  959. * readded missing revisions
  960. Revision 1.14 2002/05/16 19:46:44 carl
  961. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  962. + try to fix temp allocation (still in ifdef)
  963. + generic constructor calls
  964. + start of tassembler / tmodulebase class cleanup
  965. Revision 1.12 2002/04/07 13:34:20 carl
  966. + wdosx target
  967. Revision 1.11 2002/04/04 19:06:05 peter
  968. * removed unused units
  969. * use tlocation.size in cg.a_*loc*() routines
  970. }