globals.pas 51 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800
  1. {
  2. $Id$
  3. Copyright (c) 1998-2002 by Florian Klaempfl
  4. This unit implements some support functions and global variables
  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 globals;
  19. {$i fpcdefs.inc}
  20. { Use the internal linker by default }
  21. { define INTERNALLINKER}
  22. interface
  23. uses
  24. {$ifdef win32}
  25. windows,
  26. {$endif}
  27. {$ifdef hasunix}
  28. {$ifdef ver1_0}
  29. linux,
  30. {$else}
  31. unix,
  32. {$endif}
  33. {$endif}
  34. {$ifdef Delphi}
  35. SysUtils,
  36. dmisc,
  37. {$else}
  38. strings,
  39. dos,
  40. {$endif}
  41. cutils,cclasses,
  42. globtype,version,systems,cpuinfo;
  43. const
  44. {$ifdef Splitheap}
  45. testsplit : boolean = false;
  46. {$endif Splitheap}
  47. delphimodeswitches : tmodeswitches=
  48. [m_delphi,m_all,m_class,m_objpas,m_result,m_string_pchar,
  49. m_pointer_2_procedure,m_autoderef,m_tp_procvar,m_initfinal,m_default_ansistring,
  50. m_out,m_default_para,m_duplicate_names,m_hintdirective,m_add_pointer];
  51. fpcmodeswitches : tmodeswitches=
  52. [m_fpc,m_all,m_string_pchar,m_nested_comment,m_repeat_forward,
  53. m_cvar_support,m_initfinal,m_add_pointer,m_hintdirective];
  54. objfpcmodeswitches : tmodeswitches=
  55. [m_objfpc,m_fpc,m_all,m_class,m_objpas,m_result,m_string_pchar,m_nested_comment,
  56. m_repeat_forward,m_cvar_support,m_initfinal,m_add_pointer,m_out,m_default_para,m_hintdirective];
  57. tpmodeswitches : tmodeswitches=
  58. [m_tp7,m_all,m_tp_procvar,m_duplicate_names];
  59. gpcmodeswitches : tmodeswitches=
  60. [m_gpc,m_all];
  61. { maximum number of locals in bytes before warning is emitted }
  62. maxlocalsize = high(smallint);
  63. { maximum number of paras in bytes before warning is emitted }
  64. maxparasize = high(word);
  65. { maximum nesting of routines }
  66. maxnesting = 32;
  67. { maximum of units which are supported for a compilation }
  68. maxunits = 1024;
  69. treelogfilename = 'tree.log';
  70. type
  71. pfileposinfo = ^tfileposinfo;
  72. tfileposinfo = record
  73. line : longint;
  74. column : word;
  75. fileindex : word;
  76. { moduleindex : word; }
  77. end;
  78. TSearchPathList = class(TStringList)
  79. procedure AddPath(s:string;addfirst:boolean);overload;
  80. procedure AddPath(SrcPath,s:string;addfirst:boolean);overload;
  81. procedure AddList(list:TSearchPathList;addfirst:boolean);
  82. function FindFile(const f : string;var foundfile:string):boolean;
  83. end;
  84. tcodepagestring = string[20];
  85. { the ordinal type used when evaluating constant integer expressions }
  86. TConstExprInt = int64;
  87. { ... the same unsigned }
  88. TConstExprUInt = {$ifdef fpc}qword{$else}int64{$endif};
  89. var
  90. { specified inputfile }
  91. inputdir : dirstr;
  92. inputfile : namestr;
  93. inputextension : extstr;
  94. { specified outputfile with -o parameter }
  95. outputfile : namestr;
  96. { specified with -FE or -FU }
  97. outputexedir : dirstr;
  98. outputunitdir : dirstr;
  99. { things specified with parameters }
  100. paralinkoptions,
  101. paradynamiclinker : string;
  102. paraprintnodetree : byte;
  103. parapreprocess : boolean;
  104. printnodefile : text;
  105. { directory where the utils can be found (options -FD) }
  106. utilsdirectory : dirstr;
  107. { some flags for global compiler switches }
  108. do_build,
  109. do_release,
  110. do_make : boolean;
  111. { path for searching units, different paths can be seperated by ; }
  112. exepath : dirstr; { Path to ppc }
  113. librarysearchpath,
  114. unitsearchpath,
  115. objectsearchpath,
  116. includesearchpath : TSearchPathList;
  117. { deffile }
  118. usewindowapi : boolean;
  119. description : string;
  120. dllversion : string;
  121. dllmajor,dllminor,dllrevision : word; { revision only for netware }
  122. akttokenpos, { position of the last token }
  123. aktfilepos : tfileposinfo; { current position }
  124. { ad 18.05.2001: Screen and Threadname for Netware }
  125. nwscreenname : string;
  126. nwthreadname : string;
  127. nwcopyright : string;
  128. block_type : tblock_type; { type of currently parsed block }
  129. parsing_para_level : integer; { parameter level, used to convert
  130. proc calls to proc loads in firstcalln }
  131. compile_level : word;
  132. make_ref : boolean;
  133. resolving_forward : boolean; { used to add forward reference as second ref }
  134. inlining_procedure : boolean; { are we inlining a procedure }
  135. exceptblockcounter : integer; { each except block gets a unique number check gotos }
  136. aktexceptblock : integer; { the exceptblock number of the current block (0 if none) }
  137. { commandline values }
  138. initdefines : tstringlist;
  139. initglobalswitches : tglobalswitches;
  140. initmoduleswitches : tmoduleswitches;
  141. initlocalswitches : tlocalswitches;
  142. initmodeswitches : tmodeswitches;
  143. {$IFDEF testvarsets}
  144. Initsetalloc, {0=fixed, 1 =var}
  145. {$ENDIF}
  146. initpackenum : longint;
  147. initalignment : talignmentinfo;
  148. initoptprocessor,
  149. initspecificoptprocessor : tprocessors;
  150. initfputype : tfputype;
  151. initasmmode : tasmmode;
  152. initinterfacetype : tinterfacetypes;
  153. initoutputformat : tasm;
  154. initdefproccall : tproccalloption;
  155. initsourcecodepage : tcodepagestring;
  156. { current state values }
  157. aktglobalswitches : tglobalswitches;
  158. aktmoduleswitches : tmoduleswitches;
  159. aktlocalswitches : tlocalswitches;
  160. nextaktlocalswitches : tlocalswitches;
  161. localswitcheschanged : boolean;
  162. aktmodeswitches : tmodeswitches;
  163. {$IFDEF testvarsets}
  164. aktsetalloc,
  165. {$ENDIF}
  166. aktpackenum : longint;
  167. aktmaxfpuregisters : longint;
  168. aktalignment : talignmentinfo;
  169. aktoptprocessor,
  170. aktspecificoptprocessor : tprocessors;
  171. aktfputype : tfputype;
  172. aktasmmode : tasmmode;
  173. aktinterfacetype : tinterfacetypes;
  174. aktoutputformat : tasm;
  175. aktdefproccall : tproccalloption;
  176. aktsourcecodepage : tcodepagestring;
  177. { Memory sizes }
  178. heapsize,
  179. stacksize : longint;
  180. {$Ifdef EXTDEBUG}
  181. { parameter switches }
  182. debugstop : boolean;
  183. {$EndIf EXTDEBUG}
  184. { windows / OS/2 application type }
  185. apptype : tapptype;
  186. const
  187. RelocSection : boolean = true;
  188. RelocSectionSetExplicitly : boolean = false;
  189. LinkTypeSetExplicitly : boolean = false;
  190. DLLsource : boolean = false;
  191. DLLImageBase : pstring = nil;
  192. UseDeffileForExport : boolean = true;
  193. ForceDeffileForExport : boolean = false;
  194. { used to set all registers used for each global function
  195. this should dramatically decrease the number of
  196. recompilations needed PM }
  197. simplify_ppu : boolean = true;
  198. { should we allow non static members ? }
  199. allow_only_static : boolean = false;
  200. Inside_asm_statement : boolean = false;
  201. global_unit_count : word = 0;
  202. { for error info in pp.pas }
  203. parser_current_file : string = '';
  204. {$ifdef m68k}
  205. { PalmOS resources }
  206. palmos_applicationname : string = 'FPC Application';
  207. palmos_applicationid : string[4] = 'FPCA';
  208. {$endif m68k}
  209. procedure abstract;
  210. function bstoslash(const s : string) : string;
  211. function getdatestr:string;
  212. function gettimestr:string;
  213. function filetimestring( t : longint) : string;
  214. procedure DefaultReplacements(var s:string);
  215. function GetCurrentDir:string;
  216. function path_absolute(const s : string) : boolean;
  217. Function PathExists ( F : String) : Boolean;
  218. Function FileExists ( Const F : String) : Boolean;
  219. Function RemoveFile(const f:string):boolean;
  220. Function RemoveDir(d:string):boolean;
  221. Function GetFileTime ( Var F : File) : Longint;
  222. Function GetNamedFileTime ( Const F : String) : Longint;
  223. Function SplitPath(const s:string):string;
  224. Function SplitFileName(const s:string):string;
  225. Function SplitName(const s:string):string;
  226. Function SplitExtension(Const HStr:String):String;
  227. Function AddExtension(Const HStr,ext:String):String;
  228. Function ForceExtension(Const HStr,ext:String):String;
  229. Function FixPath(s:string;allowdot:boolean):string;
  230. function FixFileName(const s:string):string;
  231. function TargetFixPath(s:string;allowdot:boolean):string;
  232. function TargetFixFileName(const s:string):string;
  233. procedure SplitBinCmd(const s:string;var bstr,cstr:string);
  234. function FindFile(const f : string;path : string;var foundfile:string):boolean;
  235. function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
  236. function FindExe(const bin:string;var foundfile:string):boolean;
  237. function GetShortName(const n:string):string;
  238. Procedure Shell(const command:string);
  239. function GetEnvPChar(const envname:string):pchar;
  240. procedure FreeEnvPChar(p:pchar);
  241. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  242. function SetAktProcCall(const s:string; changeInit: boolean):boolean;
  243. procedure InitGlobals;
  244. procedure DoneGlobals;
  245. function string2guid(const s: string; var GUID: TGUID): boolean;
  246. function guid2string(const GUID: TGUID): string;
  247. procedure swap_qword(var q : qword);
  248. function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
  249. {# Routine to get the required alignment for size of data, which will
  250. be placed in bss segment, according to the current alignment requirements }
  251. function var_align(siz: longint): longint;
  252. {# Routine to get the required alignment for size of data, which will
  253. be placed in data/const segment, according to the current alignment requirements }
  254. function const_align(siz: longint): longint;
  255. implementation
  256. uses
  257. comphook;
  258. procedure abstract;
  259. begin
  260. do_internalerror(255);
  261. end;
  262. procedure WarnNonExistingPath(const path : string);
  263. begin
  264. if assigned({$ifndef FPCPROCVAR}@{$endif}do_comment) then
  265. do_comment(V_Hint,'Path "'+path+'" not found');
  266. end;
  267. function bstoslash(const s : string) : string;
  268. {
  269. return string s with all \ changed into /
  270. }
  271. var
  272. i : longint;
  273. begin
  274. for i:=1to length(s) do
  275. if s[i]='\' then
  276. bstoslash[i]:='/'
  277. else
  278. bstoslash[i]:=s[i];
  279. bstoslash[0]:=s[0];
  280. end;
  281. {****************************************************************************
  282. Time Handling
  283. ****************************************************************************}
  284. Function L0(l:longint):string;
  285. {
  286. return the string of value l, if l<10 then insert a zero, so
  287. the string is always at least 2 chars '01','02',etc
  288. }
  289. var
  290. s : string;
  291. begin
  292. Str(l,s);
  293. if l<10 then
  294. s:='0'+s;
  295. L0:=s;
  296. end;
  297. function gettimestr:string;
  298. {
  299. get the current time in a string HH:MM:SS
  300. }
  301. var
  302. hour,min,sec,hsec : word;
  303. begin
  304. {$ifdef delphi}
  305. dmisc.gettime(hour,min,sec,hsec);
  306. {$else delphi}
  307. dos.gettime(hour,min,sec,hsec);
  308. {$endif delphi}
  309. gettimestr:=L0(Hour)+':'+L0(min)+':'+L0(sec);
  310. end;
  311. function getdatestr:string;
  312. {
  313. get the current date in a string YY/MM/DD
  314. }
  315. var
  316. Year,Month,Day,Wday : Word;
  317. begin
  318. {$ifdef delphi}
  319. dmisc.getdate(year,month,day,wday);
  320. {$else}
  321. dos.getdate(year,month,day,wday);
  322. {$endif}
  323. getdatestr:=L0(Year)+'/'+L0(Month)+'/'+L0(Day);
  324. end;
  325. function filetimestring( t : longint) : string;
  326. {
  327. convert dos datetime t to a string YY/MM/DD HH:MM:SS
  328. }
  329. var
  330. DT : DateTime;
  331. begin
  332. if t=-1 then
  333. begin
  334. FileTimeString:='Not Found';
  335. exit;
  336. end;
  337. unpacktime(t,DT);
  338. filetimestring:=L0(dt.Year)+'/'+L0(dt.Month)+'/'+L0(dt.Day)+' '+L0(dt.Hour)+':'+L0(dt.min)+':'+L0(dt.sec);
  339. end;
  340. {****************************************************************************
  341. Default Macro Handling
  342. ****************************************************************************}
  343. procedure DefaultReplacements(var s:string);
  344. begin
  345. { Replace some macro's }
  346. Replace(s,'$FPCVER',version_string);
  347. Replace(s,'$VERSION',version_string);
  348. Replace(s,'$FULLVERSION',full_version_string);
  349. Replace(s,'$FPCDATE',date_string);
  350. Replace(s,'$FPCTARGET',target_cpu_string);
  351. Replace(s,'$FPCCPU',target_cpu_string);
  352. Replace(s,'$TARGET',target_path);
  353. Replace(s,'$FPCOS',target_path);
  354. end;
  355. {****************************************************************************
  356. File Handling
  357. ****************************************************************************}
  358. function GetCurrentDir:string;
  359. var
  360. CurrentDir : string;
  361. begin
  362. GetDir(0,CurrentDir);
  363. GetCurrentDir:=FixPath(CurrentDir,false);
  364. end;
  365. function path_absolute(const s : string) : boolean;
  366. {
  367. is path s an absolute path?
  368. }
  369. begin
  370. path_absolute:=false;
  371. {$ifdef unix}
  372. if (length(s)>0) and (s[1]='/') then
  373. path_absolute:=true;
  374. {$else unix}
  375. {$ifdef amiga}
  376. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
  377. path_absolute:=true;
  378. {$else}
  379. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
  380. ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
  381. path_absolute:=true;
  382. {$endif amiga}
  383. {$endif unix}
  384. end;
  385. {$ifndef FPC}
  386. Procedure FindClose(var Info : SearchRec);
  387. Begin
  388. End;
  389. {$endif not FPC}
  390. Function FileExists ( Const F : String) : Boolean;
  391. Var
  392. res : boolean;
  393. {$ifndef delphi}
  394. Info : SearchRec;
  395. {$endif}
  396. begin
  397. {$ifdef delphi}
  398. res:=sysutils.FileExists(f);
  399. {$else}
  400. findfirst(F,readonly+archive+hidden,info);
  401. res:=(doserror=0);
  402. findclose(Info);
  403. {$endif delphi}
  404. if assigned({$ifndef FPCPROVCAR}@{$endif}do_comment) then
  405. begin
  406. if res then
  407. do_comment(V_Tried,'Searching file '+F+'... found')
  408. else
  409. do_comment(V_Tried,'Searching file '+F+'... not found');
  410. end;
  411. FileExists:=res;
  412. end;
  413. Function PathExists ( F : String) : Boolean;
  414. Var
  415. Info : SearchRec;
  416. disk : byte;
  417. begin
  418. { these operating systems have dos type drives }
  419. if source_info.system in [system_m68k_atari,system_i386_go32v2,
  420. system_i386_win32,system_i386_os2,
  421. system_i386_emx,system_i386_wdosx] then
  422. Begin
  423. if (Length(f)=3) and (F[2]=':') and (F[3] in ['/','\']) then
  424. begin
  425. if F[1] in ['A'..'Z'] then
  426. disk:=ord(F[1])-ord('A')+1
  427. else if F[1] in ['a'..'z'] then
  428. disk:=ord(F[1])-ord('a')+1
  429. else
  430. disk:=255;
  431. if disk=255 then
  432. PathExists:=false
  433. else
  434. PathExists:=(DiskSize(disk)<>-1);
  435. exit;
  436. end;
  437. end;
  438. if F[Length(f)] in ['/','\'] then
  439. Delete(f,length(f),1);
  440. findfirst(F,readonly+archive+hidden+directory,info);
  441. PathExists:=(doserror=0) and ((info.attr and directory)=directory);
  442. findclose(Info);
  443. end;
  444. Function RemoveFile(const f:string):boolean;
  445. var
  446. g : file;
  447. begin
  448. assign(g,f);
  449. {$I-}
  450. erase(g);
  451. {$I+}
  452. RemoveFile:=(ioresult=0);
  453. end;
  454. Function RemoveDir(d:string):boolean;
  455. begin
  456. if d[length(d)]=source_info.DirSep then
  457. Delete(d,length(d),1);
  458. {$I-}
  459. rmdir(d);
  460. {$I+}
  461. RemoveDir:=(ioresult=0);
  462. end;
  463. Function SplitPath(const s:string):string;
  464. var
  465. i : longint;
  466. begin
  467. i:=Length(s);
  468. while (i>0) and not(s[i] in ['/','\']) do
  469. dec(i);
  470. SplitPath:=Copy(s,1,i);
  471. end;
  472. Function SplitFileName(const s:string):string;
  473. var
  474. p : dirstr;
  475. n : namestr;
  476. e : extstr;
  477. begin
  478. FSplit(s,p,n,e);
  479. SplitFileName:=n+e;
  480. end;
  481. Function SplitName(const s:string):string;
  482. var
  483. i,j : longint;
  484. begin
  485. i:=Length(s);
  486. j:=Length(s);
  487. while (i>0) and not(s[i] in ['/','\']) do
  488. dec(i);
  489. while (j>0) and (s[j]<>'.') do
  490. dec(j);
  491. if j<=i then
  492. j:=255;
  493. SplitName:=Copy(s,i+1,j-(i+1));
  494. end;
  495. Function SplitExtension(Const HStr:String):String;
  496. var
  497. j : longint;
  498. begin
  499. j:=length(Hstr);
  500. while (j>0) and (Hstr[j]<>'.') do
  501. begin
  502. if hstr[j]=source_info.DirSep then
  503. j:=0
  504. else
  505. dec(j);
  506. end;
  507. if j=0 then
  508. j:=254;
  509. SplitExtension:=Copy(Hstr,j,255);
  510. end;
  511. Function AddExtension(Const HStr,ext:String):String;
  512. begin
  513. if (Ext<>'') and (SplitExtension(HStr)='') then
  514. AddExtension:=Hstr+Ext
  515. else
  516. AddExtension:=Hstr;
  517. end;
  518. Function ForceExtension(Const HStr,ext:String):String;
  519. var
  520. j : longint;
  521. begin
  522. j:=length(Hstr);
  523. while (j>0) and (Hstr[j]<>'.') do
  524. dec(j);
  525. if j=0 then
  526. j:=255;
  527. ForceExtension:=Copy(Hstr,1,j-1)+Ext;
  528. end;
  529. Function FixPath(s:string;allowdot:boolean):string;
  530. var
  531. i : longint;
  532. begin
  533. { Fix separator }
  534. for i:=1 to length(s) do
  535. if s[i] in ['/','\'] then
  536. s[i]:=source_info.DirSep;
  537. { Fix ending / }
  538. if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
  539. (s[length(s)]<>':') then
  540. s:=s+source_info.DirSep;
  541. { Remove ./ }
  542. if (not allowdot) and (s='.'+source_info.DirSep) then
  543. s:='';
  544. { return }
  545. if source_info.files_case_relevent then
  546. FixPath:=s
  547. else
  548. FixPath:=Lower(s);
  549. end;
  550. function FixFileName(const s:string):string;
  551. var
  552. i : longint;
  553. begin
  554. if source_info.files_case_relevent then
  555. begin
  556. for i:=1 to length(s) do
  557. begin
  558. case s[i] of
  559. '/','\' :
  560. FixFileName[i]:=source_info.dirsep;
  561. else
  562. FixFileName[i]:=s[i];
  563. end;
  564. end;
  565. end
  566. else
  567. begin
  568. for i:=1 to length(s) do
  569. begin
  570. case s[i] of
  571. '/','\' :
  572. FixFileName[i]:=source_info.dirsep;
  573. 'A'..'Z' :
  574. FixFileName[i]:=char(byte(s[i])+32);
  575. else
  576. FixFileName[i]:=s[i];
  577. end;
  578. end;
  579. end;
  580. FixFileName[0]:=s[0];
  581. end;
  582. Function TargetFixPath(s:string;allowdot:boolean):string;
  583. var
  584. i : longint;
  585. begin
  586. { Fix separator }
  587. for i:=1 to length(s) do
  588. if s[i] in ['/','\'] then
  589. s[i]:=target_info.DirSep;
  590. { Fix ending / }
  591. if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
  592. (s[length(s)]<>':') then
  593. s:=s+target_info.DirSep;
  594. { Remove ./ }
  595. if (not allowdot) and (s='.'+target_info.DirSep) then
  596. s:='';
  597. { return }
  598. if target_info.files_case_relevent then
  599. TargetFixPath:=s
  600. else
  601. TargetFixPath:=Lower(s);
  602. end;
  603. function TargetFixFileName(const s:string):string;
  604. var
  605. i : longint;
  606. begin
  607. if target_info.files_case_relevent then
  608. begin
  609. for i:=1 to length(s) do
  610. begin
  611. case s[i] of
  612. '/','\' :
  613. TargetFixFileName[i]:=target_info.dirsep;
  614. else
  615. TargetFixFileName[i]:=s[i];
  616. end;
  617. end;
  618. end
  619. else
  620. begin
  621. for i:=1 to length(s) do
  622. begin
  623. case s[i] of
  624. '/','\' :
  625. TargetFixFileName[i]:=target_info.dirsep;
  626. 'A'..'Z' :
  627. TargetFixFileName[i]:=char(byte(s[i])+32);
  628. else
  629. TargetFixFileName[i]:=s[i];
  630. end;
  631. end;
  632. end;
  633. TargetFixFileName[0]:=s[0];
  634. end;
  635. procedure SplitBinCmd(const s:string;var bstr,cstr:string);
  636. var
  637. i : longint;
  638. begin
  639. i:=pos(' ',s);
  640. if i>0 then
  641. begin
  642. bstr:=Copy(s,1,i-1);
  643. cstr:=Copy(s,i+1,length(s)-i);
  644. end
  645. else
  646. begin
  647. bstr:=s;
  648. cstr:='';
  649. end;
  650. end;
  651. procedure TSearchPathList.AddPath(s:string;addfirst:boolean);
  652. begin
  653. AddPath('',s,AddFirst);
  654. end;
  655. procedure TSearchPathList.AddPath(SrcPath,s:string;addfirst:boolean);
  656. var
  657. j : longint;
  658. hs,hsd,
  659. CurrentDir,
  660. CurrPath : string;
  661. subdirfound : boolean;
  662. dir : searchrec;
  663. hp : TStringListItem;
  664. procedure addcurrpath;
  665. begin
  666. if addfirst then
  667. begin
  668. Remove(currPath);
  669. Insert(currPath);
  670. end
  671. else
  672. begin
  673. { Check if already in path, then we don't add it }
  674. hp:=Find(currPath);
  675. if not assigned(hp) then
  676. Concat(currPath);
  677. end;
  678. end;
  679. begin
  680. if s='' then
  681. exit;
  682. { Support default macro's }
  683. DefaultReplacements(s);
  684. { get current dir }
  685. CurrentDir:=GetCurrentDir;
  686. repeat
  687. { get currpath }
  688. if addfirst then
  689. begin
  690. j:=length(s);
  691. while (j>0) and (s[j]<>';') do
  692. dec(j);
  693. CurrPath:=FixPath(Copy(s,j+1,length(s)-j),false);
  694. if j=0 then
  695. s:=''
  696. else
  697. System.Delete(s,j,length(s)-j+1);
  698. end
  699. else
  700. begin
  701. j:=Pos(';',s);
  702. if j=0 then
  703. j:=255;
  704. CurrPath:=SrcPath+FixPath(Copy(s,1,j-1),false);
  705. System.Delete(s,1,j);
  706. end;
  707. { fix pathname }
  708. if CurrPath='' then
  709. CurrPath:='.'+source_info.DirSep
  710. else
  711. begin
  712. CurrPath:=FixPath(FExpand(CurrPath),false);
  713. if (CurrentDir<>'') and (Copy(CurrPath,1,length(CurrentDir))=CurrentDir) then
  714. begin
  715. {$ifdef AMIGA}
  716. CurrPath:=CurrentDir+Copy(CurrPath,length(CurrentDir)+1,255);
  717. {$else}
  718. CurrPath:='.'+source_info.DirSep+Copy(CurrPath,length(CurrentDir)+1,255);
  719. {$endif}
  720. end;
  721. end;
  722. { wildcard adding ? }
  723. if pos('*',currpath)>0 then
  724. begin
  725. if currpath[length(currpath)]=source_info.dirsep then
  726. hs:=Copy(currpath,1,length(CurrPath)-1)
  727. else
  728. hs:=currpath;
  729. hsd:=SplitPath(hs);
  730. findfirst(hs,directory,dir);
  731. subdirfound:=false;
  732. while doserror=0 do
  733. begin
  734. if (dir.name<>'.') and
  735. (dir.name<>'..') and
  736. ((dir.attr and directory)<>0) then
  737. begin
  738. subdirfound:=true;
  739. currpath:=hsd+dir.name+source_info.dirsep;
  740. hp:=Find(currPath);
  741. if not assigned(hp) then
  742. AddCurrPath;
  743. end;
  744. findnext(dir);
  745. if not subdirfound then
  746. WarnNonExistingPath(currpath);
  747. end;
  748. FindClose(dir);
  749. end
  750. else
  751. begin
  752. if PathExists(currpath) then
  753. addcurrpath
  754. else
  755. WarnNonExistingPath(currpath);
  756. end;
  757. until (s='');
  758. end;
  759. procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
  760. var
  761. s : string;
  762. hl : TSearchPathList;
  763. hp,hp2 : TStringListItem;
  764. begin
  765. if list.empty then
  766. exit;
  767. { create temp and reverse the list }
  768. if addfirst then
  769. begin
  770. hl:=TSearchPathList.Create;
  771. hp:=TStringListItem(list.first);
  772. while assigned(hp) do
  773. begin
  774. hl.insert(hp.Str);
  775. hp:=TStringListItem(hp.next);
  776. end;
  777. while not hl.empty do
  778. begin
  779. s:=hl.GetFirst;
  780. Remove(s);
  781. Insert(s);
  782. end;
  783. hl.Free;
  784. end
  785. else
  786. begin
  787. hp:=TStringListItem(list.first);
  788. while assigned(hp) do
  789. begin
  790. hp2:=Find(hp.Str);
  791. { Check if already in path, then we don't add it }
  792. if not assigned(hp2) then
  793. Concat(hp.Str);
  794. hp:=TStringListItem(hp.next);
  795. end;
  796. end;
  797. end;
  798. function TSearchPathList.FindFile(const f : string;var foundfile:string):boolean;
  799. Var
  800. p : TStringListItem;
  801. begin
  802. FindFile:=false;
  803. p:=TStringListItem(first);
  804. while assigned(p) do
  805. begin
  806. {
  807. Search order for case sensitive systems:
  808. 1. lowercase
  809. 2. NormalCase
  810. 3. UPPERCASE
  811. None case sensitive only lowercase
  812. }
  813. FoundFile:=p.Str+Lower(f);
  814. If FileExists(FoundFile) then
  815. begin
  816. FindFile:=true;
  817. exit;
  818. end;
  819. {$ifdef UNIX}
  820. FoundFile:=p.Str+f;
  821. If FileExists(FoundFile) then
  822. begin
  823. FindFile:=true;
  824. exit;
  825. end;
  826. FoundFile:=p.Str+Upper(f);
  827. If FileExists(FoundFile) then
  828. begin
  829. FindFile:=true;
  830. exit;
  831. end;
  832. {$endif UNIX}
  833. p:=TStringListItem(p.next);
  834. end;
  835. { Return original filename if not found }
  836. FoundFile:=f;
  837. end;
  838. Function GetFileTime ( Var F : File) : Longint;
  839. Var
  840. {$ifdef hasunix}
  841. Info : Stat;
  842. {$endif}
  843. L : longint;
  844. begin
  845. {$ifdef hasunix}
  846. FStat (F,Info);
  847. L:=Info.Mtime;
  848. {$else}
  849. GetFTime(f,l);
  850. {$endif}
  851. GetFileTime:=L;
  852. end;
  853. Function GetNamedFileTime (Const F : String) : Longint;
  854. begin
  855. GetNamedFileTime:=do_getnamedfiletime(F);
  856. end;
  857. function FindFile(const f : string;path : string;var foundfile:string):boolean;
  858. Var
  859. singlepathstring : string;
  860. i : longint;
  861. begin
  862. {$ifdef Unix}
  863. for i:=1 to length(path) do
  864. if path[i]=':' then
  865. path[i]:=';';
  866. {$endif Unix}
  867. FindFile:=false;
  868. repeat
  869. i:=pos(';',path);
  870. if i=0 then
  871. i:=256;
  872. singlepathstring:=FixPath(copy(path,1,i-1),false);
  873. delete(path,1,i);
  874. {
  875. Search order for case sensitive systems:
  876. 1. lowercase
  877. 2. NormalCase
  878. 3. UPPERCASE
  879. None case sensitive only lowercase
  880. }
  881. FoundFile:=singlepathstring+Lower(f);
  882. If FileExists(FoundFile) then
  883. begin
  884. FindFile:=true;
  885. exit;
  886. end;
  887. {$ifdef UNIX}
  888. FoundFile:=singlepathstring+f;
  889. If FileExists(FoundFile) then
  890. begin
  891. FindFile:=true;
  892. exit;
  893. end;
  894. FoundFile:=singlepathstring+Upper(f);
  895. If FileExists(FoundFile) then
  896. begin
  897. FindFile:=true;
  898. exit;
  899. end;
  900. {$endif UNIX}
  901. until path='';
  902. FoundFile:=f;
  903. end;
  904. function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
  905. Var
  906. singlepathstring : string;
  907. startpc,pc : pchar;
  908. sepch : char;
  909. begin
  910. {$ifdef Unix}
  911. sepch:=':';
  912. {$else}
  913. sepch:=';';
  914. {$endif Unix}
  915. FindFilePchar:=false;
  916. pc:=path;
  917. repeat
  918. startpc:=pc;
  919. while (pc^<>sepch) and (pc^<>';') and (pc^<>#0) do
  920. inc(pc);
  921. move(startpc^,singlepathstring[1],pc-startpc);
  922. singlepathstring[0]:=char(longint(pc-startpc));
  923. singlepathstring:=FixPath(singlepathstring,false);
  924. {
  925. Search order for case sensitive systems:
  926. 1. lowercase
  927. 2. NormalCase
  928. 3. UPPERCASE
  929. None case sensitive only lowercase
  930. }
  931. FoundFile:=singlepathstring+Lower(f);
  932. If FileExists(FoundFile) then
  933. begin
  934. FindFilePchar:=true;
  935. exit;
  936. end;
  937. {$ifdef UNIX}
  938. FoundFile:=singlepathstring+f;
  939. If FileExists(FoundFile) then
  940. begin
  941. FindFilePchar:=true;
  942. exit;
  943. end;
  944. FoundFile:=singlepathstring+Upper(f);
  945. If FileExists(FoundFile) then
  946. begin
  947. FindFilePchar:=true;
  948. exit;
  949. end;
  950. {$endif UNIX}
  951. if (pc^=#0) then
  952. break;
  953. inc(pc);
  954. until false;
  955. end;
  956. function FindExe(const bin:string;var foundfile:string):boolean;
  957. var
  958. p : pchar;
  959. found : boolean;
  960. begin
  961. found:=FindFile(FixFileName(AddExtension(bin,source_info.exeext)),'.;'+exepath,foundfile);
  962. if not found then
  963. begin
  964. p:=GetEnvPchar('PATH');
  965. found:=FindFilePChar(FixFileName(AddExtension(bin,source_info.exeext)),p,foundfile);
  966. FreeEnvPChar(p);
  967. end;
  968. FindExe:=found;
  969. end;
  970. function GetShortName(const n:string):string;
  971. {$ifdef win32}
  972. var
  973. hs,hs2 : string;
  974. i : longint;
  975. {$endif}
  976. {$ifdef go32v2}
  977. var
  978. hs : string;
  979. {$endif}
  980. begin
  981. GetShortName:=n;
  982. {$ifdef win32}
  983. hs:=n+#0;
  984. i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
  985. if (i>0) and (i<=high(hs2)) then
  986. begin
  987. hs2[0]:=chr(strlen(@hs2[1]));
  988. GetShortName:=hs2;
  989. end;
  990. {$endif}
  991. {$ifdef go32v2}
  992. hs:=n;
  993. if Dos.GetShortName(hs) then
  994. GetShortName:=hs;
  995. {$endif}
  996. end;
  997. {****************************************************************************
  998. OS Dependent things
  999. ****************************************************************************}
  1000. function GetEnvPChar(const envname:string):pchar;
  1001. {$ifdef win32}
  1002. var
  1003. s : string;
  1004. i,len : longint;
  1005. hp,p,p2 : pchar;
  1006. {$endif}
  1007. begin
  1008. {$ifdef hasunix}
  1009. GetEnvPchar:={$ifdef ver1_0}Linux{$else}Unix{$endif}.Getenv(envname);
  1010. {$define GETENVOK}
  1011. {$endif}
  1012. {$ifdef win32}
  1013. GetEnvPchar:=nil;
  1014. p:=GetEnvironmentStrings;
  1015. hp:=p;
  1016. while hp^<>#0 do
  1017. begin
  1018. s:=strpas(hp);
  1019. i:=pos('=',s);
  1020. len:=strlen(hp);
  1021. if upper(copy(s,1,i-1))=upper(envname) then
  1022. begin
  1023. GetMem(p2,len-length(envname));
  1024. Move(hp[i],p2^,len-length(envname));
  1025. GetEnvPchar:=p2;
  1026. break;
  1027. end;
  1028. { next string entry}
  1029. hp:=hp+len+1;
  1030. end;
  1031. FreeEnvironmentStrings(p);
  1032. {$define GETENVOK}
  1033. {$endif}
  1034. {$ifdef os2}
  1035. GetEnvPChar := Dos.GetEnvPChar (EnvName);
  1036. {$define GETENVOK}
  1037. {$endif}
  1038. {$ifdef GETENVOK}
  1039. {$undef GETENVOK}
  1040. {$else}
  1041. GetEnvPchar:=StrPNew({$ifdef delphi}DMisc{$else}Dos{$endif}.Getenv(envname));
  1042. {$endif}
  1043. end;
  1044. procedure FreeEnvPChar(p:pchar);
  1045. begin
  1046. {$ifndef hasunix}
  1047. {$ifndef os2}
  1048. StrDispose(p);
  1049. {$endif}
  1050. {$endif}
  1051. end;
  1052. Procedure Shell(const command:string);
  1053. { This is already defined in the linux.ppu for linux, need for the *
  1054. expansion under linux }
  1055. {$ifdef hasunix}
  1056. begin
  1057. {$ifdef ver1_0}Linux{$else}Unix{$endif}.Shell(command);
  1058. end;
  1059. {$else}
  1060. {$ifdef amiga}
  1061. begin
  1062. exec('',command);
  1063. end;
  1064. {$else}
  1065. var
  1066. comspec : string;
  1067. begin
  1068. comspec:=getenv('COMSPEC');
  1069. Exec(comspec,' /C '+command);
  1070. end;
  1071. {$endif}
  1072. {$endif}
  1073. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  1074. var
  1075. b : boolean;
  1076. begin
  1077. b:=true;
  1078. if s='DEFAULT' then
  1079. aktmodeswitches:=initmodeswitches
  1080. else
  1081. if s='DELPHI' then
  1082. aktmodeswitches:=delphimodeswitches
  1083. else
  1084. if s='TP' then
  1085. aktmodeswitches:=tpmodeswitches
  1086. else
  1087. if s='FPC' then
  1088. aktmodeswitches:=fpcmodeswitches
  1089. else
  1090. if s='OBJFPC' then
  1091. aktmodeswitches:=objfpcmodeswitches
  1092. else
  1093. if s='GPC' then
  1094. aktmodeswitches:=gpcmodeswitches
  1095. else
  1096. b:=false;
  1097. if b and changeInit then
  1098. initmodeswitches := aktmodeswitches;
  1099. if b then
  1100. begin
  1101. { turn ansistrings on by default ? }
  1102. if (m_delphi in aktmodeswitches) then
  1103. begin
  1104. include(aktlocalswitches,cs_ansistrings);
  1105. if changeinit then
  1106. include(initlocalswitches,cs_ansistrings);
  1107. end
  1108. else
  1109. begin
  1110. exclude(aktlocalswitches,cs_ansistrings);
  1111. if changeinit then
  1112. exclude(initlocalswitches,cs_ansistrings);
  1113. end;
  1114. { enum packing }
  1115. if (m_tp7 in aktmodeswitches) then
  1116. aktpackenum:=1
  1117. else
  1118. aktpackenum:=4;
  1119. if changeinit then
  1120. initpackenum:=aktpackenum;
  1121. end;
  1122. SetCompileMode:=b;
  1123. end;
  1124. function SetAktProcCall(const s:string; changeInit:boolean):boolean;
  1125. const
  1126. DefProcCallName : array[tproccalloption] of string[12] = ('',
  1127. 'CDECL',
  1128. 'CPPDECL',
  1129. '', { compilerproc }
  1130. 'FAR16',
  1131. 'FPCCALL',
  1132. 'INLINE',
  1133. '', { internproc }
  1134. '', { palmossyscall }
  1135. 'PASCAL',
  1136. 'REGISTER',
  1137. 'SAFECALL',
  1138. 'STDCALL'
  1139. );
  1140. var
  1141. t : tproccalloption;
  1142. begin
  1143. SetAktProcCall:=false;
  1144. for t:=low(tproccalloption) to high(tproccalloption) do
  1145. if DefProcCallName[t]=s then
  1146. begin
  1147. AktDefProcCall:=t;
  1148. SetAktProcCall:=true;
  1149. break;
  1150. end;
  1151. if changeinit then
  1152. InitDefProcCall:=AktDefProcCall;
  1153. end;
  1154. { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
  1155. function string2guid(const s: string; var GUID: TGUID): boolean;
  1156. function ishexstr(const hs: string): boolean;
  1157. var
  1158. i: integer;
  1159. begin
  1160. ishexstr:=false;
  1161. for i:=1 to Length(hs) do begin
  1162. if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
  1163. exit;
  1164. end;
  1165. ishexstr:=true;
  1166. end;
  1167. function hexstr2longint(const hexs: string): longint;
  1168. var
  1169. i: integer;
  1170. rl: longint;
  1171. begin
  1172. rl:=0;
  1173. for i:=1 to length(hexs) do begin
  1174. rl:=rl shl 4;
  1175. case hexs[i] of
  1176. '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
  1177. 'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
  1178. 'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
  1179. end
  1180. end;
  1181. hexstr2longint:=rl;
  1182. end;
  1183. var
  1184. i: integer;
  1185. begin
  1186. if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
  1187. (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
  1188. ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
  1189. ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
  1190. ishexstr(copy(s,26,12)) then begin
  1191. GUID.D1:=dword(hexstr2longint(copy(s,2,8)));
  1192. { these values are arealdy in the correct range (4 chars = word) }
  1193. GUID.D2:=word(hexstr2longint(copy(s,11,4)));
  1194. GUID.D3:=word(hexstr2longint(copy(s,16,4)));
  1195. for i:=0 to 1 do
  1196. GUID.D4[i]:=byte(hexstr2longint(copy(s,21+i*2,2)));
  1197. for i:=2 to 7 do
  1198. GUID.D4[i]:=byte(hexstr2longint(copy(s,22+i*2,2)));
  1199. string2guid:=true;
  1200. end
  1201. else
  1202. string2guid:=false;
  1203. end;
  1204. function guid2string(const GUID: TGUID): string;
  1205. function long2hex(l, len: longint): string;
  1206. const
  1207. hextbl: array[0..15] of char = '0123456789ABCDEF';
  1208. var
  1209. rs: string;
  1210. i: integer;
  1211. begin
  1212. rs[0]:=chr(len);
  1213. for i:=len downto 1 do begin
  1214. rs[i]:=hextbl[l and $F];
  1215. l:=l shr 4;
  1216. end;
  1217. long2hex:=rs;
  1218. end;
  1219. begin
  1220. guid2string:=
  1221. '{'+long2hex(GUID.D1,8)+
  1222. '-'+long2hex(GUID.D2,4)+
  1223. '-'+long2hex(GUID.D3,4)+
  1224. '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
  1225. '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
  1226. long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
  1227. long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
  1228. '}';
  1229. end;
  1230. procedure swap_qword(var q : qword);
  1231. begin
  1232. q:=(qword(lo(q)) shl 32) or hi(q);
  1233. end;
  1234. function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
  1235. var
  1236. tok : string;
  1237. vstr : string;
  1238. l : longint;
  1239. code : integer;
  1240. b : talignmentinfo;
  1241. begin
  1242. UpdateAlignmentStr:=true;
  1243. uppervar(s);
  1244. fillchar(b,sizeof(b),0);
  1245. repeat
  1246. tok:=GetToken(s,'=');
  1247. if tok='' then
  1248. break;
  1249. vstr:=GetToken(s,',');
  1250. val(vstr,l,code);
  1251. if tok='PROC' then
  1252. b.procalign:=l
  1253. else if tok='JUMP' then
  1254. b.jumpalign:=l
  1255. else if tok='LOOP' then
  1256. b.loopalign:=l
  1257. else if tok='CONSTMIN' then
  1258. b.constalignmin:=l
  1259. else if tok='CONSTMAX' then
  1260. b.constalignmax:=l
  1261. else if tok='VARMIN' then
  1262. b.varalignmin:=l
  1263. else if tok='VARMAX' then
  1264. b.varalignmax:=l
  1265. else if tok='LOCALMIN' then
  1266. b.localalignmin:=l
  1267. else if tok='LOCALMAX' then
  1268. b.localalignmax:=l
  1269. else if tok='RECORDMIN' then
  1270. b.recordalignmin:=l
  1271. else if tok='RECORDMAX' then
  1272. b.recordalignmax:=l
  1273. else if tok='PARAALIGN' then
  1274. b.paraalign:=l
  1275. else { Error }
  1276. UpdateAlignmentStr:=false;
  1277. until false;
  1278. UpdateAlignment(a,b);
  1279. end;
  1280. function var_align(siz: longint): longint;
  1281. begin
  1282. siz := size_2_align(siz);
  1283. var_align := used_align(siz,aktalignment.varalignmin,aktalignment.varalignmax);
  1284. end;
  1285. function const_align(siz: longint): longint;
  1286. begin
  1287. siz := size_2_align(siz);
  1288. const_align := used_align(siz,aktalignment.constalignmin,aktalignment.constalignmax);
  1289. end;
  1290. {****************************************************************************
  1291. Init
  1292. ****************************************************************************}
  1293. {$ifdef unix}
  1294. {$define need_path_search}
  1295. {$endif unix}
  1296. {$ifdef os2}
  1297. {$define need_path_search}
  1298. {$endif os2}
  1299. procedure get_exepath;
  1300. var
  1301. hs1 : namestr;
  1302. hs2 : extstr;
  1303. p : pchar;
  1304. begin
  1305. {$ifdef delphi}
  1306. exepath:=dmisc.getenv('PPC_EXEC_PATH');
  1307. {$else delphi}
  1308. exepath:=dos.getenv('PPC_EXEC_PATH');
  1309. {$endif delphi}
  1310. if exepath='' then
  1311. fsplit(FixFileName(system.paramstr(0)),exepath,hs1,hs2);
  1312. {$ifdef need_path_search}
  1313. if exepath='' then
  1314. begin
  1315. if pos(source_info.exeext,hs1) <>
  1316. (length(hs1) - length(source_info.exeext)+1) then
  1317. hs1 := hs1 + source_info.exeext;
  1318. p:=GetEnvPchar('PATH');
  1319. FindFilePChar(hs1,p,exepath);
  1320. FreeEnvPChar(p);
  1321. exepath:=SplitPath(exepath);
  1322. end;
  1323. {$endif need_path_search}
  1324. exepath:=FixPath(exepath,false);
  1325. end;
  1326. procedure DoneGlobals;
  1327. begin
  1328. initdefines.free;
  1329. if assigned(DLLImageBase) then
  1330. StringDispose(DLLImageBase);
  1331. RelocSection:=true;
  1332. RelocSectionSetExplicitly:=false;
  1333. UseDeffileForExport:=true;
  1334. librarysearchpath.Free;
  1335. unitsearchpath.Free;
  1336. objectsearchpath.Free;
  1337. includesearchpath.Free;
  1338. end;
  1339. procedure InitGlobals;
  1340. begin
  1341. get_exepath;
  1342. { reset globals }
  1343. do_build:=false;
  1344. do_release:=false;
  1345. do_make:=true;
  1346. compile_level:=0;
  1347. DLLsource:=false;
  1348. inlining_procedure:=false;
  1349. resolving_forward:=false;
  1350. make_ref:=false;
  1351. { Output }
  1352. OutputFile:='';
  1353. OutputExeDir:='';
  1354. OutputUnitDir:='';
  1355. { Utils directory }
  1356. utilsdirectory:='';
  1357. { Search Paths }
  1358. librarysearchpath:=TSearchPathList.Create;
  1359. unitsearchpath:=TSearchPathList.Create;
  1360. includesearchpath:=TSearchPathList.Create;
  1361. objectsearchpath:=TSearchPathList.Create;
  1362. { Def file }
  1363. usewindowapi:=false;
  1364. description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
  1365. dllversion:='';
  1366. nwscreenname := '';
  1367. nwthreadname := '';
  1368. nwcopyright := '';
  1369. { Init values }
  1370. initmodeswitches:=fpcmodeswitches;
  1371. initlocalswitches:=[cs_check_io,cs_typed_const_writable];
  1372. initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
  1373. initsourcecodepage:='8859-1';
  1374. initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
  1375. initoutputformat:=target_asm.id;
  1376. fillchar(initalignment,sizeof(talignmentinfo),0);
  1377. {$ifdef i386}
  1378. initoptprocessor:=Class386;
  1379. initspecificoptprocessor:=Class386;
  1380. initfputype:=fpu_x87;
  1381. initpackenum:=4;
  1382. {$IFDEF testvarsets}
  1383. initsetalloc:=0;
  1384. {$ENDIF}
  1385. initasmmode:=asmmode_i386_att;
  1386. {$endif i386}
  1387. {$ifdef m68k}
  1388. initoptprocessor:=MC68020;
  1389. initpackenum:=4;
  1390. {$IFDEF testvarsets}
  1391. initsetalloc:=0;
  1392. {$ENDIF}
  1393. initasmmode:=asmmode_standard;
  1394. {$endif m68k}
  1395. {$ifdef powerpc}
  1396. initoptprocessor:=PPC604;
  1397. initpackenum:=4;
  1398. {$IFDEF testvarsets}
  1399. initsetalloc:=0;
  1400. {$ENDIF}
  1401. initasmmode:=asmmode_direct;
  1402. initfputype:=fpu_standard;
  1403. {$endif powerpc}
  1404. {$ifdef sparc}
  1405. initoptprocessor:=SPARC_V8;
  1406. initpackenum:=4;
  1407. {$IFDEF testvarsets}
  1408. initsetalloc:=0;
  1409. {$ENDIF}
  1410. initasmmode:=asmmode_direct;
  1411. {$endif sparc}
  1412. {$ifdef arm}
  1413. initpackenum:=4;
  1414. {$IFDEF testvarsets}
  1415. initsetalloc:=0;
  1416. {$ENDIF}
  1417. initasmmode:=asmmode_direct;
  1418. initfputype:=fpu_fpa;
  1419. {$endif arm}
  1420. initinterfacetype:=it_interfacecom;
  1421. initdefproccall:=pocall_none;
  1422. initdefines:=TStringList.Create;
  1423. { memory sizes, will be overriden by parameter or default for target
  1424. in options or init_parser }
  1425. stacksize:=0;
  1426. heapsize:=0;
  1427. apptype:=app_cui;
  1428. end;
  1429. end.
  1430. {
  1431. $Log$
  1432. Revision 1.93 2003-09-03 11:18:36 florian
  1433. * fixed arm concatcopy
  1434. + arm support in the common compiler sources added
  1435. * moved some generic cg code around
  1436. + tfputype added
  1437. * ...
  1438. Revision 1.92 2003/05/23 22:33:48 florian
  1439. * fix some small flaws which prevent sparc linux system unit from compiling
  1440. * some reformatting done
  1441. Revision 1.91 2003/05/23 15:03:31 peter
  1442. * fix previous commit for unix
  1443. Revision 1.90 2003/05/23 14:39:56 peter
  1444. * FindFilePChar added to allow PATH variables > 256 chars
  1445. Revision 1.89 2003/05/15 18:58:53 peter
  1446. * removed selfpointer_offset, vmtpointer_offset
  1447. * tvarsym.adjusted_address
  1448. * address in localsymtable is now in the real direction
  1449. * removed some obsolete globals
  1450. Revision 1.88 2003/04/27 11:21:32 peter
  1451. * aktprocdef renamed to current_procdef
  1452. * procinfo renamed to current_procinfo
  1453. * procinfo will now be stored in current_module so it can be
  1454. cleaned up properly
  1455. * gen_main_procsym changed to create_main_proc and release_main_proc
  1456. to also generate a tprocinfo structure
  1457. * fixed unit implicit initfinal
  1458. Revision 1.87 2003/04/27 07:29:50 peter
  1459. * current_procdef cleanup, current_procdef is now always nil when parsing
  1460. a new procdef declaration
  1461. * aktprocsym removed
  1462. * lexlevel removed, use symtable.symtablelevel instead
  1463. * implicit init/final code uses the normal genentry/genexit
  1464. * funcret state checking updated for new funcret handling
  1465. Revision 1.86 2003/04/25 20:59:33 peter
  1466. * removed funcretn,funcretsym, function result is now in varsym
  1467. and aliases for result and function name are added using absolutesym
  1468. * vs_hidden parameter for funcret passed in parameter
  1469. * vs_hidden fixes
  1470. * writenode changed to printnode and released from extdebug
  1471. * -vp option added to generate a tree.log with the nodetree
  1472. * nicer printnode for statements, callnode
  1473. Revision 1.85 2003/04/22 14:33:38 peter
  1474. * removed some notes/hints
  1475. Revision 1.84 2003/03/23 23:21:42 hajny
  1476. + emx target added
  1477. Revision 1.83 2003/01/30 21:45:53 peter
  1478. * amiga path fix (merged)
  1479. Revision 1.82 2003/01/12 15:42:23 peter
  1480. * m68k pathexist update from 1.0.x
  1481. * palmos res update from 1.0.x
  1482. Revision 1.81 2003/01/10 21:49:00 marco
  1483. * more hasunix fixes
  1484. Revision 1.80 2003/01/04 16:20:44 hajny
  1485. * modified to make use of the common GetEnv code under OS/2
  1486. Revision 1.79 2002/12/25 01:26:17 peter
  1487. * delphi also has pointer archimetic
  1488. Revision 1.78 2002/12/07 14:27:07 carl
  1489. * 3% memory optimization
  1490. * changed some types
  1491. + added type checking with different size for call node and for
  1492. parameters
  1493. Revision 1.77 2002/12/06 17:50:00 peter
  1494. * amiga fixes merged
  1495. Revision 1.76 2002/12/01 22:07:41 carl
  1496. * warning of portabilitiy problems with parasize / localsize
  1497. + some added documentation
  1498. Revision 1.75 2002/11/30 23:13:48 carl
  1499. - cs_fp_emulation is no longer automatic for m68k target
  1500. Revision 1.74 2002/11/30 11:08:46 carl
  1501. * fix bug n last commit (this bug was only detected gby 1.0.x, fixed)
  1502. Revision 1.73 2002/11/30 00:34:20 pierre
  1503. * remove double in delphimodeswitches to allow compilation with -Cr option
  1504. Revision 1.72 2002/11/29 22:31:19 carl
  1505. + unimplemented hint directive added
  1506. * hint directive parsing implemented
  1507. * warning on these directives
  1508. Revision 1.71 2002/11/20 10:11:46 mazen
  1509. + TSearchPathList.AddPath supports a local path in addition to file name
  1510. Revision 1.70 2002/11/16 14:49:12 carl
  1511. - browser information is off by default
  1512. Revision 1.69 2002/11/15 01:58:47 peter
  1513. * merged changes from 1.0.7 up to 04-11
  1514. - -V option for generating bug report tracing
  1515. - more tracing for option parsing
  1516. - errors for cdecl and high()
  1517. - win32 import stabs
  1518. - win32 records<=8 are returned in eax:edx (turned off by default)
  1519. - heaptrc update
  1520. - more info for temp management in .s file with EXTDEBUG
  1521. Revision 1.68 2002/11/09 15:38:39 carl
  1522. + added var_align/const_align routines
  1523. Revision 1.67 2002/10/16 19:01:43 peter
  1524. + $IMPLICITEXCEPTIONS switch to turn on/off generation of the
  1525. implicit exception frames for procedures with initialized variables
  1526. and for constructors. The default is on for compatibility
  1527. Revision 1.66 2002/09/05 19:28:29 peter
  1528. * removed repetitive pass counting
  1529. * display heapsize also for extdebug
  1530. Revision 1.65 2002/08/19 19:36:42 peter
  1531. * More fixes for cross unit inlining, all tnodes are now implemented
  1532. * Moved pocall_internconst to po_internconst because it is not a
  1533. calling type at all and it conflicted when inlining of these small
  1534. functions was requested
  1535. Revision 1.64 2002/08/12 15:08:39 carl
  1536. + stab register indexes for powerpc (moved from gdb to cpubase)
  1537. + tprocessor enumeration moved to cpuinfo
  1538. + linker in target_info is now a class
  1539. * many many updates for m68k (will soon start to compile)
  1540. - removed some ifdef or correct them for correct cpu
  1541. Revision 1.63 2002/08/10 14:46:29 carl
  1542. + moved target_cpu_string to cpuinfo
  1543. * renamed asmmode enum.
  1544. * assembler reader has now less ifdef's
  1545. * move from nppcmem.pas -> ncgmem.pas vec. node.
  1546. Revision 1.62 2002/07/28 20:45:22 florian
  1547. + added direct assembler reader for PowerPC
  1548. Revision 1.61 2002/07/20 17:12:42 florian
  1549. + source code page support
  1550. Revision 1.60 2002/07/01 18:46:22 peter
  1551. * internal linker
  1552. * reorganized aasm layer
  1553. Revision 1.59 2002/07/01 16:23:52 peter
  1554. * cg64 patch
  1555. * basics for currency
  1556. * asnode updates for class and interface (not finished)
  1557. Revision 1.58 2002/05/18 13:34:08 peter
  1558. * readded missing revisions
  1559. Revision 1.57 2002/05/16 19:46:36 carl
  1560. + defines.inc -> fpcdefs.inc to avoid conflicts if compiling by hand
  1561. + try to fix temp allocation (still in ifdef)
  1562. + generic constructor calls
  1563. + start of tassembler / tmodulebase class cleanup
  1564. Revision 1.55 2002/04/20 21:32:23 carl
  1565. + generic FPC_CHECKPOINTER
  1566. + first parameter offset in stack now portable
  1567. * rename some constants
  1568. + move some cpu stuff to other units
  1569. - remove unused constents
  1570. * fix stacksize for some targets
  1571. * fix generic size problems which depend now on EXTEND_SIZE constant
  1572. Revision 1.54 2002/04/07 13:24:30 carl
  1573. + moved constant from cpuinfo, these are NOT cpu specific
  1574. constant, but more related to compiler functionality.
  1575. Revision 1.53 2002/04/02 17:11:28 peter
  1576. * tlocation,treference update
  1577. * LOC_CONSTANT added for better constant handling
  1578. * secondadd splitted in multiple routines
  1579. * location_force_reg added for loading a location to a register
  1580. of a specified size
  1581. * secondassignment parses now first the right and then the left node
  1582. (this is compatible with Kylix). This saves a lot of push/pop especially
  1583. with string operations
  1584. * adapted some routines to use the new cg methods
  1585. Revision 1.52 2002/03/28 16:07:52 armin
  1586. + initialize threadvars defined local in units
  1587. Revision 1.51 2002/01/24 18:25:48 peter
  1588. * implicit result variable generation for assembler routines
  1589. * removed m_tp modeswitch, use m_tp7 or not(m_fpc) instead
  1590. }