mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-16 01:39:27 +02:00
* exiting threads at nlm unload
* renamed some libc functions
This commit is contained in:
armin
parent
2bcaf8ceaf
commit
173aea0681
@ -1,5 +1,5 @@
|
||||
#
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/09/19]
|
||||
# Don't edit, this file is generated by FPCMake Version 1.1 [2004/09/22]
|
||||
#
|
||||
default: all
|
||||
MAKEFILETARGETS=netwlibc
|
||||
@ -1427,7 +1427,8 @@ sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
|
||||
classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconst$(PPUEXT) \
|
||||
sysconst$(PPUEXT) types$(PPUEXT) systhrds$(PPUEXT)
|
||||
sysconst$(PPUEXT) types$(PPUEXT) systhrds$(PPUEXT) \
|
||||
tthread.inc
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
|
||||
|
||||
@ -163,7 +163,8 @@ sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
|
||||
|
||||
classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
|
||||
sysutils$(PPUEXT) typinfo$(PPUEXT) rtlconst$(PPUEXT) \
|
||||
sysconst$(PPUEXT) types$(PPUEXT) systhrds$(PPUEXT)
|
||||
sysconst$(PPUEXT) types$(PPUEXT) systhrds$(PPUEXT) \
|
||||
tthread.inc
|
||||
$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
|
||||
|
||||
typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
|
||||
|
||||
@ -39,10 +39,21 @@ implementation
|
||||
{ OS - independent class implementations are in /inc directory. }
|
||||
{$i classes.inc}
|
||||
|
||||
initialization
|
||||
CommonInit;
|
||||
|
||||
finalization
|
||||
DoneThreads;
|
||||
CommonCleanup;
|
||||
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2004-09-05 20:58:47 armin
|
||||
Revision 1.2 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.1 2004/09/05 20:58:47 armin
|
||||
* first rtl version for netwlibc
|
||||
|
||||
}
|
||||
|
||||
@ -66,7 +66,7 @@ uses
|
||||
function dosversion : word;
|
||||
var i : Tutsname;
|
||||
begin
|
||||
if uname (i) >= 0 then
|
||||
if Fpuname (i) >= 0 then
|
||||
dosversion := WORD (i.netware_minor) SHL 8 + i.netware_major
|
||||
else dosversion := $0005;
|
||||
end;
|
||||
@ -217,7 +217,7 @@ begin
|
||||
//writeln (stderr,'Ok');
|
||||
if i <> -1 then
|
||||
begin
|
||||
waitpid(i,@wstat,0);
|
||||
Fpwaitpid(i,@wstat,0);
|
||||
doserror := 0;
|
||||
lastdosexitcode := wstat;
|
||||
end else
|
||||
@ -393,7 +393,7 @@ begin
|
||||
fname := f._dir + f.name;
|
||||
if length (fname) = 255 then dec (byte(fname[0]));
|
||||
fname := fname + #0;
|
||||
if stat (@fname[1],StatBuf) = 0 then
|
||||
if Fpstat (@fname[1],StatBuf) = 0 then
|
||||
timet2dostime (StatBuf.st_mtim.tv_sec, time)
|
||||
else
|
||||
time := 0;
|
||||
@ -624,7 +624,7 @@ var
|
||||
StatBuf : TStat;
|
||||
begin
|
||||
doserror := 0;
|
||||
if fstat (filerec (f).handle, StatBuf) = 0 then
|
||||
if Fpfstat (filerec (f).handle, StatBuf) = 0 then
|
||||
timet2dostime (StatBuf.st_mtim.tv_sec,time)
|
||||
else begin
|
||||
time := 0;
|
||||
@ -671,7 +671,7 @@ procedure getfattr(var f;var attr : word);
|
||||
VAR StatBuf : TStat;
|
||||
begin
|
||||
doserror := 0;
|
||||
if stat (@textrec(f).name, StatBuf) = 0 then
|
||||
if Fpstat (@textrec(f).name, StatBuf) = 0 then
|
||||
attr := nwattr2dosattr (StatBuf.st_mode)
|
||||
else
|
||||
begin
|
||||
@ -686,7 +686,7 @@ var
|
||||
StatBuf : TStat;
|
||||
newMode : longint;
|
||||
begin
|
||||
if stat (@textrec(f).name,StatBuf) = 0 then
|
||||
if Fpstat (@textrec(f).name,StatBuf) = 0 then
|
||||
begin
|
||||
newmode := StatBuf.st_mode and ($FFFF0000 - M_A_RDONLY-M_A_HIDDEN-M_A_SYSTEM-M_A_ARCH); {only this can be set by dos unit}
|
||||
newmode := newmode or M_A_BITS_SIGNIFICANT; {set netware attributes}
|
||||
@ -698,7 +698,7 @@ begin
|
||||
newmode := newmode or M_A_SYSTEM;
|
||||
if attr and archive > 0 then
|
||||
newmode := newmode or M_A_ARCH;
|
||||
if chmod (@textrec(f).name,newMode) < 0 then
|
||||
if Fpchmod (@textrec(f).name,newMode) < 0 then
|
||||
doserror := ___errno^ else
|
||||
doserror := 0;
|
||||
end else
|
||||
@ -822,7 +822,11 @@ end;
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2004-09-19 20:06:37 armin
|
||||
Revision 1.4 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.3 2004/09/19 20:06:37 armin
|
||||
* removed get/free video buf from video.pp
|
||||
* implemented sockets
|
||||
* basic library support
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -82,6 +82,7 @@ const
|
||||
Dll_Process_Detach_Hook : TDLL_Entry_Hook = nil;
|
||||
Dll_Thread_Attach_Hook : TDLL_Entry_Hook = nil;
|
||||
Dll_Thread_Detach_Hook : TDLL_Entry_Hook = nil;
|
||||
NetwareUnloadProc : pointer = nil; {like exitProc but for nlm unload only}
|
||||
envp : ppchar = nil;
|
||||
|
||||
|
||||
@ -96,7 +97,12 @@ procedure NWSysSetThreadFunctions (atv:TSysReleaseThreadVars;
|
||||
stdata:TSysSetThreadDataAreaPtr);
|
||||
|
||||
|
||||
procedure __ConsolePrintf (s :shortstring);
|
||||
procedure ConsolePrintf (s :shortstring);
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : LONGINT);
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : pchar);
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; P1,P2 : LONGINT);
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; P1,P2,P3 : LONGINT);
|
||||
procedure ConsolePrintf (FormatStr : PCHAR);
|
||||
procedure __EnterDebugger; cdecl;
|
||||
|
||||
function NWGetCodeStart : pointer; // needed for Lineinfo
|
||||
@ -126,6 +132,7 @@ var
|
||||
ReleaseThreadVars : TSysReleaseThreadVars = nil;
|
||||
AllocateThreadVars: TSysReleaseThreadVars = nil;
|
||||
SetThreadDataAreaPtr : TSysSetThreadDataAreaPtr = nil;
|
||||
TerminatingThreadID : dword = 0;
|
||||
|
||||
procedure NWSysSetThreadFunctions (atv:TSysReleaseThreadVars;
|
||||
rtv:TSysReleaseThreadVars;
|
||||
@ -153,7 +160,18 @@ var SigTermHandlerActive : boolean;
|
||||
|
||||
Procedure system_exit;
|
||||
begin
|
||||
//__ConsolePrintf ('system_exit');
|
||||
if TerminatingThreadID <> 0 then
|
||||
if TerminatingThreadID <> ThreadId then
|
||||
if TerminatingThreadID <> dword(pthread_self) then
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf ('Terminating Thread %x because halt was called while Thread %x terminates nlm'#13#10,dword(pthread_self),TerminatingThreadId);
|
||||
{$endif}
|
||||
pthread_exit (nil);
|
||||
// only for the case ExitThread fails
|
||||
while true do
|
||||
NXThreadYield;
|
||||
end;
|
||||
if assigned (ReleaseThreadVars) then ReleaseThreadVars;
|
||||
|
||||
{$ifdef autoHeapRelease}
|
||||
@ -260,7 +278,7 @@ var P2 : POINTER;
|
||||
begin
|
||||
if HeapSbrkReleased then
|
||||
begin
|
||||
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
|
||||
ConsolePrintf ('Error: SysOSFree called after all heap memory was released'#13#10);
|
||||
exit(nil);
|
||||
end;
|
||||
SysOSAlloc := _Alloc (size,HeapAllocResourceTag);
|
||||
@ -332,7 +350,7 @@ var i : longint;
|
||||
begin
|
||||
if HeapSbrkReleased then
|
||||
begin
|
||||
__ConsolePrintf ('Error: SysOSFree called after all heap memory was released');
|
||||
ConsolePrintf ('Error: SysOSFree called after all heap memory was released'#13#10);
|
||||
end else
|
||||
if (HeapSbrkLastUsed > 0) then
|
||||
for i := 1 to HeapSbrkLastUsed do
|
||||
@ -541,7 +559,7 @@ VAR res : LONGINT;
|
||||
statbuf : TStat;
|
||||
begin
|
||||
{$ifdef IOpossix}
|
||||
res := fstat (handle, statbuf);
|
||||
res := Fpfstat (handle, statbuf);
|
||||
{$else}
|
||||
res := _fstat (_fileno (_TFILE(handle)), statbuf); // was _filelength for clib
|
||||
{$endif}
|
||||
@ -858,7 +876,7 @@ procedure InitFPU;assembler;
|
||||
function CheckFunction : longint; CDECL; [public,alias: '_NonAppCheckUnload'];
|
||||
var oldPtr : pointer;
|
||||
begin
|
||||
//__ConsolePrintf ('CheckFunction');
|
||||
//ConsolePrintf ('CheckFunction'#13#10);
|
||||
if assigned (NetwareCheckFunction) then
|
||||
begin
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
@ -875,14 +893,49 @@ begin
|
||||
end;
|
||||
|
||||
|
||||
procedure __ConsolePrintf (s : shortstring);
|
||||
procedure ConsolePrintf (s : shortstring);
|
||||
begin
|
||||
if length(s) > 254 then
|
||||
byte(s[0]) := 254;
|
||||
s := s + #0;
|
||||
ConsolePrintf (@s[1]);
|
||||
end;
|
||||
|
||||
procedure ConsolePrintf (FormatStr : PCHAR);
|
||||
begin
|
||||
if length(s) > 252 then
|
||||
byte(s[0]) := 252;
|
||||
s := s + #13#10#0;
|
||||
if NWLoggerScreen = nil then
|
||||
NWLoggerScreen := getnetwarelogger;
|
||||
screenprintf (NWLoggerScreen,@s[1]);
|
||||
if NWLoggerScreen <> nil then
|
||||
screenprintf (NWLoggerScreen,FormatStr);
|
||||
end;
|
||||
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : LONGINT);
|
||||
begin
|
||||
if NWLoggerScreen = nil then
|
||||
NWLoggerScreen := getnetwarelogger;
|
||||
if NWLoggerScreen <> nil then
|
||||
screenprintf (NWLoggerScreen,FormatStr,Param);
|
||||
end;
|
||||
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; Param : pchar);
|
||||
begin
|
||||
ConsolePrintf (FormatStr,longint(Param));
|
||||
end;
|
||||
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; P1,P2 : LONGINT);
|
||||
begin
|
||||
if NWLoggerScreen = nil then
|
||||
NWLoggerScreen := getnetwarelogger;
|
||||
if NWLoggerScreen <> nil then
|
||||
screenprintf (NWLoggerScreen,FormatStr,P1,P2);
|
||||
end;
|
||||
|
||||
procedure ConsolePrintf (FormatStr : PCHAR; P1,P2,P3 : LONGINT);
|
||||
begin
|
||||
if NWLoggerScreen = nil then
|
||||
NWLoggerScreen := getnetwarelogger;
|
||||
if NWLoggerScreen <> nil then
|
||||
screenprintf (NWLoggerScreen,FormatStr,P1,P2,P3);
|
||||
end;
|
||||
|
||||
|
||||
@ -892,7 +945,7 @@ var NWUts : Tutsname;
|
||||
|
||||
procedure getCodeAddresses;
|
||||
begin
|
||||
if uname(NWUts) < 0 then
|
||||
if Fpuname(NWUts) < 0 then
|
||||
FillChar(NWuts,sizeof(NWUts),0);
|
||||
end;
|
||||
|
||||
@ -973,6 +1026,7 @@ end;
|
||||
Halt (or _exit) can not be called from this callback procedure }
|
||||
procedure TermSigHandler (Sig:longint); CDecl;
|
||||
var oldPtr : pointer;
|
||||
current_exit : procedure;
|
||||
begin
|
||||
{ Threadvar Pointer will not be valid because the signal
|
||||
handler is called by netware with a differnt thread. To avoid
|
||||
@ -980,6 +1034,28 @@ begin
|
||||
here }
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
oldPtr := SetThreadDataAreaPtr (NIL); { nil means main thread }
|
||||
|
||||
TerminatingThreadID := dword(pthread_self);
|
||||
|
||||
{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();
|
||||
NXThreadYield;
|
||||
//hadExitProc := true;
|
||||
End;
|
||||
|
||||
|
||||
SigTermHandlerActive := true; { to avoid that system_exit calls _exit }
|
||||
do_exit; { calls finalize units }
|
||||
if assigned (SetThreadDataAreaPtr) then
|
||||
@ -1025,7 +1101,9 @@ function _DLLMain (hInstDLL:pointer; fdwReason:dword; DLLParam:longint):longbool
|
||||
[public, alias : '_FPC_DLL_Entry'];
|
||||
var res : longbool;
|
||||
begin
|
||||
__ConsolePrintf ('_FPC_DLL_Entry called');
|
||||
{$ifdef DEBUG_MT}
|
||||
ConsolePrintf ('_FPC_DLL_Entry called');
|
||||
{$endif}
|
||||
_DLLMain := false;
|
||||
isLibrary := true;
|
||||
case fdwReason of
|
||||
@ -1094,7 +1172,7 @@ Begin
|
||||
HeapListAllocResourceTag :=
|
||||
AllocateResourceTag(NLMHandle,'Heap Memory List',AllocSignature);
|
||||
{$endif}
|
||||
Signal (SIGTERM, @TermSigHandler);
|
||||
FpSignal (SIGTERM, @TermSigHandler);
|
||||
|
||||
{ Setup heap }
|
||||
InitHeap;
|
||||
@ -1116,7 +1194,11 @@ Begin
|
||||
End.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.3 2004-09-19 20:06:37 armin
|
||||
Revision 1.4 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.3 2004/09/19 20:06:37 armin
|
||||
* removed get/free video buf from video.pp
|
||||
* implemented sockets
|
||||
* basic library support
|
||||
|
||||
@ -34,6 +34,14 @@ type
|
||||
|
||||
implementation
|
||||
|
||||
{ ok, so this is a hack, but it works nicely. Just never use
|
||||
a multiline argument with WRITE_DEBUG! }
|
||||
{$MACRO ON}
|
||||
{$IFDEF DEBUG_MT}
|
||||
{$define WRITE_DEBUG := ConsolePrintf} // actually write something
|
||||
{$ELSE}
|
||||
{$define WRITE_DEBUG := //} // just comment out those lines
|
||||
{$ENDIF}
|
||||
|
||||
{*****************************************************************************
|
||||
Generic overloaded
|
||||
@ -82,17 +90,13 @@ implementation
|
||||
pthread_setspecific(tlskey,dataindex);
|
||||
if thredvarsmainthread = nil then
|
||||
thredvarsmainthread := dataindex;
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf ('SysAllocateThreadVars');
|
||||
{$endif}
|
||||
WRITE_DEBUG ('SysAllocateThreadVars'#13#10);
|
||||
end;
|
||||
|
||||
|
||||
procedure SysReleaseThreadVars;
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf ('SysReleaseThreadVars');
|
||||
{$endif}
|
||||
WRITE_DEBUG ('SysReleaseThreadVars'#13#10);
|
||||
_Free (pthread_getspecific(tlskey));
|
||||
end;
|
||||
|
||||
@ -128,9 +132,7 @@ implementation
|
||||
begin
|
||||
{ Release Threadvars }
|
||||
{$ifdef HASTHREADVAR}
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf('DoneThread, releasing threadvars');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('DoneThread, releasing threadvars'#13#10);
|
||||
SysReleaseThreadVars;
|
||||
{$endif HASTHREADVAR}
|
||||
end;
|
||||
@ -139,39 +141,25 @@ implementation
|
||||
function ThreadMain(param : pointer) : pointer;cdecl;
|
||||
var
|
||||
ti : tthreadinfo;
|
||||
{$ifdef DEBUG_MT}
|
||||
// in here, don't use write/writeln before having called
|
||||
// InitThread! I wonder if anyone ever debugged these routines,
|
||||
// because they will have crashed if DEBUG_MT was enabled!
|
||||
// this took me the good part of an hour to figure out
|
||||
// why it was crashing all the time!
|
||||
// this is kind of a workaround, we simply write(2) to fd 0
|
||||
s: string[100]; // not an ansistring
|
||||
{$endif DEBUG_MT}
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf('New thread started, initing threadvars');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('New thread started, initing threadvars'#13#10);
|
||||
{$ifdef HASTHREADVAR}
|
||||
{ Allocate local thread vars, this must be the first thing,
|
||||
because the exception management and io depends on threadvars }
|
||||
SysAllocateThreadVars;
|
||||
{$endif HASTHREADVAR}
|
||||
{ Copy parameter to local data }
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf ('New thread started, initialising ...');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('New thread started, initialising ...'#13#10);
|
||||
ti:=pthreadinfo(param)^;
|
||||
dispose(pthreadinfo(param));
|
||||
{ Initialize thread }
|
||||
InitThread(ti.stklen);
|
||||
{ Start thread function }
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf('Jumping to thread function');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('Jumping to thread function'#13#10);
|
||||
ThreadMain:=pointer(ti.f(ti.p));
|
||||
DoneThread;
|
||||
pthread_detach(pointer(pthread_self));
|
||||
//pthread_detach(pointer(pthread_self));
|
||||
pthread_exit (nil);
|
||||
end;
|
||||
|
||||
|
||||
@ -182,9 +170,7 @@ implementation
|
||||
ti : pthreadinfo;
|
||||
thread_attr : pthread_attr_t;
|
||||
begin
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf('Creating new thread');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('SysBeginThread: Creating new thread'#13#10);
|
||||
{ Initialize multithreading if not done }
|
||||
if not IsMultiThread then
|
||||
begin
|
||||
@ -202,9 +188,7 @@ implementation
|
||||
ti^.p:=p;
|
||||
ti^.stklen:=stacksize;
|
||||
{ call pthread_create }
|
||||
{$ifdef DEBUG_MT}
|
||||
__ConsolePrintf('Starting new thread');
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('SysBeginThread: Starting new thread'#13#10);
|
||||
pthread_attr_init(@thread_attr);
|
||||
pthread_attr_setinheritsched(@thread_attr, PTHREAD_EXPLICIT_SCHED);
|
||||
|
||||
@ -218,9 +202,7 @@ implementation
|
||||
threadid := 0;
|
||||
end;
|
||||
SysBeginThread:=threadid;
|
||||
{$ifdef DEBUG_MT}
|
||||
writeln('BeginThread returning ',SysBeginThread);
|
||||
{$endif DEBUG_MT}
|
||||
WRITE_DEBUG('SysBeginThread returning %d'#13#10,SysBeginThread);
|
||||
end;
|
||||
|
||||
|
||||
@ -262,6 +244,7 @@ implementation
|
||||
begin
|
||||
LResult := 0;
|
||||
LResultP := @LResult;
|
||||
WRITE_DEBUG('SysWaitForThreadTerminate: waiting for %d, timeout %d'#13#10,threadHandle,timeoutMS);
|
||||
pthread_join(Pointer(threadHandle), @LResultP);
|
||||
SysWaitForThreadTerminate := LResult;
|
||||
end;
|
||||
@ -500,7 +483,11 @@ initialization
|
||||
end.
|
||||
{
|
||||
$Log$
|
||||
Revision 1.2 2004-09-19 20:06:37 armin
|
||||
Revision 1.3 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.2 2004/09/19 20:06:37 armin
|
||||
* removed get/free video buf from video.pp
|
||||
* implemented sockets
|
||||
* basic library support
|
||||
|
||||
@ -175,7 +175,7 @@ Function FileAge (Const FileName : String): Longint;
|
||||
var Info : TStat;
|
||||
TM : TTM;
|
||||
begin
|
||||
If stat (pchar(FileName),Info) <> 0 then
|
||||
If Fpstat (pchar(FileName),Info) <> 0 then
|
||||
exit(-1)
|
||||
else
|
||||
begin
|
||||
@ -189,7 +189,7 @@ end;
|
||||
Function FileExists (Const FileName : String) : Boolean;
|
||||
VAR Info : TStat;
|
||||
begin
|
||||
FileExists:=(stat(pchar(filename),Info) = 0);
|
||||
FileExists:=(Fpstat(pchar(filename),Info) = 0);
|
||||
end;
|
||||
|
||||
|
||||
@ -239,7 +239,7 @@ begin
|
||||
size := Pdirent(FindData.EntryP)^.d_size;
|
||||
name := strpas (Pdirent(FindData.EntryP)^.d_name);
|
||||
fname := FindData._dir + name;
|
||||
if stat (pchar(fname),StatBuf) = 0 then
|
||||
if Fpstat (pchar(fname),StatBuf) = 0 then
|
||||
time := UnixToWinAge (StatBuf.st_mtim.tv_sec)
|
||||
else
|
||||
time := 0;
|
||||
@ -337,7 +337,7 @@ Function FileGetDate (Handle : Longint) : Longint;
|
||||
Var Info : TStat;
|
||||
_PTM : PTM;
|
||||
begin
|
||||
If fstat(Handle,Info) <> 0 then
|
||||
If Fpfstat(Handle,Info) <> 0 then
|
||||
Result:=-1
|
||||
else
|
||||
begin
|
||||
@ -361,7 +361,7 @@ end;
|
||||
Function FileGetAttr (Const FileName : String) : Longint;
|
||||
Var Info : TStat;
|
||||
begin
|
||||
If stat (pchar(FileName),Info) <> 0 then
|
||||
If Fpstat (pchar(FileName),Info) <> 0 then
|
||||
Result:=-1
|
||||
Else
|
||||
Result := (Info.st_mode shr 16) and $ffff;
|
||||
@ -373,7 +373,7 @@ var
|
||||
StatBuf : TStat;
|
||||
newMode : longint;
|
||||
begin
|
||||
if stat (pchar(Filename),StatBuf) = 0 then
|
||||
if Fpstat (pchar(Filename),StatBuf) = 0 then
|
||||
begin
|
||||
{what should i do here ?
|
||||
only support sysutils-standard attributes or also support the extensions defined
|
||||
@ -389,7 +389,7 @@ begin
|
||||
newmode := StatBuf.st_mode and ($ffff0000-M_A_RDONLY-M_A_HIDDEN- M_A_SYSTEM-M_A_SUBDIR-M_A_ARCH);
|
||||
newmode := newmode or (attr shl 16) or M_A_BITS_SIGNIFICANT;
|
||||
end;
|
||||
if chmod (pchar(Filename),newMode) < 0 then
|
||||
if Fpchmod (pchar(Filename),newMode) < 0 then
|
||||
result := ___errno^ else
|
||||
result := 0;
|
||||
end else
|
||||
@ -509,7 +509,7 @@ end;
|
||||
function DirectoryExists (const Directory: string): boolean;
|
||||
var Info : TStat;
|
||||
begin
|
||||
If stat (pchar(Directory),Info) <> 0 then
|
||||
If Fpstat (pchar(Directory),Info) <> 0 then
|
||||
exit(false)
|
||||
else
|
||||
Exit ((Info.st_mode and M_A_SUBDIR) <> 0);
|
||||
@ -638,7 +638,11 @@ end.
|
||||
{
|
||||
|
||||
$Log$
|
||||
Revision 1.3 2004-09-19 20:06:37 armin
|
||||
Revision 1.4 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.3 2004/09/19 20:06:37 armin
|
||||
* removed get/free video buf from video.pp
|
||||
* implemented sockets
|
||||
* basic library support
|
||||
|
||||
@ -66,6 +66,16 @@
|
||||
change them completely.
|
||||
}
|
||||
|
||||
{ ok, so this is a hack, but it works nicely. Just never use
|
||||
a multiline argument with WRITE_DEBUG! }
|
||||
{$MACRO ON}
|
||||
{$IFDEF DEBUG_MT}
|
||||
{$define WRITE_DEBUG := ConsolePrintf} // actually write something
|
||||
{$ELSE}
|
||||
{$define WRITE_DEBUG := //} // just comment out those lines
|
||||
{$ENDIF}
|
||||
|
||||
|
||||
function SemaphoreInit: Pointer;
|
||||
begin
|
||||
SemaphoreInit := GetMem(SizeOf(TFilDes));
|
||||
@ -95,11 +105,22 @@ end;
|
||||
|
||||
// =========== semaphore end ===========
|
||||
|
||||
type
|
||||
PThreadRec=^TThreadRec;
|
||||
TThreadRec=record
|
||||
thread : TThread;
|
||||
next : PThreadRec;
|
||||
end;
|
||||
|
||||
var
|
||||
ThreadsInited: boolean = false;
|
||||
ThreadRoot : PThreadRec;
|
||||
ThreadsInited : boolean = false;
|
||||
DisableRemoveThread : boolean;
|
||||
ThreadCount: longint = 0;
|
||||
{$IFDEF LINUX}
|
||||
GMainPID: LongInt = 0;
|
||||
{$ENDIF}
|
||||
|
||||
const
|
||||
// stupid, considering its not even implemented...
|
||||
Priorities: array [TThreadPriority] of Integer =
|
||||
@ -112,29 +133,83 @@ begin
|
||||
{$IFDEF LINUX}
|
||||
GMainPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
ThreadRoot:=nil;
|
||||
ThreadsInited:=true;
|
||||
DisableRemoveThread:=false;
|
||||
end;
|
||||
end;
|
||||
|
||||
procedure DoneThreads;
|
||||
var
|
||||
hp,next : PThreadRec;
|
||||
begin
|
||||
ThreadsInited := false;
|
||||
DisableRemoveThread := true; {to avoid that Destroy calling RemoveThread modifies Thread List}
|
||||
while assigned(ThreadRoot) do
|
||||
begin
|
||||
WRITE_DEBUG('DoneThreads: calling Destroy'#13#10);
|
||||
ThreadRoot^.Thread.Destroy;
|
||||
hp:=ThreadRoot;
|
||||
ThreadRoot:=ThreadRoot^.Next;
|
||||
dispose(hp);
|
||||
WRITE_DEBUG('DoneThreads: called destroy, remaining threads: %d ThreadRoot: %x'#13#10,ThreadCount,longint(ThreadRoot));
|
||||
end;
|
||||
ThreadsInited:=false;
|
||||
end;
|
||||
|
||||
{ ok, so this is a hack, but it works nicely. Just never use
|
||||
a multiline argument with WRITE_DEBUG! }
|
||||
{$MACRO ON}
|
||||
{$IFDEF DEBUG_MT}
|
||||
{$define WRITE_DEBUG := writeln} // actually write something
|
||||
{$ELSE}
|
||||
{$define WRITE_DEBUG := //} // just comment out those lines
|
||||
{$ENDIF}
|
||||
procedure AddThread(t:TThread);
|
||||
var
|
||||
hp : PThreadRec;
|
||||
begin
|
||||
{ Need to initialize threads ? }
|
||||
if not ThreadsInited then
|
||||
InitThreads;
|
||||
|
||||
{ Put thread in the linked list }
|
||||
new(hp);
|
||||
hp^.Thread:=t;
|
||||
hp^.next:=ThreadRoot;
|
||||
ThreadRoot:=hp;
|
||||
|
||||
inc(ThreadCount);
|
||||
end;
|
||||
|
||||
|
||||
procedure RemoveThread(t:TThread);
|
||||
var
|
||||
lasthp,hp : PThreadRec;
|
||||
begin
|
||||
if not DisableRemoveThread then {disabled while in DoneThreads}
|
||||
begin
|
||||
hp:=ThreadRoot;
|
||||
lasthp:=nil;
|
||||
while assigned(hp) do
|
||||
begin
|
||||
if hp^.Thread=t then
|
||||
begin
|
||||
if assigned(lasthp) then
|
||||
lasthp^.next:=hp^.next
|
||||
else
|
||||
ThreadRoot:=hp^.next;
|
||||
dispose(hp);
|
||||
Dec(ThreadCount);
|
||||
if ThreadCount = 0 then ThreadsInited := false;
|
||||
exit;
|
||||
end;
|
||||
lasthp:=hp;
|
||||
hp:=hp^.next;
|
||||
end;
|
||||
end else
|
||||
dec(ThreadCount);
|
||||
end;
|
||||
|
||||
|
||||
|
||||
function ThreadFunc(parameter: Pointer): LongInt;
|
||||
var
|
||||
LThread: TThread;
|
||||
c: char;
|
||||
begin
|
||||
WRITE_DEBUG('ThreadFunc is here...');
|
||||
WRITE_DEBUG('ThreadFunc is here...'#13#10);
|
||||
LThread := TThread(parameter);
|
||||
{$IFDEF LINUX}
|
||||
// save the PID of the "thread"
|
||||
@ -142,38 +217,38 @@ begin
|
||||
// the LinuxThreads implementation is used
|
||||
LThread.FPid := fpgetpid();
|
||||
{$ENDIF}
|
||||
WRITE_DEBUG('thread initing, parameter = ', LongInt(LThread));
|
||||
WRITE_DEBUG('thread initing, parameter = %d'#13#10, LongInt(LThread));
|
||||
try
|
||||
if LThread.FInitialSuspended then begin
|
||||
SemaphoreWait(LThread.FSem);
|
||||
if not LThread.FInitialSuspended then begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
||||
LThread.Execute;
|
||||
end;
|
||||
end else begin
|
||||
WRITE_DEBUG('going into LThread.Execute');
|
||||
WRITE_DEBUG('going into LThread.Execute'#13#10);
|
||||
LThread.Execute;
|
||||
end;
|
||||
except
|
||||
on e: exception do begin
|
||||
WRITE_DEBUG('got exception: ',e.message);
|
||||
WRITE_DEBUG('got exception: %s'#13#10,pchar(e.message));
|
||||
LThread.FFatalException := TObject(AcquireExceptionObject);
|
||||
// not sure if we should really do this...
|
||||
// but .Destroy was called, so why not try FreeOnTerminate?
|
||||
if e is EThreadDestroyCalled then LThread.FFreeOnTerminate := true;
|
||||
end;
|
||||
end;
|
||||
WRITE_DEBUG('thread done running');
|
||||
WRITE_DEBUG('thread done running'#13#10);
|
||||
Result := LThread.FReturnValue;
|
||||
WRITE_DEBUG('Result is ',Result);
|
||||
WRITE_DEBUG('Result is %d'#13#10,Result);
|
||||
LThread.FFinished := True;
|
||||
LThread.DoTerminate;
|
||||
if LThread.FreeOnTerminate then begin
|
||||
WRITE_DEBUG('Thread should be freed');
|
||||
WRITE_DEBUG('Thread should be freed'#13#10);
|
||||
LThread.Free;
|
||||
WRITE_DEBUG('Thread freed');
|
||||
WRITE_DEBUG('Thread freed'#13#10);
|
||||
end;
|
||||
WRITE_DEBUG('thread func exiting');
|
||||
WRITE_DEBUG('thread func exiting'#13#10);
|
||||
end;
|
||||
|
||||
{ TThread }
|
||||
@ -182,15 +257,16 @@ begin
|
||||
// lets just hope that the user doesn't create a thread
|
||||
// via BeginThread and creates the first TThread Object in there!
|
||||
InitThreads;
|
||||
AddThread(self);
|
||||
inherited Create;
|
||||
FSem := SemaphoreInit;
|
||||
FSuspended :=CreateSuspended;
|
||||
FSuspendedExternal := false;
|
||||
FInitialSuspended := CreateSuspended;
|
||||
FFatalException := nil;
|
||||
WRITE_DEBUG('creating thread, self = ',longint(self));
|
||||
WRITE_DEBUG('creating thread, self = %d'#13#10,longint(self));
|
||||
FHandle:= BeginThread(@ThreadFunc, Pointer(Self), FThreadID);
|
||||
WRITE_DEBUG('TThread.Create done');
|
||||
WRITE_DEBUG('TThread.Create done'#13#10);
|
||||
end;
|
||||
|
||||
|
||||
@ -215,6 +291,7 @@ begin
|
||||
FFatalException := nil;
|
||||
SemaphoreDestroy(FSem);
|
||||
inherited Destroy;
|
||||
RemoveThread(self); {remove it from the list of active threads}
|
||||
end;
|
||||
|
||||
procedure TThread.SetSuspended(Value: Boolean);
|
||||
@ -326,7 +403,11 @@ end;
|
||||
|
||||
{
|
||||
$Log$
|
||||
Revision 1.1 2004-09-05 20:58:47 armin
|
||||
Revision 1.2 2004-09-26 19:23:34 armin
|
||||
* exiting threads at nlm unload
|
||||
* renamed some libc functions
|
||||
|
||||
Revision 1.1 2004/09/05 20:58:47 armin
|
||||
* first rtl version for netwlibc
|
||||
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user