system.pp 22 KB

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