globals.pas 54 KB

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