paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-16 03:59:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* moved more targets

Browse Source
This commit is contained in:
peter 2003-10-06 20:56:45 +00:00
parent 08d913f656
commit 69a956c5b6
6 changed files with 8 additions and 947 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
fcl/netbsd/classes.pp → fcl/classes/netbsd/classes.pp
View File

@ -55,7 +55,10 @@ finalization
end.
{
$Log$
Revision 1.2 2002-09-07 15:15:27 peter
Revision 1.1 2003-10-06 20:56:45 peter
* moved more targets
Revision 1.2 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
}

5
fcl/openbsd/classes.pp → fcl/classes/openbsd/classes.pp
View File

@ -55,7 +55,10 @@ finalization
end.
{
$Log$
Revision 1.2 2002-09-07 15:15:27 peter
Revision 1.1 2003-10-06 20:56:45 peter
* moved more targets
Revision 1.2 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
Revision 1.1 2002/07/30 16:03:29 marco

317
fcl/netbsd/thread.inc
View File

@ -1,317 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by Peter Vreman
Linux TThread implementation
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.
**********************************************************************}
type
PThreadRec=^TThreadRec;
TThreadRec=record
thread : TThread;
next : PThreadRec;
end;
var
ThreadRoot : PThreadRec;
ThreadsInited : boolean;
// MainThreadID: longint;
Const
ThreadCount: longint = 0;
function ThreadSelf:TThread;
var
hp : PThreadRec;
sp : longint;
begin
sp:=SPtr;
hp:=ThreadRoot;
while assigned(hp) do
begin
if (sp<=hp^.Thread.FStackPointer) and
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
begin
Result:=hp^.Thread;
exit;
end;
hp:=hp^.next;
end;
Result:=nil;
end;
//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function
procedure SIGCHLDHandler(Sig: longint); cdecl;
begin
waitpid(-1, nil, WNOHANG);
end;
Const sigzero : sigset_t = (0,0,0,0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
procedure InitThreads;
var
Act, OldAct: PSigActionRec;
begin
ThreadRoot:=nil;
ThreadsInited:=true;
// This will install SIGCHLD signal handler
// signal() installs "one-shot" handler,
// so it is better to install and set up handler with sigaction()
GetMem(Act, SizeOf(SigActionRec));
GetMem(OldAct, SizeOf(SigActionRec));
{$ifdef ver1_0}
Act^.handler.sh := @SIGCHLDHandler;
{$else}
Act^.sa_handler := @SIGCHLDHandler;
{$endif}
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
{$ifdef VER1_0}
Act^.sa_mask[0] := 0; //Do not block all signals ??. Don't need if SA_NOMASK in flags
{$else}
Act^.sa_mask := sigzero;
{$endif}
SigAction(SIGCHLD, Act, OldAct);
FreeMem(Act, SizeOf(SigActionRec));
FreeMem(OldAct, SizeOf(SigActionRec));
end;
procedure DoneThreads;
var
hp : PThreadRec;
begin
while assigned(ThreadRoot) do
begin
ThreadRoot^.Thread.Destroy;
hp:=ThreadRoot;
ThreadRoot:=ThreadRoot^.Next;
dispose(hp);
end;
ThreadsInited:=false;
end;
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, 1);
end;
procedure RemoveThread(t:TThread);
var
lasthp,hp : PThreadRec;
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);
exit;
end;
lasthp:=hp;
hp:=hp^.next;
end;
Dec(ThreadCount, 1);
if ThreadCount = 0 then DoneThreads;
end;
{ TThread }
function ThreadProc(args:pointer): Integer;cdecl;
var
FreeThread: Boolean;
Thread : TThread absolute args;
begin
try
Thread.Execute;
except
Thread.FFatalException := TObject(AcquireExceptionObject);
end;
FreeThread := Thread.FFreeOnTerminate;
Result := Thread.FReturnValue;
Thread.FFinished := True;
Thread.DoTerminate;
if FreeThread then
Thread.Free;
ExitProcess(Result);
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: Integer;
begin
inherited Create;
AddThread(self);
FSuspended := CreateSuspended;
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
{ Setup 16k of stack }
FStackSize:=16384;
Getmem(pointer(FStackPointer),FStackSize);
inc(FStackPointer,FStackSize);
FCallExitProcess:=false;
{ Clone }
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
if FSuspended then Suspend;
FThreadID := FHandle;
IsMultiThread := TRUE;
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
if FHandle <> -1 then
Kill(FHandle, SIGKILL);
dec(FStackPointer,FStackSize);
Freemem(pointer(FStackPointer),FStackSize);
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread(self);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
const
{ I Don't know idle or timecritical, value is also 20, so the largest other
possibility is 19 (PFV) }
Priorities: array [TThreadPriority] of Integer =
(-20,-19,-10,9,10,19,20);
function TThread.GetPriority: TThreadPriority;
var
P: Integer;
I: TThreadPriority;
begin
P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities[I] = P then
Result := I;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
{$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]);
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
FSynchronizeException := nil;
FMethod := Method;
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
if Assigned(FSynchronizeException) then
raise FSynchronizeException;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
Kill(FHandle, SIGSTOP);
FSuspended := true;
end;
procedure TThread.Resume;
begin
Kill(FHandle, SIGCONT);
FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
status : longint;
begin
if FThreadID = MainThreadID then
WaitPid(0,@status,0)
else
WaitPid(FHandle,@status,0);
Result:=status;
end;
{
$Log$
Revision 1.6 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.5 2003/01/31 14:49:56 pierre
* adapt 1.0 to change in signal.inc
Revision 1.4 2003/01/24 21:13:31 marco
* More bugs, but now gmake all works.
Revision 1.3 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
}

