globals.pas 54 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920
  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. Function FixPath(s:string;allowdot:boolean):string;
  552. var
  553. i : longint;
  554. begin
  555. { Fix separator }
  556. for i:=1 to length(s) do
  557. if s[i] in ['/','\'] then
  558. s[i]:=source_info.DirSep;
  559. { Fix ending / }
  560. if (length(s)>0) and (s[length(s)]<>source_info.DirSep) and
  561. (s[length(s)]<>':') then
  562. s:=s+source_info.DirSep;
  563. { Remove ./ }
  564. if (not allowdot) and (s='.'+source_info.DirSep) then
  565. s:='';
  566. { return }
  567. if source_info.files_case_relevent then
  568. FixPath:=s
  569. else
  570. FixPath:=Lower(s);
  571. end;
  572. function FixFileName(const s:string):string;
  573. var
  574. i : longint;
  575. begin
  576. if source_info.files_case_relevent then
  577. begin
  578. for i:=1 to length(s) do
  579. begin
  580. case s[i] of
  581. '/','\' :
  582. FixFileName[i]:=source_info.dirsep;
  583. else
  584. FixFileName[i]:=s[i];
  585. end;
  586. end;
  587. end
  588. else
  589. begin
  590. for i:=1 to length(s) do
  591. begin
  592. case s[i] of
  593. '/','\' :
  594. FixFileName[i]:=source_info.dirsep;
  595. 'A'..'Z' :
  596. FixFileName[i]:=char(byte(s[i])+32);
  597. else
  598. FixFileName[i]:=s[i];
  599. end;
  600. end;
  601. end;
  602. FixFileName[0]:=s[0];
  603. end;
  604. {Translates a unix or dos path to a mac path for use in MPW.
  605. If already a mac path, it does nothing. The origin of this
  606. algorithm will be put in macos/dos.pp, please update this
  607. from that, because there is some flaws in the algo below.}
  608. procedure TranslatePathToMac (var path: string);
  609. var
  610. slashPos, oldpos, newpos, oldlen: Integer;
  611. inname: Boolean;
  612. begin
  613. slashPos := Pos('/', path);
  614. if (slashPos <> 0) then {its a unix path}
  615. begin
  616. if slashPos = 1 then {its a full path}
  617. begin
  618. Delete(path,1,1);
  619. Insert('{Boot}', path, 1);
  620. end
  621. else {its a partial path}
  622. Insert('/', path, 1);
  623. end
  624. else
  625. begin
  626. slashPos := Pos('\', path);
  627. if (slashPos <> 0) then {its a dos path}
  628. begin
  629. if slashPos = 1 then {its a full path, without drive letter}
  630. begin
  631. Delete(path,1,1);
  632. Insert('{Boot}', path, 1);
  633. end
  634. else if (Length(path) >= 2) and (path[2] = ':') then {its a full path, with drive letter}
  635. begin
  636. Delete(path, 1, 2);
  637. Insert('{Boot}', path, 1)
  638. end
  639. else {its a partial path}
  640. Insert('/', path, 1);
  641. end;
  642. end;
  643. if (slashPos <> 0) then {its a unix or dos path}
  644. begin
  645. {Translate "/../" to "::" , "/./" to ":" and "/" to ":" ) in place. }
  646. oldlen := Length(path);
  647. newpos := 0;
  648. oldpos := 0;
  649. inname := false;
  650. while oldpos < oldlen do
  651. begin
  652. oldpos := oldpos + 1;
  653. case path[oldpos] of
  654. '.':
  655. if (((oldpos < oldlen) and (path[oldpos + 1] in ['.', '/', '\'])) or (oldpos = oldlen)) and not inname then
  656. begin {its really a lonely ".." or "."}
  657. {Skip two chars in any case. }
  658. {For ".." then ".." is skiped and for "." then "./" is skiped, this}
  659. {reqires the next char is a "/". Thats why a "/" was }
  660. {appended on the end above.}
  661. oldpos := oldpos + 1;
  662. end
  663. else {its part of a filename (hidden unix file, e g ".nisse")}
  664. begin
  665. inname := true;
  666. newpos := newpos + 1;
  667. path[newpos] := path[oldpos];
  668. end;
  669. '/', '\':
  670. begin
  671. inname := false;
  672. newpos := newpos + 1;
  673. path[newpos] := ':'; {Exchange to mac dir separator.}
  674. end;
  675. 'A'..'Z' :
  676. begin
  677. inname := true;
  678. newpos := newpos + 1;
  679. path[newpos] :=char(byte(path[oldpos])+32);
  680. end;
  681. else
  682. begin
  683. inname := true;
  684. newpos := newpos + 1;
  685. path[newpos] := path[oldpos];
  686. end;
  687. end;
  688. end;
  689. SetLength(path,newpos);
  690. end;
  691. end;
  692. Function TargetFixPath(s:string;allowdot:boolean):string;
  693. var
  694. i : longint;
  695. begin
  696. { Fix separator }
  697. for i:=1 to length(s) do
  698. if s[i] in ['/','\'] then
  699. s[i]:=target_info.DirSep;
  700. { Fix ending / }
  701. if (length(s)>0) and (s[length(s)]<>target_info.DirSep) and
  702. (s[length(s)]<>':') then
  703. s:=s+target_info.DirSep;
  704. { Remove ./ }
  705. if (not allowdot) and (s='.'+target_info.DirSep) then
  706. s:='';
  707. { return }
  708. if target_info.files_case_relevent then
  709. TargetFixPath:=s
  710. else
  711. TargetFixPath:=Lower(s);
  712. end;
  713. function TargetFixFileName(const s:string):string;
  714. var
  715. i : longint;
  716. begin
  717. if target_info.system = system_powerpc_MACOS then
  718. begin
  719. TargetFixFileName:= s;
  720. TranslatePathToMac(TargetFixFileName);
  721. end
  722. else if target_info.files_case_relevent then
  723. begin
  724. for i:=1 to length(s) do
  725. begin
  726. case s[i] of
  727. '/','\' :
  728. TargetFixFileName[i]:=target_info.dirsep;
  729. else
  730. TargetFixFileName[i]:=s[i];
  731. end;
  732. end;
  733. TargetFixFileName[0]:=s[0];
  734. end
  735. else
  736. begin
  737. for i:=1 to length(s) do
  738. begin
  739. case s[i] of
  740. '/','\' :
  741. TargetFixFileName[i]:=target_info.dirsep;
  742. 'A'..'Z' :
  743. TargetFixFileName[i]:=char(byte(s[i])+32);
  744. else
  745. TargetFixFileName[i]:=s[i];
  746. end;
  747. end;
  748. TargetFixFileName[0]:=s[0];
  749. end;
  750. end;
  751. procedure SplitBinCmd(const s:string;var bstr,cstr:string);
  752. var
  753. i : longint;
  754. begin
  755. i:=pos(' ',s);
  756. if i>0 then
  757. begin
  758. bstr:=Copy(s,1,i-1);
  759. cstr:=Copy(s,i+1,length(s)-i);
  760. end
  761. else
  762. begin
  763. bstr:=s;
  764. cstr:='';
  765. end;
  766. end;
  767. procedure TSearchPathList.AddPath(s:string;addfirst:boolean);
  768. begin
  769. AddPath('',s,AddFirst);
  770. end;
  771. procedure TSearchPathList.AddPath(SrcPath,s:string;addfirst:boolean);
  772. var
  773. j : longint;
  774. hs,hsd,
  775. CurrentDir,
  776. CurrPath : string;
  777. subdirfound : boolean;
  778. dir : searchrec;
  779. hp : TStringListItem;
  780. procedure addcurrpath;
  781. begin
  782. if addfirst then
  783. begin
  784. Remove(currPath);
  785. Insert(currPath);
  786. end
  787. else
  788. begin
  789. { Check if already in path, then we don't add it }
  790. hp:=Find(currPath);
  791. if not assigned(hp) then
  792. Concat(currPath);
  793. end;
  794. end;
  795. begin
  796. if s='' then
  797. exit;
  798. { Support default macro's }
  799. DefaultReplacements(s);
  800. { get current dir }
  801. CurrentDir:=GetCurrentDir;
  802. repeat
  803. { get currpath }
  804. if addfirst then
  805. begin
  806. j:=length(s);
  807. while (j>0) and (s[j]<>';') do
  808. dec(j);
  809. CurrPath:=FixPath(Copy(s,j+1,length(s)-j),false);
  810. if j=0 then
  811. s:=''
  812. else
  813. System.Delete(s,j,length(s)-j+1);
  814. end
  815. else
  816. begin
  817. j:=Pos(';',s);
  818. if j=0 then
  819. j:=255;
  820. CurrPath:=SrcPath+FixPath(Copy(s,1,j-1),false);
  821. System.Delete(s,1,j);
  822. end;
  823. { fix pathname }
  824. if CurrPath='' then
  825. CurrPath:='.'+source_info.DirSep
  826. else
  827. begin
  828. CurrPath:=FixPath(FExpand(CurrPath),false);
  829. if (CurrentDir<>'') and (Copy(CurrPath,1,length(CurrentDir))=CurrentDir) then
  830. begin
  831. {$ifdef AMIGA}
  832. CurrPath:=CurrentDir+Copy(CurrPath,length(CurrentDir)+1,255);
  833. {$else}
  834. CurrPath:='.'+source_info.DirSep+Copy(CurrPath,length(CurrentDir)+1,255);
  835. {$endif}
  836. end;
  837. end;
  838. { wildcard adding ? }
  839. if pos('*',currpath)>0 then
  840. begin
  841. if currpath[length(currpath)]=source_info.dirsep then
  842. hs:=Copy(currpath,1,length(CurrPath)-1)
  843. else
  844. hs:=currpath;
  845. hsd:=SplitPath(hs);
  846. findfirst(hs,directory,dir);
  847. subdirfound:=false;
  848. while doserror=0 do
  849. begin
  850. if (dir.name<>'.') and
  851. (dir.name<>'..') and
  852. ((dir.attr and directory)<>0) then
  853. begin
  854. subdirfound:=true;
  855. currpath:=hsd+dir.name+source_info.dirsep;
  856. hp:=Find(currPath);
  857. if not assigned(hp) then
  858. AddCurrPath;
  859. end;
  860. findnext(dir);
  861. if not subdirfound then
  862. WarnNonExistingPath(currpath);
  863. end;
  864. FindClose(dir);
  865. end
  866. else
  867. begin
  868. if PathExists(currpath) then
  869. addcurrpath
  870. else
  871. WarnNonExistingPath(currpath);
  872. end;
  873. until (s='');
  874. end;
  875. procedure TSearchPathList.AddList(list:TSearchPathList;addfirst:boolean);
  876. var
  877. s : string;
  878. hl : TSearchPathList;
  879. hp,hp2 : TStringListItem;
  880. begin
  881. if list.empty then
  882. exit;
  883. { create temp and reverse the list }
  884. if addfirst then
  885. begin
  886. hl:=TSearchPathList.Create;
  887. hp:=TStringListItem(list.first);
  888. while assigned(hp) do
  889. begin
  890. hl.insert(hp.Str);
  891. hp:=TStringListItem(hp.next);
  892. end;
  893. while not hl.empty do
  894. begin
  895. s:=hl.GetFirst;
  896. Remove(s);
  897. Insert(s);
  898. end;
  899. hl.Free;
  900. end
  901. else
  902. begin
  903. hp:=TStringListItem(list.first);
  904. while assigned(hp) do
  905. begin
  906. hp2:=Find(hp.Str);
  907. { Check if already in path, then we don't add it }
  908. if not assigned(hp2) then
  909. Concat(hp.Str);
  910. hp:=TStringListItem(hp.next);
  911. end;
  912. end;
  913. end;
  914. function TSearchPathList.FindFile(const f : string;var foundfile:string):boolean;
  915. Var
  916. p : TStringListItem;
  917. begin
  918. FindFile:=false;
  919. p:=TStringListItem(first);
  920. while assigned(p) do
  921. begin
  922. {
  923. Search order for case sensitive systems:
  924. 1. lowercase
  925. 2. NormalCase
  926. 3. UPPERCASE
  927. None case sensitive only lowercase
  928. }
  929. FoundFile:=p.Str+Lower(f);
  930. If FileExists(FoundFile) then
  931. begin
  932. FindFile:=true;
  933. exit;
  934. end;
  935. {$ifdef UNIX}
  936. FoundFile:=p.Str+f;
  937. If FileExists(FoundFile) then
  938. begin
  939. FindFile:=true;
  940. exit;
  941. end;
  942. FoundFile:=p.Str+Upper(f);
  943. If FileExists(FoundFile) then
  944. begin
  945. FindFile:=true;
  946. exit;
  947. end;
  948. {$endif UNIX}
  949. p:=TStringListItem(p.next);
  950. end;
  951. { Return original filename if not found }
  952. FoundFile:=f;
  953. end;
  954. Function GetFileTime ( Var F : File) : Longint;
  955. Var
  956. {$ifdef hasunix}
  957. info: Stat;
  958. {$endif}
  959. L : longint;
  960. begin
  961. {$ifdef hasunix}
  962. {$IFDEF havelinuxrtl10}
  963. FStat (F,Info);
  964. L:=Info.Mtime;
  965. {$ELSE}
  966. FPFStat (F,Info);
  967. L:=Info.st_Mtime;
  968. {$ENDIF}
  969. {$else}
  970. GetFTime(f,l);
  971. {$endif}
  972. GetFileTime:=L;
  973. end;
  974. Function GetNamedFileTime (Const F : String) : Longint;
  975. begin
  976. GetNamedFileTime:=do_getnamedfiletime(F);
  977. end;
  978. function FindFile(const f : string;path : string;var foundfile:string):boolean;
  979. Var
  980. singlepathstring : string;
  981. i : longint;
  982. begin
  983. {$ifdef Unix}
  984. for i:=1 to length(path) do
  985. if path[i]=':' then
  986. path[i]:=';';
  987. {$endif Unix}
  988. FindFile:=false;
  989. repeat
  990. i:=pos(';',path);
  991. if i=0 then
  992. i:=256;
  993. singlepathstring:=FixPath(copy(path,1,i-1),false);
  994. delete(path,1,i);
  995. {
  996. Search order for case sensitive systems:
  997. 1. lowercase
  998. 2. NormalCase
  999. 3. UPPERCASE
  1000. None case sensitive only lowercase
  1001. }
  1002. FoundFile:=singlepathstring+Lower(f);
  1003. If FileExists(FoundFile) then
  1004. begin
  1005. FindFile:=true;
  1006. exit;
  1007. end;
  1008. {$ifdef UNIX}
  1009. FoundFile:=singlepathstring+f;
  1010. If FileExists(FoundFile) then
  1011. begin
  1012. FindFile:=true;
  1013. exit;
  1014. end;
  1015. FoundFile:=singlepathstring+Upper(f);
  1016. If FileExists(FoundFile) then
  1017. begin
  1018. FindFile:=true;
  1019. exit;
  1020. end;
  1021. {$endif UNIX}
  1022. until path='';
  1023. FoundFile:=f;
  1024. end;
  1025. function FindFilePchar(const f : string;path : pchar;var foundfile:string):boolean;
  1026. Var
  1027. singlepathstring : string;
  1028. startpc,pc : pchar;
  1029. sepch : char;
  1030. begin
  1031. {$ifdef Unix}
  1032. sepch:=':';
  1033. {$else}
  1034. sepch:=';';
  1035. {$endif Unix}
  1036. FindFilePchar:=false;
  1037. pc:=path;
  1038. repeat
  1039. startpc:=pc;
  1040. while (pc^<>sepch) and (pc^<>';') and (pc^<>#0) do
  1041. inc(pc);
  1042. move(startpc^,singlepathstring[1],pc-startpc);
  1043. singlepathstring[0]:=char(longint(pc-startpc));
  1044. singlepathstring:=FixPath(singlepathstring,false);
  1045. {
  1046. Search order for case sensitive systems:
  1047. 1. lowercase
  1048. 2. NormalCase
  1049. 3. UPPERCASE
  1050. None case sensitive only lowercase
  1051. }
  1052. FoundFile:=singlepathstring+Lower(f);
  1053. If FileExists(FoundFile) then
  1054. begin
  1055. FindFilePchar:=true;
  1056. exit;
  1057. end;
  1058. {$ifdef UNIX}
  1059. FoundFile:=singlepathstring+f;
  1060. If FileExists(FoundFile) then
  1061. begin
  1062. FindFilePchar:=true;
  1063. exit;
  1064. end;
  1065. FoundFile:=singlepathstring+Upper(f);
  1066. If FileExists(FoundFile) then
  1067. begin
  1068. FindFilePchar:=true;
  1069. exit;
  1070. end;
  1071. {$endif UNIX}
  1072. if (pc^=#0) then
  1073. break;
  1074. inc(pc);
  1075. until false;
  1076. end;
  1077. function FindExe(const bin:string;var foundfile:string):boolean;
  1078. var
  1079. p : pchar;
  1080. found : boolean;
  1081. begin
  1082. found:=FindFile(FixFileName(AddExtension(bin,source_info.exeext)),'.;'+exepath,foundfile);
  1083. if not found then
  1084. begin
  1085. p:=GetEnvPchar('PATH');
  1086. found:=FindFilePChar(FixFileName(AddExtension(bin,source_info.exeext)),p,foundfile);
  1087. FreeEnvPChar(p);
  1088. end;
  1089. FindExe:=found;
  1090. end;
  1091. function GetShortName(const n:string):string;
  1092. {$ifdef win32}
  1093. var
  1094. hs,hs2 : string;
  1095. i : longint;
  1096. {$endif}
  1097. {$ifdef go32v2}
  1098. var
  1099. hs : string;
  1100. {$endif}
  1101. {$ifdef watcom}
  1102. var
  1103. hs : string;
  1104. {$endif}
  1105. begin
  1106. GetShortName:=n;
  1107. {$ifdef win32}
  1108. hs:=n+#0;
  1109. i:=Windows.GetShortPathName(@hs[1],@hs2[1],high(hs2));
  1110. if (i>0) and (i<=high(hs2)) then
  1111. begin
  1112. hs2[0]:=chr(strlen(@hs2[1]));
  1113. GetShortName:=hs2;
  1114. end;
  1115. {$endif}
  1116. {$ifdef go32v2}
  1117. hs:=n;
  1118. if Dos.GetShortName(hs) then
  1119. GetShortName:=hs;
  1120. {$endif}
  1121. {$ifdef watcom}
  1122. hs:=n;
  1123. if Dos.GetShortName(hs) then
  1124. GetShortName:=hs;
  1125. {$endif}
  1126. end;
  1127. {****************************************************************************
  1128. OS Dependent things
  1129. ****************************************************************************}
  1130. function GetEnvPChar(const envname:string):pchar;
  1131. {$ifdef win32}
  1132. var
  1133. s : string;
  1134. i,len : longint;
  1135. hp,p,p2 : pchar;
  1136. {$endif}
  1137. begin
  1138. {$ifdef hasunix}
  1139. GetEnvPchar:={$ifdef havelinuxrtl10}Linux.getenv{$else}BaseUnix.fpGetEnv{$endif}(envname);
  1140. {$define GETENVOK}
  1141. {$endif}
  1142. {$ifdef win32}
  1143. GetEnvPchar:=nil;
  1144. p:=GetEnvironmentStrings;
  1145. hp:=p;
  1146. while hp^<>#0 do
  1147. begin
  1148. s:=strpas(hp);
  1149. i:=pos('=',s);
  1150. len:=strlen(hp);
  1151. if upper(copy(s,1,i-1))=upper(envname) then
  1152. begin
  1153. GetMem(p2,len-length(envname));
  1154. Move(hp[i],p2^,len-length(envname));
  1155. GetEnvPchar:=p2;
  1156. break;
  1157. end;
  1158. { next string entry}
  1159. hp:=hp+len+1;
  1160. end;
  1161. FreeEnvironmentStrings(p);
  1162. {$define GETENVOK}
  1163. {$endif}
  1164. {$ifdef os2}
  1165. GetEnvPChar := Dos.GetEnvPChar (EnvName);
  1166. {$define GETENVOK}
  1167. {$endif}
  1168. {$ifdef GETENVOK}
  1169. {$undef GETENVOK}
  1170. {$else}
  1171. GetEnvPchar:=StrPNew({$ifdef delphi}DMisc{$else}Dos{$endif}.Getenv(envname));
  1172. {$endif}
  1173. end;
  1174. procedure FreeEnvPChar(p:pchar);
  1175. begin
  1176. {$ifndef hasunix}
  1177. {$ifndef os2}
  1178. StrDispose(p);
  1179. {$endif}
  1180. {$endif}
  1181. end;
  1182. Procedure Shell(const command:string);
  1183. { This is already defined in the linux.ppu for linux, need for the *
  1184. expansion under linux }
  1185. {$ifdef hasunix}
  1186. begin
  1187. {$ifdef havelinuxrtl10}Linux{$else}Unix{$endif}.Shell(command);
  1188. end;
  1189. {$else}
  1190. {$ifdef amiga}
  1191. begin
  1192. exec('',command);
  1193. end;
  1194. {$else}
  1195. var
  1196. comspec : string;
  1197. begin
  1198. comspec:=getenv('COMSPEC');
  1199. Exec(comspec,' /C '+command);
  1200. end;
  1201. {$endif}
  1202. {$endif}
  1203. {$ifdef CPUI386}
  1204. { later, this should be replaced by the math unit }
  1205. const
  1206. Default8087CW : word = $1332;
  1207. {$ASMMODE ATT}
  1208. procedure Set8087CW(cw:word);assembler;
  1209. asm
  1210. movw cw,%ax
  1211. movw %ax,default8087cw
  1212. fnclex
  1213. fldcw default8087cw
  1214. end;
  1215. function Get8087CW:word;assembler;
  1216. asm
  1217. pushl $0
  1218. fnstcw (%esp)
  1219. popl %eax
  1220. end;
  1221. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1222. var
  1223. CtlWord: Word;
  1224. begin
  1225. CtlWord:=Get8087CW;
  1226. Set8087CW( (CtlWord and $FFC0) or Byte(Longint(Mask)) );
  1227. Result:=TFPUExceptionMask(Longint(CtlWord and $3F));
  1228. end;
  1229. {$else CPUI386}
  1230. {$ifdef CPUPOWERPC}
  1231. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1232. var
  1233. newmask: record
  1234. case byte of
  1235. 1: (d: double);
  1236. 2: (a,b: cardinal);
  1237. end;
  1238. begin
  1239. { load current control register contents }
  1240. asm
  1241. mffs f0
  1242. stfd f0,newmask.d
  1243. end;
  1244. { invalid operation: bit 24 (big endian, bit 0 = left-most bit) }
  1245. if (exInvalidOp in mask) then
  1246. newmask.b := newmask.b and not(1 shl (31-24))
  1247. else
  1248. newmask.b := newmask.b or (1 shl (31-24));
  1249. { denormals can not cause exceptions on the PPC }
  1250. { zero divide: bit 27 }
  1251. if (exZeroDivide in mask) then
  1252. newmask.b := newmask.b and not(1 shl (31-27))
  1253. else
  1254. newmask.b := newmask.b or (1 shl (31-27));
  1255. { overflow: bit 25 }
  1256. if (exOverflow in mask) then
  1257. newmask.b := newmask.b and not(1 shl (31-25))
  1258. else
  1259. newmask.b := newmask.b or (1 shl (31-25));
  1260. { underflow: bit 26 }
  1261. if (exUnderflow in mask) then
  1262. newmask.b := newmask.b and not(1 shl (31-26))
  1263. else
  1264. newmask.b := newmask.b or (1 shl (31-26));
  1265. { Precision (inexact result): bit 28 }
  1266. if (exUnderflow in mask) then
  1267. newmask.b := newmask.b and not(1 shl (31-28))
  1268. else
  1269. newmask.b := newmask.b or (1 shl (31-28));
  1270. { update control register contents }
  1271. asm
  1272. lfd f0, newmask.d
  1273. mtfsf 255,f0
  1274. end;
  1275. end;
  1276. {$else CPUPOWERPC}
  1277. function SetFPUExceptionMask(const Mask: TFPUExceptionMask): TFPUExceptionMask;
  1278. begin
  1279. end;
  1280. {$endif CPUPOWERPC}
  1281. {$endif CPUI386}
  1282. function is_number_float(d : double) : boolean;
  1283. var
  1284. bytearray : array[0..7] of byte;
  1285. begin
  1286. move(d,bytearray,8);
  1287. { only 1.1 save, 1.0.x will use always little endian }
  1288. {$ifdef FPC_BIG_ENDIAN}
  1289. result:=((bytearray[0] and $7f)<>$7f) or ((bytearray[1] and $f0)<>$f0);
  1290. {$else FPC_BIG_ENDIAN}
  1291. result:=((bytearray[7] and $7f)<>$7f) or ((bytearray[6] and $f0)<>$f0);
  1292. {$endif FPC_BIG_ENDIAN}
  1293. end;
  1294. Function SetCompileMode(const s:string; changeInit: boolean):boolean;
  1295. var
  1296. b : boolean;
  1297. begin
  1298. b:=true;
  1299. if s='DEFAULT' then
  1300. aktmodeswitches:=initmodeswitches
  1301. else
  1302. if s='DELPHI' then
  1303. aktmodeswitches:=delphimodeswitches
  1304. else
  1305. if s='TP' then
  1306. aktmodeswitches:=tpmodeswitches
  1307. else
  1308. if s='FPC' then
  1309. aktmodeswitches:=fpcmodeswitches
  1310. else
  1311. if s='OBJFPC' then
  1312. aktmodeswitches:=objfpcmodeswitches
  1313. else
  1314. if s='GPC' then
  1315. aktmodeswitches:=gpcmodeswitches
  1316. else
  1317. if s='MACPAS' then
  1318. aktmodeswitches:=macmodeswitches
  1319. else
  1320. b:=false;
  1321. if b and changeInit then
  1322. initmodeswitches := aktmodeswitches;
  1323. if b then
  1324. begin
  1325. { turn ansistrings on by default ? }
  1326. if (m_delphi in aktmodeswitches) then
  1327. begin
  1328. include(aktlocalswitches,cs_ansistrings);
  1329. if changeinit then
  1330. include(initlocalswitches,cs_ansistrings);
  1331. end
  1332. else
  1333. begin
  1334. exclude(aktlocalswitches,cs_ansistrings);
  1335. if changeinit then
  1336. exclude(initlocalswitches,cs_ansistrings);
  1337. end;
  1338. { Default enum packing for delphi/tp7 }
  1339. if (m_tp7 in aktmodeswitches) or
  1340. (m_delphi in aktmodeswitches) then
  1341. aktpackenum:=1
  1342. else
  1343. aktpackenum:=4;
  1344. if changeinit then
  1345. initpackenum:=aktpackenum;
  1346. {$ifdef i386}
  1347. { Default to intel assembler for delphi/tp7 on i386 }
  1348. if (m_delphi in aktmodeswitches) or
  1349. (m_tp7 in aktmodeswitches) then
  1350. aktasmmode:=asmmode_i386_intel;
  1351. if changeinit then
  1352. initasmmode:=aktasmmode;
  1353. {$endif i386}
  1354. end;
  1355. SetCompileMode:=b;
  1356. end;
  1357. function SetAktProcCall(const s:string; changeInit:boolean):boolean;
  1358. const
  1359. DefProcCallName : array[tproccalloption] of string[12] = ('',
  1360. 'CDECL',
  1361. 'CPPDECL',
  1362. '', { compilerproc }
  1363. 'FAR16',
  1364. 'FPCCALL',
  1365. 'INLINE',
  1366. '', { internproc }
  1367. '', { syscall }
  1368. 'PASCAL',
  1369. 'REGISTER',
  1370. 'SAFECALL',
  1371. 'STDCALL',
  1372. 'SOFTFLOAT'
  1373. );
  1374. var
  1375. t : tproccalloption;
  1376. begin
  1377. result:=false;
  1378. for t:=low(tproccalloption) to high(tproccalloption) do
  1379. if DefProcCallName[t]=s then
  1380. begin
  1381. AktDefProcCall:=t;
  1382. result:=true;
  1383. break;
  1384. end;
  1385. if changeinit then
  1386. InitDefProcCall:=AktDefProcCall;
  1387. end;
  1388. function SetProcessor(const s:string; changeInit: boolean):boolean;
  1389. var
  1390. t : tprocessors;
  1391. begin
  1392. SetProcessor:=false;
  1393. for t:=low(tprocessors) to high(tprocessors) do
  1394. if processorsstr[t]=s then
  1395. begin
  1396. aktspecificoptprocessor:=t;
  1397. SetProcessor:=true;
  1398. break;
  1399. end;
  1400. if changeinit then
  1401. initspecificoptprocessor:=aktspecificoptprocessor;
  1402. end;
  1403. function SetFpuType(const s:string; changeInit: boolean):boolean;
  1404. var
  1405. t : tfputype;
  1406. begin
  1407. SetFpuType:=false;
  1408. for t:=low(tfputype) to high(tfputype) do
  1409. if fputypestr[t]=s then
  1410. begin
  1411. aktfputype:=t;
  1412. SetFpuType:=true;
  1413. break;
  1414. end;
  1415. if changeinit then
  1416. initfputype:=aktfputype;
  1417. end;
  1418. { '('D1:'00000000-'D2:'0000-'D3:'0000-'D4:'0000-000000000000)' }
  1419. function string2guid(const s: string; var GUID: TGUID): boolean;
  1420. function ishexstr(const hs: string): boolean;
  1421. var
  1422. i: integer;
  1423. begin
  1424. ishexstr:=false;
  1425. for i:=1 to Length(hs) do begin
  1426. if not (hs[i] in ['0'..'9','A'..'F','a'..'f']) then
  1427. exit;
  1428. end;
  1429. ishexstr:=true;
  1430. end;
  1431. function hexstr2longint(const hexs: string): longint;
  1432. var
  1433. i: integer;
  1434. rl: longint;
  1435. begin
  1436. rl:=0;
  1437. for i:=1 to length(hexs) do begin
  1438. rl:=rl shl 4;
  1439. case hexs[i] of
  1440. '0'..'9' : inc(rl,ord(hexs[i])-ord('0'));
  1441. 'A'..'F' : inc(rl,ord(hexs[i])-ord('A')+10);
  1442. 'a'..'f' : inc(rl,ord(hexs[i])-ord('a')+10);
  1443. end
  1444. end;
  1445. hexstr2longint:=rl;
  1446. end;
  1447. var
  1448. i: integer;
  1449. begin
  1450. if (Length(s)=38) and (s[1]='{') and (s[38]='}') and
  1451. (s[10]='-') and (s[15]='-') and (s[20]='-') and (s[25]='-') and
  1452. ishexstr(copy(s,2,8)) and ishexstr(copy(s,11,4)) and
  1453. ishexstr(copy(s,16,4)) and ishexstr(copy(s,21,4)) and
  1454. ishexstr(copy(s,26,12)) then begin
  1455. GUID.D1:=dword(hexstr2longint(copy(s,2,8)));
  1456. { these values are arealdy in the correct range (4 chars = word) }
  1457. GUID.D2:=word(hexstr2longint(copy(s,11,4)));
  1458. GUID.D3:=word(hexstr2longint(copy(s,16,4)));
  1459. for i:=0 to 1 do
  1460. GUID.D4[i]:=byte(hexstr2longint(copy(s,21+i*2,2)));
  1461. for i:=2 to 7 do
  1462. GUID.D4[i]:=byte(hexstr2longint(copy(s,22+i*2,2)));
  1463. string2guid:=true;
  1464. end
  1465. else
  1466. string2guid:=false;
  1467. end;
  1468. function guid2string(const GUID: TGUID): string;
  1469. function long2hex(l, len: longint): string;
  1470. const
  1471. hextbl: array[0..15] of char = '0123456789ABCDEF';
  1472. var
  1473. rs: string;
  1474. i: integer;
  1475. begin
  1476. rs[0]:=chr(len);
  1477. for i:=len downto 1 do begin
  1478. rs[i]:=hextbl[l and $F];
  1479. l:=l shr 4;
  1480. end;
  1481. long2hex:=rs;
  1482. end;
  1483. begin
  1484. guid2string:=
  1485. '{'+long2hex(GUID.D1,8)+
  1486. '-'+long2hex(GUID.D2,4)+
  1487. '-'+long2hex(GUID.D3,4)+
  1488. '-'+long2hex(GUID.D4[0],2)+long2hex(GUID.D4[1],2)+
  1489. '-'+long2hex(GUID.D4[2],2)+long2hex(GUID.D4[3],2)+
  1490. long2hex(GUID.D4[4],2)+long2hex(GUID.D4[5],2)+
  1491. long2hex(GUID.D4[6],2)+long2hex(GUID.D4[7],2)+
  1492. '}';
  1493. end;
  1494. function UpdateAlignmentStr(s:string;var a:talignmentinfo):boolean;
  1495. var
  1496. tok : string;
  1497. vstr : string;
  1498. l : longint;
  1499. code : integer;
  1500. b : talignmentinfo;
  1501. begin
  1502. UpdateAlignmentStr:=true;
  1503. uppervar(s);
  1504. fillchar(b,sizeof(b),0);
  1505. repeat
  1506. tok:=GetToken(s,'=');
  1507. if tok='' then
  1508. break;
  1509. vstr:=GetToken(s,',');
  1510. val(vstr,l,code);
  1511. if tok='PROC' then
  1512. b.procalign:=l
  1513. else if tok='JUMP' then
  1514. b.jumpalign:=l
  1515. else if tok='LOOP' then
  1516. b.loopalign:=l
  1517. else if tok='CONSTMIN' then
  1518. b.constalignmin:=l
  1519. else if tok='CONSTMAX' then
  1520. b.constalignmax:=l
  1521. else if tok='VARMIN' then
  1522. b.varalignmin:=l
  1523. else if tok='VARMAX' then
  1524. b.varalignmax:=l
  1525. else if tok='LOCALMIN' then
  1526. b.localalignmin:=l
  1527. else if tok='LOCALMAX' then
  1528. b.localalignmax:=l
  1529. else if tok='RECORDMIN' then
  1530. b.recordalignmin:=l
  1531. else if tok='RECORDMAX' then
  1532. b.recordalignmax:=l
  1533. else { Error }
  1534. UpdateAlignmentStr:=false;
  1535. until false;
  1536. UpdateAlignment(a,b);
  1537. end;
  1538. function var_align(siz: longint): longint;
  1539. begin
  1540. siz := size_2_align(siz);
  1541. var_align := used_align(siz,aktalignment.varalignmin,aktalignment.varalignmax);
  1542. end;
  1543. function const_align(siz: longint): longint;
  1544. begin
  1545. siz := size_2_align(siz);
  1546. const_align := used_align(siz,aktalignment.constalignmin,aktalignment.constalignmax);
  1547. end;
  1548. {****************************************************************************
  1549. Init
  1550. ****************************************************************************}
  1551. {$ifdef unix}
  1552. {$define need_path_search}
  1553. {$endif unix}
  1554. {$ifdef os2}
  1555. {$define need_path_search}
  1556. {$endif os2}
  1557. procedure get_exepath;
  1558. var
  1559. hs1 : namestr;
  1560. hs2 : extstr;
  1561. p : pchar;
  1562. begin
  1563. {$ifdef delphi}
  1564. exepath:=dmisc.getenv('PPC_EXEC_PATH');
  1565. {$else delphi}
  1566. exepath:=dos.getenv('PPC_EXEC_PATH');
  1567. {$endif delphi}
  1568. if exepath='' then
  1569. fsplit(FixFileName(system.paramstr(0)),exepath,hs1,hs2);
  1570. {$ifdef need_path_search}
  1571. if exepath='' then
  1572. begin
  1573. if pos(source_info.exeext,hs1) <>
  1574. (length(hs1) - length(source_info.exeext)+1) then
  1575. hs1 := hs1 + source_info.exeext;
  1576. p:=GetEnvPchar('PATH');
  1577. FindFilePChar(hs1,p,exepath);
  1578. FreeEnvPChar(p);
  1579. exepath:=SplitPath(exepath);
  1580. end;
  1581. {$endif need_path_search}
  1582. exepath:=FixPath(exepath,false);
  1583. end;
  1584. procedure DoneGlobals;
  1585. begin
  1586. initdefines.free;
  1587. if assigned(DLLImageBase) then
  1588. StringDispose(DLLImageBase);
  1589. librarysearchpath.Free;
  1590. unitsearchpath.Free;
  1591. objectsearchpath.Free;
  1592. includesearchpath.Free;
  1593. end;
  1594. procedure InitGlobals;
  1595. begin
  1596. get_exepath;
  1597. { reset globals }
  1598. do_build:=false;
  1599. do_release:=false;
  1600. do_make:=true;
  1601. compile_level:=0;
  1602. DLLsource:=false;
  1603. inlining_procedure:=false;
  1604. resolving_forward:=false;
  1605. make_ref:=false;
  1606. LinkTypeSetExplicitly:=false;
  1607. { Output }
  1608. OutputFile:='';
  1609. OutputExeDir:='';
  1610. OutputUnitDir:='';
  1611. { Utils directory }
  1612. utilsdirectory:='';
  1613. utilsprefix:='';
  1614. cshared:=false;
  1615. rlinkpath:='';
  1616. { Search Paths }
  1617. librarysearchpath:=TSearchPathList.Create;
  1618. unitsearchpath:=TSearchPathList.Create;
  1619. includesearchpath:=TSearchPathList.Create;
  1620. objectsearchpath:=TSearchPathList.Create;
  1621. { Def file }
  1622. usewindowapi:=false;
  1623. description:='Compiled by FPC '+version_string+' - '+target_cpu_string;
  1624. DescriptionSetExplicity:=false;
  1625. dllversion:='';
  1626. dllmajor:=1;
  1627. dllminor:=0;
  1628. dllrevision:=0;
  1629. nwscreenname := '';
  1630. nwthreadname := '';
  1631. nwcopyright := '';
  1632. UseDeffileForExports:=false;
  1633. UseDeffileForExportsSetExplicitly:=false;
  1634. RelocSection:=false;
  1635. RelocSectionSetExplicitly:=false;
  1636. LinkTypeSetExplicitly:=false;
  1637. { Init values }
  1638. initmodeswitches:=fpcmodeswitches;
  1639. initlocalswitches:=[cs_check_io,cs_typed_const_writable];
  1640. initmoduleswitches:=[cs_extsyntax,cs_implicit_exceptions];
  1641. initsourcecodepage:='8859-1';
  1642. initglobalswitches:=[cs_check_unit_name,cs_link_static{$ifdef INTERNALLINKER},cs_link_internal,cs_link_map{$endif}];
  1643. initoutputformat:=target_asm.id;
  1644. fillchar(initalignment,sizeof(talignmentinfo),0);
  1645. { might be overridden later }
  1646. initasmmode:=asmmode_standard;
  1647. {$ifdef i386}
  1648. initoptprocessor:=Class386;
  1649. initspecificoptprocessor:=Class386;
  1650. initfputype:=fpu_x87;
  1651. initpackenum:=4;
  1652. {$IFDEF testvarsets}
  1653. initsetalloc:=0;
  1654. {$ENDIF}
  1655. initasmmode:=asmmode_i386_att;
  1656. {$endif i386}
  1657. {$ifdef m68k}
  1658. initoptprocessor:=MC68020;
  1659. initpackenum:=4;
  1660. {$IFDEF testvarsets}
  1661. initsetalloc:=0;
  1662. {$ENDIF}
  1663. {$endif m68k}
  1664. {$ifdef powerpc}
  1665. initoptprocessor:=PPC604;
  1666. initpackenum:=4;
  1667. {$IFDEF testvarsets}
  1668. initsetalloc:=0;
  1669. {$ENDIF}
  1670. initfputype:=fpu_standard;
  1671. {$endif powerpc}
  1672. {$ifdef sparc}
  1673. initoptprocessor:=SPARC_V8;
  1674. initpackenum:=4;
  1675. {$IFDEF testvarsets}
  1676. initsetalloc:=0;
  1677. {$ENDIF}
  1678. {$endif sparc}
  1679. {$ifdef arm}
  1680. initpackenum:=4;
  1681. {$IFDEF testvarsets}
  1682. initsetalloc:=0;
  1683. {$ENDIF}
  1684. initfputype:=fpu_fpa;
  1685. {$endif arm}
  1686. {$ifdef x86_64}
  1687. initoptprocessor:=ClassAthlon64;
  1688. initspecificoptprocessor:=ClassAthlon64;
  1689. initfputype:=fpu_sse64;
  1690. initpackenum:=4;
  1691. {$IFDEF testvarsets}
  1692. initsetalloc:=0;
  1693. {$ENDIF}
  1694. initasmmode:=asmmode_x86_64_gas;
  1695. {$endif x86_64}
  1696. initinterfacetype:=it_interfacecom;
  1697. initdefproccall:=pocall_default;
  1698. initdefines:=TStringList.Create;
  1699. { memory sizes, will be overriden by parameter or default for target
  1700. in options or init_parser }
  1701. stacksize:=0;
  1702. heapsize:=0;
  1703. apptype:=app_cui;
  1704. end;
  1705. end.
  1706. {
  1707. $Log$
  1708. Revision 1.131 2004-06-20 08:55:29 florian
  1709. * logs truncated
  1710. Revision 1.130 2004/06/16 20:07:07 florian
  1711. * dwarf branch merged
  1712. Revision 1.129 2004/05/11 18:20:52 olle
  1713. * changed $mode mac to $mode macpas
  1714. * changed macmodeswitches to be more faithful to the mac dialect
  1715. Revision 1.128 2004/04/29 19:56:36 daniel
  1716. * Prepare compiler infrastructure for multiple ansistring types
  1717. Revision 1.127 2004/04/28 15:19:03 florian
  1718. + syscall directive support for MorphOS added
  1719. Revision 1.126.2.4 2004/05/09 15:47:21 peter
  1720. * fix typecast from word->set
  1721. }