system.inc 50 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896
  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. pstdout:=@stdout;
  816. If erroraddr<>nil Then
  817. Begin
  818. Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
  819. { to get a nice symify }
  820. Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
  821. dump_stack(pstdout^,ErrorBase,ErrorAddr);
  822. Writeln(pstdout^,'');
  823. End;
  824. SysFlushStdIO;
  825. {$endif EMBEDDED}
  826. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  827. {$if defined(MSWINDOWS) or defined(OS2)}
  828. { finally release the heap if possible, especially
  829. important for DLLs.
  830. Reset the array to nil, and finally also argv itself to
  831. avoid double freeing problem in case this function gets called twice. }
  832. if assigned(argv) then
  833. begin
  834. for i:=0 to argc-1 do
  835. if assigned(argv[i]) then
  836. begin
  837. sysfreemem(argv[i]);
  838. argv[i]:=nil;
  839. end;
  840. sysfreemem(argv);
  841. argv:=nil;
  842. end;
  843. {$endif}
  844. {$ifdef LINUX}
  845. {sysfreemem already checks for nil}
  846. { Do not try to do anything if the heap manager already reported an error }
  847. if (errorcode<>203) and (errorcode<>204) then
  848. sysfreemem(calculated_cmdline);
  849. {$endif}
  850. {$ifdef BSD}
  851. { Do not try to do anything if the heap manager already reported an error }
  852. if (errorcode<>203) and (errorcode<>204) then
  853. sysfreemem(cmdline);
  854. {$endif}
  855. {$ifdef FPC_HAS_FEATURE_HEAP}
  856. {$ifndef HAS_MEMORYMANAGER}
  857. {$ifndef FPC_NO_DEFAULT_HEAP}
  858. FinalizeHeap;
  859. {$endif not FPC_NO_DEFAULT_HEAP}
  860. {$endif not HAS_MEMORYMANAGER}
  861. {$endif FPC_HAS_FEATURE_HEAP}
  862. End;
  863. Procedure do_exit;[Public,Alias:'FPC_DO_EXIT'];
  864. begin
  865. InternalExit;
  866. System_exit;
  867. end;
  868. Procedure lib_exit;[Public,Alias:'FPC_LIB_EXIT'];
  869. begin
  870. InternalExit;
  871. end;
  872. Procedure Halt(ErrNum: Longint);
  873. Begin
  874. {$ifdef FPC_HAS_FEATURE_EXITCODE}
  875. {$ifdef FPC_LIMITED_EXITCODE}
  876. if ErrNum > maxExitCode then
  877. ExitCode:=255
  878. else
  879. {$endif FPC_LIMITED_EXITCODE}
  880. ExitCode:=ErrNum;
  881. {$endif FPC_HAS_FEATURE_EXITCODE}
  882. Do_Exit;
  883. end;
  884. function SysBackTraceStr (Addr: CodePointer): ShortString;
  885. begin
  886. SysBackTraceStr:=' $'+hexstr(addr);
  887. end;
  888. {$ifndef FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
  889. function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
  890. var
  891. curr_frame,prev_frame: pointer;
  892. curr_addr: codepointer;
  893. i: sizeint;
  894. begin
  895. curr_frame:=get_frame;
  896. curr_addr:=get_pc_addr;
  897. prev_frame:=curr_frame;
  898. get_caller_stackinfo(curr_frame,curr_addr);
  899. i:=-skipframes;
  900. while (i<count) and (curr_frame>prev_frame) and
  901. (curr_frame<StackTop) do
  902. begin
  903. if (curr_addr=nil) or
  904. (curr_frame=nil) then
  905. break;
  906. if (i>=0) then
  907. frames[i]:=curr_addr;
  908. inc(i);
  909. prev_frame:=curr_frame;
  910. get_caller_stackinfo(curr_frame,curr_addr);
  911. end;
  912. if i<0 then
  913. result:=0
  914. else
  915. result:=i;
  916. end;
  917. {$endif FPC_SYSTEM_HAS_CAPTUREBACKTRACE}
  918. Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
  919. begin
  920. If pointer(ErrorProc)<>Nil then
  921. ErrorProc(Errno,addr,frame);
  922. errorcode:=word(Errno);
  923. erroraddr:=addr;
  924. errorbase:=frame;
  925. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  926. if ExceptAddrStack <> nil then
  927. raise TObject(nil) at addr,frame;
  928. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  929. Halt(errorcode);
  930. end;
  931. { This is used internally by system skip first level,
  932. and generated the same output as before, when
  933. HandleErrorFrame function was used internally. }
  934. Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
  935. begin
  936. get_caller_stackinfo (frame, addr);
  937. HandleErrorAddrFrame (Errno,addr,frame);
  938. end;
  939. Procedure HandleErrorFrame (Errno : longint;frame : Pointer);
  940. {
  941. Procedure to handle internal errors, i.e. not user-invoked errors
  942. Internal function should ALWAYS call HandleError instead of RunError.
  943. Can be used for exception handlers to specify the frame
  944. }
  945. begin
  946. HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame));
  947. end;
  948. procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
  949. {
  950. Procedure to handle internal errors, i.e. not user-invoked errors
  951. Internal function should ALWAYS call HandleError instead of RunError.
  952. }
  953. begin
  954. HandleErrorAddrFrameInd(Errno,get_pc_addr,get_frame);
  955. end;
  956. procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
  957. var
  958. bp : pointer;
  959. pcaddr : codepointer;
  960. begin
  961. errorcode:=w;
  962. pcaddr:=get_pc_addr;
  963. bp:=get_frame;
  964. get_caller_stackinfo(bp,pcaddr);
  965. erroraddr:=pcaddr;
  966. errorbase:=bp;
  967. Halt(errorcode);
  968. end;
  969. Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif}
  970. Begin
  971. RunError (0);
  972. End;
  973. Procedure Halt;{$ifdef SYSTEMINLINE}inline;{$endif}
  974. Begin
  975. Halt(0);
  976. End;
  977. Procedure Error(RunTimeError : TRunTimeError);
  978. begin
  979. RunError(RuntimeErrorExitCodes[RunTimeError]);
  980. end;
  981. Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
  982. var
  983. i : Longint;
  984. prevfp : Pointer;
  985. is_dev : boolean;
  986. Begin
  987. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  988. try
  989. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  990. { Frame of this procedure acts as StackBottom, fp values below that are invalid. }
  991. prevfp:=get_frame;
  992. i:=0;
  993. is_dev:=do_isdevice(textrec(f).Handle);
  994. { sanity checks, new frame pointer must be always greater than the old one, further
  995. it must point into the stack area, else something went wrong }
  996. while (fp>prevfp) and (fp<StackTop) do
  997. Begin
  998. prevfp:=fp;
  999. get_caller_stackinfo(fp,addr);
  1000. if (addr=nil) then
  1001. break;
  1002. Writeln(f,BackTraceStrFunc(addr));
  1003. if (fp=nil) then
  1004. break;
  1005. Inc(i);
  1006. If ((i>max_frame_dump) and is_dev) or (i>256) Then
  1007. break;
  1008. End;
  1009. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  1010. except
  1011. { prevent endless dump if an exception occured }
  1012. end;
  1013. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  1014. End;
  1015. {$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
  1016. procedure DumpExceptionBackTrace(var f:text);
  1017. var
  1018. FrameNumber,
  1019. FrameCount : longint;
  1020. Frames : PCodePointer;
  1021. begin
  1022. if RaiseList=nil then
  1023. exit;
  1024. WriteLn(f,BackTraceStrFunc(RaiseList^.Addr));
  1025. FrameCount:=RaiseList^.Framecount;
  1026. Frames:=RaiseList^.Frames;
  1027. for FrameNumber := 0 to FrameCount-1 do
  1028. WriteLn(f,BackTraceStrFunc(Frames[FrameNumber]));
  1029. end;
  1030. {$endif FPC_HAS_FEATURE_EXCEPTIONS}
  1031. {$ifdef FPC_HAS_FEATURE_HEAP}
  1032. Type
  1033. PExitProcInfo = ^TExitProcInfo;
  1034. TExitProcInfo = Record
  1035. Next : PExitProcInfo;
  1036. SaveExit : CodePointer;
  1037. Proc : TProcedure;
  1038. End;
  1039. const
  1040. ExitProcList: PExitProcInfo = nil;
  1041. Procedure DoExitProc;
  1042. var
  1043. P : PExitProcInfo;
  1044. Proc : TProcedure;
  1045. Begin
  1046. P:=ExitProcList;
  1047. ExitProcList:=P^.Next;
  1048. ExitProc:=P^.SaveExit;
  1049. Proc:=P^.Proc;
  1050. DisPose(P);
  1051. Proc();
  1052. End;
  1053. Procedure AddExitProc(Proc: TProcedure);
  1054. var
  1055. P : PExitProcInfo;
  1056. Begin
  1057. New(P);
  1058. P^.Next:=ExitProcList;
  1059. P^.SaveExit:=ExitProc;
  1060. P^.Proc:=Proc;
  1061. ExitProcList:=P;
  1062. ExitProc:=@DoExitProc;
  1063. End;
  1064. {$endif FPC_HAS_FEATURE_HEAP}
  1065. {$ifdef FPC_HAS_FEATURE_HEAP}
  1066. function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ?
  1067. // Extra allocate reserveentries pchar's at the beginning (default param=0 after 1.0.x ?)
  1068. // Note: for internal use by skilled programmers only
  1069. // if "s" goes out of scope in the parent procedure, the pointer is dangling.
  1070. var p : ppchar;
  1071. i : LongInt;
  1072. begin
  1073. if High(s)<Low(s) Then Exit(NIL);
  1074. Getmem(p,sizeof(pchar)*(high(s)-low(s)+ReserveEntries+2)); // one more for NIL, one more
  1075. // for cmd
  1076. if p=nil then
  1077. begin
  1078. {$ifdef xunix}
  1079. fpseterrno(ESysEnomem);
  1080. {$endif}
  1081. exit(NIL);
  1082. end;
  1083. for i:=low(s) to high(s) do
  1084. p[i+Reserveentries]:=pchar(s[i]);
  1085. p[high(s)+1+Reserveentries]:=nil;
  1086. ArrayStringToPPchar:=p;
  1087. end;
  1088. Function StringToPPChar(Var S:AnsiString;ReserveEntries:integer):ppchar;
  1089. {
  1090. Create a PPChar to structure of pchars which are the arguments specified
  1091. in the string S. Especially useful for creating an ArgV for Exec-calls
  1092. }
  1093. begin
  1094. StringToPPChar:=StringToPPChar(PChar(S),ReserveEntries);
  1095. end;
  1096. Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
  1097. var
  1098. i,nr : longint;
  1099. Buf : ^char;
  1100. p : ppchar;
  1101. begin
  1102. buf:=s;
  1103. nr:=1;
  1104. while (buf^<>#0) do // count nr of args
  1105. begin
  1106. while (buf^ in [' ',#9,#10]) do // Kill separators.
  1107. inc(buf);
  1108. inc(nr);
  1109. if buf^='"' Then // quotes argument?
  1110. begin
  1111. inc(buf);
  1112. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  1113. inc(buf);
  1114. if buf^='"' then // skip closing quote.
  1115. inc(buf);
  1116. end
  1117. else
  1118. begin // else std
  1119. while not (buf^ in [' ',#0,#9,#10]) do
  1120. inc(buf);
  1121. end;
  1122. end;
  1123. getmem(p,(ReserveEntries+nr)*sizeof(pchar));
  1124. StringToPPChar:=p;
  1125. if p=nil then
  1126. begin
  1127. {$ifdef xunix}
  1128. fpseterrno(ESysEnomem);
  1129. {$endif}
  1130. exit;
  1131. end;
  1132. for i:=1 to ReserveEntries do inc(p); // skip empty slots
  1133. buf:=s;
  1134. while (buf^<>#0) do
  1135. begin
  1136. while (buf^ in [' ',#9,#10]) do // Kill separators.
  1137. begin
  1138. buf^:=#0;
  1139. inc(buf);
  1140. end;
  1141. if buf^='"' Then // quotes argument?
  1142. begin
  1143. inc(buf);
  1144. p^:=buf;
  1145. inc(p);
  1146. p^:=nil;
  1147. while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote
  1148. inc(buf);
  1149. if buf^='"' then // skip closing quote.
  1150. begin
  1151. buf^:=#0;
  1152. inc(buf);
  1153. end;
  1154. end
  1155. else
  1156. begin
  1157. p^:=buf;
  1158. inc(p);
  1159. p^:=nil;
  1160. while not (buf^ in [' ',#0,#9,#10]) do
  1161. inc(buf);
  1162. end;
  1163. end;
  1164. end;
  1165. {$endif FPC_HAS_FEATURE_HEAP}
  1166. {*****************************************************************************
  1167. Abstract/Assert support.
  1168. *****************************************************************************}
  1169. procedure fpc_emptymethod;[public,alias : 'FPC_EMPTYMETHOD'];
  1170. begin
  1171. end;
  1172. procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR'];
  1173. begin
  1174. If pointer(AbstractErrorProc)<>nil then
  1175. AbstractErrorProc();
  1176. HandleErrorAddrFrameInd(211,get_pc_addr,get_frame);
  1177. end;
  1178. Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;
  1179. ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc;
  1180. begin
  1181. if pointer(AssertErrorProc)<>nil then
  1182. AssertErrorProc(Msg,FName,LineNo,ErrorAddr)
  1183. else
  1184. HandleErrorAddrFrameInd(227,get_pc_addr,get_frame);
  1185. end;
  1186. Procedure SysAssert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer);
  1187. begin
  1188. {$ifdef FPC_HAS_FEATURE_CONSOLEIO}
  1189. If msg='' then
  1190. write(stderr,'Assertion failed')
  1191. else
  1192. write(stderr,msg);
  1193. Writeln(stderr,' (',FName,', line ',LineNo,').');
  1194. Writeln(stderr,'');
  1195. Halt(227);
  1196. {$endif FPC_HAS_FEATURE_CONSOLEIO}
  1197. end;
  1198. {*****************************************************************************
  1199. SetJmp/LongJmp support.
  1200. *****************************************************************************}
  1201. {$i setjump.inc}
  1202. {$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
  1203. {*****************************************************************************
  1204. Heap
  1205. *****************************************************************************}
  1206. {$i sysheap.inc}
  1207. {$i heap.inc}
  1208. {*****************************************************************************
  1209. Thread support
  1210. *****************************************************************************}
  1211. {$ifdef FPC_HAS_FEATURE_THREADING}
  1212. { Generic threadmanager }
  1213. {$i thread.inc}
  1214. {$ifndef FPC_SECTION_THREADVARS}
  1215. { Generic threadvar support }
  1216. {$i threadvr.inc}
  1217. {$endif FPC_SECTION_THREADVARS}
  1218. {$ifdef DISABLE_NO_THREAD_MANAGER}
  1219. { OS Dependent implementation }
  1220. {$i systhrd.inc}
  1221. {$endif DISABLE_NO_THREAD_MANAGER}
  1222. {$endif FPC_HAS_FEATURE_THREADING}
  1223. {*****************************************************************************
  1224. Dynamic library support
  1225. *****************************************************************************}
  1226. {$ifdef FPC_HAS_FEATURE_DYNLIBS}
  1227. {$i dynlib.inc}
  1228. {$ifdef DISABLE_NO_DYNLIBS_MANAGER}
  1229. { OS Dependant implementation }
  1230. {$i sysdl.inc}
  1231. {$endif DISABLE_NO_DYNLIBS_MANAGER}
  1232. {$endif FPC_HAS_FEATURE_DYNLIBS}
  1233. {*****************************************************************************
  1234. File Handling
  1235. *****************************************************************************}
  1236. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1237. { Allow slash and backslash as separators }
  1238. procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
  1239. var
  1240. i : longint;
  1241. len : sizeint;
  1242. newp : pchar;
  1243. begin
  1244. len:=length(p);
  1245. newp:=nil;
  1246. for i:=0 to len do
  1247. if p[i] in AllowDirectorySeparators then
  1248. begin
  1249. if not inplace and
  1250. not assigned(newp) then
  1251. begin
  1252. getmem(newp,len+1);
  1253. move(p^,newp^,len+1);
  1254. p:=newp;
  1255. end;
  1256. p[i]:=DirectorySeparator;
  1257. end;
  1258. end;
  1259. procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
  1260. var
  1261. i : longint;
  1262. len : sizeint;
  1263. newp : pwidechar;
  1264. begin
  1265. len:=length(p);
  1266. newp:=nil;
  1267. for i:=0 to len do
  1268. if (ord(p[i])<255) and
  1269. (ansichar(ord(p[i])) in AllowDirectorySeparators) then
  1270. begin
  1271. if not inplace and
  1272. not assigned(newp) then
  1273. begin
  1274. getmem(newp,(len+1)*2);
  1275. move(p^,newp^,(len+1)*2);
  1276. p:=newp;
  1277. end;
  1278. p[i]:=DirectorySeparator;
  1279. end;
  1280. end;
  1281. procedure DoDirSeparators(var p:shortstring);
  1282. var
  1283. i : longint;
  1284. begin
  1285. for i:=1 to length(p) do
  1286. if p[i] in AllowDirectorySeparators then
  1287. p[i]:=DirectorySeparator;
  1288. end;
  1289. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  1290. procedure DoDirSeparators(var ps:RawByteString);
  1291. var
  1292. i : longint;
  1293. p : pchar;
  1294. unique : boolean;
  1295. begin
  1296. unique:=false;
  1297. for i:=1 to length(ps) do
  1298. if ps[i] in AllowDirectorySeparators then
  1299. begin
  1300. if not unique then
  1301. begin
  1302. uniquestring(ps);
  1303. p:=pchar(ps);
  1304. unique:=true;
  1305. end;
  1306. p[i-1]:=DirectorySeparator;
  1307. end;
  1308. end;
  1309. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  1310. {$ifdef FPC_HAS_FEATURE_UNICODESTRINGS}
  1311. procedure DoDirSeparators(var ps:UnicodeString);
  1312. var
  1313. i : longint;
  1314. p : pwidechar;
  1315. unique : boolean;
  1316. begin
  1317. unique:=false;
  1318. for i:=1 to length(ps) do
  1319. if ps[i] in AllowDirectorySeparators then
  1320. begin
  1321. if not unique then
  1322. begin
  1323. uniquestring(ps);
  1324. p:=pwidechar(ps);
  1325. unique:=true;
  1326. end;
  1327. p[i-1]:=DirectorySeparator;
  1328. end;
  1329. end;
  1330. {$endif FPC_HAS_FEATURE_UNICODESTRINGS}
  1331. {$endif FPC_HAS_FEATURE_FILEIO}
  1332. { OS dependent low level file functions }
  1333. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1334. {$i sysfile.inc}
  1335. {$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1336. {$ifdef FPC_ANSI_TEXTFILEREC}
  1337. procedure do_open(var f; p: pansichar; flags: longint; pchangeable: boolean);
  1338. var
  1339. u: UnicodeString;
  1340. begin
  1341. widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
  1342. do_open(f,pwidechar(u),flags,true);
  1343. end;
  1344. procedure do_erase(p: pansichar; pchangeable: boolean);
  1345. var
  1346. u: UnicodeString;
  1347. begin
  1348. widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
  1349. do_erase(pwidechar(u),true);
  1350. end;
  1351. procedure do_rename(src, dst: pansichar; srcchangeable, dstchangeable: boolean);
  1352. var
  1353. usrc, udst: UnicodeString;
  1354. begin
  1355. widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
  1356. widestringmanager.Ansi2UnicodeMoveProc(dst,DefaultFileSystemCodePage,udst,length(dst));
  1357. do_rename(pwidechar(usrc),pwidechar(udst),true,true);
  1358. end;
  1359. procedure do_rename(src: pansichar; dst: pwidechar; srcchangeable, dstchangeable: boolean);
  1360. var
  1361. usrc: UnicodeString;
  1362. begin
  1363. widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
  1364. do_rename(pwidechar(usrc),dst,true,dstchangeable);
  1365. end;
  1366. {$endif FPC_ANSI_TEXTFILEREC}
  1367. {$endif not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1368. {$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1369. {$ifndef FPC_ANSI_TEXTFILEREC}
  1370. procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
  1371. var
  1372. s: RawByteString;
  1373. begin
  1374. widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
  1375. do_open(f,pansichar(s),flags,true);
  1376. end;
  1377. procedure do_erase(p: pwidechar; pchangeable: boolean);
  1378. var
  1379. s: RawByteString;
  1380. begin
  1381. widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
  1382. do_erase(pansichar(s),true);
  1383. end;
  1384. procedure do_rename(src, dst: pwidechar; srcchangeable, dstchangeable: boolean);
  1385. var
  1386. rsrc, rdst: RawByteString;
  1387. begin
  1388. widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
  1389. widestringmanager.Unicode2AnsiMoveProc(dst,rdst,DefaultFileSystemCodePage,length(dst));
  1390. do_rename(pansichar(rsrc),pansichar(rdst),true,true);
  1391. end;
  1392. procedure do_rename(src: pwidechar; dst: pansichar; srcchangeable, dstchangeable: boolean);
  1393. var
  1394. rsrc: RawByteString;
  1395. begin
  1396. widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
  1397. do_rename(pansichar(rsrc),dst,true,dstchangeable);
  1398. end;
  1399. {$endif not FPC_ANSI_TEXTFILEREC}
  1400. {$endif not FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1401. {$endif FPC_HAS_FEATURE_FILEIO}
  1402. { helper for targets supporting no ansistrings, it is used
  1403. by non-ansistring code }
  1404. function min(v1,v2 : SizeInt) : SizeInt;
  1405. begin
  1406. if v1<v2 then
  1407. result:=v1
  1408. else
  1409. result:=v2;
  1410. end;
  1411. {$ifdef FPC_HAS_FEATURE_TEXTIO}
  1412. { Text file }
  1413. {$i text.inc}
  1414. {$endif FPC_HAS_FEATURE_TEXTIO}
  1415. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1416. { Untyped file }
  1417. {$i file.inc}
  1418. { Typed file }
  1419. {$i typefile.inc}
  1420. {$endif FPC_HAS_FEATURE_FILEIO}
  1421. {*****************************************************************************
  1422. Directory Handling
  1423. *****************************************************************************}
  1424. {$ifdef FPC_HAS_FEATURE_FILEIO}
  1425. { OS dependent dir functions }
  1426. {$i sysdir.inc}
  1427. {$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
  1428. {$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1429. procedure do_getdir(drivenr : byte;var dir : rawbytestring);
  1430. var
  1431. u: unicodestring;
  1432. begin
  1433. Do_getdir(drivenr,u);
  1434. widestringmanager.Unicode2AnsiMoveProc(pwidechar(u),dir,DefaultRTLFileSystemCodePage,length(u));
  1435. end;
  1436. {$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1437. Procedure MkDir(Const s: RawByteString);[IOCheck];
  1438. Begin
  1439. If (s='') or (InOutRes <> 0) then
  1440. exit;
  1441. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1442. Do_mkdir(ToSingleByteFileSystemEncodedFileName(S));
  1443. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1444. Do_mkdir(S);
  1445. {$endif}
  1446. end;
  1447. Procedure RmDir(Const s: RawByteString);[IOCheck];
  1448. Begin
  1449. If (s='') or (InOutRes <> 0) then
  1450. exit;
  1451. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1452. Do_rmdir(ToSingleByteFileSystemEncodedFileName(S));
  1453. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1454. Do_rmdir(S);
  1455. {$endif}
  1456. End;
  1457. Procedure ChDir(Const s: RawByteString);[IOCheck];
  1458. Begin
  1459. If (s='') or (InOutRes <> 0) then
  1460. exit;
  1461. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1462. Do_chdir(ToSingleByteFileSystemEncodedFileName(S));
  1463. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1464. Do_chdir(S);
  1465. {$endif}
  1466. End;
  1467. Procedure getdir(drivenr:byte;Var dir:rawbytestring);
  1468. begin
  1469. Do_getdir(drivenr,dir);
  1470. { we should return results in the DefaultRTLFileSystemCodePage -> convert if
  1471. necessary }
  1472. setcodepage(dir,DefaultRTLFileSystemCodePage,true);
  1473. end;
  1474. { the generic shortstring ones are only implemented elsewhere for systems *not*
  1475. supporting ansi/unicodestrings; for now assume there are no systems that
  1476. support unicodestrings but not ansistrings }
  1477. { avoid double string conversions }
  1478. {$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1479. function GetDirStrFromShortstring(const s: shortstring): RawByteString;
  1480. begin
  1481. GetDirStrFromShortstring:=ToSingleByteFileSystemEncodedFileName(ansistring(s));
  1482. end;
  1483. {$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1484. function GetDirStrFromShortstring(const s: shortstring): UnicodeString;
  1485. begin
  1486. GetDirStrFromShortstring:=s;
  1487. end;
  1488. {$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
  1489. Procedure MkDir(Const s: shortstring);[IOCheck];
  1490. Begin
  1491. If (s='') or (InOutRes <> 0) then
  1492. exit;
  1493. Do_mkdir(GetDirStrFromShortstring(S));
  1494. End;
  1495. Procedure RmDir(Const s: shortstring);[IOCheck];
  1496. Begin
  1497. If (s='') or (InOutRes <> 0) then
  1498. exit;
  1499. Do_rmdir(GetDirStrFromShortstring(S));
  1500. End;
  1501. Procedure ChDir(Const s: shortstring);[IOCheck];
  1502. Begin
  1503. If (s='') or (InOutRes <> 0) then
  1504. exit;
  1505. Do_chdir(GetDirStrFromShortstring(S));
  1506. End;
  1507. Procedure getdir(drivenr:byte;Var dir:shortstring);
  1508. var
  1509. s: rawbytestring;
  1510. begin
  1511. Do_getdir(drivenr,s);
  1512. if length(s)<=high(dir) then
  1513. dir:=s
  1514. else
  1515. inoutres:=3;
  1516. end;
  1517. {$endif FPC_HAS_FEATURE_ANSISTRINGS}
  1518. {$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
  1519. {$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1520. { overloads required for mkdir/rmdir/chdir to ensure that the string is
  1521. converted to the right code page }
  1522. procedure do_mkdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1523. begin
  1524. do_mkdir(ToSingleByteFileSystemEncodedFileName(s));
  1525. end;
  1526. procedure do_rmdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1527. begin
  1528. do_rmdir(ToSingleByteFileSystemEncodedFileName(s));
  1529. end;
  1530. procedure do_chdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
  1531. begin
  1532. do_chdir(ToSingleByteFileSystemEncodedFileName(s));
  1533. end;
  1534. procedure do_getdir(drivenr : byte;var dir : unicodestring);
  1535. var
  1536. s: rawbytestring;
  1537. begin
  1538. Do_getdir(drivenr,s);
  1539. dir:=s;
  1540. end;
  1541. {$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
  1542. Procedure MkDir(Const s: UnicodeString);[IOCheck];
  1543. Begin
  1544. if (s='') or (InOutRes <> 0) then
  1545. exit;
  1546. Do_mkdir(S);
  1547. End;
  1548. Procedure RmDir(Const s: UnicodeString);[IOCheck];
  1549. Begin
  1550. if (s='') or (InOutRes <> 0) then
  1551. exit;
  1552. Do_rmdir(S);
  1553. End;
  1554. Procedure ChDir(Const s: UnicodeString);[IOCheck];
  1555. Begin
  1556. if (s='') or (InOutRes <> 0) then
  1557. exit;
  1558. Do_chdir(S);
  1559. End;
  1560. Procedure getdir(drivenr:byte;Var dir:unicodestring);
  1561. begin
  1562. Do_getdir(drivenr,dir);
  1563. end;
  1564. {$endif FPC_HAS_FEATURE_WIDESTRINGS}
  1565. {$endif FPC_HAS_FEATURE_FILEIO}
  1566. {*****************************************************************************
  1567. Resources support
  1568. *****************************************************************************}
  1569. {$i sysres.inc}
  1570. const
  1571. CtrlBreakHandler: TCtrlBreakHandler = nil;
  1572. {$IFNDEF FPC_HAS_SETCTRLBREAKHANDLER}
  1573. (* It is possible to provide platform specific implementation performing *)
  1574. (* special initialization; default implementation just sets the procedural *)
  1575. (* variable to make it available for use from the exception handler. *)
  1576. function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
  1577. begin
  1578. (* Return either nil or previous handler *)
  1579. SysSetCtrlBreakHandler := CtrlBreakHandler;
  1580. CtrlBreakHandler := Handler;
  1581. end;
  1582. {$ENDIF FPC_HAS_SETCTRLBREAKHANDLER}