47
fcl/netware/classes.pp
View File

@ -1,47 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
Classes unit for win32
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.
**********************************************************************}
{$mode objfpc}
{ determine the type of the resource/form file }
{$define Win16Res}
unit Classes;
interface
uses
sysutils,
typinfo,
systhrds;
{$i classesh.inc}
implementation
{ OS - independent class implementations are in /inc directory. }
{$i classes.inc}
end.
{
$Log$
Revision 1.1 2003-03-25 17:56:19 armin
* first fcl implementation for netware
Revision 1.3 2002/09/07 15:15:28 peter
* old logs removed and tabs fixed
}

278
fcl/netware/thread.inc
View File

@ -1,278 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2003 by the Free Pascal development team
Netware TThread implementation
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.
**********************************************************************}
type
PThreadRec=^TThreadRec;
TThreadRec=record
thread : TThread;
next : PThreadRec;
end;
var
ThreadRoot : PThreadRec;
ThreadsInited : boolean;
// MainThreadID: longint;
Const
ThreadCount: longint = 0;
{function ThreadSelf:TThread;
var
hp : PThreadRec;
sp : longint;
begin
sp:=SPtr;
hp:=ThreadRoot;
while assigned(hp) do
begin
if (sp<=hp^.Thread.FStackPointer) and
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
begin
Result:=hp^.Thread;
exit;
end;
hp:=hp^.next;
end;
Result:=nil;
end;}
procedure InitThreads;
begin
ThreadRoot:=nil;
ThreadsInited:=true;
end;
procedure DoneThreads;
var
hp : PThreadRec;
begin
while assigned(ThreadRoot) do
begin
ThreadRoot^.Thread.Destroy;
hp:=ThreadRoot;
ThreadRoot:=ThreadRoot^.Next;
dispose(hp);
end;
ThreadsInited:=false;
end;
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, 1);
end;
procedure RemoveThread(t:TThread);
var
lasthp,hp : PThreadRec;
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);
exit;
end;
lasthp:=hp;
hp:=hp^.next;
end;
Dec(ThreadCount, 1);
if ThreadCount = 0 then DoneThreads;
end;
{ TThread }
function ThreadProc(args:pointer): Integer;cdecl;
var
FreeThread: Boolean;
Thread : TThread absolute args;
begin
try
Thread.Execute;
except
Thread.FFatalException := TObject(AcquireExceptionObject);
end;
FreeThread := Thread.FFreeOnTerminate;
Result := Thread.FReturnValue;
Thread.FFinished := True;
Thread.DoTerminate;
if FreeThread then
Thread.Free;
EndThread(Result);
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: Integer;
begin
inherited Create;
AddThread(self);
FSuspended := CreateSuspended;
{ Create new thread }
FHandle := BeginThread (@ThreadProc,self);
if FSuspended then Suspend;
FThreadID := FHandle;
//IsMultiThread := TRUE; {already set by systhrds}
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished {and not Suspended} then
begin
if Suspended then ResumeThread (FHandle); {netware can not kill a thread}
Terminate;
WaitFor;
end;
if FHandle <> -1 then
KillThread (FHandle); {something went wrong, kill the thread (not possible on netware)}
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread(self);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
const
Priorities: array [TThreadPriority] of Integer =
(THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST, THREAD_PRIORITY_BELOW_NORMAL,
THREAD_PRIORITY_NORMAL, THREAD_PRIORITY_ABOVE_NORMAL,
THREAD_PRIORITY_HIGHEST, THREAD_PRIORITY_TIME_CRITICAL);
function TThread.GetPriority: TThreadPriority;
var
P: Integer;
I: TThreadPriority;
begin
P := ThreadGetPriority(FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities[I] = P then Result := I;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
ThreadSetPriority(FHandle, Priorities[Value]);
end;
{does not make sense for netware}
procedure TThread.Synchronize(Method: TThreadMethod);
begin
{$ifndef netware}
FSynchronizeException := nil;
FMethod := Method;
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
{$warning Synchronize needs implementation}
if Assigned(FSynchronizeException) then
raise FSynchronizeException;
{$endif}
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
SuspendThread (FHandle);
FSuspended := true;
end;
procedure TThread.Resume;
begin
ResumeThread (FHandle);
FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
ThreadSwitch;
end;
function TThread.WaitFor: Integer;
begin
Result := WaitForThreadTerminate (FHandle,0);
if Result = 0 then
FHandle := -1;
end;
{
$Log$
Revision 1.3 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.2 2003/03/27 17:14:27 armin
* more platform independent thread routines, needs to be implemented for unix
Revision 1.1 2003/03/25 17:56:19 armin
* first fcl implementation for netware
Revision 1.7 2002/12/18 20:44:36 peter
* use fillchar to clear sigset
Revision 1.6 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
}

303
fcl/openbsd/thread.inc
View File

@ -1,303 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2000 by Peter Vreman
Linux TThread implementation
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.
**********************************************************************}
type
PThreadRec=^TThreadRec;
TThreadRec=record
thread : TThread;
next : PThreadRec;
end;
var
ThreadRoot : PThreadRec;
ThreadsInited : boolean;
// MainThreadID: longint;
Const
ThreadCount: longint = 0;
function ThreadSelf:TThread;
var
hp : PThreadRec;
sp : longint;
begin
sp:=SPtr;
hp:=ThreadRoot;
while assigned(hp) do
begin
if (sp<=hp^.Thread.FStackPointer) and
(sp>(hp^.Thread.FStackPointer-hp^.Thread.FStackSize)) then
begin
Result:=hp^.Thread;
exit;
end;
hp:=hp^.next;
end;
Result:=nil;
end;
//function SIGCHLDHandler(Sig: longint): longint; cdecl;//this is std linux C declaration as function
procedure SIGCHLDHandler(Sig: longint); cdecl;
begin
waitpid(-1, nil, WNOHANG);
end;
procedure InitThreads;
var
Act, OldAct: PSigActionRec;
begin
ThreadRoot:=nil;
ThreadsInited:=true;
// This will install SIGCHLD signal handler
// signal() installs "one-shot" handler,
// so it is better to install and set up handler with sigaction()
GetMem(Act, SizeOf(SigActionRec));
GetMem(OldAct, SizeOf(SigActionRec));
Act^.handler.sh := @SIGCHLDHandler;
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
Act^.sa_mask := 0; //Do not block all signals ??. Don't need if SA_NOMASK in flags
SigAction(SIGCHLD, Act, OldAct);
FreeMem(Act, SizeOf(SigActionRec));
FreeMem(OldAct, SizeOf(SigActionRec));
end;
procedure DoneThreads;
var
hp : PThreadRec;
begin
while assigned(ThreadRoot) do
begin
ThreadRoot^.Thread.Destroy;
hp:=ThreadRoot;
ThreadRoot:=ThreadRoot^.Next;
dispose(hp);
end;
ThreadsInited:=false;
end;
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, 1);
end;
procedure RemoveThread(t:TThread);
var
lasthp,hp : PThreadRec;
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);
exit;
end;
lasthp:=hp;
hp:=hp^.next;
end;
Dec(ThreadCount, 1);
if ThreadCount = 0 then DoneThreads;
end;
{ TThread }
function ThreadProc(args:pointer): Integer;cdecl;
var
FreeThread: Boolean;
Thread : TThread absolute args;
begin
try
Thread.Execute;
except
Thread.FFatalException := TObject(AcquireExceptionObject);
end;
FreeThread := Thread.FFreeOnTerminate;
Result := Thread.FReturnValue;
Thread.FFinished := True;
Thread.DoTerminate;
if FreeThread then
Thread.Free;
ExitProcess(Result);
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: Integer;
begin
inherited Create;
AddThread(self);
FSuspended := CreateSuspended;
Flags := CLONE_VM + CLONE_FS + CLONE_FILES + CLONE_SIGHAND + SIGCHLD;
{ Setup 16k of stack }
FStackSize:=16384;
Getmem(pointer(FStackPointer),FStackSize);
inc(FStackPointer,FStackSize);
FCallExitProcess:=false;
{ Clone }
FHandle:= Clone(@ThreadProc,pointer(FStackPointer),Flags,self);
if FSuspended then Suspend;
FThreadID := FHandle;
IsMultiThread := TRUE;
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
if FHandle <> -1 then
Kill(FHandle, SIGKILL);
dec(FStackPointer,FStackSize);
Freemem(pointer(FStackPointer),FStackSize);
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread(self);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate(Self);
end;
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then
Synchronize(@CallOnTerminate);
end;
const
{ I Don't know idle or timecritical, value is also 20, so the largest other
possibility is 19 (PFV) }
Priorities: array [TThreadPriority] of Integer =
(-20,-19,-10,9,10,19,20);
function TThread.GetPriority: TThreadPriority;
var
P: Integer;
I: TThreadPriority;
begin
P := {$ifdef ver1_0}Linux{$else}Unix{$endif}.GetPriority(Prio_Process,FHandle);
Result := tpNormal;
for I := Low(TThreadPriority) to High(TThreadPriority) do
if Priorities[I] = P then
Result := I;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
{$ifdef ver1_0}Linux{$else}Unix{$endif}.SetPriority(Prio_Process,FHandle, Priorities[Value]);
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
FSynchronizeException := nil;
FMethod := Method;
{ SendMessage(ThreadWindow, CM_EXECPROC, 0, Longint(Self)); }
if Assigned(FSynchronizeException) then
raise FSynchronizeException;
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
if Value then
Suspend
else
Resume;
end;
procedure TThread.Suspend;
begin
Kill(FHandle, SIGSTOP);
FSuspended := true;
end;
procedure TThread.Resume;
begin
Kill(FHandle, SIGCONT);
FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
status : longint;
begin
if FThreadID = MainThreadID then
WaitPid(0,@status,0)
else
WaitPid(FHandle,@status,0);
Result:=status;
end;
{
$Log$
Revision 1.3 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.2 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
Revision 1.1 2002/07/30 16:03:29 marco
* Added for OpenBSD. Plain copy of NetBSD
}