globals.pas 51 KB

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