From 08d913f656509c6f8fdf6e587f12cbb0c5e7d0d1 Mon Sep 17 00:00:00 2001 From: peter Date: Mon, 6 Oct 2003 20:33:58 +0000 Subject: [PATCH] * 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 --- fcl/Makefile | 13 +- fcl/Makefile.fpc | 17 +- fcl/{inc => classes}/action.inc | 7 +- fcl/{inc => classes}/bits.inc | 15 +- fcl/{inc => classes}/classes.inc | 10 +- fcl/{inc => classes}/classesh.inc | 59 +---- fcl/{inc => classes}/collect.inc | 7 +- fcl/{inc => classes}/compon.inc | 7 +- fcl/{inc => classes}/constse.inc | 7 +- fcl/{inc => classes}/constsg.inc | 7 +- fcl/{inc => classes}/constss.inc | 7 +- fcl/{inc => classes}/cregist.inc | 7 +- fcl/{inc => classes}/dm.inc | 0 fcl/{inc => classes}/felog.inc | 7 +- fcl/{inc => classes}/filer.inc | 7 +- fcl/{inc => classes}/filerec.inc | 7 +- fcl/{ => classes}/freebsd/classes.pp | 7 +- fcl/{ => classes}/go32v2/classes.pp | 7 +- fcl/{inc => classes}/intf.inc | 7 +- fcl/{ => classes}/linux/classes.pp | 15 +- fcl/{inc => classes}/lists.inc | 11 +- fcl/{ => classes}/os2/classes.pp | 7 +- fcl/{inc => classes}/parser.inc | 7 +- fcl/{inc => classes}/persist.inc | 7 +- fcl/{inc => classes}/reader.inc | 7 +- fcl/{inc => classes}/streams.inc | 7 +- fcl/{inc => classes}/stringl.inc | 11 +- fcl/{inc => classes}/twriter.inc | 7 +- fcl/{inc => classes}/util.inc | 7 +- fcl/{ => classes}/win32/classes.pp | 7 +- fcl/{inc => classes}/writer.inc | 7 +- fcl/freebsd/thread.inc | 347 --------------------------- fcl/go32v2/thread.inc | 99 -------- fcl/linux/thread.inc | 317 ------------------------ fcl/os2/thread.inc | 255 -------------------- fcl/win32/thread.inc | 231 ------------------ 36 files changed, 198 insertions(+), 1356 deletions(-) rename fcl/{inc => classes}/action.inc (94%) rename fcl/{inc => classes}/bits.inc (96%) rename fcl/{inc => classes}/classes.inc (99%) rename fcl/{inc => classes}/classesh.inc (96%) rename fcl/{inc => classes}/collect.inc (95%) rename fcl/{inc => classes}/compon.inc (97%) rename fcl/{inc => classes}/constse.inc (97%) rename fcl/{inc => classes}/constsg.inc (97%) rename fcl/{inc => classes}/constss.inc (97%) rename fcl/{inc => classes}/cregist.inc (94%) rename fcl/{inc => classes}/dm.inc (100%) rename fcl/{inc => classes}/felog.inc (85%) rename fcl/{inc => classes}/filer.inc (77%) rename fcl/{inc => classes}/filerec.inc (80%) rename fcl/{ => classes}/freebsd/classes.pp (82%) rename fcl/{ => classes}/go32v2/classes.pp (78%) rename fcl/{inc => classes}/intf.inc (89%) rename fcl/{ => classes}/linux/classes.pp (82%) rename fcl/{inc => classes}/lists.inc (96%) rename fcl/{ => classes}/os2/classes.pp (82%) rename fcl/{inc => classes}/parser.inc (96%) rename fcl/{inc => classes}/persist.inc (93%) rename fcl/{inc => classes}/reader.inc (99%) rename fcl/{inc => classes}/streams.inc (98%) rename fcl/{inc => classes}/stringl.inc (98%) rename fcl/{inc => classes}/twriter.inc (94%) rename fcl/{inc => classes}/util.inc (74%) rename fcl/{ => classes}/win32/classes.pp (81%) rename fcl/{inc => classes}/writer.inc (98%) delete mode 100644 fcl/freebsd/thread.inc delete mode 100644 fcl/go32v2/thread.inc delete mode 100644 fcl/linux/thread.inc delete mode 100644 fcl/os2/thread.inc delete mode 100644 fcl/win32/thread.inc diff --git a/fcl/Makefile b/fcl/Makefile index 4207ad9618..7dbee3ecfd 100644 --- a/fcl/Makefile +++ b/fcl/Makefile @@ -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 diff --git a/fcl/Makefile.fpc b/fcl/Makefile.fpc index 63dcac0c9b..0420cf9e0a 100644 --- a/fcl/Makefile.fpc +++ b/fcl/Makefile.fpc @@ -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 \ No newline at end of file +ifdef CLASSES10 +classes$(PPUEXT): + $(COMPILER) -Ficlasses -Ficlasses/$(OS_TARGET) classes/$(OS_TARGET)/classes.pp +endif + +xmlreg.pp: xml diff --git a/fcl/inc/action.inc b/fcl/classes/action.inc similarity index 94% rename from fcl/inc/action.inc rename to fcl/classes/action.inc index 85b5cdc107..f2899de3a8 100644 --- a/fcl/inc/action.inc +++ b/fcl/classes/action.inc @@ -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 } diff --git a/fcl/inc/bits.inc b/fcl/classes/bits.inc similarity index 96% rename from fcl/inc/bits.inc rename to fcl/classes/bits.inc index a2bcf15f2a..4566634c38 100644 --- a/fcl/inc/bits.inc +++ b/fcl/classes/bits.inc @@ -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 diff --git a/fcl/inc/classes.inc b/fcl/classes/classes.inc similarity index 99% rename from fcl/inc/classes.inc rename to fcl/classes/classes.inc index c494fe0a85..4e1f4f59bc 100644 --- a/fcl/inc/classes.inc +++ b/fcl/classes/classes.inc @@ -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 diff --git a/fcl/inc/classesh.inc b/fcl/classes/classesh.inc similarity index 96% rename from fcl/inc/classesh.inc rename to fcl/classes/classesh.inc index d3f641e214..633cb2d96c 100644 --- a/fcl/inc/classesh.inc +++ b/fcl/classes/classesh.inc @@ -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 diff --git a/fcl/inc/collect.inc b/fcl/classes/collect.inc similarity index 95% rename from fcl/inc/collect.inc rename to fcl/classes/collect.inc index 6c2852c2e4..0da74d754e 100644 --- a/fcl/inc/collect.inc +++ b/fcl/classes/collect.inc @@ -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 } diff --git a/fcl/inc/compon.inc b/fcl/classes/compon.inc similarity index 97% rename from fcl/inc/compon.inc rename to fcl/classes/compon.inc index 194ead9a44..3e06868021 100644 --- a/fcl/inc/compon.inc +++ b/fcl/classes/compon.inc @@ -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 diff --git a/fcl/inc/constse.inc b/fcl/classes/constse.inc similarity index 97% rename from fcl/inc/constse.inc rename to fcl/classes/constse.inc index 2f3622381f..6b89206409 100644 --- a/fcl/inc/constse.inc +++ b/fcl/classes/constse.inc @@ -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 diff --git a/fcl/inc/constsg.inc b/fcl/classes/constsg.inc similarity index 97% rename from fcl/inc/constsg.inc rename to fcl/classes/constsg.inc index c049b745db..c8700f0f1e 100644 --- a/fcl/inc/constsg.inc +++ b/fcl/classes/constsg.inc @@ -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 } diff --git a/fcl/inc/constss.inc b/fcl/classes/constss.inc similarity index 97% rename from fcl/inc/constss.inc rename to fcl/classes/constss.inc index 2789f029dc..9400b6d8e7 100644 --- a/fcl/inc/constss.inc +++ b/fcl/classes/constss.inc @@ -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 } diff --git a/fcl/inc/cregist.inc b/fcl/classes/cregist.inc similarity index 94% rename from fcl/inc/cregist.inc rename to fcl/classes/cregist.inc index 1475c7747c..c534ee6ad6 100644 --- a/fcl/inc/cregist.inc +++ b/fcl/classes/cregist.inc @@ -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 diff --git a/fcl/inc/dm.inc b/fcl/classes/dm.inc similarity index 100% rename from fcl/inc/dm.inc rename to fcl/classes/dm.inc diff --git a/fcl/inc/felog.inc b/fcl/classes/felog.inc similarity index 85% rename from fcl/inc/felog.inc rename to fcl/classes/felog.inc index fafaad3cd1..0c1dfd586c 100644 --- a/fcl/inc/felog.inc +++ b/fcl/classes/felog.inc @@ -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 } diff --git a/fcl/inc/filer.inc b/fcl/classes/filer.inc similarity index 77% rename from fcl/inc/filer.inc rename to fcl/classes/filer.inc index 09efce13b1..cb5ec1ae64 100644 --- a/fcl/inc/filer.inc +++ b/fcl/classes/filer.inc @@ -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 } diff --git a/fcl/inc/filerec.inc b/fcl/classes/filerec.inc similarity index 80% rename from fcl/inc/filerec.inc rename to fcl/classes/filerec.inc index 38b5fd9681..0e77b7a438 100644 --- a/fcl/inc/filerec.inc +++ b/fcl/classes/filerec.inc @@ -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 } diff --git a/fcl/freebsd/classes.pp b/fcl/classes/freebsd/classes.pp similarity index 82% rename from fcl/freebsd/classes.pp rename to fcl/classes/freebsd/classes.pp index f6415ed450..950ce9a5dc 100644 --- a/fcl/freebsd/classes.pp +++ b/fcl/classes/freebsd/classes.pp @@ -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 diff --git a/fcl/go32v2/classes.pp b/fcl/classes/go32v2/classes.pp similarity index 78% rename from fcl/go32v2/classes.pp rename to fcl/classes/go32v2/classes.pp index d8d8d0c821..85ebcbaf9f 100644 --- a/fcl/go32v2/classes.pp +++ b/fcl/classes/go32v2/classes.pp @@ -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 } diff --git a/fcl/inc/intf.inc b/fcl/classes/intf.inc similarity index 89% rename from fcl/inc/intf.inc rename to fcl/classes/intf.inc index 3b0fe528d9..12f4e6fb19 100644 --- a/fcl/inc/intf.inc +++ b/fcl/classes/intf.inc @@ -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 diff --git a/fcl/linux/classes.pp b/fcl/classes/linux/classes.pp similarity index 82% rename from fcl/linux/classes.pp rename to fcl/classes/linux/classes.pp index 84ccfc404e..597bafa08f 100644 --- a/fcl/linux/classes.pp +++ b/fcl/classes/linux/classes.pp @@ -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 diff --git a/fcl/inc/lists.inc b/fcl/classes/lists.inc similarity index 96% rename from fcl/inc/lists.inc rename to fcl/classes/lists.inc index a40b113347..1401673d76 100644 --- a/fcl/inc/lists.inc +++ b/fcl/classes/lists.inc @@ -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 diff --git a/fcl/os2/classes.pp b/fcl/classes/os2/classes.pp similarity index 82% rename from fcl/os2/classes.pp rename to fcl/classes/os2/classes.pp index 4ededd030b..1895d6377a 100644 --- a/fcl/os2/classes.pp +++ b/fcl/classes/os2/classes.pp @@ -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 diff --git a/fcl/inc/parser.inc b/fcl/classes/parser.inc similarity index 96% rename from fcl/inc/parser.inc rename to fcl/classes/parser.inc index a102c4237b..fe097fb708 100644 --- a/fcl/inc/parser.inc +++ b/fcl/classes/parser.inc @@ -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 } diff --git a/fcl/inc/persist.inc b/fcl/classes/persist.inc similarity index 93% rename from fcl/inc/persist.inc rename to fcl/classes/persist.inc index 8615693b69..6cac202874 100644 --- a/fcl/inc/persist.inc +++ b/fcl/classes/persist.inc @@ -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 } diff --git a/fcl/inc/reader.inc b/fcl/classes/reader.inc similarity index 99% rename from fcl/inc/reader.inc rename to fcl/classes/reader.inc index 88d80786ff..7dfbe77882 100644 --- a/fcl/inc/reader.inc +++ b/fcl/classes/reader.inc @@ -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 diff --git a/fcl/inc/streams.inc b/fcl/classes/streams.inc similarity index 98% rename from fcl/inc/streams.inc rename to fcl/classes/streams.inc index de37b161e7..5c23d654f3 100644 --- a/fcl/inc/streams.inc +++ b/fcl/classes/streams.inc @@ -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 diff --git a/fcl/inc/stringl.inc b/fcl/classes/stringl.inc similarity index 98% rename from fcl/inc/stringl.inc rename to fcl/classes/stringl.inc index c77060eba8..665d2ad2e3 100644 --- a/fcl/inc/stringl.inc +++ b/fcl/classes/stringl.inc @@ -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 diff --git a/fcl/inc/twriter.inc b/fcl/classes/twriter.inc similarity index 94% rename from fcl/inc/twriter.inc rename to fcl/classes/twriter.inc index 5ec48851b7..4dda93711c 100644 --- a/fcl/inc/twriter.inc +++ b/fcl/classes/twriter.inc @@ -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 } diff --git a/fcl/inc/util.inc b/fcl/classes/util.inc similarity index 74% rename from fcl/inc/util.inc rename to fcl/classes/util.inc index cd7d6dbee3..7e9bc32ce2 100644 --- a/fcl/inc/util.inc +++ b/fcl/classes/util.inc @@ -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 } diff --git a/fcl/win32/classes.pp b/fcl/classes/win32/classes.pp similarity index 81% rename from fcl/win32/classes.pp rename to fcl/classes/win32/classes.pp index d9cba5f9fe..c86c4730e4 100644 --- a/fcl/win32/classes.pp +++ b/fcl/classes/win32/classes.pp @@ -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 diff --git a/fcl/inc/writer.inc b/fcl/classes/writer.inc similarity index 98% rename from fcl/inc/writer.inc rename to fcl/classes/writer.inc index 6a108fd056..fea08dc71d 100644 --- a/fcl/inc/writer.inc +++ b/fcl/classes/writer.inc @@ -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 diff --git a/fcl/freebsd/thread.inc b/fcl/freebsd/thread.inc deleted file mode 100644 index 48bc0b17aa..0000000000 --- a/fcl/freebsd/thread.inc +++ /dev/null @@ -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 - -} diff --git a/fcl/go32v2/thread.inc b/fcl/go32v2/thread.inc deleted file mode 100644 index 263551f41c..0000000000 --- a/fcl/go32v2/thread.inc +++ /dev/null @@ -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 - -} diff --git a/fcl/linux/thread.inc b/fcl/linux/thread.inc deleted file mode 100644 index eb88e8f909..0000000000 --- a/fcl/linux/thread.inc +++ /dev/null @@ -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 - -} diff --git a/fcl/os2/thread.inc b/fcl/os2/thread.inc deleted file mode 100644 index 08ffee608b..0000000000 --- a/fcl/os2/thread.inc +++ /dev/null @@ -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 - -} diff --git a/fcl/win32/thread.inc b/fcl/win32/thread.inc deleted file mode 100644 index bc174cec23..0000000000 --- a/fcl/win32/thread.inc +++ /dev/null @@ -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 - -}