system.pas 36 KB

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