system.inc 33 KB

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