system.pas 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957
  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 EOF_CTRLZ}
  22. { $DEFINE OS2EXCEPTIONS}
  23. {$I systemh.inc}
  24. {$IFDEF OS2EXCEPTIONS}
  25. (* Types and constants for exception handler support *)
  26. type
  27. {x} PEXCEPTION_FRAME = ^TEXCEPTION_FRAME;
  28. {x} TEXCEPTION_FRAME = record
  29. {x} next : PEXCEPTION_FRAME;
  30. {x} handler : pointer;
  31. {x} end;
  32. {$ENDIF OS2EXCEPTIONS}
  33. const
  34. LineEnding = #13#10;
  35. { LFNSupport is defined separately below!!! }
  36. DirectorySeparator = '\';
  37. DriveSeparator = ':';
  38. PathSeparator = ';';
  39. { FileNameCaseSensitive is defined separately below!!! }
  40. MaxExitCode = 65535;
  41. type Tos=(osDOS,osOS2,osDPMI);
  42. const os_mode: Tos = osOS2;
  43. first_meg: pointer = nil;
  44. {$IFDEF OS2EXCEPTIONS}
  45. {x} System_exception_frame : PEXCEPTION_FRAME =nil;
  46. {$ENDIF OS2EXCEPTIONS}
  47. type TByteArray = array [0..$ffff] of byte;
  48. PByteArray = ^TByteArray;
  49. TSysThreadIB = record
  50. TID,
  51. Priority,
  52. Version: cardinal;
  53. MCCount,
  54. MCForceFlag: word;
  55. end;
  56. PSysThreadIB = ^TSysThreadIB;
  57. TThreadInfoBlock = record
  58. PExChain,
  59. Stack,
  60. StackLimit: pointer;
  61. TIB2: PSysThreadIB;
  62. Version,
  63. Ordinal: cardinal;
  64. end;
  65. PThreadInfoBlock = ^TThreadInfoBlock;
  66. PPThreadInfoBlock = ^PThreadInfoBlock;
  67. TProcessInfoBlock = record
  68. PID,
  69. ParentPid,
  70. Handle: cardinal;
  71. Cmd,
  72. Env: PByteArray;
  73. Status,
  74. ProcType: cardinal;
  75. end;
  76. PProcessInfoBlock = ^TProcessInfoBlock;
  77. PPProcessInfoBlock = ^PProcessInfoBlock;
  78. const UnusedHandle=-1;
  79. StdInputHandle=0;
  80. StdOutputHandle=1;
  81. StdErrorHandle=2;
  82. LFNSupport: boolean = true;
  83. FileNameCaseSensitive: boolean = false;
  84. sLineBreak = LineEnding;
  85. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
  86. var
  87. { C-compatible arguments and environment }
  88. argc : longint;
  89. argv : ppchar;
  90. envp : ppchar;
  91. EnvC: cardinal;
  92. (* Pointer to the block of environment variables - used e.g. in unit Dos. *)
  93. Environment: PChar;
  94. var
  95. (* Type / run mode of the current process: *)
  96. (* 0 .. full screen OS/2 session *)
  97. (* 1 .. DOS session *)
  98. (* 2 .. VIO windowable OS/2 session *)
  99. (* 3 .. Presentation Manager OS/2 session *)
  100. (* 4 .. detached (background) OS/2 process *)
  101. ApplicationType: cardinal;
  102. (* Is allocation of memory above 512 MB address limit allowed? Initialized *)
  103. (* during initialization of system unit according to capabilities of the *)
  104. (* underlying OS/2 version, can be overridden by user - heap is allocated *)
  105. (* for all threads, so the setting isn't declared as a threadvar and *)
  106. (* should be only changed at the beginning of the main thread if needed. *)
  107. UseHighMem: boolean;
  108. procedure SetDefaultOS2FileType (FType: ShortString);
  109. procedure SetDefaultOS2Creator (Creator: ShortString);
  110. implementation
  111. {$I system.inc}
  112. {****************************************************************************
  113. Miscellaneous related routines.
  114. ****************************************************************************}
  115. procedure system_exit;
  116. begin
  117. DosFreeThreadLocalMemory (DataIndex);
  118. DosExit(1{process}, exitcode);
  119. end;
  120. {$ASMMODE ATT}
  121. function paramcount:longint;assembler;
  122. asm
  123. movl argc,%eax
  124. decl %eax
  125. end {['EAX']};
  126. function args:pointer;assembler;
  127. asm
  128. movl argv,%eax
  129. end {['EAX']};
  130. function paramstr(l:longint):string;
  131. var p:^Pchar;
  132. begin
  133. if (l>=0) and (l<=paramcount) then
  134. begin
  135. p:=args;
  136. paramstr:=strpas(p[l]);
  137. end
  138. else paramstr:='';
  139. end;
  140. procedure randomize;
  141. var
  142. dt: TSysDateTime;
  143. begin
  144. // Hmm... Lets use timer
  145. DosGetDateTime(dt);
  146. randseed:=dt.hour+(dt.minute shl 8)+(dt.second shl 16)+(dt.sec100 shl 32);
  147. end;
  148. {$ASMMODE ATT}
  149. {*****************************************************************************
  150. System unit initialization.
  151. ****************************************************************************}
  152. {****************************************************************************
  153. Error Message writing using messageboxes
  154. ****************************************************************************}
  155. type
  156. TWinMessageBox = function (Parent, Owner: cardinal;
  157. BoxText, BoxTitle: PChar; Identity, Style: cardinal): cardinal; cdecl;
  158. TWinInitialize = function (Options: cardinal): cardinal; cdecl;
  159. TWinCreateMsgQueue = function (Handle: cardinal; cmsg: longint): cardinal;
  160. cdecl;
  161. const
  162. ErrorBufferLength = 1024;
  163. mb_OK = $0000;
  164. mb_Error = $0040;
  165. mb_Moveable = $4000;
  166. MBStyle = mb_OK or mb_Error or mb_Moveable;
  167. WinInitialize: TWinInitialize = nil;
  168. WinCreateMsgQueue: TWinCreateMsgQueue = nil;
  169. WinMessageBox: TWinMessageBox = nil;
  170. EnvSize: cardinal = 0;
  171. var
  172. ErrorBuf: array [0..ErrorBufferLength] of char;
  173. ErrorLen: longint;
  174. PMWinHandle: cardinal;
  175. function ErrorWrite (var F: TextRec): integer;
  176. {
  177. An error message should always end with #13#10#13#10
  178. }
  179. var
  180. P: PChar;
  181. I: longint;
  182. begin
  183. if F.BufPos > 0 then
  184. begin
  185. if F.BufPos + ErrorLen > ErrorBufferLength then
  186. I := ErrorBufferLength - ErrorLen
  187. else
  188. I := F.BufPos;
  189. Move (F.BufPtr^, ErrorBuf [ErrorLen], I);
  190. Inc (ErrorLen, I);
  191. ErrorBuf [ErrorLen] := #0;
  192. end;
  193. if ErrorLen > 3 then
  194. begin
  195. P := @ErrorBuf [ErrorLen];
  196. for I := 1 to 4 do
  197. begin
  198. Dec (P);
  199. if not (P^ in [#10, #13]) then
  200. break;
  201. end;
  202. end;
  203. if ErrorLen = ErrorBufferLength then
  204. I := 4;
  205. if (I = 4) then
  206. begin
  207. WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
  208. ErrorLen := 0;
  209. end;
  210. F.BufPos := 0;
  211. ErrorWrite := 0;
  212. end;
  213. function ErrorClose (var F: TextRec): integer;
  214. begin
  215. if ErrorLen > 0 then
  216. begin
  217. WinMessageBox (0, 0, @ErrorBuf, PChar ('Error'), 0, MBStyle);
  218. ErrorLen := 0;
  219. end;
  220. ErrorLen := 0;
  221. ErrorClose := 0;
  222. end;
  223. function ErrorOpen (var F: TextRec): integer;
  224. begin
  225. TextRec(F).InOutFunc := @ErrorWrite;
  226. TextRec(F).FlushFunc := @ErrorWrite;
  227. TextRec(F).CloseFunc := @ErrorClose;
  228. ErrorOpen := 0;
  229. end;
  230. procedure AssignError (var T: Text);
  231. begin
  232. Assign (T, '');
  233. TextRec (T).OpenFunc := @ErrorOpen;
  234. Rewrite (T);
  235. end;
  236. procedure SysInitStdIO;
  237. begin
  238. { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
  239. displayed in a messagebox }
  240. (*
  241. StdInputHandle := longint(GetStdHandle(cardinal(STD_INPUT_HANDLE)));
  242. StdOutputHandle := longint(GetStdHandle(cardinal(STD_OUTPUT_HANDLE)));
  243. StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
  244. if not IsConsole then
  245. begin
  246. if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and
  247. (DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0)
  248. and
  249. (DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0)
  250. and
  251. (DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue))
  252. = 0)
  253. then
  254. begin
  255. WinInitialize (0);
  256. WinCreateMsgQueue (0, 0);
  257. end
  258. else
  259. HandleError (2);
  260. AssignError (StdErr);
  261. AssignError (StdOut);
  262. Assign (Output, '');
  263. Assign (Input, '');
  264. end
  265. else
  266. begin
  267. *)
  268. OpenStdIO (Input, fmInput, StdInputHandle);
  269. OpenStdIO (Output, fmOutput, StdOutputHandle);
  270. OpenStdIO (ErrOutput, fmOutput, StdErrorHandle);
  271. OpenStdIO (StdOut, fmOutput, StdOutputHandle);
  272. OpenStdIO (StdErr, fmOutput, StdErrorHandle);
  273. (*
  274. end;
  275. *)
  276. end;
  277. function strcopy(dest,source : pchar) : pchar;assembler;
  278. var
  279. saveeax,saveesi,saveedi : longint;
  280. asm
  281. movl %edi,saveedi
  282. movl %esi,saveesi
  283. {$ifdef REGCALL}
  284. movl %eax,saveeax
  285. movl %edx,%edi
  286. {$else}
  287. movl source,%edi
  288. {$endif}
  289. testl %edi,%edi
  290. jz .LStrCopyDone
  291. leal 3(%edi),%ecx
  292. andl $-4,%ecx
  293. movl %edi,%esi
  294. subl %edi,%ecx
  295. {$ifdef REGCALL}
  296. movl %eax,%edi
  297. {$else}
  298. movl dest,%edi
  299. {$endif}
  300. jz .LStrCopyAligned
  301. .LStrCopyAlignLoop:
  302. movb (%esi),%al
  303. incl %edi
  304. incl %esi
  305. testb %al,%al
  306. movb %al,-1(%edi)
  307. jz .LStrCopyDone
  308. decl %ecx
  309. jnz .LStrCopyAlignLoop
  310. .balign 16
  311. .LStrCopyAligned:
  312. movl (%esi),%eax
  313. movl %eax,%edx
  314. leal 0x0fefefeff(%eax),%ecx
  315. notl %edx
  316. addl $4,%esi
  317. andl %edx,%ecx
  318. andl $0x080808080,%ecx
  319. jnz .LStrCopyEndFound
  320. movl %eax,(%edi)
  321. addl $4,%edi
  322. jmp .LStrCopyAligned
  323. .LStrCopyEndFound:
  324. testl $0x0ff,%eax
  325. jz .LStrCopyByte
  326. testl $0x0ff00,%eax
  327. jz .LStrCopyWord
  328. testl $0x0ff0000,%eax
  329. jz .LStrCopy3Bytes
  330. movl %eax,(%edi)
  331. jmp .LStrCopyDone
  332. .LStrCopy3Bytes:
  333. xorb %dl,%dl
  334. movw %ax,(%edi)
  335. movb %dl,2(%edi)
  336. jmp .LStrCopyDone
  337. .LStrCopyWord:
  338. movw %ax,(%edi)
  339. jmp .LStrCopyDone
  340. .LStrCopyByte:
  341. movb %al,(%edi)
  342. .LStrCopyDone:
  343. {$ifdef REGCALL}
  344. movl saveeax,%eax
  345. {$else}
  346. movl dest,%eax
  347. {$endif}
  348. movl saveedi,%edi
  349. movl saveesi,%esi
  350. end;
  351. {$ifdef HASTHREADVAR}
  352. threadvar
  353. {$else HASTHREADVAR}
  354. var
  355. {$endif HASTHREADVAR}
  356. DefaultCreator: ShortString;
  357. DefaultFileType: ShortString;
  358. procedure SetDefaultOS2FileType (FType: ShortString);
  359. begin
  360. {$WARNING Not implemented yet!}
  361. DefaultFileType := FType;
  362. end;
  363. procedure SetDefaultOS2Creator (Creator: ShortString);
  364. begin
  365. {$WARNING Not implemented yet!}
  366. DefaultCreator := Creator;
  367. end;
  368. procedure InitEnvironment;
  369. var env_count : longint;
  370. dos_env,cp : pchar;
  371. begin
  372. env_count:=0;
  373. cp:=environment;
  374. while cp ^ <> #0 do
  375. begin
  376. inc(env_count);
  377. while (cp^ <> #0) do inc(longint(cp)); { skip to NUL }
  378. inc(longint(cp)); { skip to next character }
  379. end;
  380. envp := sysgetmem((env_count+1) * sizeof(pchar));
  381. envc := env_count;
  382. if (envp = nil) then exit;
  383. cp:=environment;
  384. env_count:=0;
  385. while cp^ <> #0 do
  386. begin
  387. envp[env_count] := sysgetmem(strlen(cp)+1);
  388. strcopy(envp[env_count], cp);
  389. {$IfDef DEBUGENVIRONMENT}
  390. Writeln(stderr,'env ',env_count,' = "',envp[env_count],'"');
  391. {$EndIf}
  392. inc(env_count);
  393. while (cp^ <> #0) do
  394. inc(longint(cp)); { skip to NUL }
  395. inc(longint(cp)); { skip to next character }
  396. end;
  397. envp[env_count]:=nil;
  398. end;
  399. procedure InitArguments;
  400. var
  401. arglen,
  402. count : longint;
  403. argstart,
  404. pc,arg : pchar;
  405. quote : char;
  406. argvlen : longint;
  407. procedure allocarg(idx,len:longint);
  408. begin
  409. if idx>=argvlen then
  410. begin
  411. argvlen:=(idx+8) and (not 7);
  412. sysreallocmem(argv,argvlen*sizeof(pointer));
  413. end;
  414. { use realloc to reuse already existing memory }
  415. { always allocate, even if length is zero, since }
  416. { the arg. is still present! }
  417. sysreallocmem(argv[idx],len+1);
  418. end;
  419. begin
  420. count:=0;
  421. argv:=nil;
  422. argvlen:=0;
  423. // Get argv[0]
  424. pc:=cmdline;
  425. Arglen:=0;
  426. repeat
  427. Inc(Arglen);
  428. until (pc[Arglen]=#0);
  429. allocarg(count,arglen);
  430. move(pc^,argv[count]^,arglen);
  431. { ReSetup cmdline variable }
  432. repeat
  433. Inc(Arglen);
  434. until (pc[Arglen]=#0);
  435. Inc(Arglen);
  436. pc:=GetMem(ArgLen);
  437. move(cmdline^, pc^, arglen);
  438. Arglen:=0;
  439. repeat
  440. Inc(Arglen);
  441. until (pc[Arglen]=#0);
  442. pc[Arglen]:=' '; // combine argv[0] and command line
  443. CmdLine:=pc;
  444. { process arguments }
  445. pc:=cmdline;
  446. {$IfDef DEBUGARGUMENTS}
  447. Writeln(stderr,'GetCommandLine is #',pc,'#');
  448. {$EndIf }
  449. while pc^<>#0 do
  450. begin
  451. { skip leading spaces }
  452. while pc^ in [#1..#32] do
  453. inc(pc);
  454. if pc^=#0 then
  455. break;
  456. { calc argument length }
  457. quote:=' ';
  458. argstart:=pc;
  459. arglen:=0;
  460. while (pc^<>#0) do
  461. begin
  462. case pc^ of
  463. #1..#32 :
  464. begin
  465. if quote<>' ' then
  466. inc(arglen)
  467. else
  468. break;
  469. end;
  470. '"' :
  471. begin
  472. if quote<>'''' then
  473. begin
  474. if pchar(pc+1)^<>'"' then
  475. begin
  476. if quote='"' then
  477. quote:=' '
  478. else
  479. quote:='"';
  480. end
  481. else
  482. inc(pc);
  483. end
  484. else
  485. inc(arglen);
  486. end;
  487. '''' :
  488. begin
  489. if quote<>'"' then
  490. begin
  491. if pchar(pc+1)^<>'''' then
  492. begin
  493. if quote='''' then
  494. quote:=' '
  495. else
  496. quote:='''';
  497. end
  498. else
  499. inc(pc);
  500. end
  501. else
  502. inc(arglen);
  503. end;
  504. else
  505. inc(arglen);
  506. end;
  507. inc(pc);
  508. end;
  509. { copy argument }
  510. { Don't copy the first one, it is already there.}
  511. If Count<>0 then
  512. begin
  513. allocarg(count,arglen);
  514. quote:=' ';
  515. pc:=argstart;
  516. arg:=argv[count];
  517. while (pc^<>#0) do
  518. begin
  519. case pc^ of
  520. #1..#32 :
  521. begin
  522. if quote<>' ' then
  523. begin
  524. arg^:=pc^;
  525. inc(arg);
  526. end
  527. else
  528. break;
  529. end;
  530. '"' :
  531. begin
  532. if quote<>'''' then
  533. begin
  534. if pchar(pc+1)^<>'"' then
  535. begin
  536. if quote='"' then
  537. quote:=' '
  538. else
  539. quote:='"';
  540. end
  541. else
  542. inc(pc);
  543. end
  544. else
  545. begin
  546. arg^:=pc^;
  547. inc(arg);
  548. end;
  549. end;
  550. '''' :
  551. begin
  552. if quote<>'"' then
  553. begin
  554. if pchar(pc+1)^<>'''' then
  555. begin
  556. if quote='''' then
  557. quote:=' '
  558. else
  559. quote:='''';
  560. end
  561. else
  562. inc(pc);
  563. end
  564. else
  565. begin
  566. arg^:=pc^;
  567. inc(arg);
  568. end;
  569. end;
  570. else
  571. begin
  572. arg^:=pc^;
  573. inc(arg);
  574. end;
  575. end;
  576. inc(pc);
  577. end;
  578. arg^:=#0;
  579. end;
  580. {$IfDef DEBUGARGUMENTS}
  581. Writeln(stderr,'dos arg ',count,' #',arglen,'#',argv[count],'#');
  582. {$EndIf}
  583. inc(count);
  584. end;
  585. { get argc and create an nil entry }
  586. argc:=count;
  587. allocarg(argc,0);
  588. { free unused memory }
  589. sysreallocmem(argv,(argc+1)*sizeof(pointer));
  590. end;
  591. function GetFileHandleCount: longint;
  592. var L1: longint;
  593. L2: cardinal;
  594. begin
  595. L1 := 0; (* Don't change the amount, just check. *)
  596. if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50
  597. else GetFileHandleCount := L2;
  598. end;
  599. var TIB: PThreadInfoBlock;
  600. PIB: PProcessInfoBlock;
  601. RC: cardinal;
  602. ErrStr: string;
  603. P: pointer;
  604. begin
  605. IsLibrary := FALSE;
  606. (* Initialize the amount of file handles *)
  607. FileHandleCount := GetFileHandleCount;
  608. DosGetInfoBlocks (@TIB, @PIB);
  609. StackBottom := TIB^.Stack;
  610. {Set type of application}
  611. ApplicationType := PIB^.ProcType;
  612. ProcessID := PIB^.PID;
  613. ThreadID := TIB^.TIB2^.TID;
  614. IsConsole := ApplicationType <> 3;
  615. ExitProc := nil;
  616. {Initialize the heap.}
  617. (* Logic is following:
  618. The heap is initially restricted to low address space (< 512 MB).
  619. If underlying OS/2 version allows using more than 512 MB per process
  620. (OS/2 WarpServer for e-Business, eComStation, possibly OS/2 Warp 4.0
  621. with FP13 and above as well), use of this high memory is allowed for
  622. future memory allocations at the end of System unit initialization.
  623. The consequences are that the compiled application can allocate more
  624. memory, but it must make sure to use direct DosAllocMem calls if it
  625. needs a memory block for some system API not supporting high memory.
  626. This is probably no problem for direct calls to these APIs, but
  627. there might be situations when a memory block needs to be passed
  628. to a 3rd party DLL which in turn calls such an API call. In case
  629. of problems usage of high memory can be turned off by setting
  630. UseHighMem to false - the program should change the setting at its
  631. very beginning (e.g. in initialization section of the first unit
  632. listed in the "uses" section) to avoid having preallocated memory
  633. from the high memory region before changing value of this variable. *)
  634. InitHeap;
  635. { ... and exceptions }
  636. SysInitExceptions;
  637. { ... and I/O }
  638. SysInitStdIO;
  639. { no I/O-Error }
  640. inoutres:=0;
  641. {Initialize environment (must be after InitHeap because allocates memory)}
  642. Environment := pointer (PIB^.Env);
  643. InitEnvironment;
  644. CmdLine := pointer (PIB^.Cmd);
  645. InitArguments;
  646. DefaultCreator := '';
  647. DefaultFileType := '';
  648. InitSystemThreads;
  649. {$ifdef HASVARIANT}
  650. initvariantmanager;
  651. {$endif HASVARIANT}
  652. {$IFDEF EXTDUMPGROW}
  653. { Int_HeapSize := high (cardinal);}
  654. {$ENDIF EXTDUMPGROW}
  655. RC := DosAllocMem (P, 4096, $403);
  656. if RC = 87 then
  657. (* Using of high memory address space (> 512 MB) *)
  658. (* is not supported on this system. *)
  659. UseHighMem := false
  660. else
  661. begin
  662. UseHighMem := true;
  663. if RC <> 0 then
  664. begin
  665. Str (RC, ErrStr);
  666. ErrStr := 'Error during heap initialization (DosAllocMem - ' + ErrStr + ')!!'#13#10;
  667. DosWrite (2, @ErrStr [1], Length (ErrStr), RC);
  668. HandleError (204);
  669. end
  670. else
  671. DosFreeMem (P);
  672. end;
  673. end.
  674. {
  675. $Log$
  676. Revision 1.78 2005-02-06 16:57:18 peter
  677. * threads for go32v2,os,emx,netware
  678. Revision 1.77 2004/12/05 14:36:38 hajny
  679. + GetProcessID added
  680. Revision 1.76 2004/11/04 09:32:31 peter
  681. ErrOutput added
  682. Revision 1.75 2004/10/25 15:38:59 peter
  683. * compiler defined HEAP and HEAPSIZE removed
  684. Revision 1.74 2004/09/18 11:12:09 hajny
  685. * handle type changed to thandle in do_isdevice
  686. Revision 1.73 2004/09/11 19:43:11 hajny
  687. * missing MaxExitCode added
  688. Revision 1.72 2004/07/18 15:20:38 hajny
  689. + Memory allocation routines changed to support the new memory manager
  690. Revision 1.71 2004/05/16 18:51:20 peter
  691. * use thandle in do_*
  692. Revision 1.70 2004/04/22 21:10:56 peter
  693. * do_read/do_write addr argument changed to pointer
  694. Revision 1.69 2004/03/24 19:23:09 hajny
  695. * misleading warning removed
  696. Revision 1.68 2004/03/24 19:15:59 hajny
  697. * heap management modified to be able to grow heap as needed
  698. Revision 1.67 2004/02/22 15:01:49 hajny
  699. * lots of fixes (regcall, THandle, string operations in sysutils, longint2cardinal according to OS/2 docs, dosh.inc, ...)
  700. Revision 1.66 2004/02/16 22:18:44 hajny
  701. * LastDosExitCode changed back from threadvar temporarily
  702. Revision 1.65 2004/02/02 03:24:09 yuri
  703. - prt1.as removed
  704. - removed tmporary code/comments
  705. - prt1 compilation error workaround removed
  706. Revision 1.64 2004/01/25 21:41:48 hajny
  707. * reformatting of too long comment lines - not accepted by FP IDE
  708. Revision 1.63 2004/01/21 14:15:42 florian
  709. * fixed win32 compilation
  710. Revision 1.62 2004/01/20 23:11:20 hajny
  711. * ExecuteProcess fixes, ProcessID and ThreadID added
  712. Revision 1.61 2003/12/04 21:22:38 peter
  713. * regcall updates (untested)
  714. Revision 1.60 2003/11/23 07:21:16 yuri
  715. * native heap
  716. Revision 1.59 2003/11/19 18:21:11 yuri
  717. * Memory allocation bug fixed
  718. Revision 1.58 2003/11/19 16:50:21 yuri
  719. * Environment and arguments initialization now native
  720. Revision 1.57 2003/11/06 17:20:44 yuri
  721. * Unused constants removed
  722. Revision 1.56 2003/11/03 09:42:28 marco
  723. * Peter's Cardinal<->Longint fixes patch
  724. Revision 1.55 2003/11/02 00:51:17 hajny
  725. * corrections for do_open and os_mode back
  726. Revision 1.54 2003/10/28 14:57:31 yuri
  727. * do_* functions now native
  728. Revision 1.53 2003/10/27 04:33:58 yuri
  729. * os_mode removed (not required anymore)
  730. Revision 1.52 2003/10/25 22:45:37 hajny
  731. * file handling related fixes
  732. Revision 1.51 2003/10/19 12:13:41 hajny
  733. * UnusedHandle value made the same as with other targets
  734. Revision 1.50 2003/10/19 09:37:00 hajny
  735. * minor fix in non-default sbrk code
  736. Revision 1.49 2003/10/19 09:06:28 hajny
  737. * fix for terrible long-time bug in do_open
  738. Revision 1.48 2003/10/18 16:58:39 hajny
  739. * stdcall fixes again
  740. Revision 1.47 2003/10/16 15:43:13 peter
  741. * THandle is platform dependent
  742. Revision 1.46 2003/10/14 21:10:06 hajny
  743. * another longint2cardinal fix
  744. Revision 1.45 2003/10/13 21:17:31 hajny
  745. * longint to cardinal corrections
  746. Revision 1.44 2003/10/12 18:07:30 hajny
  747. * wrong use of Intel syntax
  748. Revision 1.43 2003/10/12 17:59:40 hajny
  749. * wrong use of Intel syntax
  750. Revision 1.42 2003/10/12 17:52:28 hajny
  751. * wrong use of Intel syntax
  752. Revision 1.41 2003/10/12 10:45:36 hajny
  753. * sbrk error handling corrected
  754. Revision 1.40 2003/10/07 21:26:35 hajny
  755. * stdcall fixes and asm routines cleanup
  756. Revision 1.39 2003/10/06 16:58:27 yuri
  757. * Another set of native functions.
  758. Revision 1.38 2003/10/06 14:22:40 yuri
  759. * Some emx code removed. Now withous so stupid error as with dos ;)
  760. Revision 1.37 2003/10/04 08:30:59 yuri
  761. * at&t syntax instead of intel syntax was used
  762. Revision 1.36 2003/10/03 21:46:41 peter
  763. * stdcall fixes
  764. Revision 1.35 2003/10/01 18:42:49 yuri
  765. * Unclosed comment
  766. Revision 1.34 2003/09/29 18:39:59 hajny
  767. * append fix applied to GO32v2, OS/2 and EMX
  768. Revision 1.33 2003/09/27 11:52:36 peter
  769. * sbrk returns pointer
  770. Revision 1.32 2003/03/30 09:20:30 hajny
  771. * platform extension unification
  772. Revision 1.31 2003/01/15 22:16:12 hajny
  773. * default sharing mode changed to DenyNone
  774. Revision 1.30 2002/12/15 22:41:41 hajny
  775. * First_Meg fixed + Environment initialization under Dos
  776. Revision 1.29 2002/12/08 16:39:58 hajny
  777. - WriteLn in GUI mode support commented out until fixed
  778. Revision 1.28 2002/12/07 19:17:14 hajny
  779. * GetEnv correction, better PM support, ...
  780. Revision 1.27 2002/11/17 22:31:02 hajny
  781. * type corrections (longint x cardinal)
  782. Revision 1.26 2002/10/27 14:29:00 hajny
  783. * heap management (hopefully) fixed
  784. Revision 1.25 2002/10/14 19:39:17 peter
  785. * threads unit added for thread support
  786. Revision 1.24 2002/10/13 09:28:45 florian
  787. + call to initvariantmanager inserted
  788. Revision 1.23 2002/09/07 16:01:25 peter
  789. * old logs removed and tabs fixed
  790. Revision 1.22 2002/07/01 16:29:05 peter
  791. * sLineBreak changed to normal constant like Kylix
  792. Revision 1.21 2002/04/21 15:54:20 carl
  793. + initialize some global variables
  794. Revision 1.20 2002/04/12 17:42:16 carl
  795. + generic stack checking
  796. Revision 1.19 2002/03/11 19:10:33 peter
  797. * Regenerated with updated fpcmake
  798. Revision 1.18 2002/02/10 13:46:20 hajny
  799. * heap management corrected (heap_brk)
  800. }