system.inc 50 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880
  1. {
  2. This file is part of the Free Pascal Run time library.
  3. Copyright (c) 1999-2008 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. { ObjpasInt is the integer type, equivalent to Objpas.Integer (the Integer
  11. type in ObjFpc and Delphi modes). It is defined here for use in the
  12. implementation part of the System unit. }
  13. {$ifdef CPU16}
  14. type
  15. ObjpasInt = SmallInt;
  16. {$else CPU16}
  17. type
  18. ObjpasInt = LongInt;
  19. {$endif CPU16}
  20. { The RTTI is implemented through a series of constants : }
  21. Const
  22. // please update tkManagedTypes below if you add new
  23. // values
  24. tkUnknown = 0;
  25. tkInteger = 1;
  26. tkChar = 2;
  27. tkEnumeration = 3;
  28. tkFloat = 4;
  29. tkSet = 5;
  30. tkMethod = 6;
  31. tkSString = 7;
  32. tkString = tkSString;
  33. tkLString = 8;
  34. tkAString = 9;
  35. tkWString = 10;
  36. tkVariant = 11;
  37. tkArray = 12;
  38. tkRecord = 13;
  39. tkInterface = 14;
  40. tkClass = 15;
  41. tkObject = 16;
  42. tkWChar = 17;
  43. tkBool = 18;
  44. tkInt64 = 19;
  45. tkQWord = 20;
  46. tkDynArray = 21;
  47. tkInterfaceCorba = 22;
  48. tkProcVar = 23;
  49. tkUString = 24;
  50. tkHelper = 26;
  51. tkFile = 27;
  52. tkClassRef = 28;
  53. tkPointer = 29;
  54. // all potentially managed types
  55. tkManagedTypes = [tkAstring,tkWstring,tkUstring,tkArray,
  56. tkObject,tkRecord,tkDynArray,tkInterface,tkVariant];
  57. {****************************************************************************
  58. Local types
  59. ****************************************************************************}
  60. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  61. {$ifdef FPC_OBJFPC_EXTENDED_IF}
  62. {$if High(errorcode)<>maxExitCode}
  63. {$define FPC_LIMITED_EXITCODE}
  64. {$endif}
  65. {$else}
  66. {$define FPC_LIMITED_EXITCODE}
  67. {$endif FPC_OBJFPC_EXTENDED_IF}
  68. {$endif FPC_HAS_FEATURE_EXITCODE}
  69. Procedure HandleError (Errno : Longint); external name 'FPC_HANDLEERROR';
  70. Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
  71. Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
  72. Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
  73. {$ifdef FPC_HAS_FEATURE_TEXTIO}
  74. type
  75. FileFunc = Procedure(var t : TextRec);
  76. {$endif FPC_HAS_FEATURE_TEXTIO}
  77. const
  78. STACK_MARGIN = 16384; { Stack size margin for stack checking }
  79. { Random / Randomize constants }
  80. OldRandSeed : Cardinal = 0;
  81. { For Error Handling.}
  82. ErrorBase : Pointer = nil;public name 'FPC_ERRORBASE';
  83. { Used by the ansi/widestrings and maybe also other things in the future }
  84. var
  85. { widechar, because also used by widestring -> pwidechar conversions }
  86. emptychar : widechar;public name 'FPC_EMPTYCHAR';
  87. {$ifndef FPC_NO_GENERIC_STACK_CHECK}
  88. { if the OS does the stack checking, we don't need any stklen from the
  89. main program }
  90. initialstklen : SizeUint;external name '__stklen';
  91. {$endif FPC_NO_GENERIC_STACK_CHECK}
  92. { checks whether the given suggested size for the stack of the current
  93. thread is acceptable. If this is the case, returns it unaltered.
  94. Otherwise it should return an acceptable value.
  95. Operating systems that automatically expand their stack on demand, should
  96. simply return a very large value.
  97. Operating systems which do not have a possibility to retrieve stack size
  98. information, should simply return the given stklen value (This is the default
  99. implementation).
  100. }
  101. {$ifdef FPC_HAS_FEATURE_STACKCHECK}
  102. function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; forward;
  103. {$endif FPC_HAS_FEATURE_STACKCHECK}
  104. {*****************************************************************************
  105. OS dependent Helpers/Syscalls
  106. *****************************************************************************}
  107. { for some OSes do_isdevice is defined in sysos.inc, but for others (win32)
  108. it isn't, and is used before the actual definition is encountered }
  109. {$ifdef FPC_HAS_FEATURE_FILEIO}
  110. function do_isdevice(handle:thandle):boolean;forward;
  111. {$endif FPC_HAS_FEATURE_FILEIO}
  112. {$i sysos.inc}
  113. {****************************************************************************
  114. Include processor specific routines
  115. ****************************************************************************}
  116. {$ifdef FPC_USE_LIBC}
  117. { Under Haiku, bcopy cause a problem when searching for include file
  118. in the compiler. So, we use the internal implementation for now
  119. under BeOS and Haiku. }
  120. {$ifndef BEOS}
  121. { prefer libc implementations over our own, as they're most likely faster }
  122. {$i cgeneric.inc}
  123. { is now declared as external reference to another routine in the interface }
  124. {$i cgenstr.inc}
  125. {$endif}
  126. {$endif FPC_USE_LIBC}
  127. {$ifdef cpui386}
  128. {$ifdef SYSPROCDEFINED}
  129. {$Error Can't determine processor type !}
  130. {$endif}
  131. {$i i386.inc} { Case dependent, don't change }
  132. {$define SYSPROCDEFINED}
  133. {$endif cpui386}
  134. {$ifdef cpui8086}
  135. {$ifdef SYSPROCDEFINED}
  136. {$Error Can't determine processor type !}
  137. {$endif}
  138. {$i i8086.inc} { Case dependent, don't change }
  139. {$define SYSPROCDEFINED}
  140. {$endif cpui8086}
  141. {$ifdef cpum68k}
  142. {$ifdef SYSPROCDEFINED}
  143. {$Error Can't determine processor type !}
  144. {$endif}
  145. {$i m68k.inc} { Case dependent, don't change }
  146. {$define SYSPROCDEFINED}
  147. {$endif cpum68k}
  148. {$ifdef cpux86_64}
  149. {$ifdef SYSPROCDEFINED}
  150. {$Error Can't determine processor type !}
  151. {$endif}
  152. {$i x86_64.inc} { Case dependent, don't change }
  153. {$define SYSPROCDEFINED}
  154. {$endif cpux86_64}
  155. {$ifdef cpupowerpc32}
  156. {$ifdef SYSPROCDEFINED}
  157. {$Error Can't determine processor type !}
  158. {$endif}
  159. {$i powerpc.inc} { Case dependent, don't change }
  160. {$define SYSPROCDEFINED}
  161. {$endif cpupowerpc32}
  162. {$ifdef cpupowerpc64}
  163. {$ifdef SYSPROCDEFINED}
  164. {$Error Can't determine processor type !}
  165. {$endif}
  166. {$i powerpc64.inc} { Case dependent, don't change }
  167. {$define SYSPROCDEFINED}
  168. {$endif cpupowerpc64}
  169. {$ifdef cpualpha}
  170. {$ifdef SYSPROCDEFINED}
  171. {$Error Can't determine processor type !}
  172. {$endif}
  173. {$i alpha.inc} { Case dependent, don't change }
  174. {$define SYSPROCDEFINED}
  175. {$endif cpualpha}
  176. {$ifdef cpuiA64}
  177. {$ifdef SYSPROCDEFINED}
  178. {$Error Can't determine processor type !}
  179. {$endif}
  180. {$i ia64.inc} { Case dependent, don't change }
  181. {$define SYSPROCDEFINED}
  182. {$endif cpuiA64}
  183. {$ifdef cpusparc}
  184. {$ifdef SYSPROCDEFINED}
  185. {$Error Can't determine processor type !}
  186. {$endif}
  187. {$i sparc.inc} { Case dependent, don't change }
  188. {$define SYSPROCDEFINED}
  189. {$endif cpusparc}
  190. {$ifdef cpuarm}
  191. {$ifdef SYSPROCDEFINED}
  192. {$Error Can't determine processor type !}
  193. {$endif}
  194. {$i armdefines.inc}
  195. {$if defined(CPUTHUMB2)}
  196. {$i thumb2.inc} { Case dependent, don't change }
  197. {$else}
  198. {$if defined(CPUTHUMB)}
  199. {$i thumb.inc} { Case dependent, don't change }
  200. {$else}
  201. {$i arm.inc} { Case dependent, don't change }
  202. {$endif}
  203. {$endif}
  204. {$define SYSPROCDEFINED}
  205. {$endif cpuarm}
  206. {$ifdef cpuavr}
  207. {$ifdef SYSPROCDEFINED}
  208. {$Error Can't determine processor type !}
  209. {$endif}
  210. {$i avr.inc} { Case dependent, don't change }
  211. {$define SYSPROCDEFINED}
  212. {$endif cpuavr}
  213. {$ifdef cpumipsel}
  214. {$ifdef SYSPROCDEFINED}
  215. {$Error Can't determine processor type !}
  216. {$endif}
  217. { there is no mipsel.inc, we use mips.inc instead }
  218. {$i mips.inc} { Case dependent, don't change }
  219. {$define SYSPROCDEFINED}
  220. {$else not cpumipsel}
  221. {$ifdef cpumips}
  222. {$ifdef SYSPROCDEFINED}
  223. {$Error Can't determine processor type !}
  224. {$endif}
  225. {$i mips.inc} { Case dependent, don't change }
  226. {$define SYSPROCDEFINED}
  227. {$endif cpumips}
  228. {$endif not cpumipsel}
  229. {$ifndef SYSPROCDEFINED}
  230. {$Error Can't determine processor type !}
  231. {$endif}
  232. procedure fillchar(var x;count : SizeInt;value : boolean);
  233. begin
  234. fillchar(x,count,byte(value));
  235. end;
  236. procedure fillchar(var x;count : SizeInt;value : char);
  237. begin
  238. fillchar(x,count,byte(value));
  239. end;
  240. procedure FillByte (var x;count : SizeInt;value : byte );
  241. begin
  242. FillChar (X,Count,VALUE);
  243. end;
  244. function IndexChar(Const buf;len:SizeInt;b:char):SizeInt;
  245. begin
  246. IndexChar:=IndexByte(Buf,Len,byte(B));
  247. end;
  248. function CompareChar(Const buf1,buf2;len:SizeInt):SizeInt;
  249. begin
  250. CompareChar:=CompareByte(buf1,buf2,len);
  251. end;
  252. procedure fpc_zeromem(p:pointer;len:ptruint);
  253. begin
  254. FillChar(p^,len,0);
  255. end;
  256. procedure fpc_fillmem(out data;len:ptruint;b : byte);
  257. begin
  258. FillByte(data,len,b);
  259. end;
  260. { Include generic pascal only routines which are not defined in the processor
  261. specific include file }
  262. {$I generic.inc}
  263. {****************************************************************************
  264. Set Handling
  265. ****************************************************************************}
  266. { Include set support which is processor specific}
  267. {$i set.inc}
  268. { Include generic pascal routines for sets if the processor }
  269. { specific routines are not available. }
  270. {$i genset.inc}
  271. {****************************************************************************
  272. Math Routines
  273. ****************************************************************************}
  274. function Hi(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  275. begin
  276. Hi := b shr 4
  277. end;
  278. function Lo(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif}
  279. begin
  280. Lo := b and $0f
  281. end;
  282. Function Swap (X : Word) : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  283. Begin
  284. Swap := SwapEndian(X);
  285. End;
  286. Function Swap (X : Integer) : Integer;{$ifdef SYSTEMINLINE}inline;{$endif}
  287. Begin
  288. Swap := SwapEndian(X);
  289. End;
  290. Function Swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif}
  291. Begin
  292. Swap:=(X shl 16) + (X shr 16);
  293. End;
  294. Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
  295. Begin
  296. Swap:=(X shl 16) + (X shr 16);
  297. End;
  298. Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
  299. Begin
  300. Swap:=(X shl 32) + (X shr 32);
  301. End;
  302. Function Swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}
  303. Begin
  304. Swap:=(X shl 32) + (X shr 32);
  305. End;
  306. {$ifdef SUPPORT_DOUBLE}
  307. operator := (b:real48) d:double;{$ifdef SYSTEMINLINE}inline;{$endif}
  308. begin
  309. D:=real2double(b);
  310. end;
  311. {$endif SUPPORT_DOUBLE}
  312. {$ifdef SUPPORT_EXTENDED}
  313. operator := (b:real48) e:extended;{$ifdef SYSTEMINLINE}inline;{$endif}
  314. begin
  315. e:=real2double(b);
  316. end;
  317. {$endif SUPPORT_EXTENDED}
  318. {$ifndef FPUNONE}
  319. {$ifdef FPC_USE_LIBC}
  320. { Include libc versions }
  321. {$i cgenmath.inc}
  322. {$endif FPC_USE_LIBC}
  323. { Include processor specific routines }
  324. {$I math.inc}
  325. { Include generic version }
  326. {$I genmath.inc}
  327. {$endif}
  328. {$i gencurr.inc}
  329. function aligntoptr(p : pointer) : pointer;inline;
  330. begin
  331. {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT}
  332. result:=align(p,sizeof(p));
  333. {$else FPC_REQUIRES_PROPER_ALIGNMENT}
  334. result:=p;
  335. {$endif FPC_REQUIRES_PROPER_ALIGNMENT}
  336. end;
  337. {****************************************************************************
  338. Subroutines for String handling
  339. ****************************************************************************}
  340. { Needs to be before RTTI handling }
  341. {$i sstrings.inc}
  342. { requires sstrings.inc for initval }
  343. {$I int64p.inc}
  344. {$I int64.inc}
  345. {Requires int64.inc, since that contains the VAL functions for int64 and qword}
  346. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  347. {$i astrings.inc}
  348. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  349. {$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
  350. {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
  351. {$i wstrings.inc}
  352. {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING}
  353. {$i ustrings.inc}
  354. {$endif FPC_HAS_FEATURE_WIDESTRINGS}
  355. {$i aliases.inc}
  356. {*****************************************************************************
  357. Dynamic Array support
  358. *****************************************************************************}
  359. {$ifdef FPC_HAS_FEATURE_DYNARRAYS}
  360. {$i dynarr.inc}
  361. {$endif FPC_HAS_FEATURE_DYNARRAYS}
  362. {*****************************************************************************
  363. Object Pascal support
  364. *****************************************************************************}
  365. {$ifdef FPC_HAS_FEATURE_CLASSES}
  366. {$i objpas.inc}
  367. {$endif FPC_HAS_FEATURE_CLASSES}
  368. {*****************************************************************************
  369. Variant support
  370. *****************************************************************************}
  371. {$ifdef FPC_HAS_FEATURE_VARIANTS}
  372. {$i variant.inc}
  373. {$endif FPC_HAS_FEATURE_VARIANTS}
  374. {****************************************************************************
  375. Run-Time Type Information (RTTI)
  376. ****************************************************************************}
  377. {$ifdef FPC_HAS_FEATURE_RTTI}
  378. {$i rtti.inc}
  379. {$endif FPC_HAS_FEATURE_RTTI}
  380. {$if defined(FPC_HAS_FEATURE_RANDOM)}
  381. {----------------------------------------------------------------------
  382. Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  383. Pseudo-Random Number Generator.
  384. What is Mersenne Twister?
  385. Mersenne Twister(MT) is a pseudorandom number generator developped by
  386. Makoto Matsumoto and Takuji Nishimura (alphabetical order) during
  387. 1996-1997. MT has the following merits:
  388. It is designed with consideration on the flaws of various existing
  389. generators.
  390. Far longer period and far higher order of equidistribution than any
  391. other implemented generators. (It is proved that the period is 2^19937-1,
  392. and 623-dimensional equidistribution property is assured.)
  393. Fast generation. (Although it depends on the system, it is reported that
  394. MT is sometimes faster than the standard ANSI-C library in a system
  395. with pipeline and cache memory.)
  396. Efficient use of the memory. (The implemented C-code mt19937.c
  397. consumes only 624 words of working area.)
  398. home page
  399. http://www.math.keio.ac.jp/~matumoto/emt.html
  400. original c source
  401. http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c
  402. Coded by Takuji Nishimura, considering the suggestions by
  403. Topher Cooper and Marc Rieffel in July-Aug. 1997.
  404. This library is free software; you can redistribute it and/or
  405. modify it under the terms of the GNU Library General Public
  406. License as published by the Free Software Foundation; either
  407. version 2 of the License, or (at your option) any later
  408. version.
  409. This library is distributed in the hope that it will be useful,
  410. but WITHOUT ANY WARRANTY; without even the implied warranty of
  411. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  412. See the GNU Library General Public License for more details.
  413. You should have received a copy of the GNU Library General
  414. Public License along with this library; if not, write to the
  415. Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  416. 02111-1307 USA
  417. Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura.
  418. When you use this, send an email to: [email protected]
  419. with an appropriate reference to your work.
  420. REFERENCE
  421. M. Matsumoto and T. Nishimura,
  422. "Mersenne Twister: A 623-Dimensionally Equidistributed Uniform
  423. Pseudo-Random Number Generator",
  424. ACM Transactions on Modeling and Computer Simulation,
  425. Vol. 8, No. 1, January 1998, pp 3--30.
  426. Translated to OP and Delphi interface added by Roman Krejci (6.12.1999)
  427. http://www.rksolution.cz/delphi/tips.htm
  428. Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed
  429. 2003/10/26: adapted to use the improved intialisation mentioned at
  430. <http://www.math.keio.ac.jp/~matumoto/MT2002/emt19937ar.html> and
  431. removed the assembler code
  432. ----------------------------------------------------------------------}
  433. {$R-} {range checking off}
  434. {$Q-} {overflow checking off}
  435. { Period parameter }
  436. Const
  437. MT19937N=624;
  438. Type
  439. tMT19937StateArray = array [0..MT19937N-1] of longint; // the array for the state vector
  440. { Period parameters }
  441. const
  442. MT19937M=397;
  443. MT19937MATRIX_A =$9908b0df; // constant vector a
  444. MT19937UPPER_MASK=longint($80000000); // most significant w-r bits
  445. MT19937LOWER_MASK=longint($7fffffff); // least significant r bits
  446. { Tempering parameters }
  447. TEMPERING_MASK_B=longint($9d2c5680);
  448. TEMPERING_MASK_C=longint($efc60000);
  449. VAR
  450. mt : tMT19937StateArray;
  451. const
  452. mti: longint=MT19937N+1; // mti=MT19937N+1 means mt[] is not initialized
  453. { Initializing the array with a seed }
  454. procedure sgenrand_MT19937(seed: longint);
  455. var
  456. i: longint;
  457. begin
  458. mt[0] := seed;
  459. for i := 1 to MT19937N-1 do
  460. begin
  461. mt[i] := 1812433253 * (mt[i-1] xor (mt[i-1] shr 30)) + i;
  462. { See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. }
  463. { In the previous versions, MSBs of the seed affect }
  464. { only MSBs of the array mt[]. }
  465. { 2002/01/09 modified by Makoto Matsumoto }
  466. end;
  467. mti := MT19937N;
  468. end;
  469. function genrand_MT19937: longint;
  470. const
  471. mag01 : array [0..1] of longint =(0, longint(MT19937MATRIX_A));
  472. var
  473. y: longint;
  474. kk: longint;
  475. begin
  476. if RandSeed<>OldRandSeed then
  477. mti:=MT19937N+1;
  478. if (mti >= MT19937N) { generate MT19937N longints at one time }
  479. then begin
  480. if mti = (MT19937N+1) then // if sgenrand_MT19937() has not been called,
  481. begin
  482. sgenrand_MT19937(randseed); // default initial seed is used
  483. { hack: randseed is not used more than once in this algorithm. Most }
  484. { user changes are re-initialising reandseed with the value it had }
  485. { at the start -> with the "not", we will detect this change. }
  486. { Detecting other changes is not useful, since the generated }
  487. { numbers will be different anyway. }
  488. randseed := not(randseed);
  489. oldrandseed := randseed;
  490. end;
  491. for kk:=0 to MT19937N-MT19937M-1 do begin
  492. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  493. mt[kk] := mt[kk+MT19937M] xor (y shr 1) xor mag01[y and $00000001];
  494. end;
  495. for kk:= MT19937N-MT19937M to MT19937N-2 do begin
  496. y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK);
  497. mt[kk] := mt[kk+(MT19937M-MT19937N)] xor (y shr 1) xor mag01[y and $00000001];
  498. end;
  499. y := (mt[MT19937N-1] and MT19937UPPER_MASK) or (mt[0] and MT19937LOWER_MASK);
  500. mt[MT19937N-1] := mt[MT19937M-1] xor (y shr 1) xor mag01[y and $00000001];
  501. mti := 0;
  502. end;
  503. y := mt[mti]; inc(mti);
  504. y := y xor (y shr 11);
  505. y := y xor (y shl 7) and TEMPERING_MASK_B;
  506. y := y xor (y shl 15) and TEMPERING_MASK_C;
  507. y := y xor (y shr 18);
  508. Result := y;
  509. end;
  510. function random(l:longint): longint;
  511. begin
  512. { otherwise we can return values = l (JM) }
  513. if (l < 0) then
  514. inc(l);
  515. random := longint((int64(cardinal(genrand_MT19937))*l) shr 32);
  516. end;
  517. function random(l:int64): int64;
  518. begin
  519. { always call random, so the random generator cycles (TP-compatible) (JM) }
  520. random := int64((qword(cardinal(genrand_MT19937)) or ((qword(cardinal(genrand_MT19937)) shl 32))) and $7fffffffffffffff);
  521. if (l<>0) then
  522. random := random mod l
  523. else
  524. random := 0;
  525. end;
  526. {$ifndef FPUNONE}
  527. function random: extended;
  528. begin
  529. random := cardinal(genrand_MT19937) * (extended(1.0)/(int64(1) shl 32));
  530. end;
  531. {$endif}
  532. {$endif FPC_HAS_FEATURE_RANDOM}
  533. {****************************************************************************
  534. Memory Management
  535. ****************************************************************************}
  536. {$ifndef FPC_SYSTEM_HAS_PTR}
  537. Function Ptr(sel,off : {$ifdef CPU16}Word{$else}Longint{$endif}) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
  538. Begin
  539. ptr:=farpointer((sel shl 4)+off);
  540. End;
  541. {$endif not FPC_SYSTEM_HAS_PTR}
  542. {$ifndef FPC_SYSTEM_HAS_CSEG}
  543. Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  544. Begin
  545. Cseg:=0;
  546. End;
  547. {$endif not FPC_SYSTEM_HAS_CSEG}
  548. {$ifndef FPC_SYSTEM_HAS_DSEG}
  549. Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  550. Begin
  551. Dseg:=0;
  552. End;
  553. {$endif not FPC_SYSTEM_HAS_DSEG}
  554. {$ifndef FPC_SYSTEM_HAS_SSEG}
  555. Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
  556. Begin
  557. Sseg:=0;
  558. End;
  559. {$endif not FPC_SYSTEM_HAS_SSEG}
  560. {$push}
  561. {$R-}
  562. {$I-}
  563. {$Q-}
  564. {*****************************************************************************
  565. Miscellaneous
  566. *****************************************************************************}
  567. {$ifndef FPC_SYSTEM_HAS_STACKTOP}
  568. function StackTop: pointer;
  569. begin
  570. result:=StackBottom+StackLength;
  571. end;
  572. {$endif FPC_SYSTEM_HAS_STACKTOP}
  573. {$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR}
  574. { This provides a dummy implementation
  575. of get_pc_addr function, for CPU's that don't need
  576. the instruction address to walk the stack. }
  577. function get_pc_addr : codepointer;
  578. begin
  579. get_pc_addr:=nil;
  580. end;
  581. {$endif ndef FPC_SYSTEM_HAS_GET_PC_ADDR}
  582. {$ifndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
  583. { This provides a simple implementation
  584. of get_caller_stackinfo procedure,
  585. using get_caller_addr and get_caller_frame
  586. functions. }
  587. procedure get_caller_stackinfo(var framebp : pointer; var addr : codepointer);
  588. var
  589. nextbp : pointer;
  590. nextaddr : codepointer;
  591. begin
  592. nextbp:=get_caller_frame(framebp,addr);
  593. nextaddr:=get_caller_addr(framebp,addr);
  594. framebp:=nextbp;
  595. addr:=nextaddr;
  596. end;
  597. {$endif ndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
  598. procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc;
  599. begin
  600. HandleErrorAddrFrameInd(201,get_pc_addr,get_frame);
  601. end;
  602. procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc;
  603. begin
  604. HandleErrorAddrFrameInd(200,get_pc_addr,get_frame);
  605. end;
  606. procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc;
  607. begin
  608. HandleErrorAddrFrameInd(215,get_pc_addr,get_frame);
  609. end;
  610. procedure fpc_threaderror; [public,alias:'FPC_THREADERROR'];
  611. begin
  612. HandleErrorAddrFrameInd(6,get_pc_addr,get_frame);
  613. end;
  614. procedure fpc_invalidpointer; [public,alias:'FPC_INVALIDPOINTER'];
  615. begin
  616. HandleErrorAddrFrameInd(216,get_pc_addr,get_frame);
  617. end;
  618. procedure fpc_iocheck;[public,alias:'FPC_IOCHECK']; compilerproc;
  619. var
  620. l : longint;
  621. HInoutRes : PWord;
  622. begin
  623. HInOutRes:=@InoutRes;
  624. if HInOutRes^<>0 then
  625. begin
  626. l:=HInOutRes^;
  627. HInOutRes^:=0;
  628. HandleErrorAddrFrameInd(l,get_pc_addr,get_frame);
  629. end;
  630. end;
  631. Function IOResult:Word;
  632. var
  633. HInoutRes : PWord;
  634. Begin
  635. HInoutRes:=@InoutRes;
  636. IOResult:=HInOutRes^;
  637. HInOutRes^:=0;
  638. End;
  639. Function GetThreadID:TThreadID;{$ifdef SYSTEMINLINE}inline;{$endif}
  640. begin
  641. (* ThreadID is stored in a threadvar and made available in interface *)
  642. (* to allow setup of this value during thread initialization. *)
  643. GetThreadID := ThreadID;
  644. end;
  645. function fpc_safecallcheck(res : hresult) : hresult;[public,alias:'FPC_SAFECALLCHECK']; compilerproc; {$ifdef CPU86} register; {$endif}
  646. begin
  647. if res<0 then
  648. begin
  649. if assigned(SafeCallErrorProc) then
  650. SafeCallErrorProc(res,get_frame);
  651. HandleErrorAddrFrameInd(229,get_pc_addr,get_frame);
  652. end;
  653. result:=res;
  654. end;
  655. {*****************************************************************************
  656. Stack check code
  657. *****************************************************************************}
  658. { be compatible with old code }
  659. {$ifdef FPC_NO_GENERIC_STACK_CHECK}
  660. {$define NO_GENERIC_STACK_CHECK}
  661. {$endif FPC_NO_GENERIC_STACK_CHECK}
  662. {$IFNDEF NO_GENERIC_STACK_CHECK}
  663. {$PUSH}
  664. {$S-}
  665. procedure fpc_stackcheck(stack_size:SizeUInt);[public,alias:'FPC_STACKCHECK']; compilerproc;
  666. var
  667. c : Pointer;
  668. begin
  669. { Avoid recursive calls when called from the exit routines }
  670. if StackError then
  671. exit;
  672. { don't use sack_size, since the stack pointer has already been
  673. decreased when this routine is called
  674. }
  675. c := Sptr - STACK_MARGIN;
  676. if (c <= StackBottom) then
  677. begin
  678. StackError:=true;
  679. HandleError(202);
  680. end;
  681. end;
  682. {$POP}
  683. {$ENDIF NO_GENERIC_STACK_CHECK}
  684. {*****************************************************************************
  685. Initialization / Finalization
  686. *****************************************************************************}
  687. const
  688. maxunits=1024; { See also files.pas of the compiler source }
  689. type
  690. TInitFinalRec=record
  691. InitProc,
  692. FinalProc : TProcedure;
  693. end;
  694. TInitFinalTable = record
  695. TableCount,
  696. InitCount : {$ifdef VER2_6}longint{$else}sizeint{$endif};
  697. Procs : array[1..maxunits] of TInitFinalRec;
  698. end;
  699. PInitFinalTable = ^TInitFinalTable;
  700. {$ifndef FPC_HAS_INDIRECT_MAIN_INFORMATION}
  701. var
  702. InitFinalTable : TInitFinalTable;external name 'INITFINAL';
  703. {$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
  704. procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; compilerproc;
  705. var
  706. i : ObjpasInt;
  707. {$ifdef DEBUG}
  708. pt : PInitFinalTable;
  709. {$endif}
  710. begin
  711. { call cpu/fpu initialisation routine }
  712. fpc_cpuinit;
  713. {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
  714. {$ifdef DEBUG}
  715. pt := PInitFinalTable(EntryInformation.InitFinalTable);
  716. {$endif}
  717. with PInitFinalTable(EntryInformation.InitFinalTable)^ do
  718. {$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
  719. {$ifdef DEBUG}
  720. pt := @InitFinalTable;
  721. {$endif}
  722. with InitFinalTable do
  723. {$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
  724. begin
  725. for i:=1 to TableCount do
  726. begin
  727. if assigned(Procs[i].InitProc) then
  728. Procs[i].InitProc();
  729. InitCount:=i;
  730. end;
  731. end;
  732. if assigned(InitProc) then
  733. TProcedure(InitProc)();
  734. end;
  735. procedure internal_initializeunits; external name 'FPC_INITIALIZEUNITS';
  736. procedure fpc_LibInitializeUnits;[public,alias:'FPC_LIBINITIALIZEUNITS'];
  737. begin
  738. {$ifdef FPC_HAS_FEATURE_DYNLIBS}
  739. IsLibrary:=true;
  740. { must also be set to true for packages when implemented }
  741. ModuleIsLib:=true;
  742. internal_initializeunits;
  743. {$endif FPC_HAS_FEATURE_DYNLIBS}
  744. end;
  745. procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS'];
  746. begin
  747. {$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
  748. with PInitFinalTable(EntryInformation.InitFinalTable)^ do
  749. {$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
  750. with InitFinalTable do
  751. {$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
  752. begin
  753. while (InitCount>0) do
  754. begin
  755. // we've to decrement the cound before calling the final. code
  756. // else a halt in the final. code leads to a endless loop
  757. dec(InitCount);
  758. if assigned(Procs[InitCount+1].FinalProc) then
  759. Procs[InitCount+1].FinalProc();
  760. end;
  761. end;
  762. end;
  763. {*****************************************************************************
  764. Error / Exit / ExitProc
  765. *****************************************************************************}
  766. Procedure system_exit;forward;
  767. {$ifdef FPC_HAS_FEATURE_HEAP}
  768. {$ifndef HAS_MEMORYMANAGER}
  769. //not needed if independant memory manager
  770. Procedure FinalizeHeap;forward;
  771. {$endif HAS_MEMORYMANAGER}
  772. {$endif FPC_HAS_FEATURE_HEAP}
  773. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  774. procedure SysFlushStdIO;
  775. begin
  776. { Make sure that all output is written to the redirected file }
  777. if Textrec(Output).Mode=fmOutput then
  778. Flush(Output);
  779. if Textrec(ErrOutput).Mode=fmOutput then
  780. Flush(ErrOutput);
  781. if Textrec(stdout).Mode=fmOutput then
  782. Flush(stdout);
  783. if Textrec(StdErr).Mode=fmOutput then
  784. Flush(StdErr);
  785. end;
  786. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  787. Procedure InternalExit;
  788. var
  789. current_exit : Procedure;
  790. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  791. pstdout : ^Text;
  792. {$endif}
  793. {$if defined(MSWINDOWS) or defined(OS2)}
  794. i : longint;
  795. {$endif}
  796. Begin
  797. {$ifdef SYSTEMDEBUG}
  798. writeln('InternalExit');
  799. {$endif SYSTEMDEBUG}
  800. while exitProc<>nil Do
  801. Begin
  802. InOutRes:=0;
  803. current_exit:=tProcedure(exitProc);
  804. exitProc:=nil;
  805. current_exit();
  806. End;
  807. { Finalize units }
  808. FinalizeUnits;
  809. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  810. { the embedded system unit itself contains no routines for console i/o
  811. console i/o is done by the Consoleio unit which can do things like
  812. redirection to seriell i/o }
  813. {$ifndef EMBEDDED}
  814. { Show runtime error and exit }
  815. if WriteErrorsToStdErr then
  816. pstdout:=@stderr
  817. else
  818. pstdout:=@stdout;
  819. If erroraddr<>nil Then
  820. Begin
  821. Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
  822. { to get a nice symify }
  823. Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
  824. dump_stack(pstdout^,ErrorBase,ErrorAddr);
  825. Writeln(pstdout^,'');
  826. End;
  827. SysFlushStdIO;
  828. {$endif EMBEDDED}
  829. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  830. {$if defined(MSWINDOWS) or defined(OS2)}
  831. { finally release the heap if possible, especially
  832. important for DLLs.
  833. Reset the array to nil, and finally also argv itself to
  834. avoid double freeing problem in case this function gets called twice. }
  835. if assigned(argv) then
  836. begin
  837. for i:=0 to argc-1 do
  838. if assigned(argv[i]) then
  839. begin
  840. sysfreemem(argv[i]);
  841. argv[i]:=nil;
  842. end;
  843. sysfreemem(argv);
  844. argv:=nil;
  845. end;
  846. {$endif}
  847. {$ifdef LINUX}
  848. {sysfreemem already checks for nil}
  849. { Do not try to do anything if the heap manager already reported an error }
  850. if (errorcode<>203) and (errorcode<>204) then
  851. sysfreemem(calculated_cmdline);
  852. {$endif}
  853. {$ifdef BSD}
  854. { Do not try to do anything if the heap manager already reported an error }
  855. if (errorcode<>203) and (errorcode<>204) then
  856. sysfreemem(cmdline);
  857. {$endif}
  858. {$ifdef FPC_HAS_FEATURE_HEAP}
  859. {$ifndef HAS_MEMORYMANAGER}
  860. {$ifndef FPC_NO_DEFAULT_HEAP}
  861. FinalizeHeap;
  862. {$endif not FPC_NO_DEFAULT_HEAP}
  863. {$endif not HAS_MEMORYMANAGER}
  864. {$endif FPC_HAS_FEATURE_HEAP}
  865. End;
  866. Procedure do_exit;[Public,Alias:'FPC_DO_EXIT'];
  867. begin
  868. InternalExit;
  869. System_exit;
  870. end;
  871. Procedure lib_exit;[Public,Alias:'FPC_LIB_EXIT'];
  872. begin
  873. InternalExit;
  874. end;
  875. Procedure Halt(ErrNum: Longint);
  876. Begin
  877. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  878. {$ifdef FPC_LIMITED_EXITCODE}
  879. if ErrNum > maxExitCode then
  880. ExitCode:=255
  881. else
  882. {$endif FPC_LIMITED_EXITCODE}
  883. ExitCode:=ErrNum;
  884. {$endif FPC_HAS_FEATURE_EXITCODE}
  885. Do_Exit;
  886. end;
  887. function SysBackTraceStr (Addr: CodePointer): ShortString;
  888. begin
  889. SysBackTraceStr:=' $'+hexstr(addr);
  890. end;
  891. function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
  892. var
  893. curr_frame,prev_frame: pointer;
  894. curr_addr: codepointer;
  895. i: sizeint;
  896. begin
  897. curr_frame:=get_frame;
  898. curr_addr:=get_pc_addr;
  899. prev_frame:=curr_frame;
  900. get_caller_stackinfo(curr_frame,curr_addr);
  901. i:=-skipframes;
  902. while (i<count) and (curr_frame>prev_frame) and
  903. (curr_frame<StackTop) do
  904. begin
  905. if (curr_addr=nil) or
  906. (curr_frame=nil) then
  907. break;
  908. if (i>=0) then
  909. frames[i]:=curr_addr;
  910. inc(i);
  911. prev_frame:=curr_frame;
  912. get_caller_stackinfo(curr_frame,curr_addr);
  913. end;
  914. if i<0 then
  915. result:=0
  916. else
  917. result:=i;
  918. end;
  919. Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
  920. begin
  921. If pointer(ErrorProc)<>Nil then
  922. ErrorProc(Errno,addr,frame);
  923. errorcode:=word(Errno);
  924. erroraddr:=addr;
  925. errorbase:=frame;
  926. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  927. if ExceptAddrStack <> nil then
  928. raise TObject(nil) at addr,frame;
  929. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  930. Halt(errorcode);
  931. end;
  932. { This is used internally by system skip first level,
  933. and generated the same output as before, when
  934. HandleErrorFrame function was used internally. }
  935. Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
  936. begin
  937. get_caller_stackinfo (frame, addr);
  938. HandleErrorAddrFrame (Errno,addr,frame);
  939. end;
  940. Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
  941. {
  942. Procedure to handle internal errors, i.e. not user-invoked errors
  943. Internal function should ALWAYS call HandleError instead of RunError.
  944. Can be used for exception handlers to specify the frame
  945. }
  946. begin
  947. HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame));
  948. end;
  949. procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
  950. {
  951. Procedure to handle internal errors, i.e. not user-invoked errors
  952. Internal function should ALWAYS call HandleError instead of RunError.
  953. }
  954. begin
  955. HandleErrorAddrFrameInd(Errno,get_pc_addr,get_frame);
  956. end;
  957. procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
  958. var
  959. bp : pointer;
  960. pcaddr : codepointer;
  961. begin
  962. errorcode:=w;
  963. pcaddr:=get_pc_addr;
  964. bp:=get_frame;
  965. get_caller_stackinfo(bp,pcaddr);
  966. erroraddr:=pcaddr;
  967. errorbase:=bp;
  968. Halt(errorcode);
  969. end;
  970. Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif}
  971. Begin
  972. RunError (0);
  973. End;
  974. Procedure Halt;{$ifdef SYSTEMINLINE}inline;{$endif}
  975. Begin
  976. Halt(0);
  977. End;
  978. Procedure Error(RunTimeError : TRunTimeError);
  979. begin
  980. RunError(RuntimeErrorExitCodes[RunTimeError]);
  981. end;
  982. Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
  983. var
  984. i : Longint;
  985. prevfp : Pointer;
  986. is_dev : boolean;
  987. Begin
  988. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  989. try
  990. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  991. { Frame of this procedure acts as StackBottom, fp values below that are invalid. }
  992. prevfp:=get_frame;
  993. i:=0;
  994. is_dev:=do_isdevice(textrec(f).Handle);
  995. { sanity checks, new frame pointer must be always greater than the old one, further
  996. it must point into the stack area, else something went wrong }
  997. while (fp>prevfp) and (fp<StackTop) do
  998. Begin
  999. prevfp:=fp;
  1000. get_caller_stackinfo(fp,addr);
  1001. if (addr=nil) then
  1002. break;
  1003. Writeln(f,BackTraceStrFunc(addr));
  1004. if (fp=nil) then
  1005. break;
  1006. Inc(i);
  1007. If ((i>max_frame_dump) and is_dev) or (i>256) Then
  1008. break;
  1009. End;
  1010. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  1011. except
  1012. { prevent endless dump if an exception occured }
  1013. end;
  1014. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  1015. End;
  1016. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  1017. procedure DumpExceptionBackTrace(var f:text);
  1018. var
  1019. FrameNumber,
  1020. FrameCount : longint;
  1021. Frames : PCodePointer;
  1022. begin
  1023. if RaiseList=nil then
  1024. exit;
  1025. WriteLn(f,BackTraceStrFunc(RaiseList^.Addr));
  1026. FrameCount:=RaiseList^.Framecount;
  1027. Frames:=RaiseList^.Frames;
  1028. for FrameNumber := 0 to FrameCount-1 do
  1029. WriteLn(f,BackTraceStrFunc(Frames[FrameNumber]));
  1030. end;
  1031. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  1032. {$ifdef FPC_HAS_FEATURE_HEAP}
  1033. Type
  1034. PExitProcInfo = ^TExitProcInfo;
  1035. TExitProcInfo = Record
  1036. Next : PExitProcInfo;
  1037. SaveExit : CodePointer;
  1038. Proc : TProcedure;
  1039. End;
  1040. const
  1041. ExitProcList: PExitProcInfo = nil;
  1042. Procedure DoExitProc;
  1043. var
  1044. P : PExitProcInfo;
  1045. Proc : TProcedure;
  1046. Begin
  1047. P:=ExitProcList;
  1048. ExitProcList:=P^.Next;
  1049. ExitProc:=P^.SaveExit;
  1050. Proc:=P^.Proc;
  1051. DisPose(P);
  1052. Proc();
  1053. End;
  1054. Procedure AddExitProc(Proc: TProcedure);
  1055. var
  1056. P : PExitProcInfo;
  1057. Begin
  1058. New(P);
  1059. P^.Next:=ExitProcList;
  1060. P^.SaveExit:=ExitProc;
  1061. P^.Proc:=Proc;
  1062. ExitProcList:=P;
  1063. ExitProc:=@DoExitProc;
  1064. End;
  1065. {$endif FPC_HAS_FEATURE_HEAP}
  1066. {$ifdef FPC_HAS_FEATURE_HEAP}
  1067. function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ?
  1068. // Extra allocate reserveentries pchar's at the beginning (default param=0 after 1.0.x ?)
  1069. // Note: for internal use by skilled programmers only
  1070. // if "s" goes out of scope in the parent procedure, the pointer is dangling.
  1071. var p : ppchar;
  1072. i : LongInt;
  1073. begin
  1074. if High(s)<Low(s) Then Exit(NIL);
  1075. Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
  1076. // for cmd
  1077. if p=nil then
  1078. begin
  1079. {$ifdef xunix}
  1080. fpseterrno(ESysEnomem);
  1081. {$endif}
  1082. exit(NIL);
  1083. end;
  1084. for i:=low(s) to high(s) do
  1085. p[i+Reserveentries]:=pchar(s[i]);
  1086. p[high(s)+1+Reserveentries]:=nil;
  1087. ArrayStringToPPchar:=p;
  1088. end;
  1089. Function StringToPPChar(Var S:AnsiString;ReserveEntries:integer):ppchar;
  1090. {
  1091. Create a PPChar to structure of pchars which are the arguments specified
  1092. in the string S. Especially useful for creating an ArgV for Exec-calls
  1093. }
  1094. begin
  1095. StringToPPChar:=StringToPPChar(PChar(S),ReserveEntries);
  1096. end;
  1097. Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
  1098. var
  1099. i,nr : longint;
  1100. Buf : ^char;
  1101. p : ppchar;
  1102. begin
  1103. buf:=s;
  1104. nr:=1;
  1105. while (buf^<>#0) do // count nr of args
  1106. begin
  1107. while (buf^ in [' ',#9,#10]) do // Kill separators.
  1108. inc(buf);
  1109. inc(nr);
  1110. if buf^='"' Then // quotes argument?
  1111. begin
  1112. inc(buf);
  1113. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  1114. inc(buf);
  1115. if buf^='"' then // skip closing quote.
  1116. inc(buf);
  1117. end
  1118. else
  1119. begin // else std
  1120. while not (buf^ in [' ',#0,#9,#10]) do
  1121. inc(buf);
  1122. end;
  1123. end;
  1124. getmem(p,(ReserveEntries+nr)*sizeof(pchar));
  1125. StringToPPChar:=p;
  1126. if p=nil then
  1127. begin
  1128. {$ifdef xunix}
  1129. fpseterrno(ESysEnomem);
  1130. {$endif}
  1131. exit;
  1132. end;
  1133. for i:=1 to ReserveEntries do inc(p); // skip empty slots
  1134. buf:=s;
  1135. while (buf^<>#0) do
  1136. begin
  1137. while (buf^ in [' ',#9,#10]) do // Kill separators.
  1138. begin
  1139. buf^:=#0;
  1140. inc(buf);
  1141. end;
  1142. if buf^='"' Then // quotes argument?
  1143. begin
  1144. inc(buf);
  1145. p^:=buf;
  1146. inc(p);
  1147. p^:=nil;
  1148. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  1149. inc(buf);
  1150. if buf^='"' then // skip closing quote.
  1151. begin
  1152. buf^:=#0;
  1153. inc(buf);
  1154. end;
  1155. end
  1156. else
  1157. begin
  1158. p^:=buf;
  1159. inc(p);
  1160. p^:=nil;
  1161. while not (buf^ in [' ',#0,#9,#10]) do
  1162. inc(buf);
  1163. end;
  1164. end;
  1165. end;
  1166. {$endif FPC_HAS_FEATURE_HEAP}
  1167. {*****************************************************************************
  1168. Abstract/Assert support.
  1169. *****************************************************************************}
  1170. procedure fpc_emptymethod;[public,alias : 'FPC_EMPTYMETHOD'];
  1171. begin
  1172. end;
  1173. procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR'];
  1174. begin
  1175. If pointer(AbstractErrorProc)<>nil then
  1176. AbstractErrorProc();
  1177. HandleErrorAddrFrameInd(211,get_pc_addr,get_frame);
  1178. end;
  1179. Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;
  1180. ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc;
  1181. begin
  1182. if pointer(AssertErrorProc)<>nil then
  1183. AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
  1184. else
  1185. HandleErrorAddrFrameInd(227,get_pc_addr,get_frame);
  1186. end;
  1187. Procedure SysAssert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer);
  1188. begin
  1189. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  1190. If msg='' then
  1191. write(stderr,'Assertion failed')
  1192. else
  1193. write(stderr,msg);
  1194. Writeln(stderr,' (',FName,', line ',LineNo,').');
  1195. Writeln(stderr,'');
  1196. Halt(227);
  1197. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  1198. end;
  1199. {*****************************************************************************
  1200. SetJmp/LongJmp support.
  1201. *****************************************************************************}
  1202. {$i setjump.inc}
  1203. {$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
  1204. {*****************************************************************************
  1205. Heap
  1206. *****************************************************************************}
  1207. {$i sysheap.inc}
  1208. {$i heap.inc}
  1209. {*****************************************************************************
  1210. Thread support
  1211. *****************************************************************************}
  1212. {$ifdef FPC_HAS_FEATURE_THREADING}
  1213. { Generic threadmanager }
  1214. {$i thread.inc}
  1215. {$ifndef FPC_SECTION_THREADVARS}
  1216. { Generic threadvar support }
  1217. {$i threadvr.inc}
  1218. {$endif FPC_SECTION_THREADVARS}
  1219. {$ifdef DISABLE_NO_THREAD_MANAGER}
  1220. { OS Dependent implementation }
  1221. {$i systhrd.inc}
  1222. {$endif DISABLE_NO_THREAD_MANAGER}
  1223. {$endif FPC_HAS_FEATURE_THREADING}
  1224. {*****************************************************************************
  1225. File Handling
  1226. *****************************************************************************}
  1227. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1228. { Allow slash and backslash as separators }
  1229. procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
  1230. var
  1231. i : longint;
  1232. len : sizeint;
  1233. newp : pchar;
  1234. begin
  1235. len:=length(p);
  1236. newp:=nil;
  1237. for i:=0 to len do
  1238. if p[i] in AllowDirectorySeparators then
  1239. begin
  1240. if not inplace and
  1241. not assigned(newp) then
  1242. begin
  1243. getmem(newp,len+1);
  1244. move(p^,newp^,len+1);
  1245. p:=newp;
  1246. end;
  1247. p[i]:=DirectorySeparator;
  1248. end;
  1249. end;
  1250. procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
  1251. var
  1252. i : longint;
  1253. len : sizeint;
  1254. newp : pwidechar;
  1255. begin
  1256. len:=length(p);
  1257. newp:=nil;
  1258. for i:=0 to len do
  1259. if (ord(p[i])<255) and
  1260. (ansichar(ord(p[i])) in AllowDirectorySeparators) then
  1261. begin
  1262. if not inplace and
  1263. not assigned(newp) then
  1264. begin
  1265. getmem(newp,(len+1)*2);
  1266. move(p^,newp^,(len+1)*2);
  1267. p:=newp;
  1268. end;
  1269. p[i]:=DirectorySeparator;
  1270. end;
  1271. end;
  1272. procedure DoDirSeparators(var p:shortstring);
  1273. var
  1274. i : longint;
  1275. begin
  1276. for i:=1 to length(p) do
  1277. if p[i] in AllowDirectorySeparators then
  1278. p[i]:=DirectorySeparator;
  1279. end;
  1280. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  1281. procedure DoDirSeparators(var ps:RawByteString);
  1282. var
  1283. i : longint;
  1284. p : pchar;
  1285. unique : boolean;
  1286. begin
  1287. unique:=false;
  1288. for i:=1 to length(ps) do
  1289. if ps[i] in AllowDirectorySeparators then
  1290. begin
  1291. if not unique then
  1292. begin
  1293. uniquestring(ps);
  1294. p:=pchar(ps);
  1295. unique:=true;
  1296. end;
  1297. p[i-1]:=DirectorySeparator;
  1298. end;
  1299. end;
  1300. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  1301. {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
  1302. procedure DoDirSeparators(var ps:UnicodeString);
  1303. var
  1304. i : longint;
  1305. p : pwidechar;
  1306. unique : boolean;
  1307. begin
  1308. unique:=false;
  1309. for i:=1 to length(ps) do
  1310. if ps[i] in AllowDirectorySeparators then
  1311. begin
  1312. if not unique then
  1313. begin
  1314. uniquestring(ps);
  1315. p:=pwidechar(ps);
  1316. unique:=true;
  1317. end;
  1318. p[i-1]:=DirectorySeparator;
  1319. end;
  1320. end;
  1321. {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
  1322. {$endif FPC_HAS_FEATURE_FILEIO}
  1323. { OS dependent low level file functions }
  1324. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1325. {$i sysfile.inc}
  1326. {$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1327. {$ifdef FPC_ANSI_TEXTFILEREC}
  1328. procedure do_open(var f; p: pansichar; flags: longint; pchangeable: boolean);
  1329. var
  1330. u: UnicodeString;
  1331. begin
  1332. widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
  1333. do_open(f,pwidechar(u),flags,true);
  1334. end;
  1335. procedure do_erase(p: pansichar; pchangeable: boolean);
  1336. var
  1337. u: UnicodeString;
  1338. begin
  1339. widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
  1340. do_erase(pwidechar(u),true);
  1341. end;
  1342. procedure do_rename(src, dst: pansichar; srcchangeable, dstchangeable: boolean);
  1343. var
  1344. usrc, udst: UnicodeString;
  1345. begin
  1346. widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
  1347. widestringmanager.Ansi2UnicodeMoveProc(dst,DefaultFileSystemCodePage,udst,length(dst));
  1348. do_rename(pwidechar(usrc),pwidechar(udst),true,true);
  1349. end;
  1350. procedure do_rename(src: pansichar; dst: pwidechar; srcchangeable, dstchangeable: boolean);
  1351. var
  1352. usrc: UnicodeString;
  1353. begin
  1354. widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
  1355. do_rename(pwidechar(usrc),dst,true,dstchangeable);
  1356. end;
  1357. {$endif FPC_ANSI_TEXTFILEREC}
  1358. {$endif not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1359. {$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1360. {$ifndef FPC_ANSI_TEXTFILEREC}
  1361. procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
  1362. var
  1363. s: RawByteString;
  1364. begin
  1365. widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
  1366. do_open(f,pansichar(s),flags,true);
  1367. end;
  1368. procedure do_erase(p: pwidechar; pchangeable: boolean);
  1369. var
  1370. s: RawByteString;
  1371. begin
  1372. widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
  1373. do_erase(pansichar(s),true);
  1374. end;
  1375. procedure do_rename(src, dst: pwidechar; srcchangeable, dstchangeable: boolean);
  1376. var
  1377. rsrc, rdst: RawByteString;
  1378. begin
  1379. widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
  1380. widestringmanager.Unicode2AnsiMoveProc(dst,rdst,DefaultFileSystemCodePage,length(dst));
  1381. do_rename(pansichar(rsrc),pansichar(rdst),true,true);
  1382. end;
  1383. procedure do_rename(src: pwidechar; dst: pansichar; srcchangeable, dstchangeable: boolean);
  1384. var
  1385. rsrc: RawByteString;
  1386. begin
  1387. widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
  1388. do_rename(pansichar(rsrc),dst,true,dstchangeable);
  1389. end;
  1390. {$endif not FPC_ANSI_TEXTFILEREC}
  1391. {$endif not FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1392. {$endif FPC_HAS_FEATURE_FILEIO}
  1393. { helper for targets supporting no ansistrings, it is used
  1394. by non-ansistring code }
  1395. function min(v1,v2 : SizeInt) : SizeInt;
  1396. begin
  1397. if v1<v2 then
  1398. result:=v1
  1399. else
  1400. result:=v2;
  1401. end;
  1402. {$ifdef FPC_HAS_FEATURE_TEXTIO}
  1403. { Text file }
  1404. {$i text.inc}
  1405. {$endif FPC_HAS_FEATURE_TEXTIO}
  1406. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1407. { Untyped file }
  1408. {$i file.inc}
  1409. { Typed file }
  1410. {$i typefile.inc}
  1411. {$endif FPC_HAS_FEATURE_FILEIO}
  1412. {*****************************************************************************
  1413. Directory Handling
  1414. *****************************************************************************}
  1415. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1416. { OS dependent dir functions }
  1417. {$i sysdir.inc}
  1418. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  1419. {$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1420. procedure do_getdir(drivenr : byte;var dir : rawbytestring);
  1421. var
  1422. u: unicodestring;
  1423. begin
  1424. Do_getdir(drivenr,u);
  1425. widestringmanager.Unicode2AnsiMoveProc(pwidechar(u),dir,DefaultRTLFileSystemCodePage,length(u));
  1426. end;
  1427. {$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1428. Procedure MkDir(Const s: RawByteString);[IOCheck];
  1429. Begin
  1430. If (s='') or (InOutRes <> 0) then
  1431. exit;
  1432. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1433. Do_mkdir(ToSingleByteFileSystemEncodedFileName(S));
  1434. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1435. Do_mkdir(S);
  1436. {$endif}
  1437. end;
  1438. Procedure RmDir(Const s: RawByteString);[IOCheck];
  1439. Begin
  1440. If (s='') or (InOutRes <> 0) then
  1441. exit;
  1442. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1443. Do_rmdir(ToSingleByteFileSystemEncodedFileName(S));
  1444. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1445. Do_rmdir(S);
  1446. {$endif}
  1447. End;
  1448. Procedure ChDir(Const s: RawByteString);[IOCheck];
  1449. Begin
  1450. If (s='') or (InOutRes <> 0) then
  1451. exit;
  1452. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1453. Do_chdir(ToSingleByteFileSystemEncodedFileName(S));
  1454. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1455. Do_chdir(S);
  1456. {$endif}
  1457. End;
  1458. Procedure getdir(drivenr:byte;Var dir:rawbytestring);
  1459. begin
  1460. Do_getdir(drivenr,dir);
  1461. { we should return results in the DefaultRTLFileSystemCodePage -> convert if
  1462. necessary }
  1463. setcodepage(dir,DefaultRTLFileSystemCodePage,true);
  1464. end;
  1465. { the generic shortstring ones are only implemented elsewhere for systems *not*
  1466. supporting ansi/unicodestrings; for now assume there are no systems that
  1467. support unicodestrings but not ansistrings }
  1468. { avoid double string conversions }
  1469. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1470. function GetDirStrFromShortstring(const s: shortstring): RawByteString;
  1471. begin
  1472. GetDirStrFromShortstring:=ToSingleByteFileSystemEncodedFileName(ansistring(s));
  1473. end;
  1474. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1475. function GetDirStrFromShortstring(const s: shortstring): UnicodeString;
  1476. begin
  1477. GetDirStrFromShortstring:=s;
  1478. end;
  1479. {$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1480. Procedure MkDir(Const s: shortstring);[IOCheck];
  1481. Begin
  1482. If (s='') or (InOutRes <> 0) then
  1483. exit;
  1484. Do_mkdir(GetDirStrFromShortstring(S));
  1485. End;
  1486. Procedure RmDir(Const s: shortstring);[IOCheck];
  1487. Begin
  1488. If (s='') or (InOutRes <> 0) then
  1489. exit;
  1490. Do_rmdir(GetDirStrFromShortstring(S));
  1491. End;
  1492. Procedure ChDir(Const s: shortstring);[IOCheck];
  1493. Begin
  1494. If (s='') or (InOutRes <> 0) then
  1495. exit;
  1496. Do_chdir(GetDirStrFromShortstring(S));
  1497. End;
  1498. Procedure getdir(drivenr:byte;Var dir:shortstring);
  1499. var
  1500. s: rawbytestring;
  1501. begin
  1502. Do_getdir(drivenr,s);
  1503. if length(s)<=high(dir) then
  1504. dir:=s
  1505. else
  1506. inoutres:=3;
  1507. end;
  1508. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  1509. {$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
  1510. {$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1511. { overloads required for mkdir/rmdir/chdir to ensure that the string is
  1512. converted to the right code page }
  1513. procedure do_mkdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1514. begin
  1515. do_mkdir(ToSingleByteFileSystemEncodedFileName(s));
  1516. end;
  1517. procedure do_rmdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1518. begin
  1519. do_rmdir(ToSingleByteFileSystemEncodedFileName(s));
  1520. end;
  1521. procedure do_chdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1522. begin
  1523. do_chdir(ToSingleByteFileSystemEncodedFileName(s));
  1524. end;
  1525. procedure do_getdir(drivenr : byte;var dir : unicodestring);
  1526. var
  1527. s: rawbytestring;
  1528. begin
  1529. Do_getdir(drivenr,s);
  1530. dir:=s;
  1531. end;
  1532. {$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1533. Procedure MkDir(Const s: UnicodeString);[IOCheck];
  1534. Begin
  1535. if (s='') or (InOutRes <> 0) then
  1536. exit;
  1537. Do_mkdir(S);
  1538. End;
  1539. Procedure RmDir(Const s: UnicodeString);[IOCheck];
  1540. Begin
  1541. if (s='') or (InOutRes <> 0) then
  1542. exit;
  1543. Do_rmdir(S);
  1544. End;
  1545. Procedure ChDir(Const s: UnicodeString);[IOCheck];
  1546. Begin
  1547. if (s='') or (InOutRes <> 0) then
  1548. exit;
  1549. Do_chdir(S);
  1550. End;
  1551. Procedure getdir(drivenr:byte;Var dir:unicodestring);
  1552. begin
  1553. Do_getdir(drivenr,dir);
  1554. end;
  1555. {$endif FPC_HAS_FEATURE_WIDESTRINGS}
  1556. {$endif FPC_HAS_FEATURE_FILEIO}
  1557. {*****************************************************************************
  1558. Resources support
  1559. *****************************************************************************}
  1560. {$i sysres.inc}
  1561. const
  1562. CtrlBreakHandler: TCtrlBreakHandler = nil;
  1563. {$IFNDEF FPC_HAS_SETCTRLBREAKHANDLER}
  1564. (* It is possible to provide platform specific implementation performing *)
  1565. (* special initialization; default implementation just sets the procedural *)
  1566. (* variable to make it available for use from the exception handler. *)
  1567. function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
  1568. begin
  1569. (* Return either nil or previous handler *)
  1570. SysSetCtrlBreakHandler := CtrlBreakHandler;
  1571. CtrlBreakHandler := Handler;
  1572. end;
  1573. {$ENDIF FPC_HAS_SETCTRLBREAKHANDLER}