system.pas 36 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269
  1. {
  2. $Id$
  3. ****************************************************************************
  4. This file is part of the Free Pascal run time library.
  5. Copyright (c) 1999-2002 by Free Pascal development team
  6. Free Pascal - OS/2 runtime library
  7. See the file COPYING.FPC, included in this distribution,
  8. for details about the copyright.
  9. This program is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12. ****************************************************************************}
  13. unit {$ifdef VER1_0}sysos2{$else}System{$endif};
  14. interface
  15. {Link the startup code.}
  16. {$ifdef VER1_0}
  17. {$l prt1.oo2}
  18. {$else}
  19. {$l prt1.o}
  20. {$endif}
  21. {$ifdef SYSTEMDEBUG}
  22. {$define SYSTEMEXCEPTIONDEBUG}
  23. {$define IODEBUG}
  24. {$endif SYSTEMDEBUG}
  25. { $DEFINE OS2EXCEPTIONS}
  26. {$I systemh.inc}
  27. {$IFDEF OS2EXCEPTIONS}
  28. (* Types and constants for exception handler support *)
  29. type
  30. {x} PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
  31. {x} TEXCEPTION_FRAME = record
  32. {x} next : PEXCEPTION_FRAME;
  33. {x} handler : pointer;
  34. {x} end;
  35. {$ENDIF OS2EXCEPTIONS}
  36. {$I heaph.inc}
  37. {Platform specific information}
  38. type
  39. THandle = Longint;
  40. const
  41. LineEnding = #13#10;
  42. { LFNSupport is defined separately below!!! }
  43. DirectorySeparator = '\';
  44. DriveSeparator = ':';
  45. PathSeparator = ';';
  46. { FileNameCaseSensitive is defined separately below!!! }
  47. type Tos=(osDOS,osOS2,osDPMI);
  48. const os_mode: Tos = osOS2;
  49. first_meg: pointer = nil;
  50. {$IFDEF OS2EXCEPTIONS}
  51. {x} System_exception_frame : PEXCEPTION_FRAME =nil;
  52. {$ENDIF OS2EXCEPTIONS}
  53. type TByteArray = array [0..$ffff] of byte;
  54. PByteArray = ^TByteArray;
  55. TSysThreadIB = record
  56. TID,
  57. Priority,
  58. Version: cardinal;
  59. MCCount,
  60. MCForceFlag: word;
  61. end;
  62. PSysThreadIB = ^TSysThreadIB;
  63. TThreadInfoBlock = record
  64. PExChain,
  65. Stack,
  66. StackLimit: pointer;
  67. TIB2: PSysThreadIB;
  68. Version,
  69. Ordinal: cardinal;
  70. end;
  71. PThreadInfoBlock = ^TThreadInfoBlock;
  72. PPThreadInfoBlock = ^PThreadInfoBlock;
  73. TProcessInfoBlock = record
  74. PID,
  75. ParentPid,
  76. Handle: cardinal;
  77. Cmd,
  78. Env: PByteArray;
  79. Status,
  80. ProcType: cardinal;
  81. end;
  82. PProcessInfoBlock = ^TProcessInfoBlock;
  83. PPProcessInfoBlock = ^PProcessInfoBlock;
  84. const UnusedHandle=-1;
  85. StdInputHandle=0;
  86. StdOutputHandle=1;
  87. StdErrorHandle=2;
  88. LFNSupport: boolean = true;
  89. FileNameCaseSensitive: boolean = false;
  90. sLineBreak = LineEnding;
  91. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
  92. var
  93. { C-compatible arguments and environment }
  94. argc : longint;external name '_argc';
  95. argv : ppchar;external name '_argv';
  96. envp : ppchar;external name '_environ';
  97. EnvC: cardinal; external name '_envc';
  98. (* Pointer to the block of environment variables - used e.g. in unit Dos. *)
  99. Environment: PChar;
  100. var
  101. (* Type / run mode of the current process: *)
  102. (* 0 .. full screen OS/2 session *)
  103. (* 1 .. DOS session *)
  104. (* 2 .. VIO windowable OS/2 session *)
  105. (* 3 .. Presentation Manager OS/2 session *)
  106. (* 4 .. detached (background) OS/2 process *)
  107. ApplicationType: cardinal;
  108. implementation
  109. {$I system.inc}
  110. var
  111. heap_base: pointer; external name '__heap_base';
  112. heap_brk: pointer; external name '__heap_brk';
  113. heap_end: pointer; external name '__heap_end';
  114. (* Maximum heap size - only used if heap is allocated as continuous block. *)
  115. {$IFDEF CONTHEAP}
  116. BrkLimit: cardinal;
  117. {$ENDIF CONTHEAP}
  118. procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
  119. PAPIB: PPProcessInfoBlock); cdecl;
  120. external 'DOSCALLS' index 312;
  121. function DosLoadModule (ObjName: PChar; ObjLen: cardinal; DLLName: PChar;
  122. var Handle: cardinal): cardinal; cdecl;
  123. external 'DOSCALLS' index 318;
  124. function DosQueryProcAddr (Handle, Ordinal: cardinal; ProcName: PChar;
  125. var Address: pointer): cardinal; cdecl;
  126. external 'DOSCALLS' index 321;
  127. function DosSetRelMaxFH (var ReqCount: longint; var CurMaxFH: cardinal):
  128. cardinal; cdecl;
  129. external 'DOSCALLS' index 382;
  130. function DosSetCurrentDir (Name:PChar): cardinal; cdecl;
  131. external 'DOSCALLS' index 255;
  132. procedure DosQueryCurrentDisk(var DiskNum:cardinal;var Logical:cardinal); cdecl;
  133. external 'DOSCALLS' index 275;
  134. function DosSetDefaultDisk (DiskNum:cardinal): cardinal; cdecl;
  135. external 'DOSCALLS' index 220;
  136. { This is not real prototype, but is close enough }
  137. { for us (the 2nd parameter is actually a pointer }
  138. { to a structure). }
  139. function DosCreateDir (Name: PChar; P: pointer): cardinal; cdecl;
  140. external 'DOSCALLS' index 270;
  141. function DosDeleteDir (Name: PChar): cardinal; cdecl;
  142. external 'DOSCALLS' index 226;
  143. function DosQueryCurrentDir(DiskNum:cardinal;var Buffer;
  144. var BufLen:cardinal): cardinal; cdecl;
  145. external 'DOSCALLS' index 274;
  146. function DosMove(OldFile,NewFile:PChar):cardinal; cdecl;
  147. external 'DOSCALLS' index 271;
  148. function DosDelete(FileName:PChar):cardinal; cdecl;
  149. external 'DOSCALLS' index 259;
  150. procedure DosExit(Action, Result: cardinal); cdecl;
  151. external 'DOSCALLS' index 234;
  152. // EAs not used in System unit
  153. function DosOpen(FileName:PChar;var Handle:longint;var Action:cardinal;
  154. InitSize,Attrib,OpenFlags,FileMode:cardinal;
  155. EA:Pointer):longint; cdecl;
  156. external 'DOSCALLS' index 273;
  157. function DosClose(Handle:longint): longint; cdecl;
  158. external 'DOSCALLS' index 257;
  159. function DosRead(Handle:longint; Buffer: Pointer;Count:longint;
  160. var ActCount:longint):longint; cdecl;
  161. external 'DOSCALLS' index 281;
  162. function DosWrite(Handle:longint; Buffer: Pointer;Count:longint;
  163. var ActCount:longint):longint; cdecl;
  164. external 'DOSCALLS' index 282;
  165. function DosSetFilePtr(Handle:longint;Pos:longint;Method:cardinal;
  166. var PosActual:longint):longint; cdecl;
  167. external 'DOSCALLS' index 256;
  168. function DosSetFileSize(Handle:longint;Size:cardinal):longint; cdecl;
  169. external 'DOSCALLS' index 272;
  170. function DosQueryHType(Handle:longint;var HandType:longint;
  171. var Attr:longint):longint; cdecl;
  172. external 'DOSCALLS' index 224;
  173. type
  174. TSysDateTime=packed record
  175. Hour,
  176. Minute,
  177. Second,
  178. Sec100,
  179. Day,
  180. Month: byte;
  181. Year: word;
  182. TimeZone: smallint;
  183. WeekDay: byte;
  184. end;
  185. function DosGetDateTime(var Buf:TSysDateTime):longint; cdecl;
  186. external 'DOSCALLS' index 230;
  187. {This is the correct way to call external assembler procedures.}
  188. procedure syscall; external name '___SYSCALL';
  189. { converts an OS/2 error code to a TP compatible error }
  190. { code. Same thing exists under most other supported }
  191. { systems. }
  192. { Only call for OS/2 DLL imported routines }
  193. Procedure Errno2InOutRes;
  194. Begin
  195. { errors 1..18 are the same as in DOS }
  196. case InOutRes of
  197. { simple offset to convert these error codes }
  198. { exactly like the error codes in Win32 }
  199. 19..31 : InOutRes := InOutRes + 131;
  200. { gets a bit more complicated ... }
  201. 32..33 : InOutRes := 5;
  202. 38 : InOutRes := 100;
  203. 39 : InOutRes := 101;
  204. 112 : InOutRes := 101;
  205. 110 : InOutRes := 5;
  206. 114 : InOutRes := 6;
  207. 290 : InOutRes := 290;
  208. end;
  209. { all other cases ... we keep the same error code }
  210. end;
  211. {$IFDEF OS2EXCEPTIONS}
  212. (*
  213. The operating system defines a class of error conditions called exceptions, and specifies the default actions that are taken when these exceptions occur. The system default action in most cases is to terminate the thread that caused the exception.
  214. Exception values have the following 32-bit format:
  215. 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
  216. 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0 9 8 7 6 5 4 3 2 1 0
  217. ÚÄÄÄÂÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  218. ³Sev³C³ Facility ³ Code ³
  219. ÀÄÄÄÁÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  220. Sev Severity code. Possible values are described in the following list:
  221. 00 Success
  222. 01 Informational
  223. 10 Warning
  224. 11 Error
  225. C Customer code flag.
  226. Facility Facility code.
  227. Code Facility's status code.
  228. Exceptions that are specific to OS/2 Version 2.X (for example, XCPT_SIGNAL) have a facility code of 1.
  229. System exceptions include both synchronous and asynchronous exceptions. Synchronous exceptions are caused by events that are internal to a thread's execution. For example, synchronous exceptions could be caused by invalid parameters, or by a thread's request to end its own execution.
  230. Asynchronous exceptions are caused by events that are external to a thread's execution. For example, an asynchronous exception can be caused by a user's entering a Ctrl+C or Ctrl+Break key sequence, or by a process' issuing DosKillProcess to end the execution of another process.
  231. The Ctrl+Break and Ctrl+C exceptions are also known as signals, or as signal exceptions.
  232. The following tables show the symbolic names of system exceptions, their numerical values, and related information fields.
  233. Portable, Non-Fatal, Software-Generated Exceptions
  234. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  235. ³Exception Name ³Value ³
  236. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  237. ³XCPT_GUARD_PAGE_VIOLATION ³0x80000001³
  238. ³ ExceptionInfo[0] - R/W flag ³ ³
  239. ³ ExceptionInfo[1] - FaultAddr ³ ³
  240. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  241. ³XCPT_UNABLE_TO_GROW_STACK ³0x80010001³
  242. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  243. Portable, Fatal, Hardware-Generated Exceptions
  244. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  245. ³Exception Name ³Value ³Related Trap ³
  246. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  247. ³XCPT_ACCESS_VIOLATION ³0xC0000005³0x09, 0x0B, ³
  248. ³ ExceptionInfo[0] - Flags ³ ³0x0C, 0x0D, ³
  249. ³ XCPT_UNKNOWN_ACCESS 0x0 ³ ³0x0E ³
  250. ³ XCPT_READ_ACCESS 0x1 ³ ³ ³
  251. ³ XCPT_WRITE_ACCESS 0x2 ³ ³ ³
  252. ³ XCPT_EXECUTE_ACCESS 0x4 ³ ³ ³
  253. ³ XCPT_SPACE_ACCESS 0x8 ³ ³ ³
  254. ³ XCPT_LIMIT_ACCESS 0x10 ³ ³ ³
  255. ³ ExceptionInfo[1] - FaultAddr ³ ³ ³
  256. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  257. ³XCPT_INTEGER_DIVIDE_BY_ZERO ³0xC000009B³0 ³
  258. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  259. ³XCPT_FLOAT_DIVIDE_BY_ZERO ³0xC0000095³0x10 ³
  260. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  261. ³XCPT_FLOAT_INVALID_OPERATION ³0xC0000097³0x10 ³
  262. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  263. ³XCPT_ILLEGAL_INSTRUCTION ³0xC000001C³0x06 ³
  264. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  265. ³XCPT_PRIVILEGED_INSTRUCTION ³0xC000009D³0x0D ³
  266. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  267. ³XCPT_INTEGER_OVERFLOW ³0xC000009C³0x04 ³
  268. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  269. ³XCPT_FLOAT_OVERFLOW ³0xC0000098³0x10 ³
  270. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  271. ³XCPT_FLOAT_UNDERFLOW ³0xC000009A³0x10 ³
  272. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  273. ³XCPT_FLOAT_DENORMAL_OPERAND ³0xC0000094³0x10 ³
  274. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  275. ³XCPT_FLOAT_INEXACT_RESULT ³0xC0000096³0x10 ³
  276. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  277. ³XCPT_FLOAT_STACK_CHECK ³0xC0000099³0x10 ³
  278. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  279. ³XCPT_DATATYPE_MISALIGNMENT ³0xC000009E³0x11 ³
  280. ³ ExceptionInfo[0] - R/W flag ³ ³ ³
  281. ³ ExceptionInfo[1] - Alignment ³ ³ ³
  282. ³ ExceptionInfo[2] - FaultAddr ³ ³ ³
  283. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  284. ³XCPT_BREAKPOINT ³0xC000009F³0x03 ³
  285. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  286. ³XCPT_SINGLE_STEP ³0xC00000A0³0x01 ³
  287. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  288. Portable, Fatal, Software-Generated Exceptions
  289. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  290. ³Exception Name ³Value ³Related Trap ³
  291. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  292. ³XCPT_IN_PAGE_ERROR ³0xC0000006³0x0E ³
  293. ³ ExceptionInfo[0] - FaultAddr ³ ³ ³
  294. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  295. ³XCPT_PROCESS_TERMINATE ³0xC0010001³ ³
  296. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  297. ³XCPT_ASYNC_PROCESS_TERMINATE ³0xC0010002³ ³
  298. ³ ExceptionInfo[0] - TID of ³ ³ ³
  299. ³ terminating thread ³ ³ ³
  300. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  301. ³XCPT_NONCONTINUABLE_EXCEPTION ³0xC0000024³ ³
  302. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  303. ³XCPT_INVALID_DISPOSITION ³0xC0000025³ ³
  304. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  305. Non-Portable, Fatal Exceptions
  306. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  307. ³Exception Name ³Value ³Related Trap ³
  308. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  309. ³XCPT_INVALID_LOCK_SEQUENCE ³0xC000001D³ ³
  310. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  311. ³XCPT_ARRAY_BOUNDS_EXCEEDED ³0xC0000093³0x05 ³
  312. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  313. Unwind Operation Exceptions
  314. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  315. ³Exception Name ³Value ³
  316. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  317. ³XCPT_UNWIND ³0xC0000026³
  318. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  319. ³XCPT_BAD_STACK ³0xC0000027³
  320. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  321. ³XCPT_INVALID_UNWIND_TARGET ³0xC0000028³
  322. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  323. Fatal Signal Exceptions
  324. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  325. ³Exception Name ³Value ³
  326. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  327. ³XCPT_SIGNAL ³0xC0010003³
  328. ³ ExceptionInfo[ 0 ] - Signal ³ ³
  329. ³ Number ³ ³
  330. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  331. *)
  332. {$ENDIF OS2EXCEPTIONS}
  333. {****************************************************************************
  334. Miscellaneous related routines.
  335. ****************************************************************************}
  336. procedure system_exit;
  337. begin
  338. DosExit(1{process}, exitcode);
  339. end;
  340. {$ASMMODE ATT}
  341. function paramcount:longint;assembler;
  342. asm
  343. movl argc,%eax
  344. decl %eax
  345. end {['EAX']};
  346. function args:pointer;assembler;
  347. asm
  348. movl argv,%eax
  349. end {['EAX']};
  350. function paramstr(l:longint):string;
  351. var p:^Pchar;
  352. begin
  353. if (l>=0) and (l<=paramcount) then
  354. begin
  355. p:=args;
  356. paramstr:=strpas(p[l]);
  357. end
  358. else paramstr:='';
  359. end;
  360. procedure randomize;
  361. var
  362. dt: TSysDateTime;
  363. begin
  364. // Hmm... Lets use timer
  365. DosGetDateTime(dt);
  366. randseed:=dt.hour+(dt.minute shl 8)+(dt.second shl 16)+(dt.sec100 shl 32);
  367. end;
  368. {$ASMMODE ATT}
  369. {****************************************************************************
  370. Heap management releated routines.
  371. ****************************************************************************}
  372. { this function allows to extend the heap by calling
  373. syscall $7f00 resizes the brk area}
  374. function sbrk(size:longint):pointer;
  375. {$IFDEF DUMPGROW}
  376. var
  377. L: longword;
  378. begin
  379. WriteLn ('Trying to grow heap by ', Size, ' to ', HeapSize + Size);
  380. {$IFDEF CONTHEAP}
  381. WriteLn ('BrkLimit is ', BrkLimit);
  382. {$ENDIF CONTHEAP}
  383. asm
  384. movl size,%edx
  385. movw $0x7f00,%ax
  386. call syscall { result directly in EAX }
  387. inc %eax { Result in EAX, -1 = error (has to be transformed to 0) }
  388. jz .LSbrk_End
  389. dec %eax { No error - back to previous value }
  390. .LSbrk_End:
  391. mov %eax,L
  392. end ['eax', 'edx'];
  393. WriteLn ('New heap at ', L);
  394. Sbrk := pointer (L);
  395. end;
  396. {$ELSE DUMPGROW}
  397. assembler;
  398. asm
  399. movl size,%edx
  400. movw $0x7f00,%ax
  401. call syscall
  402. inc %eax { Result in EAX, -1 = error (has to be transformed to 0) }
  403. jz .LSbrk_End
  404. dec %eax { No error - back to previous value }
  405. .LSbrk_End:
  406. end {['eax', 'edx']};
  407. {$ENDIF DUMPGROW}
  408. function getheapstart:pointer;assembler;
  409. asm
  410. movl heap_base,%eax
  411. end {['EAX']};
  412. function getheapsize:longint;assembler;
  413. asm
  414. movl heap_brk,%eax
  415. end {['EAX']};
  416. {$i heap.inc}
  417. {****************************************************************************
  418. Low Level File Routines
  419. ****************************************************************************}
  420. procedure allowslash(p:Pchar);
  421. {Allow slash as backslash.}
  422. var i:longint;
  423. begin
  424. for i:=0 to strlen(p) do
  425. if p[i]='/' then p[i]:='\';
  426. end;
  427. procedure do_close(h:longint);
  428. begin
  429. { Only three standard handles under real OS/2 }
  430. if h>2 then
  431. begin
  432. InOutRes:=DosClose(h);
  433. end;
  434. {$ifdef IODEBUG}
  435. writeln('do_close: handle=', H, ', InOutRes=', InOutRes);
  436. {$endif}
  437. end;
  438. procedure do_erase(p:Pchar);
  439. begin
  440. allowslash(p);
  441. inoutres:=DosDelete(p);
  442. end;
  443. procedure do_rename(p1,p2:Pchar);
  444. begin
  445. allowslash(p1);
  446. allowslash(p2);
  447. inoutres:=DosMove(p1, p2);
  448. end;
  449. function do_read(h,addr,len:longint):longint;
  450. Var
  451. T: Longint;
  452. begin
  453. {$ifdef IODEBUG}
  454. write('do_read: handle=', h, ', addr=', addr, ', length=', len);
  455. {$endif}
  456. InOutRes:=DosRead(H, Pointer(Addr), Len, T);
  457. do_read:=T;
  458. {$ifdef IODEBUG}
  459. writeln(', actual_len=', t, ', InOutRes=', InOutRes);
  460. {$endif}
  461. end;
  462. function do_write(h,addr,len:longint) : longint;
  463. Var
  464. T: Longint;
  465. begin
  466. {$ifdef IODEBUG}
  467. write('do_write: handle=', h, ', addr=', addr, ', length=', len);
  468. {$endif}
  469. InOutRes:=DosWrite(H, Pointer(Addr), Len, T);
  470. do_write:=T;
  471. {$ifdef IODEBUG}
  472. writeln(', actual_len=', t, ', InOutRes=', InOutRes);
  473. {$endif}
  474. end;
  475. function do_filepos(handle:longint): longint;
  476. var
  477. PosActual: Longint;
  478. begin
  479. InOutRes:=DosSetFilePtr(Handle, 0, 1, PosActual);
  480. do_filepos:=PosActual;
  481. {$ifdef IODEBUG}
  482. writeln('do_filepos: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  483. {$endif}
  484. end;
  485. procedure do_seek(handle,pos:longint);
  486. var
  487. PosActual: Longint;
  488. begin
  489. InOutRes:=DosSetFilePtr(Handle, Pos, 0 {ZeroBased}, PosActual);
  490. {$ifdef IODEBUG}
  491. writeln('do_seek: handle=', Handle, ', pos=', pos, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  492. {$endif}
  493. end;
  494. function do_seekend(handle:longint):longint;
  495. var
  496. PosActual: Longint;
  497. begin
  498. InOutRes:=DosSetFilePtr(Handle, 0, 2 {EndBased}, PosActual);
  499. do_seekend:=PosActual;
  500. {$ifdef IODEBUG}
  501. writeln('do_seekend: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  502. {$endif}
  503. end;
  504. function do_filesize(handle:longint):longint;
  505. var aktfilepos:longint;
  506. begin
  507. aktfilepos:=do_filepos(handle);
  508. do_filesize:=do_seekend(handle);
  509. do_seek(handle,aktfilepos);
  510. end;
  511. procedure do_truncate(handle,pos:longint);
  512. begin
  513. InOutRes:=DosSetFileSize(Handle, Pos);
  514. do_seekend(handle);
  515. end;
  516. const
  517. FileHandleCount: cardinal = 20;
  518. function Increase_File_Handle_Count: boolean;
  519. var Err: word;
  520. L1: longint;
  521. L2: cardinal;
  522. begin
  523. L1 := 10;
  524. if DosSetRelMaxFH (L1, L2) <> 0 then
  525. Increase_File_Handle_Count := false
  526. else
  527. if L2 > FileHandleCount then
  528. begin
  529. FileHandleCount := L2;
  530. Increase_File_Handle_Count := true;
  531. end
  532. else
  533. Increase_File_Handle_Count := false;
  534. end;
  535. procedure do_open(var f;p:pchar;flags:longint);
  536. {
  537. filerec and textrec have both handle and mode as the first items so
  538. they could use the same routine for opening/creating.
  539. when (flags and $100) the file will be append
  540. when (flags and $1000) the file will be truncate/rewritten
  541. when (flags and $10000) there is no check for close (needed for textfiles)
  542. }
  543. var
  544. Action, Attrib, OpenFlags, FM: Cardinal;
  545. begin
  546. // convert unix slashes to normal slashes
  547. allowslash(p);
  548. // close first if opened
  549. if ((flags and $10000)=0) then
  550. begin
  551. case filerec(f).mode of
  552. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  553. fmclosed:;
  554. else
  555. begin
  556. inoutres:=102; {not assigned}
  557. exit;
  558. end;
  559. end;
  560. end;
  561. // reset file handle
  562. filerec(f).handle := UnusedHandle;
  563. Attrib:=0;
  564. OpenFlags:=0;
  565. // convert filesharing
  566. FM := Flags and $FF and not (8);
  567. (* DenyNone if sharing not specified. *)
  568. if FM and 112 = 0 then
  569. FM := FM or 64;
  570. // convert filemode to filerec modes and access mode
  571. case (FM and 3) of
  572. 0: filerec(f).mode:=fminput;
  573. 1: filerec(f).mode:=fmoutput;
  574. 2: filerec(f).mode:=fminout;
  575. end;
  576. if (flags and $1000)<>0 then
  577. OpenFlags:=OpenFlags or 2 {doOverwrite} or 16 {doCreate} // Create/overwrite
  578. else
  579. OpenFlags:=OpenFlags or 1 {doOpen}; // Open existing
  580. // Handle Std I/O
  581. if p[0]=#0 then
  582. begin
  583. case FileRec(f).mode of
  584. fminput :
  585. FileRec(f).Handle:=StdInputHandle;
  586. fminout, // this is set by rewrite
  587. fmoutput :
  588. FileRec(f).Handle:=StdOutputHandle;
  589. fmappend :
  590. begin
  591. FileRec(f).Handle:=StdOutputHandle;
  592. FileRec(f).mode:=fmoutput; // fool fmappend
  593. end;
  594. end;
  595. exit;
  596. end;
  597. Attrib:=32 {faArchive};
  598. InOutRes:=DosOpen(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
  599. // If too many open files try to set more file handles and open again
  600. if (InOutRes = 4) then
  601. if Increase_File_Handle_Count then
  602. InOutRes:=DosOpen(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
  603. If InOutRes<>0 then FileRec(F).Handle:=UnusedHandle;
  604. // If Handle created -> make some things
  605. if (FileRec(F).Handle <> UnusedHandle) then
  606. begin
  607. // Move to end of file for Append command
  608. if ((Flags and $100) <> 0) then
  609. begin
  610. do_seekend(FileRec(F).Handle);
  611. FileRec(F).Mode := fmOutput;
  612. end;
  613. end;
  614. {$ifdef IODEBUG}
  615. writeln('do_open,', filerec(f).handle, ',', filerec(f).name, ',', filerec(f).mode, ', InOutRes=', InOutRes);
  616. {$endif}
  617. end;
  618. function do_isdevice (Handle: longint): boolean;
  619. var
  620. HT, Attr: longint;
  621. begin
  622. do_isdevice:=false;
  623. If DosQueryHType(Handle, HT, Attr)<>0 then exit;
  624. if ht=1 then do_isdevice:=true;
  625. end;
  626. {$ASMMODE ATT}
  627. {*****************************************************************************
  628. UnTyped File Handling
  629. *****************************************************************************}
  630. {$i file.inc}
  631. {*****************************************************************************
  632. Typed File Handling
  633. *****************************************************************************}
  634. {$i typefile.inc}
  635. {*****************************************************************************
  636. Text File Handling
  637. *****************************************************************************}
  638. {$DEFINE EOF_CTRLZ}
  639. {$i text.inc}
  640. {****************************************************************************
  641. Directory related routines.
  642. ****************************************************************************}
  643. {*****************************************************************************
  644. Directory Handling
  645. *****************************************************************************}
  646. procedure MkDir (const S: string);[IOCHECK];
  647. var buffer:array[0..255] of char;
  648. Rc : word;
  649. begin
  650. If (s='') or (InOutRes <> 0) then
  651. exit;
  652. move(s[1],buffer,length(s));
  653. buffer[length(s)]:=#0;
  654. allowslash(Pchar(@buffer));
  655. Rc := DosCreateDir(buffer,nil);
  656. if Rc <> 0 then
  657. begin
  658. InOutRes := Rc;
  659. Errno2Inoutres;
  660. end;
  661. end;
  662. procedure rmdir(const s : string);[IOCHECK];
  663. var buffer:array[0..255] of char;
  664. Rc : word;
  665. begin
  666. if (s = '.' ) then
  667. InOutRes := 16;
  668. If (s='') or (InOutRes <> 0) then
  669. exit;
  670. move(s[1],buffer,length(s));
  671. buffer[length(s)]:=#0;
  672. allowslash(Pchar(@buffer));
  673. Rc := DosDeleteDir(buffer);
  674. if Rc <> 0 then
  675. begin
  676. InOutRes := Rc;
  677. Errno2Inoutres;
  678. end;
  679. end;
  680. {$ASMMODE INTEL}
  681. procedure ChDir (const S: string);[IOCheck];
  682. var RC: cardinal;
  683. Buffer: array [0..255] of char;
  684. begin
  685. If (s='') or (InOutRes <> 0) then exit;
  686. if (Length (S) >= 2) and (S [2] = ':') then
  687. begin
  688. RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40);
  689. if RC <> 0 then
  690. InOutRes := RC
  691. else
  692. if Length (S) > 2 then
  693. begin
  694. Move (S [1], Buffer, Length (S));
  695. Buffer [Length (S)] := #0;
  696. AllowSlash (PChar (@Buffer));
  697. RC := DosSetCurrentDir (@Buffer);
  698. if RC <> 0 then
  699. begin
  700. InOutRes := RC;
  701. Errno2InOutRes;
  702. end;
  703. end;
  704. end else begin
  705. Move (S [1], Buffer, Length (S));
  706. Buffer [Length (S)] := #0;
  707. AllowSlash (PChar (@Buffer));
  708. RC := DosSetCurrentDir (@Buffer);
  709. if RC <> 0 then
  710. begin
  711. InOutRes:= RC;
  712. Errno2InOutRes;
  713. end;
  714. end;
  715. end;
  716. {$ASMMODE ATT}
  717. procedure GetDir (DriveNr: byte; var Dir: ShortString);
  718. {Written by Michael Van Canneyt.}
  719. var sof: Pchar;
  720. i:byte;
  721. l,l2:cardinal;
  722. begin
  723. Dir [4] := #0;
  724. { Used in case the specified drive isn't available }
  725. sof:=pchar(@dir[4]);
  726. { dir[1..3] will contain '[drivenr]:\', but is not }
  727. { supplied by DOS, so we let dos string start at }
  728. { dir[4] }
  729. { Get dir from drivenr : 0=default, 1=A etc... }
  730. l:=255-3;
  731. InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l));
  732. {$WARNING Result code should be translated in some cases!}
  733. { Now Dir should be filled with directory in ASCIIZ, }
  734. { starting from dir[4] }
  735. dir[0]:=#3;
  736. dir[2]:=':';
  737. dir[3]:='\';
  738. i:=4;
  739. {Conversion to Pascal string }
  740. while (dir[i]<>#0) do
  741. begin
  742. { convert path name to DOS }
  743. if dir[i]='/' then
  744. dir[i]:='\';
  745. dir[0]:=char(i);
  746. inc(i);
  747. end;
  748. { upcase the string (FPC function) }
  749. if drivenr<>0 then { Drive was supplied. We know it }
  750. dir[1]:=chr(64+drivenr)
  751. else
  752. begin
  753. { We need to get the current drive from DOS function 19H }
  754. { because the drive was the default, which can be unknown }
  755. DosQueryCurrentDisk(l, l2);
  756. dir[1]:=chr(64+l);
  757. end;
  758. if not (FileNameCaseSensitive) then dir:=upcase(dir);
  759. end;
  760. {*****************************************************************************
  761. System unit initialization.
  762. ****************************************************************************}
  763. {****************************************************************************
  764. Error Message writing using messageboxes
  765. ****************************************************************************}
  766. type
  767. TWinMessageBox = function (Parent, Owner: cardinal;
  768. BoxText, BoxTitle: PChar; Identity, Style: cardinal): cardinal; cdecl;
  769. TWinInitialize = function (Options: cardinal): cardinal; cdecl;
  770. TWinCreateMsgQueue = function (Handle: cardinal; cmsg: longint): cardinal;
  771. cdecl;
  772. const
  773. ErrorBufferLength = 1024;
  774. mb_OK = $0000;
  775. mb_Error = $0040;
  776. mb_Moveable = $4000;
  777. MBStyle = mb_OK or mb_Error or mb_Moveable;
  778. WinInitialize: TWinInitialize = nil;
  779. WinCreateMsgQueue: TWinCreateMsgQueue = nil;
  780. WinMessageBox: TWinMessageBox = nil;
  781. EnvSize: cardinal = 0;
  782. var
  783. ErrorBuf: array [0..ErrorBufferLength] of char;
  784. ErrorLen: longint;
  785. PMWinHandle: cardinal;
  786. function ErrorWrite (var F: TextRec): integer;
  787. {
  788. An error message should always end with #13#10#13#10
  789. }
  790. var
  791. P: PChar;
  792. I: longint;
  793. begin
  794. if F.BufPos > 0 then
  795. begin
  796. if F.BufPos + ErrorLen > ErrorBufferLength then
  797. I := ErrorBufferLength - ErrorLen
  798. else
  799. I := F.BufPos;
  800. Move (F.BufPtr^, ErrorBuf [ErrorLen], I);
  801. Inc (ErrorLen, I);
  802. ErrorBuf [ErrorLen] := #0;
  803. end;
  804. if ErrorLen > 3 then
  805. begin
  806. P := @ErrorBuf [ErrorLen];
  807. for I := 1 to 4 do
  808. begin
  809. Dec (P);
  810. if not (P^ in [#10, #13]) then
  811. break;
  812. end;
  813. end;
  814. if ErrorLen = ErrorBufferLength then
  815. I := 4;
  816. if (I = 4) then
  817. begin
  818. WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
  819. ErrorLen := 0;
  820. end;
  821. F.BufPos := 0;
  822. ErrorWrite := 0;
  823. end;
  824. function ErrorClose (var F: TextRec): integer;
  825. begin
  826. if ErrorLen > 0 then
  827. begin
  828. WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
  829. ErrorLen := 0;
  830. end;
  831. ErrorLen := 0;
  832. ErrorClose := 0;
  833. end;
  834. function ErrorOpen (var F: TextRec): integer;
  835. begin
  836. TextRec(F).InOutFunc := @ErrorWrite;
  837. TextRec(F).FlushFunc := @ErrorWrite;
  838. TextRec(F).CloseFunc := @ErrorClose;
  839. ErrorOpen := 0;
  840. end;
  841. procedure AssignError (var T: Text);
  842. begin
  843. Assign (T, '');
  844. TextRec (T).OpenFunc := @ErrorOpen;
  845. Rewrite (T);
  846. end;
  847. procedure SysInitStdIO;
  848. begin
  849. { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
  850. displayed in a messagebox }
  851. (*
  852. StdInputHandle := longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
  853. StdOutputHandle := longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
  854. StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
  855. if not IsConsole then
  856. begin
  857. if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and
  858. (DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0)
  859. and
  860. (DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0)
  861. and
  862. (DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue))
  863. = 0)
  864. then
  865. begin
  866. WinInitialize (0);
  867. WinCreateMsgQueue (0, 0);
  868. end
  869. else
  870. HandleError (2);
  871. AssignError (StdErr);
  872. AssignError (StdOut);
  873. Assign (Output, '');
  874. Assign (Input, '');
  875. end
  876. else
  877. begin
  878. *)
  879. OpenStdIO (Input, fmInput, StdInputHandle);
  880. OpenStdIO (Output, fmOutput, StdOutputHandle);
  881. OpenStdIO (StdOut, fmOutput, StdOutputHandle);
  882. OpenStdIO (StdErr, fmOutput, StdErrorHandle);
  883. (*
  884. end;
  885. *)
  886. end;
  887. function GetFileHandleCount: longint;
  888. var L1: longint;
  889. L2: cardinal;
  890. begin
  891. L1 := 0; (* Don't change the amount, just check. *)
  892. if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
  893. else GetFileHandleCount := L2;
  894. end;
  895. var TIB: PThreadInfoBlock;
  896. PIB: PProcessInfoBlock;
  897. begin
  898. IsLibrary := FALSE;
  899. {$ASMMODE INTEL}
  900. asm
  901. {Enable the brk area by initializing it with the initial heap size.}
  902. mov eax, 7F01h
  903. mov edx, heap_brk
  904. add edx, heap_base
  905. call syscall
  906. cmp eax, -1
  907. jnz @heapok
  908. push dword 204
  909. call HandleError
  910. @heapok:
  911. {$IFDEF CONTHEAP}
  912. { Find out brk limit }
  913. mov eax, 7F02h
  914. mov ecx, 3
  915. call syscall
  916. jcxz @heaplimitknown
  917. mov eax, 0
  918. @heaplimitknown:
  919. mov BrkLimit, eax
  920. {$ELSE CONTHEAP}
  921. { Change sbrk behaviour to allocate arbitrary (non-contiguous) memory blocks }
  922. mov eax, 7F0Fh
  923. mov ecx, 0Ch
  924. mov edx, 8
  925. call syscall
  926. {$ENDIF CONTHEAP}
  927. end;
  928. (* Initialize the amount of file handles *)
  929. FileHandleCount := GetFileHandleCount;
  930. DosGetInfoBlocks (@TIB, @PIB);
  931. StackBottom := TIB^.Stack;
  932. Environment := pointer (PIB^.Env);
  933. ApplicationType := PIB^.ProcType;
  934. IsConsole := ApplicationType <> 3;
  935. exitproc:=nil;
  936. {Initialize the heap.}
  937. initheap;
  938. { ... and exceptions }
  939. SysInitExceptions;
  940. { ... and I/O }
  941. SysInitStdIO;
  942. { no I/O-Error }
  943. inoutres:=0;
  944. {$ifdef HASVARIANT}
  945. initvariantmanager;
  946. {$endif HASVARIANT}
  947. {$IFDEF DUMPGROW}
  948. {$IFDEF CONTHEAP}
  949. WriteLn ('Initial brk size is ', GetHeapSize);
  950. WriteLn ('Brk limit is ', BrkLimit);
  951. {$ENDIF CONTHEAP}
  952. {$ENDIF DUMPGROW}
  953. end.
  954. {
  955. $Log$
  956. Revision 1.57 2003-11-06 17:20:44 yuri
  957. * Unused constants removed
  958. Revision 1.56 2003/11/03 09:42:28 marco
  959. * Peter's Cardinal<->Longint fixes patch
  960. Revision 1.55 2003/11/02 00:51:17 hajny
  961. * corrections for do_open and os_mode back
  962. Revision 1.54 2003/10/28 14:57:31 yuri
  963. * do_* functions now native
  964. Revision 1.53 2003/10/27 04:33:58 yuri
  965. * os_mode removed (not required anymore)
  966. Revision 1.52 2003/10/25 22:45:37 hajny
  967. * file handling related fixes
  968. Revision 1.51 2003/10/19 12:13:41 hajny
  969. * UnusedHandle value made the same as with other targets
  970. Revision 1.50 2003/10/19 09:37:00 hajny
  971. * minor fix in non-default sbrk code
  972. Revision 1.49 2003/10/19 09:06:28 hajny
  973. * fix for terrible long-time bug in do_open
  974. Revision 1.48 2003/10/18 16:58:39 hajny
  975. * stdcall fixes again
  976. Revision 1.47 2003/10/16 15:43:13 peter
  977. * THandle is platform dependent
  978. Revision 1.46 2003/10/14 21:10:06 hajny
  979. * another longint2cardinal fix
  980. Revision 1.45 2003/10/13 21:17:31 hajny
  981. * longint to cardinal corrections
  982. Revision 1.44 2003/10/12 18:07:30 hajny
  983. * wrong use of Intel syntax
  984. Revision 1.43 2003/10/12 17:59:40 hajny
  985. * wrong use of Intel syntax
  986. Revision 1.42 2003/10/12 17:52:28 hajny
  987. * wrong use of Intel syntax
  988. Revision 1.41 2003/10/12 10:45:36 hajny
  989. * sbrk error handling corrected
  990. Revision 1.40 2003/10/07 21:26:35 hajny
  991. * stdcall fixes and asm routines cleanup
  992. Revision 1.39 2003/10/06 16:58:27 yuri
  993. * Another set of native functions.
  994. Revision 1.38 2003/10/06 14:22:40 yuri
  995. * Some emx code removed. Now withous so stupid error as with dos ;)
  996. Revision 1.37 2003/10/04 08:30:59 yuri
  997. * at&t syntax instead of intel syntax was used
  998. Revision 1.36 2003/10/03 21:46:41 peter
  999. * stdcall fixes
  1000. Revision 1.35 2003/10/01 18:42:49 yuri
  1001. * Unclosed comment
  1002. Revision 1.34 2003/09/29 18:39:59 hajny
  1003. * append fix applied to GO32v2, OS/2 and EMX
  1004. Revision 1.33 2003/09/27 11:52:36 peter
  1005. * sbrk returns pointer
  1006. Revision 1.32 2003/03/30 09:20:30 hajny
  1007. * platform extension unification
  1008. Revision 1.31 2003/01/15 22:16:12 hajny
  1009. * default sharing mode changed to DenyNone
  1010. Revision 1.30 2002/12/15 22:41:41 hajny
  1011. * First_Meg fixed + Environment initialization under Dos
  1012. Revision 1.29 2002/12/08 16:39:58 hajny
  1013. - WriteLn in GUI mode support commented out until fixed
  1014. Revision 1.28 2002/12/07 19:17:14 hajny
  1015. * GetEnv correction, better PM support, ...
  1016. Revision 1.27 2002/11/17 22:31:02 hajny
  1017. * type corrections (longint x cardinal)
  1018. Revision 1.26 2002/10/27 14:29:00 hajny
  1019. * heap management (hopefully) fixed
  1020. Revision 1.25 2002/10/14 19:39:17 peter
  1021. * threads unit added for thread support
  1022. Revision 1.24 2002/10/13 09:28:45 florian
  1023. + call to initvariantmanager inserted
  1024. Revision 1.23 2002/09/07 16:01:25 peter
  1025. * old logs removed and tabs fixed
  1026. Revision 1.22 2002/07/01 16:29:05 peter
  1027. * sLineBreak changed to normal constant like Kylix
  1028. Revision 1.21 2002/04/21 15:54:20 carl
  1029. + initialize some global variables
  1030. Revision 1.20 2002/04/12 17:42:16 carl
  1031. + generic stack checking
  1032. Revision 1.19 2002/03/11 19:10:33 peter
  1033. * Regenerated with updated fpcmake
  1034. Revision 1.18 2002/02/10 13:46:20 hajny
  1035. * heap management corrected (heap_brk)
  1036. }