1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090 |
- {
- $Id$
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2000 by the Free Pascal development team.
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- { no stack check in system }
- {$S-}
- unit system;
- interface
- {$define StdErrToConsole}
- {$define useLongNamespaceByDefault}
- {$define autoHeapRelease}
- {$ifdef SYSTEMDEBUG}
- {$define SYSTEMEXCEPTIONDEBUG}
- {$endif SYSTEMDEBUG}
- {$ifdef cpui386}
- {$define Set_i386_Exception_handler}
- {$endif cpui386}
- { include system-independent routine headers }
- {$I systemh.inc}
- type THandle = DWord;
- {Platform specific information}
- const
- LineEnding = #13#10;
- LFNSupport : boolean = false;
- DirectorySeparator = '/';
- DriveSeparator = ':';
- PathSeparator = ';';
- { FileNameCaseSensitive is defined separately below!!! }
- maxExitCode = 255;
- { include heap support headers }
- {$I heaph.inc}
- CONST
- { Default filehandles }
- UnusedHandle : THandle = -1;
- StdInputHandle : THandle = 0;
- StdOutputHandle : THandle = 0;
- StdErrorHandle : THandle = 0;
- FileNameCaseSensitive : boolean = false;
- sLineBreak = LineEnding;
- DefaultTextLineBreakStyle : TTextLineBreakStyle = tlbsCRLF;
- TYPE
- TNWCheckFunction = procedure (var code : longint);
- VAR
- ArgC : INTEGER;
- ArgV : ppchar;
- NetwareCheckFunction : TNWCheckFunction;
- NetwareMainThreadGroupID: longint;
- NetwareCodeStartAddress : dword;
- NetwareUnloadProc : pointer = nil; {like exitProc but for nlm unload only}
- CONST
- envp : ppchar = nil; {dummy to make heaptrc happy}
- procedure ConsolePrintf (FormatStr : PCHAR; Param : LONGINT); CDecl; external 'clib' name 'printf';
- procedure ConsolePrintf (FormatStr : PCHAR; Param : pchar); CDecl; external 'clib' name 'printf';
- procedure ConsolePrintf (FormatStr : PCHAR; P1,P2 : LONGINT); CDecl; external 'clib' name 'printf';
- procedure ConsolePrintf (FormatStr : PCHAR; P1,P2,P3 : LONGINT); CDecl; external 'clib' name 'printf';
- procedure ConsolePrintf (FormatStr : PCHAR); CDecl; external 'clib' name 'printf';
- // this gives internal compiler error 200404181
- // procedure ConsolePrintf (FormatStr : PCHAR; Param : array of const); CDecl; EXTERNAL 'clib' name 'ConsolePrintf';
- procedure __EnterDebugger; cdecl; external 'clib' name 'EnterDebugger';
- type
- TSysCloseAllRemainingSemaphores = procedure;
- TSysReleaseThreadVars = procedure;
- TSysSetThreadDataAreaPtr = function (newPtr:pointer):pointer;
- procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
- rtv:TSysReleaseThreadVars;
- stdata:TSysSetThreadDataAreaPtr);
- function NWGetCodeStart : pointer; // needed for lineinfo
- implementation
- { Indicate that stack checking is taken care by OS}
- {$DEFINE NO_GENERIC_STACK_CHECK}
- { include system independent routines }
- {$I system.inc}
- { some declarations for Netware API calls }
- {$I nwsys.inc}
- {$I errno.inc}
- var
- CloseAllRemainingSemaphores : TSysCloseAllRemainingSemaphores = nil;
- ReleaseThreadVars : TSysReleaseThreadVars = nil;
- SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil;
- TerminatingThreadID : longint = 0; {used for unload, the signal handler will}
- {be called from the console thread. avoid}
- {calling _exit in another thread}
- procedure NWSysSetThreadFunctions (crs:TSysCloseAllRemainingSemaphores;
- rtv:TSysReleaseThreadVars;
- stdata:TSysSetThreadDataAreaPtr);
- begin
- CloseAllRemainingSemaphores := crs;
- ReleaseThreadVars := rtv;
- SetThreadDataAreaPtr := stdata;
- end;
- //procedure __EnterDebugger; cdecl; external 'clib' name 'EnterDebugger';
- procedure PASCALMAIN;external name 'PASCALMAIN';
- procedure fpc_do_exit;external name 'FPC_DO_EXIT';
- {*****************************************************************************
- Startup
- *****************************************************************************}
- function __GetBssStart : pointer; external name '__getBssStart';
- function __getUninitializedDataSize : longint; external name '__getUninitializedDataSize';
- //function __getDataStart : longint; external name '__getDataStart';
- function __GetTextStart : longint; external name '__getTextStart';
- PROCEDURE nlm_main (_ArgC : LONGINT; _ArgV : ppchar); CDECL; [public,alias: '_nlm_main'];
- BEGIN
- // Initialize BSS
- if __getUninitializedDataSize > 0 then
- fillchar (__getBssStart^,__getUninitializedDataSize,0);
- NetwareCodeStartAddress := __GetTextStart;
- ArgC := _ArgC;
- ArgV := _ArgV;
- fpc_threadvar_relocate_proc := nil;
- PASCALMAIN;
- END;
- function NWGetCodeStart : pointer; // needed for lineinfo
- begin
- NWGetCodeStart := pointer(NetwareCodeStartAddress);
- end;
- {*****************************************************************************
- System Dependent Exit code
- *****************************************************************************}
- {$ifdef autoHeapRelease}
- procedure FreeSbrkMem; forward;
- {$endif}
- var SigTermHandlerActive : boolean;
- Procedure system_exit;
- begin
- if TerminatingThreadID <> 0 then
- if TerminatingThreadID <> ThreadId then
- if TerminatingThreadID <> _GetThreadID then
- begin
- {$ifdef DEBUG_MT}
- ConsolePrintf ('Terminating Thread %x because halt was called while Thread %x terminates nlm'#13#10,_GetThreadId,TerminatingThreadId);
- {$endif}
- ExitThread (EXIT_THREAD,0);
- // only for the case ExitThread fails
- while true do
- _ThreadSwitchWithDelay;
- end;
- if assigned (CloseAllRemainingSemaphores) then CloseAllRemainingSemaphores;
- if assigned (ReleaseThreadVars) then ReleaseThreadVars;
- {$ifdef autoHeapRelease}
- FreeSbrkMem; { free memory allocated by heapmanager }
- {$endif}
- if not SigTermHandlerActive then
- begin
- if ExitCode <> 0 Then { otherwise we dont see runtime-errors }
- _SetAutoScreenDestructionMode (false);
- _exit (ExitCode);
- end;
- end;
- {*****************************************************************************
- Stack check code
- *****************************************************************************}
- const StackErr : boolean = false;
- procedure int_stackcheck(stack_size:Cardinal);[public,alias:'FPC_STACKCHECK'];
- {
- called when trying to get local stack if the compiler directive $S
- is set this function must preserve all registers
- With a 2048 byte safe area used to write to StdIo without crossing
- the stack boundary
- }
- begin
- if StackErr then exit; // avoid recursive calls
- asm
- pusha
- end;
- stackerr := ( _stackavail < stack_size + 2048);
- asm
- popa
- end;
- if not StackErr then exit;
- StackErr := true;
- HandleError (202);
- end;
- {*****************************************************************************
- ParamStr/Randomize
- *****************************************************************************}
- { number of args }
- function paramcount : longint;
- begin
- paramcount := argc - 1;
- end;
- { argument number l }
- function paramstr(l : longint) : string;
- begin
- if (l>=0) and (l+1<=argc) then
- begin
- paramstr:=strpas(argv[l]);
- if l = 0 then // fix nlm path
- begin
- for l := 1 to length (paramstr) do
- if paramstr[l] = '\' then paramstr[l] := '/';
- end;
- end else
- paramstr:='';
- end;
- { set randseed to a new pseudo random value }
- procedure randomize;
- begin
- randseed := _time (NIL);
- end;
- {*****************************************************************************
- Heap Management
- *****************************************************************************}
- {$ifdef autoHeapRelease}
- const HeapInitialMaxBlocks = 32;
- type THeapSbrkBlockList = array [1.. HeapInitialMaxBlocks] of pointer;
- var HeapSbrkBlockList : ^THeapSbrkBlockList = nil;
- HeapSbrkLastUsed : dword = 0;
- HeapSbrkAllocated : dword = 0;
- { function to allocate size bytes more for the program }
- { must return the first address of new data space or nil if fail }
- { for netware all allocated blocks are saved to free them at }
- { exit (to avoid message "Module did not release xx resources") }
- Function Sbrk(size : longint):pointer;
- var P2 : POINTER;
- i : longint;
- begin
- Sbrk := _malloc (size);
- if Sbrk <> nil then begin
- if HeapSbrkBlockList = nil then
- begin
- Pointer (HeapSbrkBlockList) := _malloc (sizeof (HeapSbrkBlockList^));
- if HeapSbrkBlockList = nil then
- begin
- _free (Sbrk);
- Sbrk := nil;
- exit;
- end;
- fillchar (HeapSbrkBlockList^,sizeof(HeapSbrkBlockList^),0);
- HeapSbrkAllocated := HeapInitialMaxBlocks;
- end;
- if (HeapSbrkLastUsed > 0) then
- for i := 1 to HeapSbrkLastUsed do
- if (HeapSbrkBlockList^[i] = nil) then
- begin // reuse free slot
- HeapSbrkBlockList^[i] := Sbrk;
- exit;
- end;
- if (HeapSbrkLastUsed = HeapSbrkAllocated) then
- begin { grow }
- p2 := _realloc (HeapSbrkBlockList, (HeapSbrkAllocated + HeapInitialMaxBlocks) * sizeof(pointer));
- if p2 = nil then // should we better terminate with error ?
- begin
- _free (Sbrk);
- Sbrk := nil;
- exit;
- end;
- HeapSbrkBlockList := p2;
- inc (HeapSbrkAllocated, HeapInitialMaxBlocks);
- end;
- inc (HeapSbrkLastUsed);
- HeapSbrkBlockList^[HeapSbrkLastUsed] := Sbrk;
- end;
- end;
- procedure FreeSbrkMem;
- var i : longint;
- begin
- if HeapSbrkBlockList <> nil then
- begin
- for i := 1 to HeapSbrkLastUsed do
- if (HeapSbrkBlockList^[i] <> nil) then
- _free (HeapSbrkBlockList^[i]);
- _free (HeapSbrkBlockList);
- HeapSbrkAllocated := 0;
- HeapSbrkLastUsed := 0;
- HeapSbrkBlockList := nil;
- end;
- end;
- {*****************************************************************************
- OS Memory allocation / deallocation
- ****************************************************************************}
- function SysOSAlloc(size: ptrint): pointer;
- begin
- result := sbrk(size);
- end;
- {$define HAS_SYSOSFREE}
- procedure SysOSFree(p: pointer; size: ptrint);
- var i : longint;
- begin
- //fpmunmap(p, size);
- if (HeapSbrkLastUsed > 0) then
- for i := 1 to HeapSbrkLastUsed do
- if (HeapSbrkBlockList^[i] = p) then
- begin
- _free (p);
- HeapSbrkBlockList^[i] := nil;
- exit;
- end;
- HandleError (204); // invalid pointer operation
- end;
- {$else autoHeapRelease}
- {$define HAS_SYSOSFREE}
- procedure SysOSFree(p: pointer; size: ptrint);
- begin
- _free (p);
- end;
- function SysOSAlloc(size: ptrint): pointer;
- begin
- SysOSAlloc := _malloc (size);
- end;
- {$endif autoHeapRelease}
- { include standard heap management }
- {$I heap.inc}
- {****************************************************************************
- Low level File Routines
- All these functions can set InOutRes on errors
- ****************************************************************************}
- PROCEDURE NW2PASErr (Err : LONGINT);
- BEGIN
- if Err = 0 then { Else it will go through all the cases }
- exit;
- case Err of
- Sys_ENFILE,
- Sys_EMFILE : Inoutres:=4;
- Sys_ENOENT : Inoutres:=2;
- Sys_EBADF : Inoutres:=6;
- Sys_ENOMEM,
- Sys_EFAULT : Inoutres:=217;
- Sys_EINVAL : Inoutres:=218;
- Sys_EPIPE,
- Sys_EINTR,
- Sys_EIO,
- Sys_EAGAIN,
- Sys_ENOSPC : Inoutres:=101;
- Sys_ENAMETOOLONG,
- Sys_ELOOP,
- Sys_ENOTDIR : Inoutres:=3;
- Sys_EROFS,
- Sys_EEXIST,
- Sys_EACCES : Inoutres:=5;
- Sys_EBUSY : Inoutres:=162;
- end;
- END;
- FUNCTION errno : LONGINT;
- BEGIN
- errno := __get_errno_ptr^;
- END;
- PROCEDURE Errno2Inoutres;
- BEGIN
- NW2PASErr (errno);
- END;
- PROCEDURE SetFileError (VAR Err : LONGINT);
- BEGIN
- IF Err >= 0 THEN
- InOutRes := 0
- ELSE
- BEGIN
- Err := errno;
- NW2PASErr (Err);
- Err := 0;
- END;
- END;
- { close a file from the handle value }
- procedure do_close(handle : thandle);
- VAR res : LONGINT;
- begin
- res := _close (handle);
- IF res <> 0 THEN
- SetFileError (res)
- ELSE
- InOutRes := 0;
- end;
- procedure do_erase(p : pchar);
- VAR res : LONGINT;
- begin
- res := _unlink (p);
- IF Res < 0 THEN
- SetFileError (res)
- ELSE
- InOutRes := 0;
- end;
- procedure do_rename(p1,p2 : pchar);
- VAR res : LONGINT;
- begin
- res := _rename (p1,p2);
- IF Res < 0 THEN
- SetFileError (res)
- ELSE
- InOutRes := 0
- end;
- function do_write(h:thandle;addr:pointer;len : longint) : longint;
- VAR res : LONGINT;
- begin
- res := _write (h,addr,len);
- IF res > 0 THEN
- InOutRes := 0
- ELSE
- SetFileError (res);
- do_write := res;
- end;
- function do_read(h:thandle;addr:pointer;len : longint) : longint;
- VAR res : LONGINT;
- begin
- res := _read (h,addr,len);
- IF res > 0 THEN
- InOutRes := 0
- ELSE
- SetFileError (res);
- do_read := res;
- end;
- function do_filepos(handle : thandle) : longint;
- VAR res : LONGINT;
- begin
- InOutRes:=1;
- res := _tell (handle);
- IF res < 0 THEN
- SetFileError (res)
- ELSE
- InOutRes := 0;
- do_filepos := res;
- end;
- CONST SEEK_SET = 0; // Seek from beginning of file.
- SEEK_CUR = 1; // Seek from current position.
- SEEK_END = 2; // Seek from end of file.
- procedure do_seek(handle:thandle;pos : longint);
- VAR res : LONGINT;
- begin
- res := _lseek (handle,pos, SEEK_SET);
- IF res >= 0 THEN
- InOutRes := 0
- ELSE
- SetFileError (res);
- end;
- function do_seekend(handle:thandle):longint;
- VAR res : LONGINT;
- begin
- res := _lseek (handle,0, SEEK_END);
- IF res >= 0 THEN
- InOutRes := 0
- ELSE
- SetFileError (res);
- do_seekend := res;
- end;
- function do_filesize(handle : thandle) : longint;
- VAR res : LONGINT;
- begin
- res := _filelength (handle);
- IF res < 0 THEN
- BEGIN
- SetFileError (Res);
- do_filesize := -1;
- END ELSE
- BEGIN
- InOutRes := 0;
- do_filesize := res;
- END;
- end;
- { truncate at a given position }
- procedure do_truncate (handle:thandle;pos:longint);
- VAR res : LONGINT;
- begin
- res := _chsize (handle,pos);
- IF res <> 0 THEN
- SetFileError (res)
- ELSE
- InOutRes := 0;
- end;
- // mostly stolen from syslinux
- procedure do_open(var f;p:pchar;flags:longint);
- {
- filerec and textrec have both handle and mode as the first items so
- they could use the same routine for opening/creating.
- when (flags and $10) the file will be append
- when (flags and $100) the file will be truncate/rewritten
- when (flags and $1000) there is no check for close (needed for textfiles)
- }
- var
- oflags : longint;
- Begin
- { close first if opened }
- if ((flags and $10000)=0) then
- begin
- case FileRec(f).mode of
- fminput,fmoutput,fminout : Do_Close(FileRec(f).Handle);
- fmclosed : ;
- else
- begin
- inoutres:=102; {not assigned}
- exit;
- end;
- end;
- end;
- { reset file Handle }
- FileRec(f).Handle:=UnusedHandle;
- { We do the conversion of filemodes here, concentrated on 1 place }
- case (flags and 3) of
- 0 : begin
- oflags := O_RDONLY;
- filerec(f).mode := fminput;
- end;
- 1 : begin
- oflags := O_WRONLY;
- filerec(f).mode := fmoutput;
- end;
- 2 : begin
- oflags := O_RDWR;
- filerec(f).mode := fminout;
- end;
- end;
- if (flags and $1000)=$1000 then
- oflags:=oflags or (O_CREAT or O_TRUNC)
- else
- if (flags and $100)=$100 then
- oflags:=oflags or (O_APPEND);
- { empty name is special }
- if p[0]=#0 then
- begin
- case FileRec(f).mode of
- fminput :
- FileRec(f).Handle:=StdInputHandle;
- fminout, { this is set by rewrite }
- fmoutput :
- FileRec(f).Handle:=StdOutputHandle;
- fmappend :
- begin
- FileRec(f).Handle:=StdOutputHandle;
- FileRec(f).mode:=fmoutput; {fool fmappend}
- end;
- end;
- exit;
- end;
- { real open call }
- FileRec(f).Handle := _open(p,oflags,438);
- //WriteLn ('_open (',p,') returned ',ErrNo, 'Handle: ',FileRec(f).Handle);
- // errno does not seem to be set on succsess ??
- IF FileRec(f).Handle < 0 THEN
- if (ErrNo=Sys_EROFS) and ((OFlags and O_RDWR)<>0) then
- begin // i.e. for cd-rom
- Oflags:=Oflags and not(O_RDWR);
- FileRec(f).Handle := _open(p,oflags,438);
- end;
- IF FileRec(f).Handle < 0 THEN
- Errno2Inoutres
- ELSE
- InOutRes := 0;
- End;
- function do_isdevice(handle:THandle):boolean;
- begin
- do_isdevice := (_isatty (handle) > 0);
- end;
- {*****************************************************************************
- UnTyped File Handling
- *****************************************************************************}
- {$i file.inc}
- {*****************************************************************************
- Typed File Handling
- *****************************************************************************}
- {$i typefile.inc}
- {*****************************************************************************
- Text File Handling
- *****************************************************************************}
- { should we consider #26 as the end of a file ? }
- {?? $DEFINE EOF_CTRLZ}
- {$i text.inc}
- {*****************************************************************************
- Directory Handling
- *****************************************************************************}
- procedure mkdir(const s : string);[IOCheck];
- VAR S2 : STRING;
- Res: LONGINT;
- BEGIN
- S2 := S;
- IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
- S2 := S2 + #0;
- Res := _mkdir (@S2[1]);
- IF Res = 0 THEN
- InOutRes:=0
- ELSE
- SetFileError (Res);
- END;
- procedure rmdir(const s : string);[IOCheck];
- VAR S2 : STRING;
- Res: LONGINT;
- BEGIN
- S2 := S;
- IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
- S2 := S2 + #0;
- Res := _rmdir (@S2[1]);
- IF Res = 0 THEN
- InOutRes:=0
- ELSE
- SetFileError (Res);
- end;
- procedure chdir(const s : string);[IOCheck];
- VAR S2 : STRING;
- Res: LONGINT;
- begin
- S2 := S;
- IF Length (S2) = 255 THEN DEC (BYTE(S2[0]));
- S2 := S2 + #0;
- Res := _chdir (@S2[1]);
- IF Res = 0 THEN
- InOutRes:=0
- ELSE
- SetFileError (Res);
- end;
- procedure getdir(drivenr : byte;var dir : shortstring);
- VAR P : ARRAY [0..255] OF CHAR;
- i : LONGINT;
- begin
- P[0] := #0;
- _getcwd (@P, SIZEOF (P));
- i := _strlen (P);
- if i > 0 then
- begin
- Move (P, dir[1], i);
- BYTE(dir[0]) := i;
- For i := 1 to length (dir) do
- if dir[i] = '\' then dir [i] := '/';
- // fix / after volume, the compiler needs that
- // normaly root of a volumes is SERVERNAME/SYS:, change that
- // to SERVERNAME/SYS:/
- i := pos (':',dir);
- if (i > 0) then
- if i = Length (dir) then dir := dir + '/' else
- if dir [i+1] <> '/' then insert ('/',dir,i+1);
- END ELSE
- InOutRes := 1;
- end;
- {*****************************************************************************
- Thread Handling
- *****************************************************************************}
- procedure InitFPU;assembler;
- asm
- fninit
- fldcw fpucw
- end;
- { if return-value is <> 0, netware shows the message
- Unload Anyway ?
- To Disable unload at all, SetNLMDontUnloadFlag can be used on
- Netware >= 4.0 }
- function CheckFunction : longint; CDECL; [public,alias: 'FPC_NW_CHECKFUNCTION'];
- var oldTG:longint;
- oldPtr: pointer;
- begin
- if assigned (NetwareCheckFunction) then
- begin
- { this function is called without clib context, to allow clib
- calls, we set the thread group id before calling the
- user-function }
- oldTG := _SetThreadGroupID (NetwareMainThreadGroupID);
- { to allow use of threadvars, we simply set the threadvar-memory
- from the main thread }
- if assigned (SetThreadDataAreaPtr) then
- oldPtr := SetThreadDataAreaPtr (NIL); { nil means main threadvars }
- result := 0;
- NetwareCheckFunction (result);
- if assigned (SetThreadDataAreaPtr) then
- SetThreadDataAreaPtr (oldPtr);
- _SetThreadGroupID (oldTG);
- end else
- result := 0;
- end;
- {$ifdef StdErrToConsole}
- var ConsoleBuff : array [0..512] of char;
- Function ConsoleWrite(Var F: TextRec): Integer;
- var
- i : longint;
- Begin
- if F.BufPos>0 then
- begin
- if F.BufPos>sizeof(ConsoleBuff)-1 then
- i:=sizeof(ConsoleBuff)-1
- else
- i:=F.BufPos;
- Move(F.BufPtr^,ConsoleBuff,i);
- ConsoleBuff[i] := #0;
- ConsolePrintf(@ConsoleBuff[0]);
- end;
- F.BufPos:=0;
- ConsoleWrite := 0;
- End;
- Function ConsoleClose(Var F: TextRec): Integer;
- begin
- ConsoleClose:=0;
- end;
- Function ConsoleOpen(Var F: TextRec): Integer;
- Begin
- TextRec(F).InOutFunc:=@ConsoleWrite;
- TextRec(F).FlushFunc:=@ConsoleWrite;
- TextRec(F).CloseFunc:=@ConsoleClose;
- ConsoleOpen:=0;
- End;
- procedure AssignStdErrConsole(Var T: Text);
- begin
- Assign(T,'');
- TextRec(T).OpenFunc:=@ConsoleOpen;
- Rewrite(T);
- end;
- {$endif}
- { this will be called if the nlm is unloaded. It will NOT be
- called if the program exits i.e. with halt.
- Halt (or _exit) can not be called from this callback procedure }
- procedure TermSigHandler (Sig:longint); CDecl;
- var oldTG : longint;
- oldPtr: pointer;
- err : longint;
- current_exit : procedure;
- ThreadName : array [0..20] of char;
- HadExitProc : boolean;
- Count : longint;
- begin
- oldTG := _SetThreadGroupID (NetwareMainThreadGroupID); { this is only needed for nw 3.11 }
- { _GetThreadDataAreaPtr will not be valid because the signal
- handler is called by netware with a differnt thread. To avoid
- problems in the exit routines, we set the data of the main thread
- here }
- if assigned (SetThreadDataAreaPtr) then
- oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread }
- {this signal handler is called within the console command
- thread, the main thread is still running. Via NetwareUnloadProc
- running threads may terminate itself}
- TerminatingThreadID := _GetThreadID;
- {$ifdef DEBUG_MT}
- ConsolePrintf (#13'TermSigHandler Called, MainThread:%x, OurThread: %x'#13#10,ThreadId,TerminatingThreadId);
- if NetwareUnloadProc <> nil then
- ConsolePrintf (#13'Calling NetwareUnloadProcs'#13#10);
- {$endif}
- HadExitProc := false;
- {we need to finalize winock to release threads
- waiting on a blocking socket call. If that thread
- calls halt, we have to avoid that unit finalization
- is called by that thread because we are doing it
- here
- like the old exitProc, mainly to allow winsock to release threads
- blocking in a winsock calls }
- while NetwareUnloadProc<>nil Do
- Begin
- InOutRes:=0;
- current_exit:=tProcedure(NetwareUnloadProc);
- NetwareUnloadProc:=nil;
- current_exit();
- _ThreadSwitchWithDelay;
- hadExitProc := true;
- End;
- err := 0;
- if hadExitProc then
- begin {give the main thread a little bit of time to terminate}
- count := 0;
- repeat
- err := _GetThreadName(ThreadID,ThreadName);
- if err = 0 then _Delay (200);
- inc(count);
- until (err <> 0) or (count > 100); {about 20 seconds}
- {$ifdef DEBUG_MT}
- if err = 0 then
- ConsolePrintf (#13,'Main Thread not terminated'#13#10)
- else
- ConsolePrintf (#13'Main Thread has ended'#13#10);
- {$endif}
- end;
- if err = 0 then
- {$ifdef DEBUG_MT}
- begin
- err := _SuspendThread(ThreadId);
- ConsolePrintf (#13'SuspendThread(%x) returned %d'#13#10,ThreadId,err);
- end;
- {$else}
- _SuspendThread(ThreadId);
- {$endif}
- _ThreadSwitchWithDelay;
- {$ifdef DEBUG_MT}
- ConsolePrintf (#13'Calling do_exit'#13#10);
- {$endif}
- SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
- do_exit; { calls finalize units }
- if assigned (SetThreadDataAreaPtr) then
- SetThreadDataAreaPtr (oldPtr);
- _SetThreadGroupID (oldTG);
- {$ifdef DEBUG_MT}
- ConsolePrintf (#13'TermSigHandler: all done'#13#10);
- {$endif}
- end;
- procedure SysInitStdIO;
- begin
- { Setup stdin, stdout and stderr }
- StdInputHandle := _fileno (LONGINT (_GetStdIn^)); // GetStd** returns **FILE
- StdOutputHandle:= _fileno (LONGINT (_GetStdOut^));
- StdErrorHandle := _fileno (LONGINT (_GetStdErr^));
- OpenStdIO(Input,fmInput,StdInputHandle);
- OpenStdIO(Output,fmOutput,StdOutputHandle);
- OpenStdIO(StdOut,fmOutput,StdOutputHandle);
- {$ifdef StdErrToConsole}
- AssignStdErrConsole(StdErr);
- AssignStdErrConsole(ErrOutput);
- {$else}
- OpenStdIO(StdErr,fmOutput,StdErrorHandle);
- OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
- {$endif}
- end;
- function GetProcessID: SizeUInt;
- begin
- GetProcessID := SizeUInt (GetNlmHandle);
- end;
- {*****************************************************************************
- SystemUnit Initialization
- *****************************************************************************}
- Begin
- StackBottom := SPtr - StackLength;
- SigTermHandlerActive := false;
- NetwareCheckFunction := nil;
- NetwareMainThreadGroupID := _GetThreadGroupID;
- _Signal (_SIGTERM, @TermSigHandler);
- {$ifdef useLongNamespaceByDefault}
- if _getenv ('FPC_DISABLE_LONG_NAMESPACE') = nil then
- begin
- if _SetCurrentNameSpace (NW_NS_LONG) <> 255 then
- begin
- if _SetTargetNamespace (NW_NS_LONG) <> 255 then
- LFNSupport := true
- else
- _SetCurrentNameSpace (NW_NS_DOS);
- end;
- end;
- {$endif useLongNamespaceByDefault}
- { Setup heap }
- InitHeap;
- SysInitExceptions;
- { Reset IO Error }
- InOutRes:=0;
- ThreadID := _GetThreadID;
- {$ifdef DEBUG_MT}
- ConsolePrintf (#13'Start system, ThreadID: %x'#13#10,ThreadID);
- {$endif}
- SysInitStdIO;
- {Delphi Compatible}
- IsLibrary := FALSE;
- IsConsole := TRUE;
- ExitCode := 0;
- {$ifdef HASVARIANT}
- initvariantmanager;
- {$endif HASVARIANT}
- {$ifdef HASWIDESTRING}
- initwidestringmanager;
- {$endif HASWIDESTRING}
- End.
- {
- $Log$
- Revision 1.34 2005-02-01 20:22:49 florian
- * improved widestring infrastructure manager
- Revision 1.33 2004/12/07 11:04:42 armin
- * fixed GetProcessId
- Revision 1.32 2004/12/05 14:36:37 hajny
- + GetProcessID added
- Revision 1.31 2004/11/25 12:32:08 armin
- * adapted to new compiler check for externals
- Revision 1.30 2004/11/04 09:32:31 peter
- ErrOutput added
- Revision 1.29 2004/10/25 18:11:49 armin
- * saveregisters no longer supported by compiler, for now save all registers in stackcheck
- Revision 1.28 2004/10/25 15:38:59 peter
- * compiler defined HEAP and HEAPSIZE removed
- Revision 1.27 2004/09/26 19:25:49 armin
- * exiting threads at nlm unload
- Revision 1.26 2004/09/17 18:29:07 armin
- * added NWGetCodeStart, needed for lineinfo
- Revision 1.25 2004/09/03 19:26:27 olle
- + added maxExitCode to all System.pp
- * constrained error code to be below maxExitCode in RunError et. al.
- Revision 1.24 2004/08/01 20:02:48 armin
- * changed dir separator from \ to /
- * long namespace by default
- * dos.exec implemented
- * getenv ('PATH') is now supported
- * changed FExpand to global version
- * fixed heaplist growth error
- * support SysOSFree
- * stackcheck was without saveregisters
- * fpc can compile itself on netware
- Revision 1.23 2004/07/30 15:05:25 armin
- make netware rtl compilable under 1.9.5
- Revision 1.22 2004/06/17 16:16:14 peter
- * New heapmanager that releases memory back to the OS, donated
- by Micha Nelissen
- Revision 1.21 2004/01/20 23:11:20 hajny
- * ExecuteProcess fixes, ProcessID and ThreadID added
- Revision 1.20 2003/10/25 23:43:59 hajny
- * THandle in sysutils common using System.THandle
- Revision 1.19 2003/10/17 22:12:02 olle
- * changed i386 to cpui386
- Revision 1.18 2003/09/27 11:52:35 peter
- * sbrk returns pointer
- Revision 1.17 2003/03/25 18:17:54 armin
- * support for fcl, support for linking without debug info
- * renamed winsock2 to winsock for win32 compatinility
- * new sockets unit for netware
- * changes for compiler warnings
- Revision 1.16 2003/02/15 19:12:54 armin
- * changes for new threadvar support
- Revision 1.15 2002/10/13 09:28:45 florian
- + call to initvariantmanager inserted
- Revision 1.14 2002/09/07 16:01:21 peter
- * old logs removed and tabs fixed
- Revision 1.13 2002/07/01 16:29:05 peter
- * sLineBreak changed to normal constant like Kylix
- Revision 1.12 2002/04/15 18:47:34 carl
- + reinstate novell stack checking
- Revision 1.11 2002/04/12 17:40:11 carl
- + generic stack checking
- Revision 1.10 2002/04/01 15:20:08 armin
- + unload module no longer shows: Module did not release...
- + check-function will no longer be removed when smartlink is on
- Revision 1.9 2002/04/01 10:47:31 armin
- makefile.fpc for netware
- stderr to netware console
- free all memory (threadvars and heap) to avoid error message while unloading nlm
- Revision 1.8 2002/03/30 09:09:47 armin
- + support check-function for netware
- Revision 1.7 2002/03/17 17:57:33 armin
- + threads and winsock2 implemented
- }
|