system.inc 26 KB

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