globals.pas 57 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008
  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 havelinuxrtl10}
  29. linux,
  30. {$else}
  31. Baseunix,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_result,m_repeat_forward,m_cvar_support];
  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. treelogfilename = 'tree.log';
  70. { I don't know if this endian dependend }
  71. MathQNaN : array[0..7] of byte = (0,0,0,0,0,0,252,255);
  72. MathInf : array[0..7] of byte = (0,0,0,0,0,0,240,127);
  73. MathNegInf : array[0..7] of byte = (0,0,0,0,0,0,240,255);
  74. type
  75. TFPUException = (exInvalidOp, exDenormalized, exZeroDivide,
  76. exOverflow, exUnderflow, exPrecision);
  77. TFPUExceptionMask = set of TFPUException;
  78. pfileposinfo = ^tfileposinfo;
  79. tfileposinfo = record
  80. line : longint;
  81. column : word;
  82. fileindex : word;
  83. { moduleindex : word; }
  84. end;
  85. TSearchPathList = class(TStringList)
  86. procedure AddPath(s:string;addfirst:boolean);overload;
  87. procedure AddPath(SrcPath,s:string;addfirst:boolean);overload;
  88. procedure AddList(list:TSearchPathList;addfirst:boolean);
  89. function FindFile(const f : string;var foundfile:string):boolean;
  90. end;
  91. tcodepagestring = string[20];
  92. var
  93. { specified inputfile }
  94. inputdir : dirstr;
  95. inputfile : namestr;
  96. inputextension : extstr;
  97. { specified outputfile with -o parameter }
  98. outputfile : namestr;
  99. outputprefix : pstring;
  100. outputsuffix : pstring;
  101. outputextension : namestr;
  102. { specified with -FE or -FU }
  103. outputexedir : dirstr;
  104. outputunitdir : dirstr;
  105. { things specified with parameters }
  106. paralinkoptions,
  107. paradynamiclinker : string;
  108. paraprintnodetree : byte;
  109. parapreprocess : boolean;
  110. printnodefile : text;
  111. { typical cross compiling params}
  112. { directory where the utils can be found (options -FD) }
  113. utilsdirectory : dirstr;
  114. { targetname specific prefix used by these utils (options -XP<path>) }
  115. utilsprefix : dirstr;
  116. cshared : boolean; { pass --shared to ld to link C libs shared}
  117. Dontlinkstdlibpath: Boolean; { Don't add std paths to linkpath}
  118. rlinkpath : dirstr; { rpath-link linkdir override}
  119. { some flags for global compiler switches }
  120. do_build,
  121. do_release,
  122. do_make : boolean;
  123. { path for searching units, different paths can be seperated by ; }
  124. exepath : dirstr; { Path to ppc }
  125. librarysearchpath,
  126. unitsearchpath,
  127. objectsearchpath,
  128. includesearchpath : TSearchPathList;
  129. { linking }
  130. usewindowapi : boolean;
  131. description : string;
  132. DescriptionSetExplicity : boolean;
  133. dllversion : string;
  134. dllmajor,
  135. dllminor,
  136. dllrevision : word; { revision only for netware }
  137. UseDeffileForExports : boolean;
  138. UseDeffileForExportsSetExplicitly : boolean;
  139. RelocSection : boolean;
  140. RelocSectionSetExplicitly : boolean;
  141. LinkTypeSetExplicitly : boolean;
  142. akttokenpos, { position of the last token }
  143. aktfilepos : tfileposinfo; { current position }
  144. nwscreenname : string;
  145. nwthreadname : string;
  146. nwcopyright : string;
  147. codegenerror : boolean; { true if there is an error reported }
  148. block_type : tblock_type; { type of currently parsed block }
  149. parsing_para_level : integer; { parameter level, used to convert
  150. proc calls to proc loads in firstcalln }
  151. compile_level : word;
  152. make_ref : boolean;
  153. resolving_forward : boolean; { used to add forward reference as second ref }
  154. inlining_procedure : boolean; { are we inlining a procedure }
  155. exceptblockcounter : integer; { each except block gets a unique number check gotos }
  156. aktexceptblock : integer; { the exceptblock number of the current block (0 if none) }
  157. { commandline values }
  158. initdefines : tstringlist;
  159. initglobalswitches : tglobalswitches;
  160. initmoduleswitches : tmoduleswitches;
  161. initlocalswitches : tlocalswitches;
  162. initmodeswitches : tmodeswitches;
  163. {$IFDEF testvarsets}
  164. Initsetalloc, {0=fixed, 1 =var}
  165. {$ENDIF}
  166. initpackenum : shortint;
  167. {$ifdef ansistring_bits}
  168. initansistring_bits: Tstringbits;
  169. {$endif}
  170. initalignment : talignmentinfo;
  171. initoptprocessor,
  172. initspecificoptprocessor : tprocessors;
  173. initfputype : tfputype;
  174. initasmmode : tasmmode;
  175. initinterfacetype : tinterfacetypes;
  176. initoutputformat : tasm;
  177. initdefproccall : tproccalloption;
  178. initsourcecodepage : tcodepagestring;
  179. { current state values }
  180. aktglobalswitches : tglobalswitches;
  181. aktmoduleswitches : tmoduleswitches;
  182. aktlocalswitches : tlocalswitches;
  183. nextaktlocalswitches : tlocalswitches;
  184. localswitcheschanged : boolean;
  185. aktmodeswitches : tmodeswitches;
  186. {$IFDEF testvarsets}
  187. aktsetalloc,
  188. {$ENDIF}
  189. aktpackrecords,
  190. aktpackenum : longint;
  191. {$ifdef ansistring_bits}
  192. aktansistring_bits : Tstringbits;
  193. {$endif}
  194. aktmaxfpuregisters : longint;
  195. aktalignment : talignmentinfo;
  196. aktoptprocessor,
  197. aktspecificoptprocessor : tprocessors;
  198. aktfputype : tfputype;
  199. aktasmmode : tasmmode;
  200. aktinterfacetype : tinterfacetypes;
  201. aktoutputformat : tasm;
  202. aktdefproccall : tproccalloption;
  203. aktsourcecodepage : tcodepagestring;
  204. { Memory sizes }
  205. heapsize,
  206. stacksize : longint;
  207. {$Ifdef EXTDEBUG}
  208. { parameter switches }
  209. debugstop : boolean;
  210. {$EndIf EXTDEBUG}
  211. { windows / OS/2 application type }
  212. apptype : tapptype;
  213. const
  214. DLLsource : boolean = false;
  215. DLLImageBase : pstring = nil;
  216. { used to set all registers used for each global function
  217. this should dramatically decrease the number of
  218. recompilations needed PM }
  219. simplify_ppu : boolean = true;
  220. { should we allow non static members ? }
  221. allow_only_static : boolean = false;
  222. Inside_asm_statement : boolean = false;
  223. global_unit_count : word = 0;
  224. { for error info in pp.pas }
  225. parser_current_file : string = '';
  226. {$ifdef m68k}
  227. { PalmOS resources }
  228. palmos_applicationname : string = 'FPC Application';
  229. palmos_applicationid : string[4] = 'FPCA';
  230. {$endif m68k}
  231. procedure abstract;
  232. function bstoslash(const s : string) : string;
  233. function getdatestr:string;
  234. function gettimestr:string;
  235. function filetimestring( t : longint) : string;
  236. procedure DefaultReplacements(var s:string);
  237. function GetCurrentDir:string;
  238. function path_absolute(const s : string) : boolean;
  239. Function PathExists ( F : String) : Boolean;
  240. Function FileExists ( Const F : String) : Boolean;
  241. function FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
  242. Function RemoveFile(const f:string):boolean;
  243. Function RemoveDir(d:string):boolean;
  244. Function GetFileTime ( Var F : File) : Longint;
  245. Function GetNamedFileTime ( Const F : String) : Longint;
  246. Function SplitPath(const s:string):string;
  247. Function SplitFileName(const s:string):string;
  248. Function SplitName(const s:string):string;
  249. Function SplitExtension(Const HStr:String):String;
  250. Function AddExtension(Const HStr,ext:String):String;
  251. Function ForceExtension(Const HStr,ext:String):String;
  252. Function FixPath(s:string;allowdot:boolean):string;
  253. function FixFileName(const s:string):string;
  254. function TargetFixPath(s:string;allowdot:boolean):string;
  255. function TargetFixFileName(const s:string):string;
  256. procedure SplitBinCmd(const s:string;var bstr,cstr:string);
  257. function FindFile(const f : string;path : string;var foundfile:string):boolean;
  258. function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
  259. function FindExe(const bin:string;var foundfile:string):boolean;
  260. function GetShortName(const n:string):string;
  261. function Shell(const command:string): longint;
  262. function GetEnvPChar(const envname:string):pchar;
  263. procedure FreeEnvPChar(p:pchar);
  264. function SetFPUExceptionMask(const Mask : TFPUExceptionMask) : TFPUExceptionMask;
  265. function is_number_float(d : double) : boolean;
  266. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  267. function SetAktProcCall(const s:string; changeInit: boolean):boolean;
  268. function SetProcessor(const s:string; changeInit: boolean):boolean;
  269. function SetFpuType(const s:string; changeInit: boolean):boolean;
  270. procedure InitGlobals;
  271. procedure DoneGlobals;
  272. function string2guid(const s: string; var GUID: TGUID): boolean;
  273. function guid2string(const GUID: TGUID): string;
  274. function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
  275. {# Routine to get the required alignment for size of data, which will
  276. be placed in bss segment, according to the current alignment requirements }
  277. function var_align(siz: longint): longint;
  278. {# Routine to get the required alignment for size of data, which will
  279. be placed in data/const segment, according to the current alignment requirements }
  280. function const_align(siz: longint): longint;
  281. implementation
  282. uses
  283. {$ifdef macos}
  284. macutils,
  285. {$endif}
  286. comphook;
  287. procedure abstract;
  288. begin
  289. do_internalerror(255);
  290. end;
  291. procedure WarnNonExistingPath(const path : string);
  292. begin
  293. if assigned({$ifndef FPCPROCVAR}@{$endif}do_comment) then
  294. do_comment(V_Hint,'Path "'+path+'" not found');
  295. end;
  296. function bstoslash(const s : string) : string;
  297. {
  298. return string s with all \ changed into /
  299. }
  300. var
  301. i : longint;
  302. begin
  303. for i:=1to length(s) do
  304. if s[i]='\' then
  305. bstoslash[i]:='/'
  306. else
  307. bstoslash[i]:=s[i];
  308. bstoslash[0]:=s[0];
  309. end;
  310. {****************************************************************************
  311. Time Handling
  312. ****************************************************************************}
  313. Function L0(l:longint):string;
  314. {
  315. return the string of value l, if l<10 then insert a zero, so
  316. the string is always at least 2 chars '01','02',etc
  317. }
  318. var
  319. s : string;
  320. begin
  321. Str(l,s);
  322. if l<10 then
  323. s:='0'+s;
  324. L0:=s;
  325. end;
  326. function gettimestr:string;
  327. {
  328. get the current time in a string HH:MM:SS
  329. }
  330. var
  331. hour,min,sec,hsec : word;
  332. begin
  333. {$ifdef delphi}
  334. dmisc.gettime(hour,min,sec,hsec);
  335. {$else delphi}
  336. dos.gettime(hour,min,sec,hsec);
  337. {$endif delphi}
  338. gettimestr:=L0(Hour)+':'+L0(min)+':'+L0(sec);
  339. end;
  340. function getdatestr:string;
  341. {
  342. get the current date in a string YY/MM/DD
  343. }
  344. var
  345. Year,Month,Day,Wday : Word;
  346. begin
  347. {$ifdef delphi}
  348. dmisc.getdate(year,month,day,wday);
  349. {$else}
  350. dos.getdate(year,month,day,wday);
  351. {$endif}
  352. getdatestr:=L0(Year)+'/'+L0(Month)+'/'+L0(Day);
  353. end;
  354. function filetimestring( t : longint) : string;
  355. {
  356. convert dos datetime t to a string YY/MM/DD HH:MM:SS
  357. }
  358. var
  359. DT : DateTime;
  360. begin
  361. if t=-1 then
  362. begin
  363. FileTimeString:='Not Found';
  364. exit;
  365. end;
  366. unpacktime(t,DT);
  367. filetimestring:=L0(dt.Year)+'/'+L0(dt.Month)+'/'+L0(dt.Day)+' '+L0(dt.Hour)+':'+L0(dt.min)+':'+L0(dt.sec);
  368. end;
  369. {****************************************************************************
  370. Default Macro Handling
  371. ****************************************************************************}
  372. procedure DefaultReplacements(var s:string);
  373. begin
  374. { Replace some macros }
  375. Replace(s,'$FPCVER',version_string);
  376. Replace(s,'$VERSION',version_string);
  377. Replace(s,'$FULLVERSION',full_version_string);
  378. Replace(s,'$FPCDATE',date_string);
  379. Replace(s,'$FPCTARGET',target_cpu_string);
  380. Replace(s,'$FPCCPU',target_cpu_string);
  381. Replace(s,'$TARGET',target_path);
  382. Replace(s,'$FPCOS',target_path);
  383. end;
  384. {****************************************************************************
  385. File Handling
  386. ****************************************************************************}
  387. function GetCurrentDir:string;
  388. var
  389. CurrentDir : string;
  390. begin
  391. GetDir(0,CurrentDir);
  392. GetCurrentDir:=FixPath(CurrentDir,false);
  393. end;
  394. function path_absolute(const s : string) : boolean;
  395. {
  396. is path s an absolute path?
  397. }
  398. begin
  399. path_absolute:=false;
  400. {$ifdef unix}
  401. if (length(s)>0) and (s[1]='/') then
  402. path_absolute:=true;
  403. {$else unix}
  404. {$ifdef amiga}
  405. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or (Pos(':',s) = length(s)) then
  406. path_absolute:=true;
  407. {$else}
  408. {$ifdef macos}
  409. if IsMacFullPath(s) then
  410. path_absolute:=true;
  411. {$else}
  412. if ((length(s)>0) and ((s[1]='\') or (s[1]='/'))) or
  413. ((length(s)>2) and (s[2]=':') and ((s[3]='\') or (s[3]='/'))) then
  414. path_absolute:=true;
  415. {$endif macos}
  416. {$endif amiga}
  417. {$endif unix}
  418. end;
  419. {$ifndef FPC}
  420. Procedure FindClose(var Info : SearchRec);
  421. Begin
  422. End;
  423. {$endif not FPC}
  424. Function FileExists ( Const F : String) : Boolean;
  425. Var
  426. res : boolean;
  427. {$ifndef delphi}
  428. Info : SearchRec;
  429. {$endif}
  430. begin
  431. {$ifdef delphi}
  432. res:=sysutils.FileExists(f);
  433. {$else}
  434. findfirst(F,readonly+archive+hidden,info);
  435. res:=(doserror=0);
  436. findclose(Info);
  437. {$endif delphi}
  438. if assigned({$ifndef FPCPROVCAR}@{$endif}do_comment) then
  439. begin
  440. if res then
  441. do_comment(V_Tried,'Searching file '+F+'... found')
  442. else
  443. do_comment(V_Tried,'Searching file '+F+'... not found');
  444. end;
  445. FileExists:=res;
  446. end;
  447. function FileExistsNonCase(const path,fn:string;var foundfile:string):boolean;
  448. var
  449. fn2 : string;
  450. begin
  451. result:=false;
  452. if source_info.files_case_relevent then
  453. begin
  454. {
  455. Search order for case sensitive systems:
  456. 1. NormalCase
  457. 2. lowercase
  458. 3. UPPERCASE
  459. }
  460. FoundFile:=path+fn;
  461. If FileExists(FoundFile) then
  462. begin
  463. result:=true;
  464. exit;
  465. end;
  466. fn2:=Lower(fn);
  467. if fn2<>fn then
  468. begin
  469. FoundFile:=path+fn2;
  470. If FileExists(FoundFile) then
  471. begin
  472. result:=true;
  473. exit;
  474. end;
  475. end;
  476. fn2:=Upper(fn);
  477. if fn2<>fn then
  478. begin
  479. FoundFile:=path+fn2;
  480. If FileExists(FoundFile) then
  481. begin
  482. result:=true;
  483. exit;
  484. end;
  485. end;
  486. end
  487. else
  488. begin
  489. { None case sensitive only lowercase }
  490. FoundFile:=path+Lower(fn);
  491. If FileExists(FoundFile) then
  492. begin
  493. result:=true;
  494. exit;
  495. end;
  496. end;
  497. { Set foundfile to something usefull }
  498. FoundFile:=fn;
  499. end;
  500. Function PathExists ( F : String) : Boolean;
  501. Var
  502. Info : SearchRec;
  503. disk : byte;
  504. begin
  505. if F='' then
  506. begin
  507. result:=true;
  508. exit;
  509. end;
  510. { these operating systems have dos type drives }
  511. if source_info.system in [system_m68k_atari,system_i386_go32v2,
  512. system_i386_win32,system_i386_os2,
  513. system_i386_emx,system_i386_wdosx] then
  514. Begin
  515. if (Length(f)=3) and (F[2]=':') and (F[3] in ['/','\']) then
  516. begin
  517. if F[1] in ['A'..'Z'] then
  518. disk:=ord(F[1])-ord('A')+1
  519. else if F[1] in ['a'..'z'] then
  520. disk:=ord(F[1])-ord('a')+1
  521. else
  522. disk:=255;
  523. if disk=255 then
  524. PathExists:=false
  525. else
  526. PathExists:=(DiskSize(disk)<>-1);
  527. exit;
  528. end;
  529. end;
  530. if F[Length(f)] in ['/','\'] then
  531. Delete(f,length(f),1);
  532. findfirst(F,readonly+archive+hidden+directory,info);
  533. PathExists:=(doserror=0) and ((info.attr and directory)=directory);
  534. findclose(Info);
  535. end;
  536. Function RemoveFile(const f:string):boolean;
  537. var
  538. g : file;
  539. begin
  540. assign(g,f);
  541. {$I-}
  542. erase(g);
  543. {$I+}
  544. RemoveFile:=(ioresult=0);
  545. end;
  546. Function RemoveDir(d:string):boolean;
  547. begin
  548. if d[length(d)]=source_info.DirSep then
  549. Delete(d,length(d),1);
  550. {$I-}
  551. rmdir(d);
  552. {$I+}
  553. RemoveDir:=(ioresult=0);
  554. end;
  555. Function SplitPath(const s:string):string;
  556. var
  557. i : longint;
  558. begin
  559. i:=Length(s);
  560. while (i>0) and not(s[i] in ['/','\']) do
  561. dec(i);
  562. SplitPath:=Copy(s,1,i);
  563. end;
  564. Function SplitFileName(const s:string):string;
  565. var
  566. p : dirstr;
  567. n : namestr;
  568. e : extstr;
  569. begin
  570. FSplit(s,p,n,e);
  571. SplitFileName:=n+e;
  572. end;
  573. Function SplitName(const s:string):string;
  574. var
  575. i,j : longint;
  576. begin
  577. i:=Length(s);
  578. j:=Length(s);
  579. while (i>0) and not(s[i] in ['/','\']) do
  580. dec(i);
  581. while (j>0) and (s[j]<>'.') do
  582. dec(j);
  583. if j<=i then
  584. j:=255;
  585. SplitName:=Copy(s,i+1,j-(i+1));
  586. end;
  587. Function SplitExtension(Const HStr:String):String;
  588. var
  589. j : longint;
  590. begin
  591. j:=length(Hstr);
  592. while (j>0) and (Hstr[j]<>'.') do
  593. begin
  594. if hstr[j]=source_info.DirSep then
  595. j:=0
  596. else
  597. dec(j);
  598. end;
  599. if j=0 then
  600. j:=254;
  601. SplitExtension:=Copy(Hstr,j,255);
  602. end;
  603. Function AddExtension(Const HStr,ext:String):String;
  604. begin
  605. if (Ext<>'') and (SplitExtension(HStr)='') then
  606. AddExtension:=Hstr+Ext
  607. else
  608. AddExtension:=Hstr;
  609. end;
  610. Function ForceExtension(Const HStr,ext:String):String;
  611. var
  612. j : longint;
  613. begin
  614. j:=length(Hstr);
  615. while (j>0) and (Hstr[j]<>'.') do
  616. dec(j);
  617. if j=0 then
  618. j:=255;
  619. ForceExtension:=Copy(Hstr,1,j-1)+Ext;
  620. end;
  621. Function FixPath(s:string;allowdot:boolean):string;
  622. var
  623. i : longint;
  624. begin
  625. { Fix separator }
  626. for i:=1 to length(s) do
  627. if s[i] in ['/','\'] then
  628. s[i]:=source_info.DirSep;
  629. { Fix ending / }
  630. if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
  631. (s[length(s)]<>':') then
  632. s:=s+source_info.DirSep;
  633. { Remove ./ }
  634. if (not allowdot) and (s='.'+source_info.DirSep) then
  635. s:='';
  636. { return }
  637. if source_info.files_case_relevent then
  638. FixPath:=s
  639. else
  640. FixPath:=Lower(s);
  641. end;
  642. {Actually the version in macutils.pp could be used,
  643. but that would not work for crosscompiling, so this is a slightly modified
  644. version of it.}
  645. function TranslatePathToMac (const path: string; mpw: Boolean): string;
  646. function GetVolumeIdentifier: string;
  647. begin
  648. GetVolumeIdentifier := '{Boot}'
  649. (*
  650. if mpw then
  651. GetVolumeIdentifier := '{Boot}'
  652. else
  653. GetVolumeIdentifier := macosBootVolumeName;
  654. *)
  655. end;
  656. var
  657. slashPos, oldpos, newpos, oldlen, maxpos: Longint;
  658. begin
  659. oldpos := 1;
  660. slashPos := Pos('/', path);
  661. if (slashPos <> 0) then {its a unix path}
  662. begin
  663. if slashPos = 1 then
  664. begin {its a full path}
  665. oldpos := 2;
  666. TranslatePathToMac := GetVolumeIdentifier;
  667. end
  668. else {its a partial path}
  669. TranslatePathToMac := ':';
  670. end
  671. else
  672. begin
  673. slashPos := Pos('\', path);
  674. if (slashPos <> 0) then {its a dos path}
  675. begin
  676. if slashPos = 1 then
  677. begin {its a full path, without drive letter}
  678. oldpos := 2;
  679. TranslatePathToMac := GetVolumeIdentifier;
  680. end
  681. else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter}
  682. begin
  683. oldpos := 4;
  684. TranslatePathToMac := GetVolumeIdentifier;
  685. end
  686. else {its a partial path}
  687. TranslatePathToMac := ':';
  688. end;
  689. end;
  690. if (slashPos <> 0) then {its a unix or dos path}
  691. begin
  692. {Translate "/../" to "::" , "/./" to ":" and "/" to ":" }
  693. newpos := Length(TranslatePathToMac);
  694. oldlen := Length(path);
  695. SetLength(TranslatePathToMac, newpos + oldlen); {It will be no longer than what is already}
  696. {prepended plus length of path.}
  697. maxpos := Length(TranslatePathToMac); {Get real maxpos, can be short if String is ShortString}
  698. {There is never a slash in the beginning, because either it was an absolute path, and then the}
  699. {drive and slash was removed, or it was a relative path without a preceding slash.}
  700. while oldpos <= oldlen do
  701. begin
  702. {Check if special dirs, ./ or ../ }
  703. if path[oldPos] = '.' then
  704. if (oldpos + 1 <= oldlen) and (path[oldPos + 1] = '.') then
  705. begin
  706. if (oldpos + 2 > oldlen) or (path[oldPos + 2] in ['/', '\']) then
  707. begin
  708. {It is "../" or ".." translates to ":" }
  709. if newPos = maxPos then
  710. begin {Shouldn't actually happen, but..}
  711. Exit('');
  712. end;
  713. newPos := newPos + 1;
  714. TranslatePathToMac[newPos] := ':';
  715. oldPos := oldPos + 3;
  716. continue; {Start over again}
  717. end;
  718. end
  719. else if (oldpos + 1 > oldlen) or (path[oldPos + 1] in ['/', '\']) then
  720. begin
  721. {It is "./" or "." ignor it }
  722. oldPos := oldPos + 2;
  723. continue; {Start over again}
  724. end;
  725. {Collect file or dir name}
  726. while (oldpos <= oldlen) and not (path[oldPos] in ['/', '\']) do
  727. begin
  728. if newPos = maxPos then
  729. begin {Shouldn't actually happen, but..}
  730. Exit('');
  731. end;
  732. newPos := newPos + 1;
  733. TranslatePathToMac[newPos] := path[oldPos];
  734. oldPos := oldPos + 1;
  735. end;
  736. {When we come here there is either a slash or we are at the end.}
  737. if (oldpos <= oldlen) then
  738. begin
  739. if newPos = maxPos then
  740. begin {Shouldn't actually happen, but..}
  741. Exit('');
  742. end;
  743. newPos := newPos + 1;
  744. TranslatePathToMac[newPos] := ':';
  745. oldPos := oldPos + 1;
  746. end;
  747. end;
  748. SetLength(TranslatePathToMac, newpos);
  749. end
  750. else if (path = '.') then
  751. TranslatePathToMac := ':'
  752. else if (path = '..') then
  753. TranslatePathToMac := '::'
  754. else
  755. TranslatePathToMac := path; {its a mac path}
  756. end;
  757. function FixFileName(const s:string):string;
  758. var
  759. i : longint;
  760. begin
  761. if source_info.system = system_powerpc_MACOS then
  762. FixFileName:= TranslatePathToMac(s, true)
  763. else if source_info.files_case_relevent then
  764. begin
  765. for i:=1 to length(s) do
  766. begin
  767. case s[i] of
  768. '/','\' :
  769. FixFileName[i]:=source_info.dirsep;
  770. else
  771. FixFileName[i]:=s[i];
  772. end;
  773. end;
  774. FixFileName[0]:=s[0];
  775. end
  776. else
  777. begin
  778. for i:=1 to length(s) do
  779. begin
  780. case s[i] of
  781. '/','\' :
  782. FixFileName[i]:=source_info.dirsep;
  783. 'A'..'Z' :
  784. FixFileName[i]:=char(byte(s[i])+32);
  785. else
  786. FixFileName[i]:=s[i];
  787. end;
  788. end;
  789. FixFileName[0]:=s[0];
  790. end;
  791. end;
  792. Function TargetFixPath(s:string;allowdot:boolean):string;
  793. var
  794. i : longint;
  795. begin
  796. { Fix separator }
  797. for i:=1 to length(s) do
  798. if s[i] in ['/','\'] then
  799. s[i]:=target_info.DirSep;
  800. { Fix ending / }
  801. if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
  802. (s[length(s)]<>':') then
  803. s:=s+target_info.DirSep;
  804. { Remove ./ }
  805. if (not allowdot) and (s='.'+target_info.DirSep) then
  806. s:='';
  807. { return }
  808. if target_info.files_case_relevent then
  809. TargetFixPath:=s
  810. else
  811. TargetFixPath:=Lower(s);
  812. end;
  813. function TargetFixFileName(const s:string):string;
  814. var
  815. i : longint;
  816. begin
  817. if target_info.system = system_powerpc_MACOS then
  818. TargetFixFileName:= TranslatePathToMac(s, true)
  819. else if target_info.files_case_relevent then
  820. begin
  821. for i:=1 to length(s) do
  822. begin
  823. case s[i] of
  824. '/','\' :
  825. TargetFixFileName[i]:=target_info.dirsep;
  826. else
  827. TargetFixFileName[i]:=s[i];
  828. end;
  829. end;
  830. TargetFixFileName[0]:=s[0];
  831. end
  832. else
  833. begin
  834. for i:=1 to length(s) do
  835. begin
  836. case s[i] of
  837. '/','\' :
  838. TargetFixFileName[i]:=target_info.dirsep;
  839. 'A'..'Z' :
  840. TargetFixFileName[i]:=char(byte(s[i])+32);
  841. else
  842. TargetFixFileName[i]:=s[i];
  843. end;
  844. end;
  845. TargetFixFileName[0]:=s[0];
  846. end;
  847. end;
  848. procedure SplitBinCmd(const s:string;var bstr,cstr:string);
  849. var
  850. i : longint;
  851. begin
  852. i:=pos(' ',s);
  853. if i>0 then
  854. begin
  855. bstr:=Copy(s,1,i-1);
  856. cstr:=Copy(s,i+1,length(s)-i);
  857. end
  858. else
  859. begin
  860. bstr:=s;
  861. cstr:='';
  862. end;
  863. end;
  864. procedure TSearchPathList.AddPath(s:string;addfirst:boolean);
  865. begin
  866. AddPath('',s,AddFirst);
  867. end;
  868. procedure TSearchPathList.AddPath(SrcPath,s:string;addfirst:boolean);
  869. var
  870. j : longint;
  871. hs,hsd,
  872. CurrentDir,
  873. currPath : string;
  874. subdirfound : boolean;
  875. dir : searchrec;
  876. hp : TStringListItem;
  877. procedure AddCurrPath;
  878. begin
  879. if addfirst then
  880. begin
  881. Remove(currPath);
  882. Insert(currPath);
  883. end
  884. else
  885. begin
  886. { Check if already in path, then we don't add it }
  887. hp:=Find(currPath);
  888. if not assigned(hp) then
  889. Concat(currPath);
  890. end;
  891. end;
  892. begin
  893. if s='' then
  894. exit;
  895. { Support default macro's }
  896. DefaultReplacements(s);
  897. { get current dir }
  898. CurrentDir:=GetCurrentDir;
  899. repeat
  900. { get currpath }
  901. if addfirst then
  902. begin
  903. j:=length(s);
  904. while (j>0) and (s[j]<>';') do
  905. dec(j);
  906. currPath:= TrimSpace(Copy(s,j+1,length(s)-j));
  907. DePascalQuote(currPath);
  908. currPath:=FixPath(currPath,false);
  909. if j=0 then
  910. s:=''
  911. else
  912. System.Delete(s,j,length(s)-j+1);
  913. end
  914. else
  915. begin
  916. j:=Pos(';',s);
  917. if j=0 then
  918. j:=255;
  919. currPath:= TrimSpace(Copy(s,1,j-1));
  920. DePascalQuote(currPath);
  921. currPath:=SrcPath+FixPath(currPath,false);
  922. System.Delete(s,1,j);
  923. end;
  924. { fix pathname }
  925. if currPath='' then
  926. currPath:='.'+source_info.DirSep
  927. else
  928. begin
  929. currPath:=FixPath(FExpand(currPath),false);
  930. if (CurrentDir<>'') and (Copy(currPath,1,length(CurrentDir))=CurrentDir) then
  931. begin
  932. {$ifdef AMIGA}
  933. currPath:=CurrentDir+Copy(currPath,length(CurrentDir)+1,255);
  934. {$else}
  935. currPath:='.'+source_info.DirSep+Copy(currPath,length(CurrentDir)+1,255);
  936. {$endif}
  937. end;
  938. end;
  939. { wildcard adding ? }
  940. if pos('*',currpath)>0 then
  941. begin
  942. if currpath[length(currpath)]=source_info.dirsep then
  943. hs:=Copy(currpath,1,length(currPath)-1)
  944. else
  945. hs:=currpath;
  946. hsd:=SplitPath(hs);
  947. findfirst(hs,directory,dir);
  948. subdirfound:=false;
  949. while doserror=0 do
  950. begin
  951. if (dir.name<>'.') and
  952. (dir.name<>'..') and
  953. ((dir.attr and directory)<>0) then
  954. begin
  955. subdirfound:=true;
  956. currpath:=hsd+dir.name+source_info.dirsep;
  957. hp:=Find(currPath);
  958. if not assigned(hp) then
  959. AddCurrPath;
  960. end;
  961. findnext(dir);
  962. if not subdirfound then
  963. WarnNonExistingPath(currpath);
  964. end;
  965. FindClose(dir);
  966. end
  967. else
  968. begin
  969. if PathExists(currpath) then
  970. AddCurrPath
  971. else
  972. WarnNonExistingPath(currpath);
  973. end;
  974. until (s='');
  975. end;
  976. procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
  977. var
  978. s : string;
  979. hl : TSearchPathList;
  980. hp,hp2 : TStringListItem;
  981. begin
  982. if list.empty then
  983. exit;
  984. { create temp and reverse the list }
  985. if addfirst then
  986. begin
  987. hl:=TSearchPathList.Create;
  988. hp:=TStringListItem(list.first);
  989. while assigned(hp) do
  990. begin
  991. hl.insert(hp.Str);
  992. hp:=TStringListItem(hp.next);
  993. end;
  994. while not hl.empty do
  995. begin
  996. s:=hl.GetFirst;
  997. Remove(s);
  998. Insert(s);
  999. end;
  1000. hl.Free;
  1001. end
  1002. else
  1003. begin
  1004. hp:=TStringListItem(list.first);
  1005. while assigned(hp) do
  1006. begin
  1007. hp2:=Find(hp.Str);
  1008. { Check if already in path, then we don't add it }
  1009. if not assigned(hp2) then
  1010. Concat(hp.Str);
  1011. hp:=TStringListItem(hp.next);
  1012. end;
  1013. end;
  1014. end;
  1015. function TSearchPathList.FindFile(const f : string;var foundfile:string):boolean;
  1016. Var
  1017. p : TStringListItem;
  1018. begin
  1019. FindFile:=false;
  1020. p:=TStringListItem(first);
  1021. while assigned(p) do
  1022. begin
  1023. result:=FileExistsNonCase(p.Str,f,FoundFile);
  1024. if result then
  1025. exit;
  1026. p:=TStringListItem(p.next);
  1027. end;
  1028. { Return original filename if not found }
  1029. FoundFile:=f;
  1030. end;
  1031. Function GetFileTime ( Var F : File) : Longint;
  1032. Var
  1033. {$ifdef hasunix}
  1034. info: Stat;
  1035. {$endif}
  1036. L : longint;
  1037. begin
  1038. {$ifdef hasunix}
  1039. {$IFDEF havelinuxrtl10}
  1040. FStat (F,Info);
  1041. L:=Info.Mtime;
  1042. {$ELSE}
  1043. FPFStat (F,Info);
  1044. L:=Info.st_Mtime;
  1045. {$ENDIF}
  1046. {$else}
  1047. GetFTime(f,l);
  1048. {$endif}
  1049. GetFileTime:=L;
  1050. end;
  1051. Function GetNamedFileTime (Const F : String) : Longint;
  1052. begin
  1053. GetNamedFileTime:=do_getnamedfiletime(F);
  1054. end;
  1055. function FindFile(const f : string;path : string;var foundfile:string):boolean;
  1056. Var
  1057. singlepathstring : string;
  1058. i : longint;
  1059. begin
  1060. {$ifdef Unix}
  1061. for i:=1 to length(path) do
  1062. if path[i]=':' then
  1063. path[i]:=';';
  1064. {$endif Unix}
  1065. FindFile:=false;
  1066. repeat
  1067. i:=pos(';',path);
  1068. if i=0 then
  1069. i:=256;
  1070. singlepathstring:=FixPath(copy(path,1,i-1),false);
  1071. delete(path,1,i);
  1072. result:=FileExistsNonCase(singlepathstring,f,FoundFile);
  1073. if result then
  1074. exit;
  1075. until path='';
  1076. FoundFile:=f;
  1077. end;
  1078. function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
  1079. Var
  1080. singlepathstring : string;
  1081. startpc,pc : pchar;
  1082. sepch : char;
  1083. begin
  1084. {$ifdef Unix}
  1085. sepch:=':';
  1086. {$else}
  1087. {$ifdef macos}
  1088. sepch:=',';
  1089. {$else}
  1090. sepch:=';';
  1091. {$endif macos}
  1092. {$endif Unix}
  1093. FindFilePchar:=false;
  1094. pc:=path;
  1095. repeat
  1096. startpc:=pc;
  1097. while (pc^<>sepch) and (pc^<>';') and (pc^<>#0) do
  1098. inc(pc);
  1099. move(startpc^,singlepathstring[1],pc-startpc);
  1100. singlepathstring[0]:=char(longint(pc-startpc));
  1101. singlepathstring:=FixPath(singlepathstring,false);
  1102. result:=FileExistsNonCase(singlepathstring,f,FoundFile);
  1103. if result then
  1104. exit;
  1105. if (pc^=#0) then
  1106. break;
  1107. inc(pc);
  1108. until false;
  1109. foundfile:=f;
  1110. end;
  1111. function FindExe(const bin:string;var foundfile:string):boolean;
  1112. var
  1113. p : pchar;
  1114. found : boolean;
  1115. begin
  1116. found:=FindFile(FixFileName(AddExtension(bin,source_info.exeext)),'.;'+exepath,foundfile);
  1117. if not found then
  1118. begin
  1119. {$ifdef macos}
  1120. p:=GetEnvPchar('Commands');
  1121. {$else}
  1122. p:=GetEnvPchar('PATH');
  1123. {$endif}
  1124. found:=FindFilePChar(FixFileName(AddExtension(bin,source_info.exeext)),p,foundfile);
  1125. FreeEnvPChar(p);
  1126. end;
  1127. FindExe:=found;
  1128. end;
  1129. function GetShortName(const n:string):string;
  1130. {$ifdef win32}
  1131. var
  1132. hs,hs2 : string;
  1133. i : longint;
  1134. {$endif}
  1135. {$ifdef go32v2}
  1136. var
  1137. hs : string;
  1138. {$endif}
  1139. {$ifdef watcom}
  1140. var
  1141. hs : string;
  1142. {$endif}
  1143. begin
  1144. GetShortName:=n;
  1145. {$ifdef win32}
  1146. hs:=n+#0;
  1147. i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
  1148. if (i>0) and (i<=high(hs2)) then
  1149. begin
  1150. hs2[0]:=chr(strlen(@hs2[1]));
  1151. GetShortName:=hs2;
  1152. end;
  1153. {$endif}
  1154. {$ifdef go32v2}
  1155. hs:=n;
  1156. if Dos.GetShortName(hs) then
  1157. GetShortName:=hs;
  1158. {$endif}
  1159. {$ifdef watcom}
  1160. hs:=n;
  1161. if Dos.GetShortName(hs) then
  1162. GetShortName:=hs;
  1163. {$endif}
  1164. end;
  1165. {****************************************************************************
  1166. OS Dependent things
  1167. ****************************************************************************}
  1168. function GetEnvPChar(const envname:string):pchar;
  1169. {$ifdef win32}
  1170. var
  1171. s : string;
  1172. i,len : longint;
  1173. hp,p,p2 : pchar;
  1174. {$endif}
  1175. begin
  1176. {$ifdef hasunix}
  1177. GetEnvPchar:={$ifdef havelinuxrtl10}Linux.getenv{$else}BaseUnix.fpGetEnv{$endif}(envname);
  1178. {$define GETENVOK}
  1179. {$endif}
  1180. {$ifdef win32}
  1181. GetEnvPchar:=nil;
  1182. p:=GetEnvironmentStrings;
  1183. hp:=p;
  1184. while hp^<>#0 do
  1185. begin
  1186. s:=strpas(hp);
  1187. i:=pos('=',s);
  1188. len:=strlen(hp);
  1189. if upper(copy(s,1,i-1))=upper(envname) then
  1190. begin
  1191. GetMem(p2,len-length(envname));
  1192. Move(hp[i],p2^,len-length(envname));
  1193. GetEnvPchar:=p2;
  1194. break;
  1195. end;
  1196. { next string entry}
  1197. hp:=hp+len+1;
  1198. end;
  1199. FreeEnvironmentStrings(p);
  1200. {$define GETENVOK}
  1201. {$endif}
  1202. {$ifdef os2}
  1203. GetEnvPChar := Dos.GetEnvPChar (EnvName);
  1204. {$define GETENVOK}
  1205. {$endif}
  1206. {$ifdef GETENVOK}
  1207. {$undef GETENVOK}
  1208. {$else}
  1209. GetEnvPchar:=StrPNew({$ifdef delphi}DMisc{$else}Dos{$endif}.Getenv(envname));
  1210. {$endif}
  1211. end;
  1212. procedure FreeEnvPChar(p:pchar);
  1213. begin
  1214. {$ifndef hasunix}
  1215. {$ifndef os2}
  1216. StrDispose(p);
  1217. {$endif}
  1218. {$endif}
  1219. end;
  1220. function Shell(const command:string): longint;
  1221. { This is already defined in the linux.ppu for linux, need for the *
  1222. expansion under linux }
  1223. {$ifdef hasunix}
  1224. begin
  1225. result := {$ifdef havelinuxrtl10}Linux{$else}Unix{$endif}.Shell(command);
  1226. end;
  1227. {$else}
  1228. {$ifdef amiga}
  1229. begin
  1230. exec('',command);
  1231. if (doserror <> 0) then
  1232. result := doserror
  1233. else
  1234. result := dosexitcode;
  1235. end;
  1236. {$else}
  1237. var
  1238. comspec : string;
  1239. begin
  1240. comspec:=getenv('COMSPEC');
  1241. Exec(comspec,' /C '+command);
  1242. if (doserror <> 0) then
  1243. result := doserror
  1244. else
  1245. result := dosexitcode;
  1246. end;
  1247. {$endif}
  1248. {$endif}
  1249. {$ifdef CPUI386}
  1250. { later, this should be replaced by the math unit }
  1251. const
  1252. Default8087CW : word = $1332;
  1253. {$ASMMODE ATT}
  1254. procedure Set8087CW(cw:word);assembler;
  1255. asm
  1256. movw cw,%ax
  1257. movw %ax,default8087cw
  1258. fnclex
  1259. fldcw default8087cw
  1260. end;
  1261. function Get8087CW:word;assembler;
  1262. asm
  1263. pushl $0
  1264. fnstcw (%esp)
  1265. popl %eax
  1266. end;
  1267. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1268. var
  1269. CtlWord: Word;
  1270. begin
  1271. CtlWord:=Get8087CW;
  1272. Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
  1273. Result:=TFPUExceptionMask(Longint(CtlWord and $3F));
  1274. end;
  1275. {$else CPUI386}
  1276. {$ifdef CPUPOWERPC}
  1277. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1278. var
  1279. newmask: record
  1280. case byte of
  1281. 1: (d: double);
  1282. 2: (a,b: cardinal);
  1283. end;
  1284. begin
  1285. { load current control register contents }
  1286. asm
  1287. mffs f0
  1288. stfd f0,newmask.d
  1289. end;
  1290. { invalid operation: bit 24 (big endian, bit 0 = left-most bit) }
  1291. if (exInvalidOp in mask) then
  1292. newmask.b := newmask.b and not(1 shl (31-24))
  1293. else
  1294. newmask.b := newmask.b or (1 shl (31-24));
  1295. { denormals can not cause exceptions on the PPC }
  1296. { zero divide: bit 27 }
  1297. if (exZeroDivide in mask) then
  1298. newmask.b := newmask.b and not(1 shl (31-27))
  1299. else
  1300. newmask.b := newmask.b or (1 shl (31-27));
  1301. { overflow: bit 25 }
  1302. if (exOverflow in mask) then
  1303. newmask.b := newmask.b and not(1 shl (31-25))
  1304. else
  1305. newmask.b := newmask.b or (1 shl (31-25));
  1306. { underflow: bit 26 }
  1307. if (exUnderflow in mask) then
  1308. newmask.b := newmask.b and not(1 shl (31-26))
  1309. else
  1310. newmask.b := newmask.b or (1 shl (31-26));
  1311. { Precision (inexact result): bit 28 }
  1312. if (exPrecision in mask) then
  1313. newmask.b := newmask.b and not(1 shl (31-28))
  1314. else
  1315. newmask.b := newmask.b or (1 shl (31-28));
  1316. { update control register contents }
  1317. asm
  1318. lfd f0, newmask.d
  1319. mtfsf 255,f0
  1320. end;
  1321. end;
  1322. {$else CPUPOWERPC}
  1323. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1324. begin
  1325. end;
  1326. {$endif CPUPOWERPC}
  1327. {$endif CPUI386}
  1328. function is_number_float(d : double) : boolean;
  1329. var
  1330. bytearray : array[0..7] of byte;
  1331. begin
  1332. move(d,bytearray,8);
  1333. { only 1.1 save, 1.0.x will use always little endian }
  1334. {$ifdef FPC_BIG_ENDIAN}
  1335. result:=((bytearray[0] and $7f)<>$7f) or ((bytearray[1] and $f0)<>$f0);
  1336. {$else FPC_BIG_ENDIAN}
  1337. result:=((bytearray[7] and $7f)<>$7f) or ((bytearray[6] and $f0)<>$f0);
  1338. {$endif FPC_BIG_ENDIAN}
  1339. end;
  1340. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  1341. var
  1342. b : boolean;
  1343. begin
  1344. b:=true;
  1345. if s='DEFAULT' then
  1346. aktmodeswitches:=initmodeswitches
  1347. else
  1348. if s='DELPHI' then
  1349. aktmodeswitches:=delphimodeswitches
  1350. else
  1351. if s='TP' then
  1352. aktmodeswitches:=tpmodeswitches
  1353. else
  1354. if s='FPC' then
  1355. aktmodeswitches:=fpcmodeswitches
  1356. else
  1357. if s='OBJFPC' then
  1358. aktmodeswitches:=objfpcmodeswitches
  1359. else
  1360. if s='GPC' then
  1361. aktmodeswitches:=gpcmodeswitches
  1362. else
  1363. if s='MACPAS' then
  1364. aktmodeswitches:=macmodeswitches
  1365. else
  1366. b:=false;
  1367. if b and changeInit then
  1368. initmodeswitches := aktmodeswitches;
  1369. if b then
  1370. begin
  1371. { turn ansistrings on by default ? }
  1372. if (m_delphi in aktmodeswitches) then
  1373. begin
  1374. include(aktlocalswitches,cs_ansistrings);
  1375. if changeinit then
  1376. include(initlocalswitches,cs_ansistrings);
  1377. end
  1378. else
  1379. begin
  1380. exclude(aktlocalswitches,cs_ansistrings);
  1381. if changeinit then
  1382. exclude(initlocalswitches,cs_ansistrings);
  1383. end;
  1384. { Default enum packing for delphi/tp7 }
  1385. if (m_tp7 in aktmodeswitches) or
  1386. (m_delphi in aktmodeswitches) then
  1387. aktpackenum:=1
  1388. else
  1389. aktpackenum:=4;
  1390. if changeinit then
  1391. initpackenum:=aktpackenum;
  1392. {$ifdef i386}
  1393. { Default to intel assembler for delphi/tp7 on i386 }
  1394. if (m_delphi in aktmodeswitches) or
  1395. (m_tp7 in aktmodeswitches) then
  1396. aktasmmode:=asmmode_i386_intel;
  1397. if changeinit then
  1398. initasmmode:=aktasmmode;
  1399. {$endif i386}
  1400. end;
  1401. SetCompileMode:=b;
  1402. end;
  1403. function SetAktProcCall(const s:string; changeInit:boolean):boolean;
  1404. const
  1405. DefProcCallName : array[tproccalloption] of string[12] = ('',
  1406. 'CDECL',
  1407. 'CPPDECL',
  1408. '', { compilerproc }
  1409. 'FAR16',
  1410. 'FPCCALL',
  1411. 'INLINE',
  1412. '', { internproc }
  1413. '', { syscall }
  1414. 'PASCAL',
  1415. 'REGISTER',
  1416. 'SAFECALL',
  1417. 'STDCALL',
  1418. 'SOFTFLOAT'
  1419. );
  1420. var
  1421. t : tproccalloption;
  1422. begin
  1423. result:=false;
  1424. for t:=low(tproccalloption) to high(tproccalloption) do
  1425. if DefProcCallName[t]=s then
  1426. begin
  1427. AktDefProcCall:=t;
  1428. result:=true;
  1429. break;
  1430. end;
  1431. if changeinit then
  1432. InitDefProcCall:=AktDefProcCall;
  1433. end;
  1434. function SetProcessor(const s:string; changeInit: boolean):boolean;
  1435. var
  1436. t : tprocessors;
  1437. begin
  1438. SetProcessor:=false;
  1439. for t:=low(tprocessors) to high(tprocessors) do
  1440. if processorsstr[t]=s then
  1441. begin
  1442. aktspecificoptprocessor:=t;
  1443. SetProcessor:=true;
  1444. break;
  1445. end;
  1446. if changeinit then
  1447. initspecificoptprocessor:=aktspecificoptprocessor;
  1448. end;
  1449. function SetFpuType(const s:string; changeInit: boolean):boolean;
  1450. var
  1451. t : tfputype;
  1452. begin
  1453. SetFpuType:=false;
  1454. for t:=low(tfputype) to high(tfputype) do
  1455. if fputypestr[t]=s then
  1456. begin
  1457. aktfputype:=t;
  1458. SetFpuType:=true;
  1459. break;
  1460. end;
  1461. if changeinit then
  1462. initfputype:=aktfputype;
  1463. end;
  1464. { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
  1465. function string2guid(const s: string; var GUID: TGUID): boolean;
  1466. function ishexstr(const hs: string): boolean;
  1467. var
  1468. i: integer;
  1469. begin
  1470. ishexstr:=false;
  1471. for i:=1 to Length(hs) do begin
  1472. if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
  1473. exit;
  1474. end;
  1475. ishexstr:=true;
  1476. end;
  1477. function hexstr2longint(const hexs: string): longint;
  1478. var
  1479. i: integer;
  1480. rl: longint;
  1481. begin
  1482. rl:=0;
  1483. for i:=1 to length(hexs) do begin
  1484. rl:=rl shl 4;
  1485. case hexs[i] of
  1486. '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
  1487. 'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
  1488. 'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
  1489. end
  1490. end;
  1491. hexstr2longint:=rl;
  1492. end;
  1493. var
  1494. i: integer;
  1495. begin
  1496. if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
  1497. (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
  1498. ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
  1499. ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
  1500. ishexstr(copy(s,26,12)) then begin
  1501. GUID.D1:=dword(hexstr2longint(copy(s,2,8)));
  1502. { these values are arealdy in the correct range (4 chars = word) }
  1503. GUID.D2:=word(hexstr2longint(copy(s,11,4)));
  1504. GUID.D3:=word(hexstr2longint(copy(s,16,4)));
  1505. for i:=0 to 1 do
  1506. GUID.D4[i]:=byte(hexstr2longint(copy(s,21+i*2,2)));
  1507. for i:=2 to 7 do
  1508. GUID.D4[i]:=byte(hexstr2longint(copy(s,22+i*2,2)));
  1509. string2guid:=true;
  1510. end
  1511. else
  1512. string2guid:=false;
  1513. end;
  1514. function guid2string(const GUID: TGUID): string;
  1515. function long2hex(l, len: longint): string;
  1516. const
  1517. hextbl: array[0..15] of char = '0123456789ABCDEF';
  1518. var
  1519. rs: string;
  1520. i: integer;
  1521. begin
  1522. rs[0]:=chr(len);
  1523. for i:=len downto 1 do begin
  1524. rs[i]:=hextbl[l and $F];
  1525. l:=l shr 4;
  1526. end;
  1527. long2hex:=rs;
  1528. end;
  1529. begin
  1530. guid2string:=
  1531. '{'+long2hex(GUID.D1,8)+
  1532. '-'+long2hex(GUID.D2,4)+
  1533. '-'+long2hex(GUID.D3,4)+
  1534. '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
  1535. '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
  1536. long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
  1537. long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
  1538. '}';
  1539. end;
  1540. function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
  1541. var
  1542. tok : string;
  1543. vstr : string;
  1544. l : longint;
  1545. code : integer;
  1546. b : talignmentinfo;
  1547. begin
  1548. UpdateAlignmentStr:=true;
  1549. uppervar(s);
  1550. fillchar(b,sizeof(b),0);
  1551. repeat
  1552. tok:=GetToken(s,'=');
  1553. if tok='' then
  1554. break;
  1555. vstr:=GetToken(s,',');
  1556. val(vstr,l,code);
  1557. if tok='PROC' then
  1558. b.procalign:=l
  1559. else if tok='JUMP' then
  1560. b.jumpalign:=l
  1561. else if tok='LOOP' then
  1562. b.loopalign:=l
  1563. else if tok='CONSTMIN' then
  1564. b.constalignmin:=l
  1565. else if tok='CONSTMAX' then
  1566. b.constalignmax:=l
  1567. else if tok='VARMIN' then
  1568. b.varalignmin:=l
  1569. else if tok='VARMAX' then
  1570. b.varalignmax:=l
  1571. else if tok='LOCALMIN' then
  1572. b.localalignmin:=l
  1573. else if tok='LOCALMAX' then
  1574. b.localalignmax:=l
  1575. else if tok='RECORDMIN' then
  1576. b.recordalignmin:=l
  1577. else if tok='RECORDMAX' then
  1578. b.recordalignmax:=l
  1579. else { Error }
  1580. UpdateAlignmentStr:=false;
  1581. until false;
  1582. UpdateAlignment(a,b);
  1583. end;
  1584. function var_align(siz: longint): longint;
  1585. begin
  1586. siz := size_2_align(siz);
  1587. var_align := used_align(siz,aktalignment.varalignmin,aktalignment.varalignmax);
  1588. end;
  1589. function const_align(siz: longint): longint;
  1590. begin
  1591. siz := size_2_align(siz);
  1592. const_align := used_align(siz,aktalignment.constalignmin,aktalignment.constalignmax);
  1593. end;
  1594. {****************************************************************************
  1595. Init
  1596. ****************************************************************************}
  1597. {$ifdef unix}
  1598. {$define need_path_search}
  1599. {$endif unix}
  1600. {$ifdef os2}
  1601. {$define need_path_search}
  1602. {$endif os2}
  1603. procedure get_exepath;
  1604. var
  1605. hs1 : namestr;
  1606. hs2 : extstr;
  1607. {$ifdef need_path_search}
  1608. p : pchar;
  1609. {$endif need_path_search}
  1610. begin
  1611. {$ifdef delphi}
  1612. exepath:=dmisc.getenv('PPC_EXEC_PATH');
  1613. {$else delphi}
  1614. exepath:=dos.getenv('PPC_EXEC_PATH');
  1615. {$endif delphi}
  1616. if exepath='' then
  1617. fsplit(FixFileName(system.paramstr(0)),exepath,hs1,hs2);
  1618. {$ifdef need_path_search}
  1619. if exepath='' then
  1620. begin
  1621. if pos(source_info.exeext,hs1) <>
  1622. (length(hs1) - length(source_info.exeext)+1) then
  1623. hs1 := hs1 + source_info.exeext;
  1624. p:=GetEnvPchar('PATH');
  1625. FindFilePChar(hs1,p,exepath);
  1626. FreeEnvPChar(p);
  1627. exepath:=SplitPath(exepath);
  1628. end;
  1629. {$endif need_path_search}
  1630. exepath:=FixPath(exepath,false);
  1631. end;
  1632. procedure DoneGlobals;
  1633. begin
  1634. initdefines.free;
  1635. if assigned(DLLImageBase) then
  1636. StringDispose(DLLImageBase);
  1637. librarysearchpath.Free;
  1638. unitsearchpath.Free;
  1639. objectsearchpath.Free;
  1640. includesearchpath.Free;
  1641. end;
  1642. procedure InitGlobals;
  1643. begin
  1644. get_exepath;
  1645. { reset globals }
  1646. do_build:=false;
  1647. do_release:=false;
  1648. do_make:=true;
  1649. compile_level:=0;
  1650. DLLsource:=false;
  1651. inlining_procedure:=false;
  1652. resolving_forward:=false;
  1653. make_ref:=false;
  1654. LinkTypeSetExplicitly:=false;
  1655. { Output }
  1656. OutputFile:='';
  1657. OutputPrefix:=Nil;
  1658. OutputSuffix:=Nil;
  1659. OutputExtension:='';
  1660. OutputExeDir:='';
  1661. OutputUnitDir:='';
  1662. { Utils directory }
  1663. utilsdirectory:='';
  1664. utilsprefix:='';
  1665. cshared:=false;
  1666. rlinkpath:='';
  1667. { Search Paths }
  1668. librarysearchpath:=TSearchPathList.Create;
  1669. unitsearchpath:=TSearchPathList.Create;
  1670. includesearchpath:=TSearchPathList.Create;
  1671. objectsearchpath:=TSearchPathList.Create;
  1672. { Def file }
  1673. usewindowapi:=false;
  1674. description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
  1675. DescriptionSetExplicity:=false;
  1676. dllversion:='';
  1677. dllmajor:=1;
  1678. dllminor:=0;
  1679. dllrevision:=0;
  1680. nwscreenname := '';
  1681. nwthreadname := '';
  1682. nwcopyright := '';
  1683. UseDeffileForExports:=false;
  1684. UseDeffileForExportsSetExplicitly:=false;
  1685. RelocSection:=false;
  1686. RelocSectionSetExplicitly:=false;
  1687. LinkTypeSetExplicitly:=false;
  1688. { Init values }
  1689. initmodeswitches:=fpcmodeswitches;
  1690. initlocalswitches:=[cs_check_io,cs_typed_const_writable];
  1691. initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
  1692. initsourcecodepage:='8859-1';
  1693. initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
  1694. initoutputformat:=target_asm.id;
  1695. fillchar(initalignment,sizeof(talignmentinfo),0);
  1696. { might be overridden later }
  1697. initasmmode:=asmmode_standard;
  1698. {$ifdef i386}
  1699. initoptprocessor:=Class386;
  1700. initspecificoptprocessor:=Class386;
  1701. initfputype:=fpu_x87;
  1702. initpackenum:=4;
  1703. {$IFDEF testvarsets}
  1704. initsetalloc:=0;
  1705. {$ENDIF}
  1706. initasmmode:=asmmode_i386_att;
  1707. {$endif i386}
  1708. {$ifdef m68k}
  1709. initoptprocessor:=MC68020;
  1710. initpackenum:=4;
  1711. {$IFDEF testvarsets}
  1712. initsetalloc:=0;
  1713. {$ENDIF}
  1714. {$endif m68k}
  1715. {$ifdef powerpc}
  1716. initoptprocessor:=PPC604;
  1717. initpackenum:=4;
  1718. {$IFDEF testvarsets}
  1719. initsetalloc:=0;
  1720. {$ENDIF}
  1721. initfputype:=fpu_standard;
  1722. {$endif powerpc}
  1723. {$ifdef sparc}
  1724. initoptprocessor:=SPARC_V8;
  1725. initpackenum:=4;
  1726. {$IFDEF testvarsets}
  1727. initsetalloc:=0;
  1728. {$ENDIF}
  1729. {$endif sparc}
  1730. {$ifdef arm}
  1731. initpackenum:=4;
  1732. {$IFDEF testvarsets}
  1733. initsetalloc:=0;
  1734. {$ENDIF}
  1735. initfputype:=fpu_fpa;
  1736. {$endif arm}
  1737. {$ifdef x86_64}
  1738. initoptprocessor:=ClassAthlon64;
  1739. initspecificoptprocessor:=ClassAthlon64;
  1740. initfputype:=fpu_sse64;
  1741. initpackenum:=4;
  1742. {$IFDEF testvarsets}
  1743. initsetalloc:=0;
  1744. {$ENDIF}
  1745. initasmmode:=asmmode_x86_64_gas;
  1746. {$endif x86_64}
  1747. initinterfacetype:=it_interfacecom;
  1748. initdefproccall:=pocall_default;
  1749. initdefines:=TStringList.Create;
  1750. { memory sizes, will be overriden by parameter or default for target
  1751. in options or init_parser }
  1752. stacksize:=0;
  1753. heapsize:=0;
  1754. apptype:=app_cui;
  1755. end;
  1756. end.
  1757. {
  1758. $Log$
  1759. Revision 1.138 2004-09-08 11:23:31 michael
  1760. + Check if outputdir exists, Fix exitcode when displaying help pages
  1761. Revision 1.137 2004/08/31 22:02:30 olle
  1762. + support for quoting of paths in TSearchPathList.AddPath so that
  1763. compiler directives which take paths, will support quotes.
  1764. * uppdated TranslateMacPath
  1765. Revision 1.136 2004/08/28 20:25:25 peter
  1766. * optimized search for noncasesensitive names. It now searches
  1767. first for NormalCase and skips double tests
  1768. Revision 1.135 2004/08/20 10:29:31 olle
  1769. + made fpc work as an MPW tool, by itself calling asm and link.
  1770. * bugfix in fp exception flag settings routine
  1771. Revision 1.134 2004/08/02 07:15:54 michael
  1772. + Patch from Christian Iversen to implement LIBPREFIX/SUFFIX/EXTENSION directives
  1773. Revision 1.133 2004/07/17 15:51:57 jonas
  1774. * shell now returns an exitcode
  1775. * print an error if linking failed when linking was done using a script
  1776. Revision 1.132 2004/07/05 23:28:24 olle
  1777. + FixFileName now handles Mac OS paths
  1778. Revision 1.131 2004/06/20 08:55:29 florian
  1779. * logs truncated
  1780. Revision 1.130 2004/06/16 20:07:07 florian
  1781. * dwarf branch merged
  1782. Revision 1.129 2004/05/11 18:20:52 olle
  1783. * changed $mode mac to $mode macpas
  1784. * changed macmodeswitches to be more faithful to the mac dialect
  1785. Revision 1.128 2004/04/29 19:56:36 daniel
  1786. * Prepare compiler infrastructure for multiple ansistring types
  1787. Revision 1.127 2004/04/28 15:19:03 florian
  1788. + syscall directive support for MorphOS added
  1789. Revision 1.126.2.4 2004/05/09 15:47:21 peter
  1790. * fix typecast from word->set
  1791. }