system.pas 46 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665
  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. {$ifdef SYSTEMDEBUG}
  16. {$define SYSTEMEXCEPTIONDEBUG}
  17. {.$define IODEBUG}
  18. {.$define DEBUGENVIRONMENT}
  19. {.$define DEBUGARGUMENTS}
  20. {$endif SYSTEMDEBUG}
  21. { $DEFINE OS2EXCEPTIONS}
  22. {$I systemh.inc}
  23. {$IFDEF OS2EXCEPTIONS}
  24. (* Types and constants for exception handler support *)
  25. type
  26. {x} PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
  27. {x} TEXCEPTION_FRAME = record
  28. {x} next : PEXCEPTION_FRAME;
  29. {x} handler : pointer;
  30. {x} end;
  31. {$ENDIF OS2EXCEPTIONS}
  32. {$I heaph.inc}
  33. {Platform specific information}
  34. type
  35. THandle = Longint;
  36. const
  37. LineEnding = #13#10;
  38. { LFNSupport is defined separately below!!! }
  39. DirectorySeparator = '\';
  40. DriveSeparator = ':';
  41. PathSeparator = ';';
  42. { FileNameCaseSensitive is defined separately below!!! }
  43. type Tos=(osDOS,osOS2,osDPMI);
  44. const os_mode: Tos = osOS2;
  45. first_meg: pointer = nil;
  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;
  91. argv : ppchar;
  92. envp : ppchar;
  93. EnvC: cardinal;
  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. procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
  107. PAPIB: PPProcessInfoBlock); cdecl;
  108. external 'DOSCALLS' index 312;
  109. function DosLoadModule (ObjName: PChar; ObjLen: cardinal; DLLName: PChar;
  110. var Handle: cardinal): cardinal; cdecl;
  111. external 'DOSCALLS' index 318;
  112. function DosQueryProcAddr (Handle, Ordinal: cardinal; ProcName: PChar;
  113. var Address: pointer): cardinal; cdecl;
  114. external 'DOSCALLS' index 321;
  115. function DosSetRelMaxFH (var ReqCount: longint; var CurMaxFH: cardinal):
  116. cardinal; cdecl;
  117. external 'DOSCALLS' index 382;
  118. function DosSetCurrentDir (Name:PChar): cardinal; cdecl;
  119. external 'DOSCALLS' index 255;
  120. procedure DosQueryCurrentDisk(var DiskNum:cardinal;var Logical:cardinal); cdecl;
  121. external 'DOSCALLS' index 275;
  122. function DosSetDefaultDisk (DiskNum:cardinal): cardinal; cdecl;
  123. external 'DOSCALLS' index 220;
  124. { This is not real prototype, but is close enough }
  125. { for us (the 2nd parameter is actually a pointer }
  126. { to a structure). }
  127. function DosCreateDir (Name: PChar; P: pointer): cardinal; cdecl;
  128. external 'DOSCALLS' index 270;
  129. function DosDeleteDir (Name: PChar): cardinal; cdecl;
  130. external 'DOSCALLS' index 226;
  131. function DosQueryCurrentDir(DiskNum:cardinal;var Buffer;
  132. var BufLen:cardinal): cardinal; cdecl;
  133. external 'DOSCALLS' index 274;
  134. function DosMove(OldFile,NewFile:PChar):cardinal; cdecl;
  135. external 'DOSCALLS' index 271;
  136. function DosDelete(FileName:PChar):cardinal; cdecl;
  137. external 'DOSCALLS' index 259;
  138. procedure DosExit(Action, Result: cardinal); cdecl;
  139. external 'DOSCALLS' index 234;
  140. // EAs not used in System unit
  141. function DosOpen(FileName:PChar;var Handle: THandle;var Action:cardinal;
  142. InitSize,Attrib,OpenFlags,FileMode:cardinal;
  143. EA:Pointer): cardinal; cdecl;
  144. external 'DOSCALLS' index 273;
  145. function DosClose(Handle: THandle): cardinal; cdecl;
  146. external 'DOSCALLS' index 257;
  147. function DosRead(Handle: THandle; Buffer: Pointer; Count: cardinal;
  148. var ActCount: cardinal): cardinal; cdecl;
  149. external 'DOSCALLS' index 281;
  150. function DosWrite(Handle: THandle; Buffer: Pointer;Count: cardinal;
  151. var ActCount: cardinal): cardinal; cdecl;
  152. external 'DOSCALLS' index 282;
  153. function DosSetFilePtr(Handle: THandle; Pos:longint; Method:cardinal;
  154. var PosActual: cardinal): cardinal; cdecl;
  155. external 'DOSCALLS' index 256;
  156. function DosSetFileSize(Handle: THandle; Size: cardinal): cardinal; cdecl;
  157. external 'DOSCALLS' index 272;
  158. function DosQueryHType(Handle: THandle; var HandType: cardinal;
  159. var Attr: cardinal): cardinal; cdecl;
  160. external 'DOSCALLS' index 224;
  161. type
  162. TSysDateTime=packed record
  163. Hour,
  164. Minute,
  165. Second,
  166. Sec100,
  167. Day,
  168. Month: byte;
  169. Year: word;
  170. TimeZone: smallint;
  171. WeekDay: byte;
  172. end;
  173. function DosGetDateTime(var Buf:TSysDateTime): cardinal; cdecl;
  174. external 'DOSCALLS' index 230;
  175. { converts an OS/2 error code to a TP compatible error }
  176. { code. Same thing exists under most other supported }
  177. { systems. }
  178. { Only call for OS/2 DLL imported routines }
  179. Procedure Errno2InOutRes;
  180. Begin
  181. { errors 1..18 are the same as in DOS }
  182. case InOutRes of
  183. { simple offset to convert these error codes }
  184. { exactly like the error codes in Win32 }
  185. 19..31 : InOutRes := InOutRes + 131;
  186. { gets a bit more complicated ... }
  187. 32..33 : InOutRes := 5;
  188. 38 : InOutRes := 100;
  189. 39 : InOutRes := 101;
  190. 112 : InOutRes := 101;
  191. 110 : InOutRes := 5;
  192. 114 : InOutRes := 6;
  193. 290 : InOutRes := 290;
  194. end;
  195. { all other cases ... we keep the same error code }
  196. end;
  197. {$IFDEF OS2EXCEPTIONS}
  198. (*
  199. 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.
  200. Exception values have the following 32-bit format:
  201. 3 3 2 2 2 2 2 2 2 2 2 2 1 1 1 1 1 1 1 1 1 1
  202. 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
  203. ÚÄÄÄÂÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  204. ³Sev³C³ Facility ³ Code ³
  205. ÀÄÄÄÁÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  206. Sev Severity code. Possible values are described in the following list:
  207. 00 Success
  208. 01 Informational
  209. 10 Warning
  210. 11 Error
  211. C Customer code flag.
  212. Facility Facility code.
  213. Code Facility's status code.
  214. Exceptions that are specific to OS/2 Version 2.X (for example, XCPT_SIGNAL)
  215. have a facility code of 1.
  216. System exceptions include both synchronous and asynchronous exceptions.
  217. Synchronous exceptions are caused by events that are internal to a thread's
  218. execution. For example, synchronous exceptions could be caused by invalid
  219. parameters, or by a thread's request to end its own execution.
  220. Asynchronous exceptions are caused by events that are external to a thread's
  221. execution. For example, an asynchronous exception can be caused by a user's
  222. entering a Ctrl+C or Ctrl+Break key sequence, or by a process' issuing
  223. DosKillProcess to end the execution of another process.
  224. The Ctrl+Break and Ctrl+C exceptions are also known as signals, or as signal
  225. exceptions.
  226. The following tables show the symbolic names of system exceptions, their
  227. numerical values, and related information fields.
  228. Portable, Non-Fatal, Software-Generated Exceptions
  229. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  230. ³Exception Name ³Value ³
  231. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  232. ³XCPT_GUARD_PAGE_VIOLATION ³0x80000001³
  233. ³ ExceptionInfo[0] - R/W flag ³ ³
  234. ³ ExceptionInfo[1] - FaultAddr ³ ³
  235. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  236. ³XCPT_UNABLE_TO_GROW_STACK ³0x80010001³
  237. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  238. Portable, Fatal, Hardware-Generated Exceptions
  239. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  240. ³Exception Name ³Value ³Related Trap ³
  241. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  242. ³XCPT_ACCESS_VIOLATION ³0xC0000005³0x09, 0x0B, ³
  243. ³ ExceptionInfo[0] - Flags ³ ³0x0C, 0x0D, ³
  244. ³ XCPT_UNKNOWN_ACCESS 0x0 ³ ³0x0E ³
  245. ³ XCPT_READ_ACCESS 0x1 ³ ³ ³
  246. ³ XCPT_WRITE_ACCESS 0x2 ³ ³ ³
  247. ³ XCPT_EXECUTE_ACCESS 0x4 ³ ³ ³
  248. ³ XCPT_SPACE_ACCESS 0x8 ³ ³ ³
  249. ³ XCPT_LIMIT_ACCESS 0x10 ³ ³ ³
  250. ³ ExceptionInfo[1] - FaultAddr ³ ³ ³
  251. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  252. ³XCPT_INTEGER_DIVIDE_BY_ZERO ³0xC000009B³0 ³
  253. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  254. ³XCPT_FLOAT_DIVIDE_BY_ZERO ³0xC0000095³0x10 ³
  255. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  256. ³XCPT_FLOAT_INVALID_OPERATION ³0xC0000097³0x10 ³
  257. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  258. ³XCPT_ILLEGAL_INSTRUCTION ³0xC000001C³0x06 ³
  259. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  260. ³XCPT_PRIVILEGED_INSTRUCTION ³0xC000009D³0x0D ³
  261. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  262. ³XCPT_INTEGER_OVERFLOW ³0xC000009C³0x04 ³
  263. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  264. ³XCPT_FLOAT_OVERFLOW ³0xC0000098³0x10 ³
  265. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  266. ³XCPT_FLOAT_UNDERFLOW ³0xC000009A³0x10 ³
  267. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  268. ³XCPT_FLOAT_DENORMAL_OPERAND ³0xC0000094³0x10 ³
  269. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  270. ³XCPT_FLOAT_INEXACT_RESULT ³0xC0000096³0x10 ³
  271. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  272. ³XCPT_FLOAT_STACK_CHECK ³0xC0000099³0x10 ³
  273. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  274. ³XCPT_DATATYPE_MISALIGNMENT ³0xC000009E³0x11 ³
  275. ³ ExceptionInfo[0] - R/W flag ³ ³ ³
  276. ³ ExceptionInfo[1] - Alignment ³ ³ ³
  277. ³ ExceptionInfo[2] - FaultAddr ³ ³ ³
  278. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  279. ³XCPT_BREAKPOINT ³0xC000009F³0x03 ³
  280. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  281. ³XCPT_SINGLE_STEP ³0xC00000A0³0x01 ³
  282. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  283. Portable, Fatal, Software-Generated Exceptions
  284. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  285. ³Exception Name ³Value ³Related Trap ³
  286. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  287. ³XCPT_IN_PAGE_ERROR ³0xC0000006³0x0E ³
  288. ³ ExceptionInfo[0] - FaultAddr ³ ³ ³
  289. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  290. ³XCPT_PROCESS_TERMINATE ³0xC0010001³ ³
  291. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  292. ³XCPT_ASYNC_PROCESS_TERMINATE ³0xC0010002³ ³
  293. ³ ExceptionInfo[0] - TID of ³ ³ ³
  294. ³ terminating thread ³ ³ ³
  295. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  296. ³XCPT_NONCONTINUABLE_EXCEPTION ³0xC0000024³ ³
  297. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  298. ³XCPT_INVALID_DISPOSITION ³0xC0000025³ ³
  299. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  300. Non-Portable, Fatal Exceptions
  301. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄÄÄÄ¿
  302. ³Exception Name ³Value ³Related Trap ³
  303. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  304. ³XCPT_INVALID_LOCK_SEQUENCE ³0xC000001D³ ³
  305. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄÄÄÄ´
  306. ³XCPT_ARRAY_BOUNDS_EXCEEDED ³0xC0000093³0x05 ³
  307. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÄÄÄÙ
  308. Unwind Operation Exceptions
  309. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  310. ³Exception Name ³Value ³
  311. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  312. ³XCPT_UNWIND ³0xC0000026³
  313. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  314. ³XCPT_BAD_STACK ³0xC0000027³
  315. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  316. ³XCPT_INVALID_UNWIND_TARGET ³0xC0000028³
  317. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  318. Fatal Signal Exceptions
  319. ÚÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÂÄÄÄÄÄÄÄÄÄÄ¿
  320. ³Exception Name ³Value ³
  321. ÃÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÅÄÄÄÄÄÄÄÄÄÄ´
  322. ³XCPT_SIGNAL ³0xC0010003³
  323. ³ ExceptionInfo[ 0 ] - Signal ³ ³
  324. ³ Number ³ ³
  325. ÀÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÄÁÄÄÄÄÄÄÄÄÄÄÙ
  326. *)
  327. {$ENDIF OS2EXCEPTIONS}
  328. {****************************************************************************
  329. Miscellaneous related routines.
  330. ****************************************************************************}
  331. procedure system_exit;
  332. begin
  333. DosExit(1{process}, exitcode);
  334. end;
  335. {$ASMMODE ATT}
  336. function paramcount:longint;assembler;
  337. asm
  338. movl argc,%eax
  339. decl %eax
  340. end {['EAX']};
  341. function args:pointer;assembler;
  342. asm
  343. movl argv,%eax
  344. end {['EAX']};
  345. function paramstr(l:longint):string;
  346. var p:^Pchar;
  347. begin
  348. if (l>=0) and (l<=paramcount) then
  349. begin
  350. p:=args;
  351. paramstr:=strpas(p[l]);
  352. end
  353. else paramstr:='';
  354. end;
  355. procedure randomize;
  356. var
  357. dt: TSysDateTime;
  358. begin
  359. // Hmm... Lets use timer
  360. DosGetDateTime(dt);
  361. randseed:=dt.hour+(dt.minute shl 8)+(dt.second shl 16)+(dt.sec100 shl 32);
  362. end;
  363. {$ASMMODE ATT}
  364. {****************************************************************************
  365. Heap management releated routines.
  366. ****************************************************************************}
  367. {Get some memory.
  368. P = Pointer to memory will be returned here.
  369. Size = Number of bytes to get. The size is rounded up to a multiple
  370. of 4096. This is probably not the case on non-intel 386
  371. versions of OS/2.
  372. Flags = One or more of the mfXXXX constants.}
  373. function DosAllocMem(var P:pointer;Size,Flag:cardinal): cardinal; cdecl;
  374. external 'DOSCALLS' index 299;
  375. function DosSetMem(P:pointer;Size,Flag:cardinal): cardinal; cdecl;
  376. external 'DOSCALLS' index 305;
  377. var
  378. Int_Heap_End: pointer;
  379. Int_Heap: pointer;
  380. {$IFNDEF VER1_0}
  381. external name 'HEAP';
  382. {$ENDIF VER1_0}
  383. Int_HeapSize: cardinal; external name 'HEAPSIZE';
  384. PreviousHeap: cardinal;
  385. AllocatedMemory: cardinal;
  386. function GetHeapSize: longint;
  387. begin
  388. GetHeapSize := PreviousHeap + longint (Int_Heap_End) - longint (Int_Heap);
  389. end;
  390. function Sbrk (Size: longint): pointer;
  391. var
  392. P: pointer;
  393. RC: cardinal;
  394. const
  395. MemAllocBlock = 4 * 1024 * 1024;
  396. begin
  397. {$IFDEF DUMPGROW}
  398. WriteLn ('Trying to grow heap by ', Size, ' to ', HeapSize + Size);
  399. {$ENDIF}
  400. // commit memory
  401. RC := DosSetMem (Int_Heap_End, Size, $13);
  402. if RC <> 0 then
  403. (* Not enough memory was allocated - let's try to allocate more
  404. (4 MB steps or as much as requested if more than 4 MB needed). *)
  405. begin
  406. if Size > MemAllocBlock then
  407. begin
  408. RC := DosAllocMem (P, Size, 3);
  409. if RC = 0 then Inc (AllocatedMemory, Size);
  410. end
  411. else
  412. begin
  413. RC := DosAllocMem (P, MemAllocBlock, 3);
  414. if RC = 0 then Inc (AllocatedMemory, MemAllocBlock);
  415. end;
  416. if RC = 0 then
  417. begin
  418. PreviousHeap := GetHeapSize;
  419. Int_Heap := P;
  420. Int_Heap_End := P;
  421. RC := DosSetMem (Int_Heap_End, Size, $13);
  422. end
  423. else
  424. begin
  425. Sbrk := nil;
  426. {$IFDEF DUMPGROW}
  427. WriteLn ('Error ', RC, ' during additional memory allocation!');
  428. WriteLn ('Total allocated memory is ', cardinal (AllocatedMemory), ', ',
  429. GetHeapSize, ' committed.');
  430. {$ENDIF DUMPGROW}
  431. Exit;
  432. end;
  433. end;
  434. if RC <> 0 then
  435. begin
  436. {$IFDEF DUMPGROW}
  437. WriteLn ('Error ', RC, ' while trying to commit more memory!');
  438. WriteLn ('Current memory object starts at ', cardinal (Int_Heap),
  439. ' and committed until ', cardinal (Int_Heap_End));
  440. WriteLn ('Total allocated memory is ', cardinal (AllocatedMemory), ', ',
  441. GetHeapSize, ' committed.');
  442. {$ENDIF DUMPGROW}
  443. Sbrk := nil;
  444. end
  445. else
  446. begin
  447. Sbrk := Int_Heap_End;
  448. {$IFDEF DUMPGROW}
  449. WriteLn ('New heap at ', cardinal (Int_Heap_End));
  450. {$ENDIF DUMPGROW}
  451. Inc (Int_Heap_End, Size);
  452. end;
  453. end;
  454. function GetHeapStart: pointer;
  455. begin
  456. GetHeapStart := Int_Heap;
  457. end;
  458. {$i heap.inc}
  459. {****************************************************************************
  460. Low Level File Routines
  461. ****************************************************************************}
  462. procedure allowslash(p:Pchar);
  463. {Allow slash as backslash.}
  464. var i:longint;
  465. begin
  466. for i:=0 to strlen(p) do
  467. if p[i]='/' then p[i]:='\';
  468. end;
  469. procedure do_close(h:longint);
  470. begin
  471. { Only three standard handles under real OS/2 }
  472. if h>2 then
  473. begin
  474. InOutRes:=DosClose(h);
  475. end;
  476. {$ifdef IODEBUG}
  477. writeln('do_close: handle=', H, ', InOutRes=', InOutRes);
  478. {$endif}
  479. end;
  480. procedure do_erase(p:Pchar);
  481. begin
  482. allowslash(p);
  483. inoutres:=DosDelete(p);
  484. end;
  485. procedure do_rename(p1,p2:Pchar);
  486. begin
  487. allowslash(p1);
  488. allowslash(p2);
  489. inoutres:=DosMove(p1, p2);
  490. end;
  491. function do_read(h:longint;addr:pointer;len:longint):longint;
  492. Var
  493. T: cardinal;
  494. begin
  495. {$ifdef IODEBUG}
  496. write('do_read: handle=', h, ', addr=', ptrint(addr), ', length=', len);
  497. {$endif}
  498. InOutRes:=DosRead(H, Addr, Len, T);
  499. do_read:= longint (T);
  500. {$ifdef IODEBUG}
  501. writeln(', actual_len=', t, ', InOutRes=', InOutRes);
  502. {$endif}
  503. end;
  504. function do_write(h:longint;addr:pointer;len:longint) : longint;
  505. Var
  506. T: cardinal;
  507. begin
  508. {$ifdef IODEBUG}
  509. write('do_write: handle=', h, ', addr=', ptrint(addr), ', length=', len);
  510. {$endif}
  511. InOutRes:=DosWrite(H, Addr, Len, T);
  512. do_write:= longint (T);
  513. {$ifdef IODEBUG}
  514. writeln(', actual_len=', t, ', InOutRes=', InOutRes);
  515. {$endif}
  516. end;
  517. function do_filepos(handle:longint): longint;
  518. var
  519. PosActual: cardinal;
  520. begin
  521. InOutRes:=DosSetFilePtr(Handle, 0, 1, PosActual);
  522. do_filepos:=longint (PosActual);
  523. {$ifdef IODEBUG}
  524. writeln('do_filepos: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  525. {$endif}
  526. end;
  527. procedure do_seek(handle,pos:longint);
  528. var
  529. PosActual: cardinal;
  530. begin
  531. InOutRes:=DosSetFilePtr(Handle, Pos, 0 {ZeroBased}, PosActual);
  532. {$ifdef IODEBUG}
  533. writeln('do_seek: handle=', Handle, ', pos=', pos, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  534. {$endif}
  535. end;
  536. function do_seekend(handle:longint):longint;
  537. var
  538. PosActual: cardinal;
  539. begin
  540. InOutRes:=DosSetFilePtr(Handle, 0, 2 {EndBased}, PosActual);
  541. do_seekend:=longint (PosActual);
  542. {$ifdef IODEBUG}
  543. writeln('do_seekend: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
  544. {$endif}
  545. end;
  546. function do_filesize(handle:longint):longint;
  547. var aktfilepos: cardinal;
  548. begin
  549. aktfilepos:=do_filepos(handle);
  550. do_filesize:=do_seekend(handle);
  551. do_seek(handle,aktfilepos);
  552. end;
  553. procedure do_truncate(handle,pos:longint);
  554. begin
  555. InOutRes:=DosSetFileSize(Handle, Pos);
  556. do_seekend(handle);
  557. end;
  558. const
  559. FileHandleCount: cardinal = 20;
  560. function Increase_File_Handle_Count: boolean;
  561. var Err: word;
  562. L1: longint;
  563. L2: cardinal;
  564. begin
  565. L1 := 10;
  566. if DosSetRelMaxFH (L1, L2) <> 0 then
  567. Increase_File_Handle_Count := false
  568. else
  569. if L2 > FileHandleCount then
  570. begin
  571. FileHandleCount := L2;
  572. Increase_File_Handle_Count := true;
  573. end
  574. else
  575. Increase_File_Handle_Count := false;
  576. end;
  577. procedure do_open(var f;p:pchar;flags:longint);
  578. {
  579. filerec and textrec have both handle and mode as the first items so
  580. they could use the same routine for opening/creating.
  581. when (flags and $100) the file will be append
  582. when (flags and $1000) the file will be truncate/rewritten
  583. when (flags and $10000) there is no check for close (needed for textfiles)
  584. }
  585. var
  586. Action, Attrib, OpenFlags, FM: Cardinal;
  587. begin
  588. // convert unix slashes to normal slashes
  589. allowslash(p);
  590. // close first if opened
  591. if ((flags and $10000)=0) then
  592. begin
  593. case filerec(f).mode of
  594. fminput,fmoutput,fminout : Do_Close(filerec(f).handle);
  595. fmclosed:;
  596. else
  597. begin
  598. inoutres:=102; {not assigned}
  599. exit;
  600. end;
  601. end;
  602. end;
  603. // reset file handle
  604. filerec(f).handle := UnusedHandle;
  605. Attrib:=0;
  606. OpenFlags:=0;
  607. // convert filesharing
  608. FM := Flags and $FF and not (8);
  609. (* DenyNone if sharing not specified. *)
  610. if FM and 112 = 0 then
  611. FM := FM or 64;
  612. // convert filemode to filerec modes and access mode
  613. case (FM and 3) of
  614. 0: filerec(f).mode:=fminput;
  615. 1: filerec(f).mode:=fmoutput;
  616. 2: filerec(f).mode:=fminout;
  617. end;
  618. if (flags and $1000)<>0 then
  619. OpenFlags:=OpenFlags or 2 {doOverwrite} or 16 {doCreate} // Create/overwrite
  620. else
  621. OpenFlags:=OpenFlags or 1 {doOpen}; // Open existing
  622. // Handle Std I/O
  623. if p[0]=#0 then
  624. begin
  625. case FileRec(f).mode of
  626. fminput :
  627. FileRec(f).Handle:=StdInputHandle;
  628. fminout, // this is set by rewrite
  629. fmoutput :
  630. FileRec(f).Handle:=StdOutputHandle;
  631. fmappend :
  632. begin
  633. FileRec(f).Handle:=StdOutputHandle;
  634. FileRec(f).mode:=fmoutput; // fool fmappend
  635. end;
  636. end;
  637. exit;
  638. end;
  639. Attrib:=32 {faArchive};
  640. InOutRes:=DosOpen(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
  641. // If too many open files try to set more file handles and open again
  642. if (InOutRes = 4) then
  643. if Increase_File_Handle_Count then
  644. InOutRes:=DosOpen(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
  645. If InOutRes<>0 then FileRec(F).Handle:=UnusedHandle;
  646. // If Handle created -> make some things
  647. if (FileRec(F).Handle <> UnusedHandle) then
  648. begin
  649. // Move to end of file for Append command
  650. if ((Flags and $100) <> 0) then
  651. begin
  652. do_seekend(FileRec(F).Handle);
  653. FileRec(F).Mode := fmOutput;
  654. end;
  655. end;
  656. {$ifdef IODEBUG}
  657. writeln('do_open,', filerec(f).handle, ',', filerec(f).name, ',', filerec(f).mode, ', InOutRes=', InOutRes);
  658. {$endif}
  659. end;
  660. function do_isdevice (Handle: longint): boolean;
  661. var
  662. HT, Attr: cardinal;
  663. begin
  664. do_isdevice:=false;
  665. If DosQueryHType(Handle, HT, Attr)<>0 then exit;
  666. if ht=1 then do_isdevice:=true;
  667. end;
  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 strcopy(dest,source : pchar) : pchar;assembler;
  930. var
  931. saveeax,saveesi,saveedi : longint;
  932. asm
  933. movl %edi,saveedi
  934. movl %esi,saveesi
  935. {$ifdef REGCALL}
  936. movl %eax,saveeax
  937. movl %edx,%edi
  938. {$else}
  939. movl source,%edi
  940. {$endif}
  941. testl %edi,%edi
  942. jz .LStrCopyDone
  943. leal 3(%edi),%ecx
  944. andl $-4,%ecx
  945. movl %edi,%esi
  946. subl %edi,%ecx
  947. {$ifdef REGCALL}
  948. movl %eax,%edi
  949. {$else}
  950. movl dest,%edi
  951. {$endif}
  952. jz .LStrCopyAligned
  953. .LStrCopyAlignLoop:
  954. movb (%esi),%al
  955. incl %edi
  956. incl %esi
  957. testb %al,%al
  958. movb %al,-1(%edi)
  959. jz .LStrCopyDone
  960. decl %ecx
  961. jnz .LStrCopyAlignLoop
  962. .balign 16
  963. .LStrCopyAligned:
  964. movl (%esi),%eax
  965. movl %eax,%edx
  966. leal 0x0fefefeff(%eax),%ecx
  967. notl %edx
  968. addl $4,%esi
  969. andl %edx,%ecx
  970. andl $0x080808080,%ecx
  971. jnz .LStrCopyEndFound
  972. movl %eax,(%edi)
  973. addl $4,%edi
  974. jmp .LStrCopyAligned
  975. .LStrCopyEndFound:
  976. testl $0x0ff,%eax
  977. jz .LStrCopyByte
  978. testl $0x0ff00,%eax
  979. jz .LStrCopyWord
  980. testl $0x0ff0000,%eax
  981. jz .LStrCopy3Bytes
  982. movl %eax,(%edi)
  983. jmp .LStrCopyDone
  984. .LStrCopy3Bytes:
  985. xorb %dl,%dl
  986. movw %ax,(%edi)
  987. movb %dl,2(%edi)
  988. jmp .LStrCopyDone
  989. .LStrCopyWord:
  990. movw %ax,(%edi)
  991. jmp .LStrCopyDone
  992. .LStrCopyByte:
  993. movb %al,(%edi)
  994. .LStrCopyDone:
  995. {$ifdef REGCALL}
  996. movl saveeax,%eax
  997. {$else}
  998. movl dest,%eax
  999. {$endif}
  1000. movl saveedi,%edi
  1001. movl saveesi,%esi
  1002. end;
  1003. procedure InitEnvironment;
  1004. var env_count : longint;
  1005. dos_env,cp : pchar;
  1006. begin
  1007. env_count:=0;
  1008. cp:=environment;
  1009. while cp ^ <> #0 do
  1010. begin
  1011. inc(env_count);
  1012. while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
  1013. inc(longint(cp)); { skip to next character }
  1014. end;
  1015. envp := sysgetmem((env_count+1) * sizeof(pchar));
  1016. envc := env_count;
  1017. if (envp = nil) then exit;
  1018. cp:=environment;
  1019. env_count:=0;
  1020. while cp^ <> #0 do
  1021. begin
  1022. envp[env_count] := sysgetmem(strlen(cp)+1);
  1023. strcopy(envp[env_count], cp);
  1024. {$IfDef DEBUGENVIRONMENT}
  1025. Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"');
  1026. {$EndIf}
  1027. inc(env_count);
  1028. while (cp^ <> #0) do
  1029. inc(longint(cp)); { skip to NUL }
  1030. inc(longint(cp)); { skip to next character }
  1031. end;
  1032. envp[env_count]:=nil;
  1033. end;
  1034. procedure InitArguments;
  1035. var
  1036. arglen,
  1037. count : longint;
  1038. argstart,
  1039. pc,arg : pchar;
  1040. quote : char;
  1041. argvlen : longint;
  1042. procedure allocarg(idx,len:longint);
  1043. begin
  1044. if idx>=argvlen then
  1045. begin
  1046. argvlen:=(idx+8) and (not 7);
  1047. sysreallocmem(argv,argvlen*sizeof(pointer));
  1048. end;
  1049. { use realloc to reuse already existing memory }
  1050. { always allocate, even if length is zero, since }
  1051. { the arg. is still present! }
  1052. sysreallocmem(argv[idx],len+1);
  1053. end;
  1054. begin
  1055. count:=0;
  1056. argv:=nil;
  1057. argvlen:=0;
  1058. // Get argv[0]
  1059. pc:=cmdline;
  1060. Arglen:=0;
  1061. repeat
  1062. Inc(Arglen);
  1063. until (pc[Arglen]=#0);
  1064. allocarg(count,arglen);
  1065. move(pc^,argv[count]^,arglen);
  1066. { ReSetup cmdline variable }
  1067. repeat
  1068. Inc(Arglen);
  1069. until (pc[Arglen]=#0);
  1070. Inc(Arglen);
  1071. pc:=GetMem(ArgLen);
  1072. move(cmdline^, pc^, arglen);
  1073. Arglen:=0;
  1074. repeat
  1075. Inc(Arglen);
  1076. until (pc[Arglen]=#0);
  1077. pc[Arglen]:=' '; // combine argv[0] and command line
  1078. CmdLine:=pc;
  1079. { process arguments }
  1080. pc:=cmdline;
  1081. {$IfDef DEBUGARGUMENTS}
  1082. Writeln(stderr,'GetCommandLine is #',pc,'#');
  1083. {$EndIf }
  1084. while pc^<>#0 do
  1085. begin
  1086. { skip leading spaces }
  1087. while pc^ in [#1..#32] do
  1088. inc(pc);
  1089. if pc^=#0 then
  1090. break;
  1091. { calc argument length }
  1092. quote:=' ';
  1093. argstart:=pc;
  1094. arglen:=0;
  1095. while (pc^<>#0) do
  1096. begin
  1097. case pc^ of
  1098. #1..#32 :
  1099. begin
  1100. if quote<>' ' then
  1101. inc(arglen)
  1102. else
  1103. break;
  1104. end;
  1105. '"' :
  1106. begin
  1107. if quote<>'''' then
  1108. begin
  1109. if pchar(pc+1)^<>'"' then
  1110. begin
  1111. if quote='"' then
  1112. quote:=' '
  1113. else
  1114. quote:='"';
  1115. end
  1116. else
  1117. inc(pc);
  1118. end
  1119. else
  1120. inc(arglen);
  1121. end;
  1122. '''' :
  1123. begin
  1124. if quote<>'"' then
  1125. begin
  1126. if pchar(pc+1)^<>'''' then
  1127. begin
  1128. if quote='''' then
  1129. quote:=' '
  1130. else
  1131. quote:='''';
  1132. end
  1133. else
  1134. inc(pc);
  1135. end
  1136. else
  1137. inc(arglen);
  1138. end;
  1139. else
  1140. inc(arglen);
  1141. end;
  1142. inc(pc);
  1143. end;
  1144. { copy argument }
  1145. { Don't copy the first one, it is already there.}
  1146. If Count<>0 then
  1147. begin
  1148. allocarg(count,arglen);
  1149. quote:=' ';
  1150. pc:=argstart;
  1151. arg:=argv[count];
  1152. while (pc^<>#0) do
  1153. begin
  1154. case pc^ of
  1155. #1..#32 :
  1156. begin
  1157. if quote<>' ' then
  1158. begin
  1159. arg^:=pc^;
  1160. inc(arg);
  1161. end
  1162. else
  1163. break;
  1164. end;
  1165. '"' :
  1166. begin
  1167. if quote<>'''' then
  1168. begin
  1169. if pchar(pc+1)^<>'"' then
  1170. begin
  1171. if quote='"' then
  1172. quote:=' '
  1173. else
  1174. quote:='"';
  1175. end
  1176. else
  1177. inc(pc);
  1178. end
  1179. else
  1180. begin
  1181. arg^:=pc^;
  1182. inc(arg);
  1183. end;
  1184. end;
  1185. '''' :
  1186. begin
  1187. if quote<>'"' then
  1188. begin
  1189. if pchar(pc+1)^<>'''' then
  1190. begin
  1191. if quote='''' then
  1192. quote:=' '
  1193. else
  1194. quote:='''';
  1195. end
  1196. else
  1197. inc(pc);
  1198. end
  1199. else
  1200. begin
  1201. arg^:=pc^;
  1202. inc(arg);
  1203. end;
  1204. end;
  1205. else
  1206. begin
  1207. arg^:=pc^;
  1208. inc(arg);
  1209. end;
  1210. end;
  1211. inc(pc);
  1212. end;
  1213. arg^:=#0;
  1214. end;
  1215. {$IfDef DEBUGARGUMENTS}
  1216. Writeln(stderr,'dos arg ',count,' #',arglen,'#',argv[count],'#');
  1217. {$EndIf}
  1218. inc(count);
  1219. end;
  1220. { get argc and create an nil entry }
  1221. argc:=count;
  1222. allocarg(argc,0);
  1223. { free unused memory }
  1224. sysreallocmem(argv,(argc+1)*sizeof(pointer));
  1225. end;
  1226. function GetFileHandleCount: longint;
  1227. var L1: longint;
  1228. L2: cardinal;
  1229. begin
  1230. L1 := 0; (* Don't change the amount, just check. *)
  1231. if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
  1232. else GetFileHandleCount := L2;
  1233. end;
  1234. var TIB: PThreadInfoBlock;
  1235. PIB: PProcessInfoBlock;
  1236. RC: cardinal;
  1237. ErrStr: string;
  1238. begin
  1239. IsLibrary := FALSE;
  1240. (* Initialize the amount of file handles *)
  1241. FileHandleCount := GetFileHandleCount;
  1242. DosGetInfoBlocks (@TIB, @PIB);
  1243. StackBottom := TIB^.Stack;
  1244. {Set type of application}
  1245. ApplicationType := PIB^.ProcType;
  1246. ProcessID := PIB^.PID;
  1247. ThreadID := TIB^.TIB2^.TID;
  1248. IsConsole := ApplicationType <> 3;
  1249. exitproc:=nil;
  1250. {Initialize the heap.}
  1251. // Logic is following:
  1252. // Application allocates the amount of memory specified by the compiler
  1253. // switch -Ch but without commiting. On heap growing required amount of
  1254. // memory commited. More memory is allocated as needed within sbrk.
  1255. RC := DosAllocMem (Int_Heap, Int_HeapSize, 3);
  1256. if RC <> 0 then
  1257. begin
  1258. Str (RC, ErrStr);
  1259. ErrStr := 'Error during heap initialization (' + ErrStr + ')!!';
  1260. DosWrite (2, @ErrStr [1], Length (ErrStr), RC);
  1261. HandleError (204);
  1262. end;
  1263. AllocatedMemory := Int_HeapSize;
  1264. Int_Heap_End := Int_Heap;
  1265. PreviousHeap := 0;
  1266. InitHeap;
  1267. { ... and exceptions }
  1268. SysInitExceptions;
  1269. { ... and I/O }
  1270. SysInitStdIO;
  1271. { no I/O-Error }
  1272. inoutres:=0;
  1273. {Initialize environment (must be after InitHeap because allocates memory)}
  1274. Environment := pointer (PIB^.Env);
  1275. InitEnvironment;
  1276. CmdLine := pointer (PIB^.Cmd);
  1277. InitArguments;
  1278. {$ifdef HASVARIANT}
  1279. initvariantmanager;
  1280. {$endif HASVARIANT}
  1281. {$IFDEF DUMPGROW}
  1282. WriteLn ('Initial brk size is ', GetHeapSize);
  1283. {$ENDIF DUMPGROW}
  1284. end.
  1285. {
  1286. $Log$
  1287. Revision 1.70 2004-04-22 21:10:56 peter
  1288. * do_read/do_write addr argument changed to pointer
  1289. Revision 1.69 2004/03/24 19:23:09 hajny
  1290. * misleading warning removed
  1291. Revision 1.68 2004/03/24 19:15:59 hajny
  1292. * heap management modified to be able to grow heap as needed
  1293. Revision 1.67 2004/02/22 15:01:49 hajny
  1294. * lots of fixes (regcall, THandle, string operations in sysutils, longint2cardinal according to OS/2 docs, dosh.inc, ...)
  1295. Revision 1.66 2004/02/16 22:18:44 hajny
  1296. * LastDosExitCode changed back from threadvar temporarily
  1297. Revision 1.65 2004/02/02 03:24:09 yuri
  1298. - prt1.as removed
  1299. - removed tmporary code/comments
  1300. - prt1 compilation error workaround removed
  1301. Revision 1.64 2004/01/25 21:41:48 hajny
  1302. * reformatting of too long comment lines - not accepted by FP IDE
  1303. Revision 1.63 2004/01/21 14:15:42 florian
  1304. * fixed win32 compilation
  1305. Revision 1.62 2004/01/20 23:11:20 hajny
  1306. * ExecuteProcess fixes, ProcessID and ThreadID added
  1307. Revision 1.61 2003/12/04 21:22:38 peter
  1308. * regcall updates (untested)
  1309. Revision 1.60 2003/11/23 07:21:16 yuri
  1310. * native heap
  1311. Revision 1.59 2003/11/19 18:21:11 yuri
  1312. * Memory allocation bug fixed
  1313. Revision 1.58 2003/11/19 16:50:21 yuri
  1314. * Environment and arguments initialization now native
  1315. Revision 1.57 2003/11/06 17:20:44 yuri
  1316. * Unused constants removed
  1317. Revision 1.56 2003/11/03 09:42:28 marco
  1318. * Peter's Cardinal<->Longint fixes patch
  1319. Revision 1.55 2003/11/02 00:51:17 hajny
  1320. * corrections for do_open and os_mode back
  1321. Revision 1.54 2003/10/28 14:57:31 yuri
  1322. * do_* functions now native
  1323. Revision 1.53 2003/10/27 04:33:58 yuri
  1324. * os_mode removed (not required anymore)
  1325. Revision 1.52 2003/10/25 22:45:37 hajny
  1326. * file handling related fixes
  1327. Revision 1.51 2003/10/19 12:13:41 hajny
  1328. * UnusedHandle value made the same as with other targets
  1329. Revision 1.50 2003/10/19 09:37:00 hajny
  1330. * minor fix in non-default sbrk code
  1331. Revision 1.49 2003/10/19 09:06:28 hajny
  1332. * fix for terrible long-time bug in do_open
  1333. Revision 1.48 2003/10/18 16:58:39 hajny
  1334. * stdcall fixes again
  1335. Revision 1.47 2003/10/16 15:43:13 peter
  1336. * THandle is platform dependent
  1337. Revision 1.46 2003/10/14 21:10:06 hajny
  1338. * another longint2cardinal fix
  1339. Revision 1.45 2003/10/13 21:17:31 hajny
  1340. * longint to cardinal corrections
  1341. Revision 1.44 2003/10/12 18:07:30 hajny
  1342. * wrong use of Intel syntax
  1343. Revision 1.43 2003/10/12 17:59:40 hajny
  1344. * wrong use of Intel syntax
  1345. Revision 1.42 2003/10/12 17:52:28 hajny
  1346. * wrong use of Intel syntax
  1347. Revision 1.41 2003/10/12 10:45:36 hajny
  1348. * sbrk error handling corrected
  1349. Revision 1.40 2003/10/07 21:26:35 hajny
  1350. * stdcall fixes and asm routines cleanup
  1351. Revision 1.39 2003/10/06 16:58:27 yuri
  1352. * Another set of native functions.
  1353. Revision 1.38 2003/10/06 14:22:40 yuri
  1354. * Some emx code removed. Now withous so stupid error as with dos ;)
  1355. Revision 1.37 2003/10/04 08:30:59 yuri
  1356. * at&t syntax instead of intel syntax was used
  1357. Revision 1.36 2003/10/03 21:46:41 peter
  1358. * stdcall fixes
  1359. Revision 1.35 2003/10/01 18:42:49 yuri
  1360. * Unclosed comment
  1361. Revision 1.34 2003/09/29 18:39:59 hajny
  1362. * append fix applied to GO32v2, OS/2 and EMX
  1363. Revision 1.33 2003/09/27 11:52:36 peter
  1364. * sbrk returns pointer
  1365. Revision 1.32 2003/03/30 09:20:30 hajny
  1366. * platform extension unification
  1367. Revision 1.31 2003/01/15 22:16:12 hajny
  1368. * default sharing mode changed to DenyNone
  1369. Revision 1.30 2002/12/15 22:41:41 hajny
  1370. * First_Meg fixed + Environment initialization under Dos
  1371. Revision 1.29 2002/12/08 16:39:58 hajny
  1372. - WriteLn in GUI mode support commented out until fixed
  1373. Revision 1.28 2002/12/07 19:17:14 hajny
  1374. * GetEnv correction, better PM support, ...
  1375. Revision 1.27 2002/11/17 22:31:02 hajny
  1376. * type corrections (longint x cardinal)
  1377. Revision 1.26 2002/10/27 14:29:00 hajny
  1378. * heap management (hopefully) fixed
  1379. Revision 1.25 2002/10/14 19:39:17 peter
  1380. * threads unit added for thread support
  1381. Revision 1.24 2002/10/13 09:28:45 florian
  1382. + call to initvariantmanager inserted
  1383. Revision 1.23 2002/09/07 16:01:25 peter
  1384. * old logs removed and tabs fixed
  1385. Revision 1.22 2002/07/01 16:29:05 peter
  1386. * sLineBreak changed to normal constant like Kylix
  1387. Revision 1.21 2002/04/21 15:54:20 carl
  1388. + initialize some global variables
  1389. Revision 1.20 2002/04/12 17:42:16 carl
  1390. + generic stack checking
  1391. Revision 1.19 2002/03/11 19:10:33 peter
  1392. * Regenerated with updated fpcmake
  1393. Revision 1.18 2002/02/10 13:46:20 hajny
  1394. * heap management corrected (heap_brk)
  1395. }