system.pp 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902
  1. {
  2. $Id$
  3. This file is part of the Free Pascal run time library.
  4. Copyright (c) 1999-2000 by the Free Pascal development team.
  5. See the file COPYING.FPC, included in this distribution,
  6. for details about the copyright.
  7. This program is distributed in the hope that it will be useful,
  8. but WITHOUT ANY WARRANTY; without even the implied warranty of
  9. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  10. **********************************************************************}
  11. { no stack check in system }
  12. {$S-}
  13. unit system;
  14. interface
  15. {$define StdErrToConsole}
  16. {$ifdef SYSTEMDEBUG}
  17. {$define SYSTEMEXCEPTIONDEBUG}
  18. {$endif SYSTEMDEBUG}
  19. {$ifdef cpui386}
  20. {$define Set_i386_Exception_handler}
  21. {$endif cpui386}
  22. { include system-independent routine headers }
  23. {$I systemh.inc}
  24. type THandle = DWord;
  25. {Platform specific information}
  26. const
  27. LineEnding = #13#10;
  28. LFNSupport = false; { ??? - that's how it was declared in dos.pp! }
  29. DirectorySeparator = '\';
  30. DriveSeparator = ':';
  31. PathSeparator = ';';
  32. { FileNameCaseSensitive is defined separately below!!! }
  33. { include heap support headers }
  34. {$I heaph.inc}
  35. CONST
  36. { Default filehandles }
  37. UnusedHandle : THandle = -1;
  38. StdInputHandle : THandle = 0;
  39. StdOutputHandle : THandle = 0;
  40. StdErrorHandle : THandle = 0;
  41. FileNameCaseSensitive : boolean = false;
  42. sLineBreak = LineEnding;
  43. DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
  44. TYPE
  45. TNWCheckFunction = procedure (var code : longint);
  46. VAR
  47. ArgC : INTEGER;
  48. ArgV : ppchar;
  49. NetwareCheckFunction : TNWCheckFunction;
  50. NetwareMainThreadGroupID: longint;
  51. NetwareCodeStartAddress : dword;
  52. CONST
  53. envp : ppchar = nil; {dummy to make heaptrc happy}
  54. PROCEDURE ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl;
  55. PROCEDURE ConsolePrintf3 (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl;
  56. PROCEDURE ConsolePrintf (FormatStr : PCHAR); CDecl;
  57. type
  58. TSysCloseAllRemainingSemaphores = procedure;
  59. TSysReleaseThreadVars = procedure;
  60. TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer;
  61. procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
  62. rtv:TSysReleaseThreadVars;
  63. stdata:TSysSetThreadDataAreaPtr);
  64. implementation
  65. { Indicate that stack checking is taken care by OS}
  66. {$DEFINE NO_GENERIC_STACK_CHECK}
  67. { include system independent routines }
  68. {$I system.inc}
  69. { some declarations for Netware API calls }
  70. {$I nwsys.inc}
  71. {$I errno.inc}
  72. {procedure setup_arguments;
  73. begin
  74. end;
  75. }
  76. {procedure setup_environment;
  77. begin
  78. end;
  79. }
  80. var
  81. CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil;
  82. ReleaseThreadVars : TSysReleaseThreadVars = nil;
  83. SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil;
  84. procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
  85. rtv:TSysReleaseThreadVars;
  86. stdata:TSysSetThreadDataAreaPtr);
  87. begin
  88. CloseAllRemainingSemaphores := crs;
  89. ReleaseThreadVars := rtv;
  90. SetThreadDataAreaPtr := stdata;
  91. end;
  92. procedure PASCALMAIN;external name 'PASCALMAIN';
  93. procedure fpc_do_exit;external name 'FPC_DO_EXIT';
  94. {*****************************************************************************
  95. Startup
  96. *****************************************************************************}
  97. function __GetBssStart : pointer; external name '__getBssStart';
  98. function __getUninitializedDataSize : longint; external name '__getUninitializedDataSize';
  99. //function __getDataStart : longint; external name '__getDataStart';
  100. function __GetTextStart : longint; external name '__getTextStart';
  101. PROCEDURE nlm_main (_ArgC : LONGINT; _ArgV : ppchar); CDECL; [public,alias: '_nlm_main'];
  102. BEGIN
  103. // Initialize BSS
  104. if __getUninitializedDataSize > 0 then
  105. fillchar (__getBssStart^,__getUninitializedDataSize,0);
  106. NetwareCodeStartAddress := __GetTextStart;
  107. ArgC := _ArgC;
  108. ArgV := _ArgV;
  109. fpc_threadvar_relocate_proc := nil;
  110. PASCALMAIN;
  111. END;
  112. {*****************************************************************************
  113. System Dependent Exit code
  114. *****************************************************************************}
  115. procedure FreeSbrkMem; forward;
  116. var SigTermHandlerActive : boolean;
  117. Procedure system_exit;
  118. begin
  119. if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
  120. if assigned (ReleaseThreadVars) then ReleaseThreadVars;
  121. FreeSbrkMem; { free memory allocated by heapmanager }
  122. if not SigTermHandlerActive then
  123. begin
  124. if ExitCode <> 0 Then { otherwise we dont see runtime-errors }
  125. _SetAutoScreenDestructionMode (false);
  126. _exit (ExitCode);
  127. end;
  128. end;
  129. {*****************************************************************************
  130. Stack check code
  131. *****************************************************************************}
  132. procedure int_stackcheck(stack_size:longint);[public,alias:'FPC_STACKCHECK'];
  133. {
  134. called when trying to get local stack if the compiler directive $S
  135. is set this function must preserve esi !!!! because esi is set by
  136. the calling proc for methods it must preserve all registers !!
  137. With a 2048 byte safe area used to write to StdIo without crossing
  138. the stack boundary
  139. }
  140. begin
  141. IF _stackavail > stack_size + 2048 THEN EXIT;
  142. HandleError (202);
  143. end;
  144. {*****************************************************************************
  145. ParamStr/Randomize
  146. *****************************************************************************}
  147. { number of args }
  148. function paramcount : longint;
  149. begin
  150. paramcount := argc - 1;
  151. end;
  152. { argument number l }
  153. function paramstr(l : longint) : string;
  154. begin
  155. if (l>=0) and (l+1<=argc) then
  156. paramstr:=strpas(argv[l])
  157. else
  158. paramstr:='';
  159. end;
  160. { set randseed to a new pseudo random value }
  161. procedure randomize;
  162. begin
  163. randseed := _time (NIL);
  164. end;
  165. {*****************************************************************************
  166. Heap Management
  167. *****************************************************************************}
  168. var
  169. heap : longint;external name 'HEAP';
  170. intern_heapsize : longint;external name 'HEAPSIZE';
  171. { first address of heap }
  172. function getheapstart:pointer;
  173. assembler;
  174. asm
  175. leal HEAP,%eax
  176. end ['EAX'];
  177. { current length of heap }
  178. function getheapsize:longint;
  179. assembler;
  180. asm
  181. movl intern_HEAPSIZE,%eax
  182. end ['EAX'];
  183. const HeapInitialMaxBlocks = 32;
  184. type THeapSbrkBlockList = array [1.. HeapInitialMaxBlocks] of pointer;
  185. var HeapSbrkBlockList : ^THeapSbrkBlockList = nil;
  186. HeapSbrkLastUsed : dword = 0;
  187. HeapSbrkAllocated : dword = 0;
  188. { function to allocate size bytes more for the program }
  189. { must return the first address of new data space or nil if fail }
  190. { for netware all allocated blocks are saved to free them at }
  191. { exit (to avoid message "Module did not release xx resources") }
  192. Function Sbrk(size : longint):pointer;
  193. var P2 : POINTER;
  194. i : longint;
  195. begin
  196. Sbrk := _malloc (size);
  197. if Sbrk <> nil then begin
  198. if HeapSbrkBlockList = nil then
  199. begin
  200. Pointer (HeapSbrkBlockList) := _malloc (sizeof (HeapSbrkBlockList^));
  201. if HeapSbrkBlockList = nil then
  202. begin
  203. _free (Sbrk);
  204. Sbrk := nil;
  205. exit;
  206. end;
  207. fillchar (HeapSbrkBlockList^,sizeof(HeapSbrkBlockList^),0);
  208. HeapSbrkAllocated := HeapInitialMaxBlocks;
  209. end;
  210. if (HeapSbrkLastUsed > 0) then
  211. for i := 1 to HeapSbrkLastUsed do
  212. if (HeapSbrkBlockList^[i] = nil) then
  213. begin // reuse free slot
  214. HeapSbrkBlockList^[i] := Sbrk;
  215. exit;
  216. end;
  217. if (HeapSbrkLastUsed = HeapSbrkAllocated) then
  218. begin { grow }
  219. p2 := _realloc (HeapSbrkBlockList, HeapSbrkAllocated + HeapInitialMaxBlocks);
  220. if p2 = nil then
  221. begin
  222. _free (Sbrk);
  223. Sbrk := nil;
  224. exit;
  225. end;
  226. inc (HeapSbrkAllocated, HeapInitialMaxBlocks);
  227. end;
  228. inc (HeapSbrkLastUsed);
  229. HeapSbrkBlockList^[HeapSbrkLastUsed] := Sbrk;
  230. end;
  231. end;
  232. procedure FreeSbrkMem;
  233. var i : longint;
  234. begin
  235. if HeapSbrkBlockList <> nil then
  236. begin
  237. for i := 1 to HeapSbrkLastUsed do
  238. if (HeapSbrkBlockList^[i] <> nil) then
  239. _free (HeapSbrkBlockList^[i]);
  240. _free (HeapSbrkBlockList);
  241. HeapSbrkAllocated := 0;
  242. HeapSbrkLastUsed := 0;
  243. HeapSbrkBlockList := nil;
  244. end;
  245. end;
  246. {*****************************************************************************
  247. OS Memory allocation / deallocation
  248. ****************************************************************************}
  249. function SysOSAlloc(size: ptrint): pointer;
  250. begin
  251. result := sbrk(size);
  252. end;
  253. {$define HAS_SYSOSFREE}
  254. procedure SysOSFree(p: pointer; size: ptrint);
  255. var i : longint;
  256. begin
  257. //fpmunmap(p, size);
  258. if (HeapSbrkLastUsed > 0) then
  259. for i := 1 to HeapSbrkLastUsed do
  260. if (HeapSbrkBlockList^[i] = p) then
  261. begin
  262. _free (p);
  263. HeapSbrkBlockList^[i] := nil;
  264. exit;
  265. end;
  266. HandleError (204); // invalid pointer operation
  267. end;
  268. { include standard heap management }
  269. {$I heap.inc}
  270. {****************************************************************************
  271. Low level File Routines
  272. All these functions can set InOutRes on errors
  273. ****************************************************************************}
  274. PROCEDURE NW2PASErr (Err : LONGINT);
  275. BEGIN
  276. if Err = 0 then { Else it will go through all the cases }
  277. exit;
  278. case Err of
  279. Sys_ENFILE,
  280. Sys_EMFILE : Inoutres:=4;
  281. Sys_ENOENT : Inoutres:=2;
  282. Sys_EBADF : Inoutres:=6;
  283. Sys_ENOMEM,
  284. Sys_EFAULT : Inoutres:=217;
  285. Sys_EINVAL : Inoutres:=218;
  286. Sys_EPIPE,
  287. Sys_EINTR,
  288. Sys_EIO,
  289. Sys_EAGAIN,
  290. Sys_ENOSPC : Inoutres:=101;
  291. Sys_ENAMETOOLONG,
  292. Sys_ELOOP,
  293. Sys_ENOTDIR : Inoutres:=3;
  294. Sys_EROFS,
  295. Sys_EEXIST,
  296. Sys_EACCES : Inoutres:=5;
  297. Sys_EBUSY : Inoutres:=162;
  298. end;
  299. END;
  300. FUNCTION errno : LONGINT;
  301. BEGIN
  302. errno := __get_errno_ptr^;
  303. END;
  304. PROCEDURE Errno2Inoutres;
  305. BEGIN
  306. NW2PASErr (errno);
  307. END;
  308. PROCEDURE SetFileError (VAR Err : LONGINT);
  309. BEGIN
  310. IF Err >= 0 THEN
  311. InOutRes := 0
  312. ELSE
  313. BEGIN
  314. Err := errno;
  315. NW2PASErr (Err);
  316. Err := 0;
  317. END;
  318. END;
  319. { close a file from the handle value }
  320. procedure do_close(handle : thandle);
  321. VAR res : LONGINT;
  322. begin
  323. res := _close (handle);
  324. IF res <> 0 THEN
  325. SetFileError (res)
  326. ELSE
  327. InOutRes := 0;
  328. end;
  329. procedure do_erase(p : pchar);
  330. VAR res : LONGINT;
  331. begin
  332. res := _unlink (p);
  333. IF Res < 0 THEN
  334. SetFileError (res)
  335. ELSE
  336. InOutRes := 0;
  337. end;
  338. procedure do_rename(p1,p2 : pchar);
  339. VAR res : LONGINT;
  340. begin
  341. res := _rename (p1,p2);
  342. IF Res < 0 THEN
  343. SetFileError (res)
  344. ELSE
  345. InOutRes := 0
  346. end;
  347. function do_write(h:thandle;addr:pointer;len : longint) : longint;
  348. VAR res : LONGINT;
  349. begin
  350. res := _write (h,addr,len);
  351. IF res > 0 THEN
  352. InOutRes := 0
  353. ELSE
  354. SetFileError (res);
  355. do_write := res;
  356. end;
  357. function do_read(h:thandle;addr:pointer;len : longint) : longint;
  358. VAR res : LONGINT;
  359. begin
  360. res := _read (h,addr,len);
  361. IF res > 0 THEN
  362. InOutRes := 0
  363. ELSE
  364. SetFileError (res);
  365. do_read := res;
  366. end;
  367. function do_filepos(handle : thandle) : longint;
  368. VAR res : LONGINT;
  369. begin
  370. InOutRes:=1;
  371. res := _tell (handle);
  372. IF res < 0 THEN
  373. SetFileError (res)
  374. ELSE
  375. InOutRes := 0;
  376. do_filepos := res;
  377. end;
  378. CONST SEEK_SET = 0; // Seek from beginning of file.
  379. SEEK_CUR = 1; // Seek from current position.
  380. SEEK_END = 2; // Seek from end of file.
  381. procedure do_seek(handle:thandle;pos : longint);
  382. VAR res : LONGINT;
  383. begin
  384. res := _lseek (handle,pos, SEEK_SET);
  385. IF res >= 0 THEN
  386. InOutRes := 0
  387. ELSE
  388. SetFileError (res);
  389. end;
  390. function do_seekend(handle:thandle):longint;
  391. VAR res : LONGINT;
  392. begin
  393. res := _lseek (handle,0, SEEK_END);
  394. IF res >= 0 THEN
  395. InOutRes := 0
  396. ELSE
  397. SetFileError (res);
  398. do_seekend := res;
  399. end;
  400. function do_filesize(handle : thandle) : longint;
  401. VAR res : LONGINT;
  402. begin
  403. res := _filelength (handle);
  404. IF res < 0 THEN
  405. BEGIN
  406. SetFileError (Res);
  407. do_filesize := -1;
  408. END ELSE
  409. BEGIN
  410. InOutRes := 0;
  411. do_filesize := res;
  412. END;
  413. end;
  414. { truncate at a given position }
  415. procedure do_truncate (handle:thandle;pos:longint);
  416. VAR res : LONGINT;
  417. begin
  418. res := _chsize (handle,pos);
  419. IF res <> 0 THEN
  420. SetFileError (res)
  421. ELSE
  422. InOutRes := 0;
  423. end;
  424. // mostly stolen from syslinux
  425. procedure do_open(var f;p:pchar;flags:longint);
  426. {
  427. filerec and textrec have both handle and mode as the first items so
  428. they could use the same routine for opening/creating.
  429. when (flags and $10) the file will be append
  430. when (flags and $100) the file will be truncate/rewritten
  431. when (flags and $1000) there is no check for close (needed for textfiles)
  432. }
  433. var
  434. oflags : longint;
  435. Begin
  436. { close first if opened }
  437. if ((flags and $10000)=0) then
  438. begin
  439. case FileRec(f).mode of
  440. fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
  441. fmclosed : ;
  442. else
  443. begin
  444. inoutres:=102; {not assigned}
  445. exit;
  446. end;
  447. end;
  448. end;
  449. { reset file Handle }
  450. FileRec(f).Handle:=UnusedHandle;
  451. { We do the conversion of filemodes here, concentrated on 1 place }
  452. case (flags and 3) of
  453. 0 : begin
  454. oflags := O_RDONLY;
  455. filerec(f).mode := fminput;
  456. end;
  457. 1 : begin
  458. oflags := O_WRONLY;
  459. filerec(f).mode := fmoutput;
  460. end;
  461. 2 : begin
  462. oflags := O_RDWR;
  463. filerec(f).mode := fminout;
  464. end;
  465. end;
  466. if (flags and $1000)=$1000 then
  467. oflags:=oflags or (O_CREAT or O_TRUNC)
  468. else
  469. if (flags and $100)=$100 then
  470. oflags:=oflags or (O_APPEND);
  471. { empty name is special }
  472. if p[0]=#0 then
  473. begin
  474. case FileRec(f).mode of
  475. fminput :
  476. FileRec(f).Handle:=StdInputHandle;
  477. fminout, { this is set by rewrite }
  478. fmoutput :
  479. FileRec(f).Handle:=StdOutputHandle;
  480. fmappend :
  481. begin
  482. FileRec(f).Handle:=StdOutputHandle;
  483. FileRec(f).mode:=fmoutput; {fool fmappend}
  484. end;
  485. end;
  486. exit;
  487. end;
  488. { real open call }
  489. FileRec(f).Handle := _open(p,oflags,438);
  490. //WriteLn ('_open (',p,') liefert ',ErrNo, 'Handle: ',FileRec(f).Handle);
  491. // errno does not seem to be set on succsess ??
  492. IF FileRec(f).Handle < 0 THEN
  493. if (ErrNo=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
  494. begin // i.e. for cd-rom
  495. Oflags:=Oflags and not(O_RDWR);
  496. FileRec(f).Handle := _open(p,oflags,438);
  497. end;
  498. IF FileRec(f).Handle < 0 THEN
  499. Errno2Inoutres
  500. ELSE
  501. InOutRes := 0;
  502. End;
  503. function do_isdevice(handle:THandle):boolean;
  504. begin
  505. do_isdevice := (_isatty (handle) > 0);
  506. end;
  507. {*****************************************************************************
  508. UnTyped File Handling
  509. *****************************************************************************}
  510. {$i file.inc}
  511. {*****************************************************************************
  512. Typed File Handling
  513. *****************************************************************************}
  514. {$i typefile.inc}
  515. {*****************************************************************************
  516. Text File Handling
  517. *****************************************************************************}
  518. { should we consider #26 as the end of a file ? }
  519. {?? $DEFINE EOF_CTRLZ}
  520. {$i text.inc}
  521. {*****************************************************************************
  522. Directory Handling
  523. *****************************************************************************}
  524. procedure mkdir(const s : string);[IOCheck];
  525. VAR S2 : STRING;
  526. Res: LONGINT;
  527. BEGIN
  528. S2 := S;
  529. IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
  530. S2 := S2 + #0;
  531. Res := _mkdir (@S2[1]);
  532. IF Res = 0 THEN
  533. InOutRes:=0
  534. ELSE
  535. SetFileError (Res);
  536. END;
  537. procedure rmdir(const s : string);[IOCheck];
  538. VAR S2 : STRING;
  539. Res: LONGINT;
  540. BEGIN
  541. S2 := S;
  542. IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
  543. S2 := S2 + #0;
  544. Res := _rmdir (@S2[1]);
  545. IF Res = 0 THEN
  546. InOutRes:=0
  547. ELSE
  548. SetFileError (Res);
  549. end;
  550. procedure chdir(const s : string);[IOCheck];
  551. VAR S2 : STRING;
  552. Res: LONGINT;
  553. begin
  554. S2 := S;
  555. IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
  556. S2 := S2 + #0;
  557. Res := _chdir (@S2[1]);
  558. IF Res = 0 THEN
  559. InOutRes:=0
  560. ELSE
  561. SetFileError (Res);
  562. end;
  563. procedure getdir(drivenr : byte;var dir : shortstring);
  564. VAR P : ARRAY [0..255] OF CHAR;
  565. Len: LONGINT;
  566. begin
  567. P[0] := #0;
  568. _getcwd (@P, SIZEOF (P));
  569. Len := _strlen (P);
  570. IF Len > 0 THEN
  571. BEGIN
  572. Move (P, dir[1], Len);
  573. BYTE(dir[0]) := Len;
  574. END ELSE
  575. InOutRes := 1;
  576. end;
  577. {*****************************************************************************
  578. Thread Handling
  579. *****************************************************************************}
  580. procedure InitFPU;assembler;
  581. asm
  582. fninit
  583. fldcw fpucw
  584. end;
  585. { if return-value is <> 0, netware shows the message
  586. Unload Anyway ?
  587. To Disable unload at all, SetNLMDontUnloadFlag can be used on
  588. Netware >= 4.0 }
  589. function CheckFunction : longint; CDECL; [public,alias: 'FPC_NW_CHECKFUNCTION'];
  590. var oldTG:longint;
  591. oldPtr: pointer;
  592. begin
  593. if assigned (NetwareCheckFunction) then
  594. begin
  595. { this function is called without clib context, to allow clib
  596. calls, we set the thread group id before calling the
  597. user-function }
  598. oldTG := _SetThreadGroupID (NetwareMainThreadGroupID);
  599. { to allow use of threadvars, we simply set the threadvar-memory
  600. from the main thread }
  601. if assigned (SetThreadDataAreaPtr) then
  602. oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
  603. result := 0;
  604. NetwareCheckFunction (result);
  605. if assigned (SetThreadDataAreaPtr) then
  606. SetThreadDataAreaPtr (oldPtr);
  607. _SetThreadGroupID (oldTG);
  608. end else
  609. result := 0;
  610. end;
  611. {$ifdef StdErrToConsole}
  612. var ConsoleBuff : array [0..512] of char;
  613. Function ConsoleWrite(Var F: TextRec): Integer;
  614. var
  615. i : longint;
  616. Begin
  617. if F.BufPos>0 then
  618. begin
  619. if F.BufPos>sizeof(ConsoleBuff)-1 then
  620. i:=sizeof(ConsoleBuff)-1
  621. else
  622. i:=F.BufPos;
  623. Move(F.BufPtr^,ConsoleBuff,i);
  624. ConsoleBuff[i] := #0;
  625. ConsolePrintf(@ConsoleBuff[0]);
  626. end;
  627. F.BufPos:=0;
  628. ConsoleWrite := 0;
  629. End;
  630. Function ConsoleClose(Var F: TextRec): Integer;
  631. begin
  632. ConsoleClose:=0;
  633. end;
  634. Function ConsoleOpen(Var F: TextRec): Integer;
  635. Begin
  636. TextRec(F).InOutFunc:=@ConsoleWrite;
  637. TextRec(F).FlushFunc:=@ConsoleWrite;
  638. TextRec(F).CloseFunc:=@ConsoleClose;
  639. ConsoleOpen:=0;
  640. End;
  641. procedure AssignStdErrConsole(Var T: Text);
  642. begin
  643. Assign(T,'');
  644. TextRec(T).OpenFunc:=@ConsoleOpen;
  645. Rewrite(T);
  646. end;
  647. {$endif}
  648. { this will be called if the nlm is unloaded. It will NOT be
  649. called if the program exits i.e. with halt.
  650. Halt (or _exit) can not be called from this callback procedure }
  651. procedure TermSigHandler (Sig:longint); CDecl;
  652. var oldTG : longint;
  653. oldPtr: pointer;
  654. begin
  655. oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); { this is only needed for nw 3.11 }
  656. { _GetThreadDataAreaPtr will not be valid because the signal
  657. handler is called by netware with a differnt thread. To avoid
  658. problems in the exit routines, we set the data of the main thread
  659. here }
  660. if assigned (SetThreadDataAreaPtr) then
  661. oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread }
  662. SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
  663. do_exit; { calls finalize units }
  664. if assigned (SetThreadDataAreaPtr) then
  665. SetThreadDataAreaPtr (oldPtr);
  666. _SetThreadGroupID (oldTG);
  667. end;
  668. procedure SysInitStdIO;
  669. begin
  670. { Setup stdin, stdout and stderr }
  671. StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE !
  672. StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
  673. StdErrorHandle := _fileno (LONGINT (_GetStdErr^));
  674. OpenStdIO(Input,fmInput,StdInputHandle);
  675. OpenStdIO(Output,fmOutput,StdOutputHandle);
  676. OpenStdIO(StdOut,fmOutput,StdOutputHandle);
  677. {$ifdef StdErrToConsole}
  678. AssignStdErrConsole(StdErr);
  679. {$else}
  680. OpenStdIO(StdErr,fmOutput,StdErrorHandle);
  681. {$endif}
  682. end;
  683. {*****************************************************************************
  684. SystemUnit Initialization
  685. *****************************************************************************}
  686. Begin
  687. StackBottom := SPtr - StackLength;
  688. SigTermHandlerActive := false;
  689. NetwareCheckFunction := nil;
  690. NetwareMainThreadGroupID := _GetThreadGroupID;
  691. _Signal (_SIGTERM, @TermSigHandler);
  692. { Setup heap }
  693. InitHeap;
  694. SysInitExceptions;
  695. { Reset IO Error }
  696. InOutRes:=0;
  697. (* This should be changed to a real value during *)
  698. (* thread driver initialization if appropriate. *)
  699. ThreadID := 1;
  700. SysInitStdIO;
  701. {Delphi Compatible}
  702. IsLibrary := FALSE;
  703. IsConsole := TRUE;
  704. ExitCode := 0;
  705. {$ifdef HASVARIANT}
  706. initvariantmanager;
  707. {$endif HASVARIANT}
  708. End.
  709. {
  710. $Log$
  711. Revision 1.23 2004-07-30 15:05:25 armin
  712. make netware rtl compilable under 1.9.5
  713. Revision 1.22 2004/06/17 16:16:14 peter
  714. * New heapmanager that releases memory back to the OS, donated
  715. by Micha Nelissen
  716. Revision 1.21 2004/01/20 23:11:20 hajny
  717. * ExecuteProcess fixes, ProcessID and ThreadID added
  718. Revision 1.20 2003/10/25 23:43:59 hajny
  719. * THandle in sysutils common using System.THandle
  720. Revision 1.19 2003/10/17 22:12:02 olle
  721. * changed i386 to cpui386
  722. Revision 1.18 2003/09/27 11:52:35 peter
  723. * sbrk returns pointer
  724. Revision 1.17 2003/03/25 18:17:54 armin
  725. * support for fcl, support for linking without debug info
  726. * renamed winsock2 to winsock for win32 compatinility
  727. * new sockets unit for netware
  728. * changes for compiler warnings
  729. Revision 1.16 2003/02/15 19:12:54 armin
  730. * changes for new threadvar support
  731. Revision 1.15 2002/10/13 09:28:45 florian
  732. + call to initvariantmanager inserted
  733. Revision 1.14 2002/09/07 16:01:21 peter
  734. * old logs removed and tabs fixed
  735. Revision 1.13 2002/07/01 16:29:05 peter
  736. * sLineBreak changed to normal constant like Kylix
  737. Revision 1.12 2002/04/15 18:47:34 carl
  738. + reinstate novell stack checking
  739. Revision 1.11 2002/04/12 17:40:11 carl
  740. + generic stack checking
  741. Revision 1.10 2002/04/01 15:20:08 armin
  742. + unload module no longer shows: Module did not release...
  743. + check-function will no longer be removed when smartlink is on
  744. Revision 1.9 2002/04/01 10:47:31 armin
  745. makefile.fpc for netware
  746. stderr to netware console
  747. free all memory (threadvars and heap) to avoid error message while unloading nlm
  748. Revision 1.8 2002/03/30 09:09:47 armin
  749. + support check-function for netware
  750. Revision 1.7 2002/03/17 17:57:33 armin
  751. + threads and winsock2 implemented
  752. }