paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-13 14:09:29 +02:00
Code Issues Packages Projects Releases Wiki Activity

* classes moved to rtl for 1.1

Browse Source 
* classes .inc and classes.pp files moved to fcl/classes for
    backwards 1.0.x compatiblity to have it in the fcl
This commit is contained in:
peter 2003-10-06 20:33:58 +00:00
parent f13b9aa406
commit 08d913f656
36 changed files with 198 additions and 1356 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
fcl/Makefile
View File

@ -1,5 +1,5 @@
#
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/10/04]
# Don't edit, this file is generated by FPCMake Version 1.1 [2003/10/05]
#
default: all
MAKEFILETARGETS=linux go32v2 win32 os2 freebsd beos netbsd amiga atari sunos qnx netware openbsd wdosx palmos macos darwin emx watcom
@ -205,8 +205,11 @@ endif
PACKAGESDIR:=$(wildcard $(FPCDIR) $(FPCDIR)/packages/base $(FPCDIR)/packages/extra)
override PACKAGE_NAME=fcl
override PACKAGE_VERSION=1.0.6
ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
CLASSES10=classes
endif
override TARGET_DIRS+=xml image db shedit passrc net
override TARGET_UNITS+=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp cgiapp wformat whtml wtex
override TARGET_UNITS+=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext iostream zstream cachecls xmlreg registry eventlog custapp cgiapp wformat whtml wtex
ifeq ($(OS_TARGET),linux)
override TARGET_UNITS+=process resolve ssockets fpasync syncobjs
endif
@ -225,7 +228,7 @@ endif
ifeq ($(OS_TARGET),openbsd)
override TARGET_UNITS+=process ssockets resolve fpasync
endif
override TARGET_RSTS+=classes ssockets cachecls resolve custapp cgiapp eventlog registry
override TARGET_RSTS+=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
override TARGET_EXAMPLEDIRS+=tests
override CLEAN_UNITS+=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszlib trees zbase zcompres zdeflate zinflate zuncompr zutil
override INSTALL_FPCPACKAGE=y
@ -2180,4 +2183,8 @@ makefiles: fpc_makefiles
ifneq ($(wildcard fpcmake.loc),)
include fpcmake.loc
endif
ifdef CLASSES10
classes$(PPUEXT):
$(COMPILER) -Ficlasses -Ficlasses/$(OS_TARGET) classes/$(OS_TARGET)/classes.pp
endif
xmlreg.pp: xml

17
fcl/Makefile.fpc
View File

@ -20,7 +20,7 @@ units=adler gzcrc gzio infblock infcodes inffast inftrees infutil minigzip paszl
[target]
dirs=xml image db shedit passrc net
units=classes contnrs inifiles ezcgi pipes rtfpars idea base64 gettext \
units=$(CLASSES10) contnrs inifiles ezcgi pipes rtfpars idea base64 gettext \
iostream zstream cachecls xmlreg registry eventlog custapp cgiapp \
wformat whtml wtex
units_freebsd=process ssockets resolve fpasync
@ -29,7 +29,7 @@ units_openbsd=process ssockets resolve fpasync
units_linux=process resolve ssockets fpasync syncobjs
units_win32=process fileinfo resolve ssockets syncobjs
units_netware=resolve ssockets
rsts=classes ssockets cachecls resolve custapp cgiapp eventlog registry
rsts=$(CLASSES10) ssockets cachecls resolve custapp cgiapp eventlog registry
exampledirs=tests
[compiler]
@ -54,5 +54,16 @@ fpcpackage=y
[default]
fpcdir=..
[prerules]
# Also build classes for 1.0.x
ifneq ($(findstring 1.0.,$(FPC_VERSION)),)
CLASSES10=classes
endif
[rules]
xmlreg.pp: xml
ifdef CLASSES10
classes$(PPUEXT):
$(COMPILER) -Ficlasses -Ficlasses/$(OS_TARGET) classes/$(OS_TARGET)/classes.pp
endif
xmlreg.pp: xml

