system.pas 36 KB

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