system.inc 32 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195
  1. {
  2. This file is part of the Free Pascal Run time library.
  3. Copyright (c) 1999-2000 by the Free Pascal development team
  4. See the file COPYING.FPC, included in this distribution,
  5. For details about the copyright.
  6. This program is distributed in the hope that it will be useful,
  7. but WITHOUT ANY WARRANTY; without even the implied warranty of
  8. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  9. **********************************************************************}
  10. {****************************************************************************
  11. Local types
  12. ****************************************************************************}
  13. {
  14. TextRec and FileRec are put in a separate file to make it available to other
  15. units without putting it explicitly in systemh.
  16. This way we keep TP compatibility, and the TextRec definition is available
  17. for everyone who needs it.
  18. }
  19. {$i filerec.inc}
  20. {$i textrec.inc}
  21. Procedure HandleError (Errno : Longint); forward;
  22. Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
  23. type
  24. FileFunc = Procedure(var t : TextRec);
  25. const
  26. STACK_MARGIN = 16384; { Stack size margin for stack checking }
  27. { Random / Randomize constants }
  28. OldRandSeed : Cardinal = 0;
  29. { For Error Handling.}
  30. ErrorBase : Pointer = nil;
  31. { Used by the ansistrings and maybe also other things in the future }
  32. var
  33. emptychar : char;public name 'FPC_EMPTYCHAR';
  34. initialstklen : SizeUint;external name '__stklen';
  35. { checks whether the given suggested size for the stack of the current
  36. thread is acceptable. If this is the case, returns it unaltered.
  37. Otherwise it should return an acceptable value.
  38. Operating systems that automatically expand their stack on demand, should
  39. simply return a very large value.
  40. Operating systems which do not have a possibility to retrieve stack size
  41. information, should simply return the given stklen value (This is the default
  42. implementation).
  43. }
  44. {$ifdef FPC_HAS_FEATURE_STACKCHECK}
  45. function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; forward;
  46. {$endif FPC_HAS_FEATURE_STACKCHECK}
  47. {****************************************************************************
  48. Include processor specific routines
  49. ****************************************************************************}
  50. {$ifdef FPC_USE_LIBC}
  51. { prefer libc implementations over our own, as they're most likely faster }
  52. {$i cgeneric.inc}
  53. { is now declared as external reference to another routine in the interface }
  54. {$i cgenstr.inc}
  55. {$endif FPC_USE_LIBC}
  56. {$ifdef cpui386}
  57. {$ifdef SYSPROCDEFINED}
  58. {$Error Can't determine processor type !}
  59. {$endif}
  60. {$i i386.inc} { Case dependent, don't change }
  61. {$endif cpui386}
  62. {$ifdef cpum68k}
  63. {$ifdef SYSPROCDEFINED}
  64. {$Error Can't determine processor type !}
  65. {$endif}
  66. {$i m68k.inc} { Case dependent, don't change }
  67. {$define SYSPROCDEFINED}
  68. {$endif cpum68k}
  69. {$ifdef cpux86_64}
  70. {$ifdef SYSPROCDEFINED}
  71. {$Error Can't determine processor type !}
  72. {$endif}
  73. {$i x86_64.inc} { Case dependent, don't change }
  74. {$define SYSPROCDEFINED}
  75. {$endif cpux86_64}
  76. {$ifdef cpupowerpc32}
  77. {$ifdef SYSPROCDEFINED}
  78. {$Error Can't determine processor type !}
  79. {$endif}
  80. {$i powerpc.inc} { Case dependent, don't change }
  81. {$define SYSPROCDEFINED}
  82. {$endif cpupowerpc32}
  83. {$ifdef cpupowerpc64}
  84. {$ifdef SYSPROCDEFINED}
  85. {$Error Can't determine processor type !}
  86. {$endif}
  87. {$i powerpc64.inc} { Case dependent, don't change }
  88. {$define SYSPROCDEFINED}
  89. {$endif cpupowerpc64}
  90. {$ifdef cpualpha}
  91. {$ifdef SYSPROCDEFINED}
  92. {$Error Can't determine processor type !}
  93. {$endif}
  94. {$i alpha.inc} { Case dependent, don't change }
  95. {$define SYSPROCDEFINED}
  96. {$endif cpualpha}
  97. {$ifdef cpuiA64}
  98. {$ifdef SYSPROCDEFINED}
  99. {$Error Can't determine processor type !}
  100. {$endif}
  101. {$i ia64.inc} { Case dependent, don't change }
  102. {$define SYSPROCDEFINED}
  103. {$endif cpuiA64}
  104. {$ifdef cpusparc}
  105. {$ifdef SYSPROCDEFINED}
  106. {$Error Can't determine processor type !}
  107. {$endif}
  108. {$i sparc.inc} { Case dependent, don't change }
  109. {$define SYSPROCDEFINED}
  110. {$endif cpusparc}
  111. {$ifdef cpuarm}
  112. {$ifdef SYSPROCDEFINED}
  113. {$Error Can't determine processor type !}
  114. {$endif}
  115. {$i arm.inc} { Case dependent, don't change }
  116. {$define SYSPROCDEFINED}
  117. {$endif cpuarm}
  118. {$ifndef INTERNALMOVEFILLCHAR}
  119. procedure fillchar(var x;count : SizeInt;value : boolean);{$ifdef SYSTEMINLINE}inline;{$endif}
  120. begin
  121. fillchar(x,count,byte(value));
  122. end;
  123. procedure fillchar(var x;count : SizeInt;value : char);{$ifdef SYSTEMINLINE}inline;{$endif}
  124. begin
  125. fillchar(x,count,byte(value));
  126. end;
  127. {$endif INTERNALMOVEFILLCHAR}
  128. { Include generic pascal only routines which are not defined in the processor
  129. specific include file }
  130. {$I generic.inc}
  131. {****************************************************************************
  132. Set Handling
  133. ****************************************************************************}
  134. { Include set support which is processor specific}
  135. {$i set.inc}
  136. { Include generic pascal routines for sets if the processor }
  137. { specific routines are not available. }
  138. {$i genset.inc}
  139. {****************************************************************************
  140. Math Routines
  141. ****************************************************************************}
  142. function Hi(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  143. begin
  144. Hi := b shr 4
  145. end;
  146. function Lo(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  147. begin
  148. Lo := b and $0f
  149. end;
  150. Function swap (X : Word) : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  151. Begin
  152. swap:=(X and $ff) shl 8 + (X shr 8)
  153. End;
  154. Function Swap (X : Integer) : Integer;{$ifdef SYSTEMINLINE}inline;{$endif}
  155. Begin
  156. swap:=(X and $ff) shl 8 + (X shr 8)
  157. End;
  158. Function swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif}
  159. Begin
  160. Swap:=(X and $ffff) shl 16 + (X shr 16)
  161. End;
  162. Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
  163. Begin
  164. Swap:=(X and $ffff) shl 16 + (X shr 16)
  165. End;
  166. Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
  167. Begin
  168. Swap:=(X and $ffffffff) shl 32 + (X shr 32);
  169. End;
  170. Function swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
  171. Begin
  172. Swap:=(X and $ffffffff) shl 32 + (X shr 32);
  173. End;
  174. {$ifdef SUPPORT_DOUBLE}
  175. operator := (b:real48) d:double;{$ifdef SYSTEMINLINE}inline;{$endif}
  176. begin
  177. D:=real2double(b);
  178. end;
  179. {$endif SUPPORT_DOUBLE}
  180. {$ifdef SUPPORT_EXTENDED}
  181. operator := (b:real48) e:extended;{$ifdef SYSTEMINLINE}inline;{$endif}
  182. begin
  183. e:=real2double(b);
  184. end;
  185. {$endif SUPPORT_EXTENDED}
  186. {$ifdef FPC_USE_LIBC}
  187. { Include libc versions }
  188. {$i cgenmath.inc}
  189. {$endif FPC_USE_LIBC}
  190. { Include processor specific routines }
  191. {$I math.inc}
  192. { Include generic version }
  193. {$I genmath.inc}
  194. function aligntoptr(p : pointer) : pointer;inline;
  195. begin
  196. {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  197. result:=align(p,sizeof(p));
  198. {$else FPC_REQUIRES_PROPER_ALIGNMENT}
  199. result:=p;
  200. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  201. end;
  202. {****************************************************************************
  203. Subroutines for String handling
  204. ****************************************************************************}
  205. { Needs to be before RTTI handling }
  206. {$i sstrings.inc}
  207. { requires sstrings.inc for initval }
  208. {$I int64p.inc}
  209. {$I int64.inc}
  210. {Requires int64.inc, since that contains the VAL functions for int64 and qword}
  211. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  212. {$i astrings.inc}
  213. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  214. {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
  215. {$i wstrings.inc}
  216. {$endif FPC_HAS_FEATURE_WIDESTRINGS}
  217. {$i aliases.inc}
  218. {*****************************************************************************
  219. Dynamic Array support
  220. *****************************************************************************}
  221. {$ifdef FPC_HAS_FEATURE_DYNARRAYS}
  222. {$i dynarr.inc}
  223. {$endif FPC_HAS_FEATURE_DYNARRAYS}
  224. {*****************************************************************************
  225. Object Pascal support
  226. *****************************************************************************}
  227. {$ifdef FPC_HAS_FEATURE_CLASSES}
  228. {$i objpas.inc}
  229. {$endif FPC_HAS_FEATURE_CLASSES}
  230. {*****************************************************************************
  231. Variant support
  232. *****************************************************************************}
  233. {$ifdef FPC_HAS_FEATURE_VARIANTS}
  234. {$i variant.inc}
  235. {$endif FPC_HAS_FEATURE_VARIANTS}
  236. {****************************************************************************
  237. Run-Time Type Information (RTTI)
  238. ****************************************************************************}
  239. {$ifdef FPC_HAS_FEATURE_RTTI}
  240. {$i rtti.inc}
  241. {$endif FPC_HAS_FEATURE_VARIANTS}
  242. {----------------------------------------------------------------------
  243. Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  244. Pseudo-Random Number Generator.
  245. What is Mersenne Twister?
  246. Mersenne Twister(MT) is a pseudorandom number generator developped by
  247. Makoto Matsumoto and Takuji Nishimura (alphabetical order) during
  248. 1996-1997. MT has the following merits:
  249. It is designed with consideration on the flaws of various existing
  250. generators.
  251. Far longer period and far higher order of equidistribution than any
  252. other implemented generators. (It is proved that the period is 2^19937-1,
  253. and 623-dimensional equidistribution property is assured.)
  254. Fast generation. (Although it depends on the system, it is reported that
  255. MT is sometimes faster than the standard ANSI-C library in a system
  256. with pipeline and cache memory.)
  257. Efficient use of the memory. (The implemented C-code mt19937.c
  258. consumes only 624 words of working area.)
  259. home page
  260. http://www.math.keio.ac.jp/~matumoto/emt.html
  261. original c source
  262. http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c
  263. Coded by Takuji Nishimura, considering the suggestions by
  264. Topher Cooper and Marc Rieffel in July-Aug. 1997.
  265. This library is free software; you can redistribute it and/or
  266. modify it under the terms of the GNU Library General Public
  267. License as published by the Free Software Foundation; either
  268. version 2 of the License, or (at your option) any later
  269. version.
  270. This library is distributed in the hope that it will be useful,
  271. but WITHOUT ANY WARRANTY; without even the implied warranty of
  272. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  273. See the GNU Library General Public License for more details.
  274. You should have received a copy of the GNU Library General
  275. Public License along with this library; if not, write to the
  276. Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  277. 02111-1307 USA
  278. Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura.
  279. When you use this, send an email to: [email protected]
  280. with an appropriate reference to your work.
  281. REFERENCE
  282. M. Matsumoto and T. Nishimura,
  283. "Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  284. Pseudo-Random Number Generator",
  285. ACM Transactions on Modeling and Computer Simulation,
  286. Vol. 8, No. 1, January 1998, pp 3--30.
  287. Translated to OP and Delphi interface added by Roman Krejci (6.12.1999)
  288. http://www.rksolution.cz/delphi/tips.htm
  289. Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed
  290. 2003/10/26: adapted to use the improved intialisation mentioned at
  291. <http://www.math.keio.ac.jp/~matumoto/MT2002/emt19937ar.html> and
  292. removed the assembler code
  293. ----------------------------------------------------------------------}
  294. {$R-} {range checking off}
  295. {$Q-} {overflow checking off}
  296. { Period parameter }
  297. Const
  298. MT19937N=624;
  299. Type
  300. tMT19937StateArray = array [0..MT19937N-1] of longint; // the array for the state vector
  301. { Period parameters }
  302. const
  303. MT19937M=397;
  304. MT19937MATRIX_A =$9908b0df; // constant vector a
  305. MT19937UPPER_MASK=$80000000; // most significant w-r bits
  306. MT19937LOWER_MASK=$7fffffff; // least significant r bits
  307. { Tempering parameters }
  308. TEMPERING_MASK_B=$9d2c5680;
  309. TEMPERING_MASK_C=$efc60000;
  310. VAR
  311. mt : tMT19937StateArray;
  312. const
  313. mti: longint=MT19937N+1; // mti=MT19937N+1 means mt[] is not initialized
  314. { Initializing the array with a seed }
  315. procedure sgenrand_MT19937(seed: longint);
  316. var
  317. i: longint;
  318. begin
  319. mt[0] := seed;
  320. for i := 1 to MT19937N-1 do
  321. begin
  322. mt[i] := 1812433253 * (mt[i-1] xor (mt[i-1] shr 30)) + i;
  323. { See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. }
  324. { In the previous versions, MSBs of the seed affect }
  325. { only MSBs of the array mt[]. }
  326. { 2002/01/09 modified by Makoto Matsumoto }
  327. end;
  328. mti := MT19937N;
  329. end;
  330. function genrand_MT19937: longint;
  331. const
  332. mag01 : array [0..1] of longint =(0, longint(MT19937MATRIX_A));
  333. var
  334. y: longint;
  335. kk: longint;
  336. begin
  337. if RandSeed<>OldRandSeed then
  338. mti:=MT19937N+1;
  339. if (mti >= MT19937N) { generate MT19937N longints at one time }
  340. then begin
  341. if mti = (MT19937N+1) then // if sgenrand_MT19937() has not been called,
  342. begin
  343. sgenrand_MT19937(randseed); // default initial seed is used
  344. { hack: randseed is not used more than once in this algorithm. Most }
  345. { user changes are re-initialising reandseed with the value it had }
  346. { at the start -> with the "not", we will detect this change. }
  347. { Detecting other changes is not useful, since the generated }
  348. { numbers will be different anyway. }
  349. randseed := not(randseed);
  350. oldrandseed := randseed;
  351. end;
  352. for kk:=0 to MT19937N-MT19937M-1 do begin
  353. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  354. mt[kk] := mt[kk+MT19937M] xor (y shr 1) xor mag01[y and $00000001];
  355. end;
  356. for kk:= MT19937N-MT19937M to MT19937N-2 do begin
  357. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  358. mt[kk] := mt[kk+(MT19937M-MT19937N)] xor (y shr 1) xor mag01[y and $00000001];
  359. end;
  360. y := (mt[MT19937N-1] and MT19937UPPER_MASK) or (mt[0] and MT19937LOWER_MASK);
  361. mt[MT19937N-1] := mt[MT19937M-1] xor (y shr 1) xor mag01[y and $00000001];
  362. mti := 0;
  363. end;
  364. y := mt[mti]; inc(mti);
  365. y := y xor (y shr 11);
  366. y := y xor (y shl 7) and TEMPERING_MASK_B;
  367. y := y xor (y shl 15) and TEMPERING_MASK_C;
  368. y := y xor (y shr 18);
  369. Result := y;
  370. end;
  371. function random(l:longint): longint;
  372. begin
  373. { otherwise we can return values = l (JM) }
  374. if (l < 0) then
  375. inc(l);
  376. random := longint((int64(cardinal(genrand_MT19937))*l) shr 32);
  377. end;
  378. function random(l:int64): int64;
  379. begin
  380. { always call random, so the random generator cycles (TP-compatible) (JM) }
  381. random := int64((qword(cardinal(genrand_MT19937)) or ((qword(cardinal(genrand_MT19937)) shl 32))) and $7fffffffffffffff);
  382. if (l<>0) then
  383. random := random mod l
  384. else
  385. random := 0;
  386. end;
  387. function random: extended;
  388. begin
  389. random := cardinal(genrand_MT19937) * (1.0/(int64(1) shl 32));
  390. end;
  391. {****************************************************************************
  392. Memory Management
  393. ****************************************************************************}
  394. Function Ptr(sel,off : Longint) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
  395. Begin
  396. ptr:=farpointer((sel shl 4)+off);
  397. End;
  398. Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  399. Begin
  400. Cseg:=0;
  401. End;
  402. Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  403. Begin
  404. Dseg:=0;
  405. End;
  406. Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  407. Begin
  408. Sseg:=0;
  409. End;
  410. {*****************************************************************************
  411. Directory support.
  412. *****************************************************************************}
  413. {$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
  414. Procedure getdir(drivenr:byte;Var dir:ansistring);
  415. { this is needed to also allow ansistrings, the shortstring version is
  416. OS dependent }
  417. var
  418. s : shortstring;
  419. begin
  420. getdir(drivenr,s);
  421. dir:=s;
  422. end;
  423. {$endif}
  424. {$ifopt R+}
  425. {$define RangeCheckWasOn}
  426. {$R-}
  427. {$endif opt R+}
  428. {$ifopt I+}
  429. {$define IOCheckWasOn}
  430. {$I-}
  431. {$endif opt I+}
  432. {$ifopt Q+}
  433. {$define OverflowCheckWasOn}
  434. {$Q-}
  435. {$endif opt Q+}
  436. {*****************************************************************************
  437. Miscellaneous
  438. *****************************************************************************}
  439. procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc;
  440. begin
  441. HandleErrorFrame(201,get_frame);
  442. end;
  443. procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc;
  444. begin
  445. HandleErrorFrame(200,get_frame);
  446. end;
  447. procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc;
  448. begin
  449. HandleErrorFrame(215,get_frame);
  450. end;
  451. procedure fpc_iocheck;[public,alias:'FPC_IOCHECK']; compilerproc;
  452. var
  453. l : longint;
  454. begin
  455. if InOutRes<>0 then
  456. begin
  457. l:=InOutRes;
  458. InOutRes:=0;
  459. HandleErrorFrame(l,get_frame);
  460. end;
  461. end;
  462. Function IOResult:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  463. Begin
  464. IOResult:=InOutRes;
  465. InOutRes:=0;
  466. End;
  467. Function GetThreadID:TThreadID;{$ifdef SYSTEMINLINE}inline;{$endif}
  468. begin
  469. (* ThreadID is stored in a threadvar and made available in interface *)
  470. (* to allow setup of this value during thread initialization. *)
  471. GetThreadID := ThreadID;
  472. end;
  473. function fpc_safecallcheck(res : hresult) : hresult;[public,alias:'FPC_SAFECALLCHECK']; compilerproc;
  474. begin
  475. if res<0 then
  476. begin
  477. if assigned(SafeCallErrorProc) then
  478. SafeCallErrorProc(res,get_frame);
  479. HandleErrorFrame(229,get_frame);
  480. end;
  481. result:=res;
  482. end;
  483. {*****************************************************************************
  484. Stack check code
  485. *****************************************************************************}
  486. {$IFNDEF NO_GENERIC_STACK_CHECK}
  487. {$IFOPT S+}
  488. {$DEFINE STACKCHECK}
  489. {$ENDIF}
  490. {$S-}
  491. procedure fpc_stackcheck(stack_size:SizeUInt);[public,alias:'FPC_STACKCHECK'];
  492. var
  493. c : Pointer;
  494. begin
  495. { Avoid recursive calls when called from the exit routines }
  496. if StackError then
  497. exit;
  498. c := Sptr - (stack_size + STACK_MARGIN);
  499. if (c <= StackBottom) then
  500. begin
  501. StackError:=true;
  502. HandleError(202);
  503. end;
  504. end;
  505. {$IFDEF STACKCHECK}
  506. {$S+}
  507. {$ENDIF}
  508. {$UNDEF STACKCHECK}
  509. {$ENDIF NO_GENERIC_STACK_CHECK}
  510. {*****************************************************************************
  511. Initialization / Finalization
  512. *****************************************************************************}
  513. const
  514. maxunits=1024; { See also files.pas of the compiler source }
  515. type
  516. TInitFinalRec=record
  517. InitProc,
  518. FinalProc : TProcedure;
  519. end;
  520. TInitFinalTable=record
  521. TableCount,
  522. InitCount : longint;
  523. Procs : array[1..maxunits] of TInitFinalRec;
  524. end;
  525. var
  526. InitFinalTable : TInitFinalTable;external name 'INITFINAL';
  527. procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; compilerproc;
  528. var
  529. i : longint;
  530. begin
  531. { call cpu/fpu initialisation routine }
  532. fpc_cpuinit;
  533. with InitFinalTable do
  534. begin
  535. for i:=1 to TableCount do
  536. begin
  537. if assigned(Procs[i].InitProc) then
  538. Procs[i].InitProc();
  539. InitCount:=i;
  540. end;
  541. end;
  542. if assigned(InitProc) then
  543. TProcedure(InitProc)();
  544. end;
  545. procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS'];
  546. begin
  547. with InitFinalTable do
  548. begin
  549. while (InitCount>0) do
  550. begin
  551. // we've to decrement the cound before calling the final. code
  552. // else a halt in the final. code leads to a endless loop
  553. dec(InitCount);
  554. if assigned(Procs[InitCount+1].FinalProc) then
  555. Procs[InitCount+1].FinalProc();
  556. end;
  557. end;
  558. end;
  559. {*****************************************************************************
  560. Error / Exit / ExitProc
  561. *****************************************************************************}
  562. Procedure system_exit;forward;
  563. {$ifdef FPC_HAS_FEATURE_HEAP}
  564. {$if not (defined(HAS_MEMORYMANAGER) or defined(HAS_MT_MEMORYMANAGER))}
  565. //not needed if independant memory manager
  566. Procedure FinalizeHeap;forward;
  567. {$endif HAS_MEMORYMANAGER}
  568. {$endif FPC_HAS_FEATURE_HEAP}
  569. Procedure InternalExit;
  570. var
  571. current_exit : Procedure;
  572. pstdout : ^Text;
  573. {$if defined(MSWINDOWS) or defined(OS2)}
  574. i : longint;
  575. {$endif}
  576. Begin
  577. {$ifdef SYSTEMDEBUG}
  578. writeln('InternalExit');
  579. {$endif SYSTEMDEBUG}
  580. while exitProc<>nil Do
  581. Begin
  582. InOutRes:=0;
  583. current_exit:=tProcedure(exitProc);
  584. exitProc:=nil;
  585. current_exit();
  586. End;
  587. { Finalize units }
  588. FinalizeUnits;
  589. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  590. { Show runtime error and exit }
  591. pstdout:=@stdout;
  592. If erroraddr<>nil Then
  593. Begin
  594. Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(PtrInt(Erroraddr),sizeof(PtrInt)*2));
  595. { to get a nice symify }
  596. Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
  597. dump_stack(pstdout^,ErrorBase);
  598. Writeln(pstdout^,'');
  599. End;
  600. { Make sure that all output is written to the redirected file }
  601. Flush(Output);
  602. Flush(ErrOutput);
  603. Flush(pstdout^);
  604. Flush(StdErr);
  605. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  606. {$if defined(MSWINDOWS) or defined(OS2)}
  607. { finally release the heap if possible, especially
  608. important for DLLs }
  609. for i:=0 to argc do
  610. sysfreemem(argv[i]);
  611. sysfreemem(argv);
  612. {$endif}
  613. {$ifdef LINUX}
  614. {sysfreemem already checks for nil}
  615. sysfreemem(calculated_cmdline);
  616. {$endif}
  617. {$ifdef BSD}
  618. sysfreemem(cmdline);
  619. {$endif}
  620. {$ifdef FPC_HAS_FEATURE_HEAP}
  621. {$if not (defined(HAS_MEMORYMANAGER) or defined(HAS_MT_MEMORYMANAGER))}
  622. FinalizeHeap;
  623. {$endif HAS_MEMORYMANAGER}
  624. {$endif FPC_HAS_FEATURE_HEAP}
  625. End;
  626. Procedure do_exit;[Public,Alias:'FPC_DO_EXIT'];
  627. begin
  628. InternalExit;
  629. System_exit;
  630. end;
  631. Procedure lib_exit;[Public,Alias:'FPC_LIB_EXIT'];
  632. begin
  633. InternalExit;
  634. end;
  635. Procedure Halt(ErrNum: Byte);
  636. Begin
  637. ExitCode:=Errnum;
  638. Do_Exit;
  639. end;
  640. function SysBackTraceStr (Addr: Pointer): ShortString;
  641. begin
  642. SysBackTraceStr:=' $'+HexStr(Ptrint(addr),sizeof(PtrInt)*2);
  643. end;
  644. Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR'];
  645. begin
  646. If pointer(ErrorProc)<>Nil then
  647. ErrorProc(Errno,addr,frame);
  648. errorcode:=word(Errno);
  649. erroraddr:=addr;
  650. errorbase:=frame;
  651. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  652. if ExceptAddrStack <> nil then
  653. raise TObject(nil) at addr,frame;
  654. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  655. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  656. if errorcode <= maxExitCode then
  657. halt(errorcode)
  658. else
  659. halt(255)
  660. {$else FPC_HAS_FEATURE_EXITCODE}
  661. halt;
  662. {$endif FPC_HAS_FEATURE_EXITCODE}
  663. end;
  664. Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
  665. {
  666. Procedure to handle internal errors, i.e. not user-invoked errors
  667. Internal function should ALWAYS call HandleError instead of RunError.
  668. Can be used for exception handlers to specify the frame
  669. }
  670. begin
  671. HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame));
  672. end;
  673. Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR'];
  674. {
  675. Procedure to handle internal errors, i.e. not user-invoked errors
  676. Internal function should ALWAYS call HandleError instead of RunError.
  677. }
  678. begin
  679. HandleErrorFrame(Errno,get_frame);
  680. end;
  681. procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
  682. begin
  683. errorcode:=w;
  684. erroraddr:=get_caller_addr(get_frame);
  685. errorbase:=get_caller_frame(get_frame);
  686. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  687. if errorcode <= maxExitCode then
  688. halt(errorcode)
  689. else
  690. halt(255)
  691. {$else FPC_HAS_FEATURE_EXITCODE}
  692. halt;
  693. {$endif FPC_HAS_FEATURE_EXITCODE}
  694. end;
  695. Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif}
  696. Begin
  697. RunError (0);
  698. End;
  699. Procedure Halt;{$ifdef SYSTEMINLINE}inline;{$endif}
  700. Begin
  701. Halt(0);
  702. End;
  703. Procedure Error(RunTimeError : TRunTimeError);
  704. begin
  705. RunError(RuntimeErrorExitCodes[RunTimeError]);
  706. end;
  707. {$ifdef FPC_HAS_FEATURE_FILEIO}
  708. function do_isdevice(handle:thandle):boolean;forward;
  709. {$endif FPC_HAS_FEATURE_FILEIO}
  710. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  711. Procedure dump_stack(var f : text;bp : Pointer);
  712. var
  713. i : Longint;
  714. prevbp : Pointer;
  715. is_dev : boolean;
  716. caller_frame,
  717. caller_addr : Pointer;
  718. Begin
  719. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  720. try
  721. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  722. prevbp:=bp-1;
  723. i:=0;
  724. is_dev:=do_isdevice(textrec(f).Handle);
  725. while bp > prevbp Do
  726. Begin
  727. caller_addr := get_caller_addr(bp);
  728. caller_frame := get_caller_frame(bp);
  729. if (caller_addr=nil) then
  730. break;
  731. Writeln(f,BackTraceStrFunc(caller_addr));
  732. if (caller_frame=nil) then
  733. break;
  734. Inc(i);
  735. If ((i>max_frame_dump) and is_dev) or (i>256) Then
  736. break;
  737. prevbp:=bp;
  738. bp:=caller_frame;
  739. End;
  740. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  741. except
  742. { prevent endless dump if an exception occured }
  743. end;
  744. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  745. End;
  746. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  747. {$ifdef FPC_HAS_FEATURE_HEAP}
  748. Type
  749. PExitProcInfo = ^TExitProcInfo;
  750. TExitProcInfo = Record
  751. Next : PExitProcInfo;
  752. SaveExit : Pointer;
  753. Proc : TProcedure;
  754. End;
  755. const
  756. ExitProcList: PExitProcInfo = nil;
  757. Procedure DoExitProc;
  758. var
  759. P : PExitProcInfo;
  760. Proc : TProcedure;
  761. Begin
  762. P:=ExitProcList;
  763. ExitProcList:=P^.Next;
  764. ExitProc:=P^.SaveExit;
  765. Proc:=P^.Proc;
  766. DisPose(P);
  767. Proc();
  768. End;
  769. Procedure AddExitProc(Proc: TProcedure);
  770. var
  771. P : PExitProcInfo;
  772. Begin
  773. New(P);
  774. P^.Next:=ExitProcList;
  775. P^.SaveExit:=ExitProc;
  776. P^.Proc:=Proc;
  777. ExitProcList:=P;
  778. ExitProc:=@DoExitProc;
  779. End;
  780. {$endif FPC_HAS_FEATURE_HEAP}
  781. {$ifdef FPC_HAS_FEATURE_HEAP}
  782. function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ?
  783. // Extra allocate reserveentries pchar's at the beginning (default param=0 after 1.0.x ?)
  784. // Note: for internal use by skilled programmers only
  785. // if "s" goes out of scope in the parent procedure, the pointer is dangling.
  786. var p : ppchar;
  787. i : LongInt;
  788. begin
  789. if High(s)<Low(s) Then Exit(NIL);
  790. Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
  791. // for cmd
  792. if p=nil then
  793. begin
  794. {$ifdef xunix}
  795. fpseterrno(ESysEnomem);
  796. {$endif}
  797. exit(NIL);
  798. end;
  799. for i:=low(s) to high(s) do
  800. p[i+Reserveentries]:=pchar(s[i]);
  801. p[high(s)+1+Reserveentries]:=nil;
  802. ArrayStringToPPchar:=p;
  803. end;
  804. Function StringToPPChar(Var S:AnsiString;ReserveEntries:integer):ppchar;
  805. {
  806. Create a PPChar to structure of pchars which are the arguments specified
  807. in the string S. Especially usefull for creating an ArgV for Exec-calls
  808. }
  809. begin
  810. StringToPPChar:=StringToPPChar(PChar(S),ReserveEntries);
  811. end;
  812. Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
  813. var
  814. i,nr : longint;
  815. Buf : ^char;
  816. p : ppchar;
  817. begin
  818. buf:=s;
  819. nr:=1;
  820. while (buf^<>#0) do // count nr of args
  821. begin
  822. while (buf^ in [' ',#9,#10]) do // Kill separators.
  823. inc(buf);
  824. inc(nr);
  825. if buf^='"' Then // quotes argument?
  826. begin
  827. inc(buf);
  828. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  829. inc(buf);
  830. if buf^='"' then // skip closing quote.
  831. inc(buf);
  832. end
  833. else
  834. begin // else std
  835. while not (buf^ in [' ',#0,#9,#10]) do
  836. inc(buf);
  837. end;
  838. end;
  839. getmem(p,(ReserveEntries+nr)*sizeof(pchar));
  840. StringToPPChar:=p;
  841. if p=nil then
  842. begin
  843. {$ifdef xunix}
  844. fpseterrno(ESysEnomem);
  845. {$endif}
  846. exit;
  847. end;
  848. for i:=1 to ReserveEntries do inc(p); // skip empty slots
  849. buf:=s;
  850. while (buf^<>#0) do
  851. begin
  852. while (buf^ in [' ',#9,#10]) do // Kill separators.
  853. begin
  854. buf^:=#0;
  855. inc(buf);
  856. end;
  857. if buf^='"' Then // quotes argument?
  858. begin
  859. inc(buf);
  860. p^:=buf;
  861. inc(p);
  862. p^:=nil;
  863. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  864. inc(buf);
  865. if buf^='"' then // skip closing quote.
  866. begin
  867. buf^:=#0;
  868. inc(buf);
  869. end;
  870. end
  871. else
  872. begin
  873. p^:=buf;
  874. inc(p);
  875. p^:=nil;
  876. while not (buf^ in [' ',#0,#9,#10]) do
  877. inc(buf);
  878. end;
  879. end;
  880. end;
  881. {$endif FPC_HAS_FEATURE_HEAP}
  882. {*****************************************************************************
  883. Abstract/Assert support.
  884. *****************************************************************************}
  885. procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR'];
  886. begin
  887. If pointer(AbstractErrorProc)<>nil then
  888. AbstractErrorProc();
  889. HandleErrorFrame(211,get_frame);
  890. end;
  891. Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc;
  892. begin
  893. if pointer(AssertErrorProc)<>nil then
  894. AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
  895. else
  896. HandleErrorFrame(227,get_frame);
  897. end;
  898. Procedure SysAssert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer);
  899. begin
  900. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  901. If msg='' then
  902. write(stderr,'Assertion failed')
  903. else
  904. write(stderr,msg);
  905. Writeln(stderr,' (',FName,', line ',LineNo,').');
  906. Writeln(stderr,'');
  907. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  908. Halt(227);
  909. {$else FPC_HAS_FEATURE_EXITCODE}
  910. halt;
  911. {$endif FPC_HAS_FEATURE_EXITCODE}
  912. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  913. end;
  914. {*****************************************************************************
  915. SetJmp/LongJmp support.
  916. *****************************************************************************}
  917. {$i setjump.inc}
  918. {$ifdef IOCheckWasOn}
  919. {$I+}
  920. {$endif}
  921. {$ifdef RangeCheckWasOn}
  922. {$R+}
  923. {$endif}
  924. {$ifdef OverflowCheckWasOn}
  925. {$Q+}
  926. {$endif}
  927. {*****************************************************************************
  928. OS dependent Helpers/Syscalls
  929. *****************************************************************************}
  930. {$i sysos.inc}
  931. {*****************************************************************************
  932. Heap
  933. *****************************************************************************}
  934. {$ifdef FPC_HAS_FEATURE_HEAP}
  935. {$i sysheap.inc}
  936. {$i heap.inc}
  937. {$endif FPC_HAS_FEATURE_HEAP}
  938. {*****************************************************************************
  939. Thread support
  940. *****************************************************************************}
  941. {$ifdef FPC_HAS_FEATURE_THREADING}
  942. { Generic threadmanager }
  943. {$i thread.inc}
  944. { Generic threadvar support }
  945. {$i threadvr.inc}
  946. { OS Dependent implementation }
  947. {$i systhrd.inc}
  948. {$endif FPC_HAS_FEATURE_THREADING}
  949. {*****************************************************************************
  950. File Handling
  951. *****************************************************************************}
  952. { OS dependent low level file functions }
  953. {$ifdef FPC_HAS_FEATURE_FILEIO}
  954. {$i sysfile.inc}
  955. {$endif FPC_HAS_FEATURE_FILEIO}
  956. { Text file }
  957. {$ifdef FPC_HAS_FEATURE_TEXTIO}
  958. {$i text.inc}
  959. {$endif FPC_HAS_FEATURE_TEXTIO}
  960. {$ifdef FPC_HAS_FEATURE_FILEIO}
  961. { Untyped file }
  962. {$i file.inc}
  963. { Typed file }
  964. {$i typefile.inc}
  965. {$endif FPC_HAS_FEATURE_FILEIO}
  966. {*****************************************************************************
  967. Directory Handling
  968. *****************************************************************************}
  969. { OS dependent dir functions }
  970. {$i sysdir.inc}
  971. {*****************************************************************************
  972. Resources support
  973. *****************************************************************************}
  974. {$ifndef HAS_RESOURCES}
  975. {$i sysres.inc}
  976. {$endif}
  977. Function FindResource(ModuleHandle: HMODULE; ResourceName, ResourceType: AnsiString): TResourceHandle;
  978. begin
  979. Result:=FindResource(ModuleHandle,PChar(ResourceName),PChar(ResourceType));
  980. end;