system.inc 27 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977
  1. {
  2. $Id$
  3. This file is part of the Free Pascal Run time library.
  4. Copyright (c) 1999-2000 by the Free Pascal development team
  5. See the file COPYING.FPC, included in this distribution,
  6. For details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. {****************************************************************************
  12. Local types
  13. ****************************************************************************}
  14. {
  15. TextRec and FileRec are put in a separate file to make it available to other
  16. units without putting it explicitly in systemh.
  17. This way we keep TP compatibility, and the TextRec definition is available
  18. for everyone who needs it.
  19. }
  20. {$i filerec.inc}
  21. {$i textrec.inc}
  22. Procedure HandleError (Errno : Longint); forward;
  23. Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
  24. type
  25. FileFunc = Procedure(var t : TextRec);
  26. const
  27. STACK_MARGIN = 16384; { Stack size margin for stack checking }
  28. { Random / Randomize constants }
  29. OldRandSeed : Cardinal = 0;
  30. { For Error Handling.}
  31. ErrorBase : Pointer = nil;
  32. { Used by the ansistrings and maybe also other things in the future }
  33. var
  34. emptychar : char;public name 'FPC_EMPTYCHAR';
  35. initialstklen : longint;external name '__stklen';
  36. {****************************************************************************
  37. Routines which have compiler magic
  38. ****************************************************************************}
  39. {$I innr.inc}
  40. Function lo(i : Integer) : byte; [INTERNPROC: In_lo_Word];
  41. Function lo(w : Word) : byte; [INTERNPROC: In_lo_Word];
  42. Function lo(l : Longint) : Word; [INTERNPROC: In_lo_long];
  43. Function lo(l : DWord) : Word; [INTERNPROC: In_lo_long];
  44. Function hi(i : Integer) : byte; [INTERNPROC: In_hi_Word];
  45. Function hi(w : Word) : byte; [INTERNPROC: In_hi_Word];
  46. Function hi(l : Longint) : Word; [INTERNPROC: In_hi_long];
  47. Function hi(l : DWord) : Word; [INTERNPROC: In_hi_long];
  48. Function lo(q : QWord) : DWord; [INTERNPROC: In_lo_qword];
  49. Function lo(i : Int64) : DWord; [INTERNPROC: In_lo_qword];
  50. Function hi(q : QWord) : DWord; [INTERNPROC: In_hi_qword];
  51. Function hi(i : Int64) : DWord; [INTERNPROC: In_hi_qword];
  52. Function chr(b : byte) : Char; [INTERNPROC: In_chr_byte];
  53. {$ifndef INTERNLENGTH}
  54. Function Length(s : string) : byte; [INTERNPROC: In_Length_string];
  55. Function Length(c : char) : byte; [INTERNPROC: In_Length_string];
  56. {$endif INTERNLENGTH}
  57. Procedure Reset(var f : TypedFile); [INTERNPROC: In_Reset_TypedFile];
  58. Procedure Rewrite(var f : TypedFile); [INTERNPROC: In_Rewrite_TypedFile];
  59. {****************************************************************************
  60. Include processor specific routines
  61. ****************************************************************************}
  62. {$ifdef FPC_USE_LIBC}
  63. { prefer libc implementations over our own, as they're most likely faster }
  64. {$i cgeneric.inc}
  65. {$endif FPC_USE_LIBC}
  66. {$ifdef cpui386}
  67. {$ifdef SYSPROCDEFINED}
  68. {$Error Can't determine processor type !}
  69. {$endif}
  70. {$i i386.inc} { Case dependent, don't change }
  71. {$endif cpui386}
  72. {$ifdef cpum68k}
  73. {$ifdef SYSPROCDEFINED}
  74. {$Error Can't determine processor type !}
  75. {$endif}
  76. {$i m68k.inc} { Case dependent, don't change }
  77. {$define SYSPROCDEFINED}
  78. {$endif cpum68k}
  79. {$ifdef cpux86_64}
  80. {$ifdef SYSPROCDEFINED}
  81. {$Error Can't determine processor type !}
  82. {$endif}
  83. {$i x86_64.inc} { Case dependent, don't change }
  84. {$define SYSPROCDEFINED}
  85. {$endif cpux86_64}
  86. {$ifdef cpupowerpc}
  87. {$ifdef SYSPROCDEFINED}
  88. {$Error Can't determine processor type !}
  89. {$endif}
  90. {$i powerpc.inc} { Case dependent, don't change }
  91. {$define SYSPROCDEFINED}
  92. {$endif cpupowerpc}
  93. {$ifdef cpualpha}
  94. {$ifdef SYSPROCDEFINED}
  95. {$Error Can't determine processor type !}
  96. {$endif}
  97. {$i alpha.inc} { Case dependent, don't change }
  98. {$define SYSPROCDEFINED}
  99. {$endif cpualpha}
  100. {$ifdef cpuiA64}
  101. {$ifdef SYSPROCDEFINED}
  102. {$Error Can't determine processor type !}
  103. {$endif}
  104. {$i ia64.inc} { Case dependent, don't change }
  105. {$define SYSPROCDEFINED}
  106. {$endif cpuiA64}
  107. {$ifdef cpusparc}
  108. {$ifdef SYSPROCDEFINED}
  109. {$Error Can't determine processor type !}
  110. {$endif}
  111. {$i sparc.inc} { Case dependent, don't change }
  112. {$define SYSPROCDEFINED}
  113. {$endif cpusparc}
  114. {$ifdef cpuarm}
  115. {$ifdef SYSPROCDEFINED}
  116. {$Error Can't determine processor type !}
  117. {$endif}
  118. {$i arm.inc} { Case dependent, don't change }
  119. {$define SYSPROCDEFINED}
  120. {$endif cpuarm}
  121. procedure fillchar(var x;count : longint;value : boolean);{$ifdef SYSTEMINLINE}inline;{$endif}
  122. begin
  123. fillchar(x,count,byte(value));
  124. end;
  125. procedure fillchar(var x;count : longint;value : char);{$ifdef SYSTEMINLINE}inline;{$endif}
  126. begin
  127. fillchar(x,count,byte(value));
  128. end;
  129. { Include generic pascal only routines which are not defined in the processor
  130. specific include file }
  131. {$I generic.inc}
  132. {****************************************************************************
  133. Set Handling
  134. ****************************************************************************}
  135. { Include set support which is processor specific}
  136. {$i set.inc}
  137. { Include generic pascal routines for sets if the processor }
  138. { specific routines are not available. }
  139. {$i genset.inc}
  140. {****************************************************************************
  141. Math Routines
  142. ****************************************************************************}
  143. function Hi(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  144. begin
  145. Hi := b shr 4
  146. end;
  147. function Lo(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  148. begin
  149. Lo := b and $0f
  150. end;
  151. Function swap (X : Word) : Word;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_word];
  152. Begin
  153. swap:=(X and $ff) shl 8 + (X shr 8)
  154. End;
  155. Function Swap (X : Integer) : Integer;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_word];
  156. Begin
  157. swap:=(X and $ff) shl 8 + (X shr 8)
  158. End;
  159. Function swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_long];
  160. Begin
  161. Swap:=(X and $ffff) shl 16 + (X shr 16)
  162. End;
  163. Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_long];
  164. Begin
  165. Swap:=(X and $ffff) shl 16 + (X shr 16)
  166. End;
  167. Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_qword];
  168. Begin
  169. Swap:=(X and $ffffffff) shl 32 + (X shr 32);
  170. End;
  171. Function swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_swap_qword];
  172. Begin
  173. Swap:=(X and $ffffffff) shl 32 + (X shr 32);
  174. End;
  175. operator := (b:real48) d:double;
  176. begin
  177. D:=real2double(b);
  178. end;
  179. {$ifdef SUPPORT_EXTENDED}
  180. operator := (b:real48) e:extended;
  181. begin
  182. e:=real2double(b);
  183. end;
  184. {$endif SUPPORT_EXTENDED}
  185. { Include processor specific routines }
  186. {$I math.inc}
  187. { Include generic version }
  188. {$I genmath.inc}
  189. {****************************************************************************
  190. Subroutines for String handling
  191. ****************************************************************************}
  192. { Needs to be before RTTI handling }
  193. {$i sstrings.inc}
  194. { requires sstrings.inc for initval }
  195. {$I int64p.inc}
  196. {$I int64.inc}
  197. {Requires int64.inc, since that contains the VAL functions for int64 and qword}
  198. {$i astrings.inc}
  199. {$ifdef HASWIDESTRING}
  200. {$i wstrings.inc}
  201. {$endif HASWIDESTRING}
  202. {$i aliases.inc}
  203. {*****************************************************************************
  204. Dynamic Array support
  205. *****************************************************************************}
  206. {$i dynarr.inc}
  207. {*****************************************************************************
  208. Object Pascal support
  209. *****************************************************************************}
  210. {$i objpas.inc}
  211. {*****************************************************************************
  212. Variant support
  213. *****************************************************************************}
  214. {$ifdef HASVARIANT}
  215. {$i variant.inc}
  216. {$endif HASVARIANT}
  217. {****************************************************************************
  218. Run-Time Type Information (RTTI)
  219. ****************************************************************************}
  220. {$i rtti.inc}
  221. {----------------------------------------------------------------------
  222. Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  223. Pseudo-Random Number Generator.
  224. What is Mersenne Twister?
  225. Mersenne Twister(MT) is a pseudorandom number generator developped by
  226. Makoto Matsumoto and Takuji Nishimura (alphabetical order) during
  227. 1996-1997. MT has the following merits:
  228. It is designed with consideration on the flaws of various existing
  229. generators.
  230. Far longer period and far higher order of equidistribution than any
  231. other implemented generators. (It is proved that the period is 2^19937-1,
  232. and 623-dimensional equidistribution property is assured.)
  233. Fast generation. (Although it depends on the system, it is reported that
  234. MT is sometimes faster than the standard ANSI-C library in a system
  235. with pipeline and cache memory.)
  236. Efficient use of the memory. (The implemented C-code mt19937.c
  237. consumes only 624 words of working area.)
  238. home page
  239. http://www.math.keio.ac.jp/~matumoto/emt.html
  240. original c source
  241. http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c
  242. Coded by Takuji Nishimura, considering the suggestions by
  243. Topher Cooper and Marc Rieffel in July-Aug. 1997.
  244. This library is free software; you can redistribute it and/or
  245. modify it under the terms of the GNU Library General Public
  246. License as published by the Free Software Foundation; either
  247. version 2 of the License, or (at your option) any later
  248. version.
  249. This library is distributed in the hope that it will be useful,
  250. but WITHOUT ANY WARRANTY; without even the implied warranty of
  251. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  252. See the GNU Library General Public License for more details.
  253. You should have received a copy of the GNU Library General
  254. Public License along with this library; if not, write to the
  255. Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  256. 02111-1307 USA
  257. Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura.
  258. When you use this, send an email to: [email protected]
  259. with an appropriate reference to your work.
  260. REFERENCE
  261. M. Matsumoto and T. Nishimura,
  262. "Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  263. Pseudo-Random Number Generator",
  264. ACM Transactions on Modeling and Computer Simulation,
  265. Vol. 8, No. 1, January 1998, pp 3--30.
  266. Translated to OP and Delphi interface added by Roman Krejci (6.12.1999)
  267. http://www.rksolution.cz/delphi/tips.htm
  268. Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed
  269. 2003/10/26: adapted to use the improved intialisation mentioned at
  270. <http://www.math.keio.ac.jp/~matumoto/MT2002/emt19937ar.html> and
  271. removed the assembler code
  272. ----------------------------------------------------------------------}
  273. {$R-} {range checking off}
  274. {$Q-} {overflow checking off}
  275. { Period parameter }
  276. Const
  277. MT19937N=624;
  278. Type
  279. tMT19937StateArray = array [0..MT19937N-1] of longint; // the array for the state vector
  280. { Period parameters }
  281. const
  282. MT19937M=397;
  283. MT19937MATRIX_A =$9908b0df; // constant vector a
  284. MT19937UPPER_MASK=$80000000; // most significant w-r bits
  285. MT19937LOWER_MASK=$7fffffff; // least significant r bits
  286. { Tempering parameters }
  287. TEMPERING_MASK_B=$9d2c5680;
  288. TEMPERING_MASK_C=$efc60000;
  289. VAR
  290. mt : tMT19937StateArray;
  291. const
  292. mti: longint=MT19937N+1; // mti=MT19937N+1 means mt[] is not initialized
  293. { Initializing the array with a seed }
  294. procedure sgenrand_MT19937(seed: longint);
  295. var
  296. i: longint;
  297. begin
  298. mt[0] := seed;
  299. for i := 1 to MT19937N-1 do
  300. begin
  301. mt[i] := 1812433253 * (mt[i-1] xor (mt[i-1] shr 30)) + i;
  302. { See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. }
  303. { In the previous versions, MSBs of the seed affect }
  304. { only MSBs of the array mt[]. }
  305. { 2002/01/09 modified by Makoto Matsumoto }
  306. end;
  307. mti := MT19937N;
  308. end;
  309. function genrand_MT19937: longint;
  310. const
  311. mag01 : array [0..1] of longint =(0, longint(MT19937MATRIX_A));
  312. var
  313. y: longint;
  314. kk: longint;
  315. begin
  316. if (mti >= MT19937N) or
  317. (randseed <> oldrandseed) { generate MT19937N longints at one time }
  318. then begin
  319. if mti = (MT19937N+1) then // if sgenrand_MT19937() has not been called,
  320. begin
  321. sgenrand_MT19937(randseed); // default initial seed is used
  322. { hack: randseed is not used more than once in this algorithm. Most }
  323. { user changes are re-initialising reandseed with the value it had }
  324. { at the start -> with the "not", we will detect this change. }
  325. { Detecting other changes is not useful, since the generated }
  326. { numbers will be different anyway. }
  327. randseed := not(randseed);
  328. oldrandseed := randseed;
  329. end;
  330. for kk:=0 to MT19937N-MT19937M-1 do begin
  331. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  332. mt[kk] := mt[kk+MT19937M] xor (y shr 1) xor mag01[y and $00000001];
  333. end;
  334. for kk:= MT19937N-MT19937M to MT19937N-2 do begin
  335. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  336. mt[kk] := mt[kk+(MT19937M-MT19937N)] xor (y shr 1) xor mag01[y and $00000001];
  337. end;
  338. y := (mt[MT19937N-1] and MT19937UPPER_MASK) or (mt[0] and MT19937LOWER_MASK);
  339. mt[MT19937N-1] := mt[MT19937M-1] xor (y shr 1) xor mag01[y and $00000001];
  340. mti := 0;
  341. end;
  342. y := mt[mti]; inc(mti);
  343. y := y xor (y shr 11);
  344. y := y xor (y shl 7) and TEMPERING_MASK_B;
  345. y := y xor (y shl 15) and TEMPERING_MASK_C;
  346. y := y xor (y shr 18);
  347. Result := y;
  348. end;
  349. function random(l:cardinal): cardinal;
  350. begin
  351. random := cardinal((int64(cardinal(genrand_MT19937))*l) shr 32);
  352. end;
  353. function random(l:longint): longint;
  354. begin
  355. random := longint((int64(cardinal(genrand_MT19937))*l) shr 32);
  356. end;
  357. function random: extended;
  358. begin
  359. random := cardinal(genrand_MT19937) * (1.0/(int64(1) shl 32));
  360. end;
  361. {****************************************************************************
  362. Memory Management
  363. ****************************************************************************}
  364. Function Ptr(sel,off : Longint) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:in_const_ptr];
  365. Begin
  366. ptr:=farpointer((sel shl 4)+off);
  367. End;
  368. Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  369. Begin
  370. Cseg:=0;
  371. End;
  372. Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  373. Begin
  374. Dseg:=0;
  375. End;
  376. Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  377. Begin
  378. Sseg:=0;
  379. End;
  380. {*****************************************************************************
  381. Directory support.
  382. *****************************************************************************}
  383. Procedure getdir(drivenr:byte;Var dir:ansistring);
  384. { this is needed to also allow ansistrings, the shortstring version is
  385. OS dependent }
  386. var
  387. s : shortstring;
  388. begin
  389. getdir(drivenr,s);
  390. dir:=s;
  391. end;
  392. {$ifopt R+}
  393. {$define RangeCheckWasOn}
  394. {$R-}
  395. {$endif opt R+}
  396. {$ifopt I+}
  397. {$define IOCheckWasOn}
  398. {$I-}
  399. {$endif opt I+}
  400. {$ifopt Q+}
  401. {$define OverflowCheckWasOn}
  402. {$Q-}
  403. {$endif opt Q+}
  404. {*****************************************************************************
  405. Miscellaneous
  406. *****************************************************************************}
  407. procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; {$ifdef hascompilerproc} compilerproc; {$endif}
  408. begin
  409. HandleErrorFrame(201,get_frame);
  410. end;
  411. procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; {$ifdef hascompilerproc} compilerproc; {$endif}
  412. begin
  413. HandleErrorFrame(200,get_frame);
  414. end;
  415. procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; {$ifdef hascompilerproc} compilerproc; {$endif}
  416. begin
  417. HandleErrorFrame(215,get_frame);
  418. end;
  419. procedure fpc_iocheck;[saveregisters,public,alias:'FPC_IOCHECK']; {$ifdef hascompilerproc} compilerproc; {$endif}
  420. var
  421. l : longint;
  422. begin
  423. if InOutRes<>0 then
  424. begin
  425. l:=InOutRes;
  426. InOutRes:=0;
  427. HandleErrorFrame(l,get_frame);
  428. end;
  429. end;
  430. Function IOResult:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  431. Begin
  432. IOResult:=InOutRes;
  433. InOutRes:=0;
  434. End;
  435. {*****************************************************************************
  436. Stack check code
  437. *****************************************************************************}
  438. {$IFNDEF NO_GENERIC_STACK_CHECK}
  439. {$IFOPT S+}
  440. {$DEFINE STACKCHECK}
  441. {$ENDIF}
  442. {$S-}
  443. procedure fpc_stackcheck(stack_size:Cardinal);[saveregisters,public,alias:'FPC_STACKCHECK'];
  444. var
  445. c : Pointer;
  446. begin
  447. { Avoid recursive calls when called from the exit routines }
  448. if StackError then
  449. exit;
  450. c := Sptr - (stack_size + STACK_MARGIN);
  451. if (c <= StackBottom) then
  452. begin
  453. StackError:=true;
  454. HandleError(202);
  455. end;
  456. end;
  457. {$IFDEF STACKCHECK}
  458. {$S+}
  459. {$ENDIF}
  460. {$UNDEF STACKCHECK}
  461. {$ENDIF NO_GENERIC_STACK_CHECK}
  462. {*****************************************************************************
  463. Initialization / Finalization
  464. *****************************************************************************}
  465. const
  466. maxunits=1024; { See also files.pas of the compiler source }
  467. type
  468. TInitFinalRec=record
  469. InitProc,
  470. FinalProc : TProcedure;
  471. end;
  472. TInitFinalTable=record
  473. TableCount,
  474. InitCount : longint;
  475. Procs : array[1..maxunits] of TInitFinalRec;
  476. end;
  477. var
  478. InitFinalTable : TInitFinalTable;external name 'INITFINAL';
  479. procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; {$ifdef hascompilerproc} compilerproc; {$endif}
  480. var
  481. i : longint;
  482. begin
  483. { call cpu/fpu initialisation routine }
  484. fpc_cpuinit;
  485. with InitFinalTable do
  486. begin
  487. for i:=1 to TableCount do
  488. begin
  489. if assigned(Procs[i].InitProc) then
  490. Procs[i].InitProc();
  491. InitCount:=i;
  492. end;
  493. end;
  494. end;
  495. procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS'];
  496. begin
  497. with InitFinalTable do
  498. begin
  499. while (InitCount>0) do
  500. begin
  501. // we've to decrement the cound before calling the final. code
  502. // else a halt in the final. code leads to a endless loop
  503. dec(InitCount);
  504. if assigned(Procs[InitCount+1].FinalProc) then
  505. Procs[InitCount+1].FinalProc();
  506. end;
  507. end;
  508. end;
  509. {*****************************************************************************
  510. Error / Exit / ExitProc
  511. *****************************************************************************}
  512. Procedure system_exit;forward;
  513. Procedure InternalExit;
  514. var
  515. current_exit : Procedure;
  516. Begin
  517. while exitProc<>nil Do
  518. Begin
  519. InOutRes:=0;
  520. current_exit:=tProcedure(exitProc);
  521. exitProc:=nil;
  522. current_exit();
  523. End;
  524. { Finalize units }
  525. FinalizeUnits;
  526. { Show runtime error and exit }
  527. If erroraddr<>nil Then
  528. Begin
  529. Writeln(stdout,'Runtime error ',Errorcode,' at $',hexstr(Longint(Erroraddr),8));
  530. { to get a nice symify }
  531. Writeln(stdout,BackTraceStrFunc(Erroraddr));
  532. dump_stack(stdout,ErrorBase);
  533. Writeln(stdout,'');
  534. End;
  535. End;
  536. Procedure do_exit;[Public,Alias:'FPC_DO_EXIT'];
  537. begin
  538. InternalExit;
  539. System_exit;
  540. end;
  541. Procedure lib_exit;saveregisters;[Public,Alias:'FPC_LIB_EXIT'];
  542. begin
  543. InternalExit;
  544. end;
  545. Procedure Halt(ErrNum: Byte);
  546. Begin
  547. ExitCode:=Errnum;
  548. Do_Exit;
  549. end;
  550. function SysBackTraceStr (Addr: Pointer): ShortString;
  551. begin
  552. SysBackTraceStr:=' $'+HexStr(Longint(addr),8);
  553. end;
  554. Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR'];
  555. begin
  556. If pointer(ErrorProc)<>Nil then
  557. ErrorProc(Errno,addr,frame);
  558. errorcode:=word(Errno);
  559. exitcode:=word(Errno);
  560. erroraddr:=addr;
  561. errorbase:=frame;
  562. halt(errorcode);
  563. end;
  564. Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
  565. {
  566. Procedure to handle internal errors, i.e. not user-invoked errors
  567. Internal function should ALWAYS call HandleError instead of RunError.
  568. Can be used for exception handlers to specify the frame
  569. }
  570. begin
  571. HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame));
  572. end;
  573. Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR'];
  574. {
  575. Procedure to handle internal errors, i.e. not user-invoked errors
  576. Internal function should ALWAYS call HandleError instead of RunError.
  577. }
  578. begin
  579. HandleErrorFrame(Errno,get_frame);
  580. end;
  581. procedure runerror(w : word);[alias: 'FPC_RUNERROR'];
  582. begin
  583. errorcode:=w;
  584. exitcode:=w;
  585. erroraddr:=get_caller_addr(get_frame);
  586. errorbase:=get_caller_frame(get_frame);
  587. halt(errorcode);
  588. end;
  589. Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif}
  590. Begin
  591. RunError (0);
  592. End;
  593. Procedure Halt;{$ifdef SYSTEMINLINE}inline;{$endif}
  594. Begin
  595. Halt(0);
  596. End;
  597. function do_isdevice(handle:longint):boolean;forward;
  598. Procedure dump_stack(var f : text;bp : Pointer);
  599. var
  600. i : Longint;
  601. prevbp : Pointer;
  602. is_dev : boolean;
  603. caller_addr : Pointer;
  604. Begin
  605. prevbp:=bp-1;
  606. i:=0;
  607. is_dev:=do_isdevice(textrec(f).Handle);
  608. while bp > prevbp Do
  609. Begin
  610. caller_addr := get_caller_addr(bp);
  611. if caller_addr <> nil then
  612. Writeln(f,BackTraceStrFunc(caller_addr));
  613. Inc(i);
  614. If ((i>max_frame_dump) and is_dev) or (i>256) Then
  615. exit;
  616. prevbp:=bp;
  617. bp:=get_caller_frame(bp);
  618. End;
  619. End;
  620. Type
  621. PExitProcInfo = ^TExitProcInfo;
  622. TExitProcInfo = Record
  623. Next : PExitProcInfo;
  624. SaveExit : Pointer;
  625. Proc : TProcedure;
  626. End;
  627. const
  628. ExitProcList: PExitProcInfo = nil;
  629. Procedure DoExitProc;
  630. var
  631. P : PExitProcInfo;
  632. Proc : TProcedure;
  633. Begin
  634. P:=ExitProcList;
  635. ExitProcList:=P^.Next;
  636. ExitProc:=P^.SaveExit;
  637. Proc:=P^.Proc;
  638. DisPose(P);
  639. Proc();
  640. End;
  641. Procedure AddExitProc(Proc: TProcedure);
  642. var
  643. P : PExitProcInfo;
  644. Begin
  645. New(P);
  646. P^.Next:=ExitProcList;
  647. P^.SaveExit:=ExitProc;
  648. P^.Proc:=Proc;
  649. ExitProcList:=P;
  650. ExitProc:=@DoExitProc;
  651. End;
  652. {*****************************************************************************
  653. Abstract/Assert support.
  654. *****************************************************************************}
  655. procedure AbstractError;[public,alias : 'FPC_ABSTRACTERROR'];
  656. begin
  657. If pointer(AbstractErrorProc)<>nil then
  658. AbstractErrorProc();
  659. HandleErrorFrame(211,get_frame);
  660. end;
  661. {$ifdef hascompilerproc}
  662. { alias for internal usage in the compiler }
  663. procedure fpc_AbstractErrorIntern; compilerproc; external name 'FPC_ABSTRACTERROR';
  664. {$endif hascompilerproc}
  665. Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); [SaveRegisters,Public,Alias : 'FPC_ASSERT']; {$ifdef hascompilerproc} compilerproc; {$endif}
  666. begin
  667. if pointer(AssertErrorProc)<>nil then
  668. AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
  669. else
  670. HandleErrorFrame(227,get_frame);
  671. end;
  672. Procedure SysAssert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer);
  673. begin
  674. If msg='' then
  675. write(stderr,'Assertion failed')
  676. else
  677. write(stderr,msg);
  678. Writeln(stderr,' (',FName,', line ',LineNo,').');
  679. Writeln(stderr,'');
  680. Halt(227);
  681. end;
  682. {*****************************************************************************
  683. SetJmp/LongJmp support.
  684. *****************************************************************************}
  685. {$i setjump.inc}
  686. {$ifdef IOCheckWasOn}
  687. {$I+}
  688. {$endif}
  689. {$ifdef RangeCheckWasOn}
  690. {$R+}
  691. {$endif}
  692. {$ifdef OverflowCheckWasOn}
  693. {$Q+}
  694. {$endif}
  695. {
  696. $Log$
  697. Revision 1.53 2004-02-06 20:17:13 daniel
  698. * Use $ for hex numbers instead of alien 0x
  699. Revision 1.52 2004/01/22 20:12:37 florian
  700. * fixed syscall number
  701. Revision 1.51 2004/01/11 12:21:06 jonas
  702. * fixed wrong include filename
  703. Revision 1.50 2004/01/11 11:10:07 jonas
  704. + cgeneric.inc: implementations of rtl routines based on libc
  705. * system.inc: include cgeneric.inc before powerpc.inc/i386.inc/... if
  706. FPC_USE_LIBC is defined
  707. * powerpc.inc, i386.inc: check whether the routines they implement aren't
  708. implemented yet in another include file (cgeneric.inc)
  709. Revision 1.49 2004/01/02 17:21:50 jonas
  710. + fpc_cpuinit procedure to allow cpu/fpu initialisation before any unit
  711. initialises
  712. + fpu exceptions for invalid operations and division by zero enabled for
  713. ppc
  714. Revision 1.48 2004/01/01 17:58:16 jonas
  715. + integer division-by-zero detection support for ppc
  716. + compilerproc FPC_DIVBYZERO
  717. Revision 1.47 2003/11/03 09:42:28 marco
  718. * Peter's Cardinal<->Longint fixes patch
  719. Revision 1.46 2003/10/29 18:23:45 jonas
  720. * hack to allow repeatable random sequences using the new random number
  721. generator
  722. * fixed range warning/error
  723. Revision 1.45 2003/10/26 21:15:43 hajny
  724. * minor fix for new Random
  725. Revision 1.44 2003/10/26 18:46:02 jonas
  726. * replaced random generator with the Mersenne twister, which is about
  727. 3.5 times faster
  728. Revision 1.43 2003/09/14 11:34:13 peter
  729. * moved int64 asm code to int64p.inc
  730. * save ebx,esi
  731. Revision 1.42 2003/09/03 14:09:37 florian
  732. * arm fixes to the common rtl code
  733. * some generic math code fixed
  734. * ...
  735. Revision 1.41 2003/08/21 22:10:55 olle
  736. - removed parameter from fpc_iocheck
  737. * changed processor compiler directive * to cpu*
  738. Revision 1.40 2003/03/17 14:30:11 peter
  739. * changed address parameter/return values to pointer instead
  740. of longint
  741. Revision 1.39 2003/02/05 21:48:34 mazen
  742. * fixing run time errors related to unimplemented abstract methods in CG
  743. + giving empty emplementations for some RTL functions
  744. Revision 1.38 2002/12/07 14:36:33 carl
  745. - avoid warnings (add typecast)
  746. Revision 1.37 2002/11/18 18:33:51 peter
  747. * Swap(QWord) constant support
  748. Revision 1.36 2002/10/14 19:39:17 peter
  749. * threads unit added for thread support
  750. Revision 1.35 2002/09/18 18:32:01 carl
  751. * assert now halts with exitcode 227 (as Delphi does)
  752. Revision 1.34 2002/09/07 15:07:46 peter
  753. * old logs removed and tabs fixed
  754. Revision 1.33 2002/08/19 19:34:02 peter
  755. * SYSTEMINLINE define that will add inline directives for small
  756. functions and wrappers. This will be defined automaticly when
  757. the compiler defines the HASINLINE directive
  758. Revision 1.32 2002/07/28 20:43:48 florian
  759. * several fixes for linux/powerpc
  760. * several fixes to MT
  761. Revision 1.31 2002/07/26 22:46:06 florian
  762. * interface of system unit for Linux/PowerPC compiles
  763. Revision 1.30 2002/07/26 16:42:00 florian
  764. * endian directive for PowerPC fixed
  765. Revision 1.29 2002/07/04 20:40:09 florian
  766. + some x86-64 support added
  767. Revision 1.28 2002/04/21 15:51:50 carl
  768. * StackError is now a typed constant
  769. + $S can be used under unix
  770. Revision 1.27 2002/04/15 19:38:40 peter
  771. * stackcheck protected against infinite recursive after stack error
  772. * stackcheck requires saveregisters, because it can be called from
  773. iocheck and then will destroy the result of the original function
  774. Revision 1.26 2002/04/15 18:51:20 carl
  775. + generic stack checking can be overriden
  776. Revision 1.25 2002/04/12 17:37:36 carl
  777. + generic stack checking
  778. }