7
fcl/inc/action.inc → fcl/classes/action.inc
View File

@ -187,7 +187,12 @@ end;
{
$Log$
Revision 1.1 2002-01-06 21:54:49 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.1 2002/01/06 21:54:49 peter
* action classes added
}

15
fcl/inc/bits.inc → fcl/classes/bits.inc
View File

@ -24,9 +24,9 @@ Procedure BitsError (Msg : string);
begin
{$ifdef VER1_0}
Raise EBitsError.Create(Msg) at get_caller_addr(get_frame);
Raise EBitsError.Create(Msg) at longint(get_caller_addr(get_frame));
{$else VER1_0}
Raise EBitsError.Create(Msg) at pointer(get_caller_addr(get_frame));
Raise EBitsError.Create(Msg) at get_caller_addr(get_frame);
{$endif VER1_0}
end;
@ -34,9 +34,9 @@ Procedure BitsErrorFmt (Msg : string; const Args : array of const);
begin
{$ifdef VER1_0}
Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
Raise EBitsError.CreateFmt(Msg,args) at longint(get_caller_addr(get_frame));
{$else VER1_0}
Raise EBitsError.CreateFmt(Msg,args) at pointer(get_caller_addr(get_frame));
Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
{$endif VER1_0}
end;
@ -380,7 +380,12 @@ end;
{
$Log$
Revision 1.9 2003-05-25 16:05:18 jonas
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.9 2003/05/25 16:05:18 jonas
* made Args parameter of BitsErrorFmt a const one
Revision 1.8 2002/09/07 15:15:24 peter

10
fcl/inc/classes.inc → fcl/classes/classes.inc
View File

@ -60,9 +60,6 @@ var
{ TStrings and TStringList implementations }
{$i stringl.inc}
{ TThread implementation }
{$i thread.inc}
{ TPersistent implementation }
{$i persist.inc }
@ -1212,7 +1209,12 @@ end;
{
$Log$
Revision 1.14 2003-06-04 17:40:44 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.14 2003/06/04 17:40:44 michael
+ Minor fix by Mattias Gaertner
Revision 1.13 2003/06/04 15:27:24 michael

59
fcl/inc/classesh.inc → fcl/classes/classesh.inc
View File

@ -1081,59 +1081,6 @@ type
property Token: Char read FToken;
end;
{ TThread }
EThread = class(Exception);
TThreadMethod = procedure of object;
TThreadPriority = (tpIdle, tpLowest, tpLower, tpNormal, tpHigher, tpHighest,
tpTimeCritical);
TThread = class
private
FHandle: THandle;
FThreadID: THandle;
FTerminated: Boolean;
FSuspended: Boolean;
FFreeOnTerminate: Boolean;
FFinished: Boolean;
FReturnValue: Integer;
FOnTerminate: TNotifyEvent;
FMethod: TThreadMethod;
FSynchronizeException: TObject;
FFatalException: TObject;
procedure CallOnTerminate;
function GetPriority: TThreadPriority;
procedure SetPriority(Value: TThreadPriority);
procedure SetSuspended(Value: Boolean);
protected
procedure DoTerminate; virtual;
procedure Execute; virtual; abstract;
procedure Synchronize(Method: TThreadMethod);
property ReturnValue: Integer read FReturnValue write FReturnValue;
property Terminated: Boolean read FTerminated;
public
{$ifdef Unix}
{ Needed for linux }
FStackPointer : integer;
FStackSize : integer;
FCallExitProcess : boolean;
{$endif}
constructor Create(CreateSuspended: Boolean);
destructor Destroy; override;
procedure Resume;
procedure Suspend;
procedure Terminate;
function WaitFor: Integer;
property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
property Handle: THandle read FHandle;
property Priority: TThreadPriority read GetPriority write SetPriority;
property Suspended: Boolean read FSuspended write SetSuspended;
property ThreadID: THandle read FThreadID;
property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
property FatalException: TObject read FFatalException;
end;
{ TComponent class }
TOperation = (opInsert, opRemove);
@ -1521,8 +1468,10 @@ function LineStart(Buffer, BufPos: PChar): PChar;
{
$Log$
Revision 1.26 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.25 2003/08/16 15:50:47 michael
+ Fix from Mattias gaertner for IDE support

7
fcl/inc/collect.inc → fcl/classes/collect.inc
View File

@ -341,7 +341,12 @@ end;
{
$Log$
Revision 1.3 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/compon.inc → fcl/classes/compon.inc
View File

@ -533,7 +533,12 @@ end;
{
$Log$
Revision 1.9 2003-04-27 21:16:11 sg
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.9 2003/04/27 21:16:11 sg
* Fixed TComponent.ValidateRename
Revision 1.8 2002/10/15 20:06:19 michael

7
fcl/inc/constse.inc → fcl/classes/constse.inc
View File

@ -276,7 +276,12 @@ const
{
$Log$
Revision 1.8 2003-06-04 17:37:52 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.8 2003/06/04 17:37:52 michael
en InitInheritedComponent erbij voor Delphi 6 compatibiliteit
Revision 1.7 2002/09/07 15:15:24 peter

7
fcl/inc/constsg.inc → fcl/classes/constsg.inc
View File

@ -274,7 +274,12 @@ const
{
$Log$
Revision 1.4 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.4 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/constss.inc → fcl/classes/constss.inc
View File

@ -273,7 +273,12 @@ const
{
$Log$
Revision 1.4 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.4 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/cregist.inc → fcl/classes/cregist.inc
View File

@ -197,7 +197,12 @@ end;
{
$Log$
Revision 1.5 2003-04-19 14:29:25 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.5 2003/04/19 14:29:25 michael
+ Fix from Mattias Gaertner, closes memory leak
Revision 1.4 2002/09/07 15:15:24 peter

0
fcl/inc/dm.inc → fcl/classes/dm.inc
View File

7
fcl/inc/felog.inc → fcl/classes/felog.inc
View File

@ -64,7 +64,12 @@ end;
{
$Log$
Revision 1.1 2003-02-19 20:25:16 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.1 2003/02/19 20:25:16 michael
+ Added event log
}

7
fcl/inc/filer.inc → fcl/classes/filer.inc
View File

@ -23,7 +23,12 @@ end;
{
$Log$
Revision 1.3 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/filerec.inc → fcl/classes/filerec.inc
View File

@ -35,7 +35,12 @@ type
{
$Log$
Revision 1.3 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/freebsd/classes.pp → fcl/classes/freebsd/classes.pp
View File

@ -55,7 +55,12 @@ finalization
end.
{
$Log$
Revision 1.6 2003-09-20 12:38:29 marco
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.6 2003/09/20 12:38:29 marco
* FCL now compiles for FreeBSD with new 1.1. Now Linux.
Revision 1.5 2002/09/07 15:15:24 peter

7
fcl/go32v2/classes.pp → fcl/classes/go32v2/classes.pp
View File

@ -43,7 +43,12 @@ finalization
end.
{
$Log$
Revision 1.3 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/intf.inc → fcl/classes/intf.inc
View File

@ -114,7 +114,12 @@
{
$Log$
Revision 1.2 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.2 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
Revision 1.1 2002/07/16 13:32:51 florian

15
fcl/linux/classes.pp → fcl/classes/linux/classes.pp
View File

@ -16,11 +16,6 @@
{$mode objfpc}
{ Require threading }
{$ifndef ver1_0}
{$threading on}
{$endif ver1_0}
{ determine the type of the resource/form file }
{$define Win16Res}
@ -54,13 +49,15 @@ initialization
finalization
CommonCleanup;
if ThreadsInited then
DoneThreads;
end.
{
$Log$
Revision 1.7 2003-09-20 15:10:30 marco
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.7 2003/09/20 15:10:30 marco
* small fixes. fcl now compiles
Revision 1.6 2002/10/14 19:45:54 peter

11
fcl/inc/lists.inc → fcl/classes/lists.inc
View File

@ -165,9 +165,9 @@ class procedure TList.Error(const Msg: string; Data: Integer);
begin
{$ifdef VER1_0}
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
Raise EListError.CreateFmt(Msg,[Data]) at longint(get_caller_addr(get_frame));
{$else VER1_0}
Raise EListError.CreateFmt(Msg,[Data]) at pointer(get_caller_addr(get_frame));
Raise EListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
{$endif VER1_0}
end;
@ -440,7 +440,12 @@ end;
{
$Log$
Revision 1.9 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.9 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
Revision 1.8 2002/08/16 10:04:58 michael

7
fcl/os2/classes.pp → fcl/classes/os2/classes.pp
View File

@ -47,7 +47,12 @@ finalization
end.
{
$Log$
Revision 1.7 2003-09-02 19:49:16 hajny
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.7 2003/09/02 19:49:16 hajny
* compilation fix (typinfo needed already in interface now)
Revision 1.6 2002/09/07 15:15:27 peter

7
fcl/inc/parser.inc → fcl/classes/parser.inc
View File

@ -308,7 +308,12 @@ begin
end;
{
$Log$
Revision 1.4 2002-09-07 15:15:24 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.4 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

7
fcl/inc/persist.inc → fcl/classes/persist.inc
View File

@ -160,7 +160,12 @@ end;
{
$Log$
Revision 1.4 2002-09-07 15:15:25 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.4 2002/09/07 15:15:25 peter
* old logs removed and tabs fixed
}

7
fcl/inc/reader.inc → fcl/classes/reader.inc
View File

@ -1305,7 +1305,12 @@ end;
{
$Log$
Revision 1.8 2003-08-16 15:50:47 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.8 2003/08/16 15:50:47 michael
+ Fix from Mattias gaertner for IDE support
Revision 1.7 2002/12/02 12:04:07 sg

7
fcl/inc/streams.inc → fcl/classes/streams.inc
View File

@ -783,7 +783,12 @@ end;
{
$Log$
Revision 1.13 2003-07-26 16:20:50 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.13 2003/07/26 16:20:50 michael
+ Fixed readstring from TStringStream (
Revision 1.12 2002/04/25 19:14:13 sg

11
fcl/inc/stringl.inc → fcl/classes/stringl.inc
View File

@ -250,9 +250,9 @@ Procedure TStrings.Error(const Msg: string; Data: Integer);
begin
{$ifdef VER1_0}
Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
Raise EStringListError.CreateFmt(Msg,[Data]) at longint(get_caller_addr(get_frame));
{$else VER1_0}
Raise EStringListError.CreateFmt(Msg,[Data]) at pointer(get_caller_addr(get_frame));
Raise EStringListError.CreateFmt(Msg,[Data]) at get_caller_addr(get_frame);
{$endif VER1_0}
end;
@ -1044,7 +1044,12 @@ end;
{
$Log$
Revision 1.15 2003-05-29 23:13:57 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.15 2003/05/29 23:13:57 michael
fixed case insensitivity of TStrings.IndexOf
Revision 1.14 2002/12/10 21:05:44 michael

7
fcl/inc/twriter.inc → fcl/classes/twriter.inc
View File

@ -215,7 +215,12 @@ end;*)
{
$Log$
Revision 1.3 2002-09-07 15:15:26 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:26 peter
* old logs removed and tabs fixed
}

7
fcl/inc/util.inc → fcl/classes/util.inc
View File

@ -26,7 +26,12 @@ end;
{
$Log$
Revision 1.3 2002-09-07 15:15:26 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.3 2002/09/07 15:15:26 peter
* old logs removed and tabs fixed
}

7
fcl/win32/classes.pp → fcl/classes/win32/classes.pp
View File

@ -51,7 +51,12 @@ finalization
end.
{
$Log$
Revision 1.4 2002-10-14 19:46:13 peter
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.4 2002/10/14 19:46:13 peter
* threading switch
Revision 1.3 2002/09/07 15:15:29 peter

7
fcl/inc/writer.inc → fcl/classes/writer.inc
View File

@ -832,7 +832,12 @@ end;}
{
$Log$
Revision 1.8 2003-08-16 15:50:47 michael
Revision 1.1 2003-10-06 20:33:58 peter
* classes moved to rtl for 1.1
* classes .inc and classes.pp files moved to fcl/classes for
backwards 1.0.x compatiblity to have it in the fcl
Revision 1.8 2003/08/16 15:50:47 michael
+ Fix from Mattias gaertner for IDE support
Revision 1.7 2002/09/20 09:28:11 michael

347
fcl/freebsd/thread.inc
View File

@ -1,347 +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
{$ifdef ver1_0}
waitpid(-1, nil, WNOHANG);
{$else}
fpwaitpid(-1, nil, WNOHANG);
{$endif}
end;
const zeroset :sigset = (0,0,0,0);
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));
{$ifndef ver1_0}
Act^.sa_handler := @SIGCHLDHandler;
fillchar(Act^.sa_mask,sizeof(sigset_t),#0);
{$else}
Act^.handler.sh := @SIGCHLDHandler;
Act^.sa_mask := zeroset;
{$endif}
Act^.sa_flags := SA_NOCLDSTOP {or SA_NOMASK or SA_RESTART};
//Do not block all signals ??. Don't need if SA_NOMASK in flags
{$ifdef ver1_0}
SigAction(SIGCHLD, @Act, @OldAct);
{$else}
fpsigaction(SIGCHLD, @Act, @OldAct);
{$endif}
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;
{$ifdef ver1_0}ExitProcess{$else}fpExit{$endif}(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
{$ifdef ver1_0}kill({$else}fpkill({$endif}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.getpriority
{$else}
Unix.fpGetPriority
{$endif} (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.Setpriority
{$else}
Unix.fpSetPriority
{$endif} (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
{$ifdef ver1_0}kill({$else}fpkill({$endif}FHandle, SIGSTOP);
FSuspended := true;
end;
procedure TThread.Resume;
begin
{$ifdef ver1_0}kill({$else}fpkill({$endif}FHandle, SIGCONT);
FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
status : longint;
begin
{$ifdef ver1_0}
if FThreadID = MainThreadID then
WaitPid(0,@status,0)
else
WaitPid(FHandle,@status,0);
{$else}
if FThreadID = MainThreadID then
fpWaitPid(0,@status,0)
else
fpWaitPid(FHandle,@status,0);
{$endif}
Result:=status;
end;
{
$Log$
Revision 1.12 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.11 2003/09/20 14:51:42 marco
* small v1_0 fix
Revision 1.10 2003/09/20 12:38:29 marco
* FCL now compiles for FreeBSD with new 1.1. Now Linux.
Revision 1.9 2003/01/17 19:01:07 marco
* small fix
Revision 1.8 2002/11/17 21:09:44 marco
* 16byte sigset
Revision 1.7 2002/10/24 12:47:54 marco
* Fix emptying sa_mask
Revision 1.6 2002/09/07 15:15:24 peter
* old logs removed and tabs fixed
}

99
fcl/go32v2/thread.inc
View File

@ -1,99 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
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.
**********************************************************************}
{****************************************************************************}
{* TThread *}
{****************************************************************************}
procedure TThread.CallOnTerminate;
begin
end;
function TThread.GetPriority: TThreadPriority;
begin
GetPriority:=tpNormal;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
begin
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
end;
procedure TThread.DoTerminate;
begin
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
end;
constructor TThread.Create(CreateSuspended: Boolean);
begin
{IsMultiThread := TRUE; }
end;
destructor TThread.Destroy;
begin
end;
procedure TThread.Resume;
begin
end;
procedure TThread.Suspend;
begin
end;
procedure TThread.Terminate;
begin
end;
function TThread.WaitFor: Integer;
begin
WaitFor:=0;
end;
{
$Log$
Revision 1.4 2002-09-07 15:15:24 peter
* old logs removed and tabs fixed
}

317
fcl/linux/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
{$ifdef ver1_0}waitpid{$else}fpwaitpid{$endif}(-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};
Fillchar(Act^.sa_mask,sizeof(Act^.sa_mask),0); //Do not block all signals ??. Don't need if SA_NOMASK in flags
{$ifdef ver1_0}
SigAction(SIGCHLD, Act, OldAct);
{$else}
FpSigAction(SIGCHLD, @Act, @OldAct);
{$endif}
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;
{$ifdef ver1_0}ExitProcess{$else}fpexit{$endif}(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
{$ifdef ver1_0}Kill{$else}fpkill{$endif}(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.GetPriority(Prio_Process,FHandle);
{$else}
Unix.fpGetPriority(Prio_Process,FHandle);
{$endif}
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.SetPriority(Prio_Process,FHandle,Priorities[Value]);
{$else}
Unix.fpSetPriority(Prio_Process,FHandle,Priorities[Value]);
{$endif}
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
{$ifdef ver1_0}Kill{$else}fpkill{$endif}(FHandle, SIGSTOP);
FSuspended := true;
end;
procedure TThread.Resume;
begin
{$ifdef ver1_0}Kill{$else}fpkill{$endif}(FHandle, SIGCONT);
FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
status : longint;
begin
if FThreadID = MainThreadID then
{$ifdef ver1_0}waitpid{$else}fpwaitpid{$endif}(0,@status,0)
else
{$ifdef ver1_0}waitpid{$else}fpwaitpid{$endif}(FHandle,@status,0);
Result:=status;
end;
{
$Log$
Revision 1.9 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.8 2003/09/20 15:10:30 marco
* small fixes. fcl now compiles
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
}

255
fcl/os2/thread.inc
View File

@ -1,255 +0,0 @@
{
$Id$
This file is part of the Free Component Library (FCL)
Copyright (c) 1999-2002 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.
**********************************************************************}
{****************************************************************************}
{* TThread *}
{****************************************************************************}
(* OS/2 specific declarations - see unit DosCalls for descriptions *)
type
TByteArray = array [0..$fff0] of byte;
PByteArray = ^TByteArray;
TThreadEntry = function (Param: pointer): longint; cdecl;
TSysThreadIB = record
TID, Priority, Version: longint;
MCCount, MCForceFlag: word;
end;
PSysThreadIB = ^TSysThreadIB;
TThreadInfoBlock = record
Exh_Chain, Stack, StackLimit: pointer;
TIB2: PSysThreadIB;
Version, Ordinal: longint;
end;
PThreadInfoBlock = ^TThreadInfoBlock;
PPThreadInfoBlock = ^PThreadInfoBlock;
TProcessInfoBlock = record
PID, ParentPID, HMTE: longint;
Cmd, Env: PByteArray;
flStatus, tType: longint;
end;
PProcessInfoBlock = ^TProcessInfoBlock;
PPProcessInfoBlock = ^PProcessInfoBlock;
const
deThread = 0;
deProcess = 1;
dtSuspended = 1;
dtStack_Commited = 2;
dtWait = 0;
dtNoWait = 1;
procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
PAPIB: PPProcessInfoBlock); cdecl; external 'DOSCALLS' index 312;
function DosSetPriority (Scope, TrClass, Delta, PortID: longint): longint;
cdecl; external 'DOSCALLS' index 236;
procedure DosExit (Action, Result: longint); cdecl;
external 'DOSCALLS' index 233;
function DosCreateThread (var TID: longint; Address: TThreadEntry;
aParam: pointer; Flags: longint; StackSize: longint): longint; cdecl;
external 'DOSCALLS' index 311;
function DosKillThread (TID: longint): longint; cdecl;
external 'DOSCALLS' index 111;
function DosResumeThread (TID: longint): longint; cdecl;
external 'DOSCALLS' index 237;
function DosSuspendThread (TID: longint): longint; cdecl;
external 'DOSCALLS' index 238;
function DosWaitThread (var TID: longint; Option: longint): longint; cdecl;
external 'DOSCALLS' index 349;
const
Priorities: array [TThreadPriority] of word = ($100, $200, $207, $20F, $217,
$21F, $300);
ThreadCount: longint = 0;
(* Implementation of exported functions *)
procedure AddThread (T: TThread);
begin
Inc (ThreadCount);
end;
procedure RemoveThread (T: TThread);
begin
Dec (ThreadCount);
end;
procedure TThread.CallOnTerminate;
begin
FOnTerminate (Self);
end;
function TThread.GetPriority: TThreadPriority;
var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
I: TThreadPriority;
begin
DosGetInfoBlocks (@PTIB, @PPIB);
with PTIB^.TIB2^ do
if Priority >= $300 then GetPriority := tpTimeCritical else
if Priority < $200 then GetPriority := tpIdle else
begin
I := Succ (Low (TThreadPriority));
while (I < High (TThreadPriority)) and
(Priority - Priorities [I] <= Priorities [Succ (I)] - Priority) do Inc (I);
GetPriority := I;
end;
end;
procedure TThread.SetPriority(Value: TThreadPriority);
var
PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock;
begin
DosGetInfoBlocks (@PTIB, @PPIB);
(*
PTIB^.TIB2^.Priority := Priorities [Value];
*)
DosSetPriority (2, High (Priorities [Value]),
Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);
end;
procedure TThread.SetSuspended(Value: Boolean);
begin
if Value <> FSuspended then
begin
if Value then Suspend else Resume;
end;
end;
procedure TThread.DoTerminate;
begin
if Assigned (FOnTerminate) then Synchronize (@CallOnTerminate);
end;
procedure TThread.Synchronize(Method: TThreadMethod);
begin
end;
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;
DosExit (deThread, Result);
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: Integer;
begin
inherited Create;
AddThread (Self);
FSuspended := CreateSuspended;
Flags := dtStack_Commited;
if FSuspended then Flags := Flags or dtSuspended;
if DosCreateThread (FThreadID, @ThreadProc, pointer (Self), Flags, 16384)
<> 0 then
begin
FFinished := true;
Destroy;
end else FHandle := FThreadID;
IsMultiThread := TRUE;
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
if FHandle <> -1 then DosKillThread (FHandle);
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread (Self);
end;
procedure TThread.Resume;
begin
FSuspended := not (DosResumeThread (FHandle) = 0);
end;
procedure TThread.Suspend;
begin
FSuspended := DosSuspendThread (FHandle) = 0;
end;
procedure TThread.Terminate;
begin
FTerminated := true;
end;
function TThread.WaitFor: Integer;
begin
WaitFor := DosWaitThread (FHandle, dtWait);
end;
{
$Log$
Revision 1.8 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.7 2003/02/20 17:12:39 hajny
* fixes for OS/2 v2.1 incompatibility
Revision 1.6 2002/09/07 15:15:27 peter
* old logs removed and tabs fixed
Revision 1.5 2002/02/10 13:38:14 hajny
* DosCalls dependency removed to avoid type redefinitions
}

231
fcl/win32/thread.inc
View File

@ -1,231 +0,0 @@
{ Thread management routines }
const
CM_EXECPROC = $8FFF;
CM_DESTROYWINDOW = $8FFE;
type
PRaiseFrame = ^TRaiseFrame;
TRaiseFrame = record
NextRaise: PRaiseFrame;
ExceptAddr: Pointer;
ExceptObject: TObject;
ExceptionRecord: pointer; {PExceptionRecord}
end;
var
ThreadWindow: HWND;
ThreadCount: Integer;
function ThreadWndProc(Window: HWnd; AMessage:UInt; WParam : WParam; LParam: LParam): Longint; stdcall;
begin
case AMessage of
CM_EXECPROC:
with TThread(lParam) do
begin
Result := 0;
try
FSynchronizeException := nil;
FMethod;
except
{ if RaiseList <> nil then
begin
FSynchronizeException := PRaiseFrame(RaiseList)^.ExceptObject;
PRaiseFrame(RaiseList)^.ExceptObject := nil;
end; }
end;
end;
CM_DESTROYWINDOW:
begin
DestroyWindow(Window);
Result := 0;
end;
else
Result := DefWindowProc(Window, AMessage, wParam, lParam);
end;
end;
const
ThreadWindowClass: TWndClass = (
style: 0;
lpfnWndProc: nil;
cbClsExtra: 0;
cbWndExtra: 0;
hInstance: 0;
hIcon: 0;
hCursor: 0;
hbrBackground: 0;
lpszMenuName: nil;
lpszClassName: 'TThreadWindow');
procedure AddThread;
function AllocateWindow: HWND;
var
TempClass: TWndClass;
ClassRegistered: Boolean;
begin
ThreadWindowClass.hInstance := HInstance;
ThreadWindowClass.lpfnWndProc:=WndProc(@ThreadWndProc);
ClassRegistered := GetClassInfo(HInstance, ThreadWindowClass.lpszClassName,
@TempClass);
if not ClassRegistered or (TempClass.lpfnWndProc <> WndProc(@ThreadWndProc)) then
begin
if ClassRegistered then
Windows.UnregisterClass(ThreadWindowClass.lpszClassName, HInstance);
Windows.RegisterClass(ThreadWindowClass);
end;
Result := CreateWindow(ThreadWindowClass.lpszClassName, '', 0,
0, 0, 0, 0, 0, 0, HInstance, nil);
end;
begin
if ThreadCount = 0 then
ThreadWindow := AllocateWindow;
Inc(ThreadCount);
end;
procedure RemoveThread;
begin
Dec(ThreadCount);
if ThreadCount = 0 then
PostMessage(ThreadWindow, CM_DESTROYWINDOW, 0, 0);
end;
{ TThread }
function ThreadProc(Thread: TThread): Integer;
var
FreeThread: Boolean;
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;
ExitThread(Result);
end;
constructor TThread.Create(CreateSuspended: Boolean);
var
Flags: Integer;
begin
inherited Create;
AddThread;
FSuspended := CreateSuspended;
Flags := 0;
if CreateSuspended then Flags := CREATE_SUSPENDED;
IsMultiThread := TRUE;
FHandle := CreateThread(nil, 0, @ThreadProc, Pointer(self), Flags, DWord(FThreadID));
FFatalException := nil;
end;
destructor TThread.Destroy;
begin
if not FFinished and not Suspended then
begin
Terminate;
WaitFor;
end;
if FHandle <> 0 then CloseHandle(FHandle);
FFatalException.Free;
FFatalException := nil;
inherited Destroy;
RemoveThread;
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 := GetThreadPriority(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
SetThreadPriority(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
FSuspended := True;
SuspendThread(FHandle);
end;
procedure TThread.Resume;
begin
if ResumeThread(FHandle) = 1 then FSuspended := False;
end;
procedure TThread.Terminate;
begin
FTerminated := True;
end;
function TThread.WaitFor: Integer;
var
Msg: TMsg;
begin
if GetCurrentThreadID = MainThreadID then
while MsgWaitForMultipleObjects(1, FHandle, False, INFINITE, QS_SENDMESSAGE) = WAIT_OBJECT_0 + 1 do
PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE)
else
WaitForSingleObject(ulong(FHandle), INFINITE);
GetExitCodeThread(FHandle, DWord(Result));
end;
{
$Log$
Revision 1.8 2003-10-06 17:06:55 florian
* applied Johannes Berg's patch for exception handling in threads
Revision 1.7 2003/04/23 11:35:30 peter
* wndproc definition fix
Revision 1.6 2002/09/07 15:15:29 peter
* old logs removed and tabs fixed
}