* moved classes unit to rtl

rtl/freebsd/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
@@ -230,9 +230,9 @@ GRAPHDIR=$(INC)/graph
 ifndef USELIBGGI
 USELIBGGI=NO
 endif
-override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil $(LINUXUNIT) unix initc  dos crt objects printer sysutils typinfo math varutils cpu mmx charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types systhrds sysctl
+override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil $(LINUXUNIT) unix initc  dos crt objects printer sysutils typinfo classes math varutils cpu mmx charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard console serial variants types systhrds sysctl
 override TARGET_LOADERS+=prt0 cprt0
-override TARGET_RSTS+=math varutils typinfo
+override TARGET_RSTS+=math varutils typinfo classes variants
 override INSTALL_FPCPACKAGE=y y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC) $(BSDPROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC)
@@ -1355,9 +1355,12 @@ dos$(PPUEXT) : $(UNIXINC)/dos.pp $(INC)/filerec.inc $(INC)/textrec.inc strings$(
 crt$(PPUEXT) : $(UNIXINC)/crt.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
 printer$(PPUEXT) : $(UNIXINC)/printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
-sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/freebsd/Makefile.fpc

@@ -13,11 +13,11 @@ loaders=prt0 cprt0
 units=$(SYSTEMUNIT) objpas strings baseunix syscall unixutil \
       $(LINUXUNIT) unix initc  \
       dos crt objects printer \
-      sysutils typinfo math varutils \
+      sysutils typinfo classes math varutils \
       cpu mmx charset ucomplex getopts heaptrc lineinfo \
       errors sockets gpm ipc terminfo \
       video mouse keyboard console serial variants types systhrds sysctl
-rsts=math varutils typinfo
+rsts=math varutils typinfo classes variants
 
 [require]
 nortl=y
@@ -164,9 +164,13 @@ printer$(PPUEXT) : $(UNIXINC)/printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYST
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp

rtl/freebsd/classes.pp

@@ -0,0 +1,72 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+implementation
+
+uses
+{$ifdef ver1_0}
+  linux
+{$else}
+  baseunix,unix
+{$endif}
+  ;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+  if ThreadsInited then
+     DoneThreads;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+}

rtl/freebsd/tthread.inc

@@ -0,0 +1,350 @@
+{
+    $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.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+
+}

rtl/go32v2/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
@@ -221,9 +221,9 @@ endif
 ifdef NO_EXCEPTIONS_IN_SYSTEM
 override FPCOPT+=-dNO_EXCEPTIONS_IN_SYSTEM
 endif
-override TARGET_UNITS+=system objpas strings go32 dpmiexcp initc ports profile dxeload emu387 dos crt objects printer graph sysutils math typinfo cpu mmx ucomplex getopts heaptrc lineinfo msmouse charset varutils video mouse keyboard variants vesamode types
+override TARGET_UNITS+=system objpas strings go32 dpmiexcp initc ports profile dxeload emu387 dos crt objects printer graph sysutils classes math typinfo cpu mmx ucomplex getopts heaptrc lineinfo msmouse charset varutils video mouse keyboard variants vesamode types
 override TARGET_LOADERS+=prt0 exceptn fpu
-override TARGET_RSTS+=math varutils typinfo
+override TARGET_RSTS+=math varutils typinfo classes variants
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC)
@@ -1349,9 +1349,12 @@ GRAPHINCDEPS=$(addprefix $(GRAPHDIR)/,$(GRAPHINCNAMES))
 graph$(PPUEXT) : graph.pp go32$(PPUEXT) ports$(PPUEXT) system$(PPUEXT) \
 		 $(GRAPHINCDEPS) vesa.inc vesah.inc dpmi.inc
 	$(COMPILER) -I$(GRAPHDIR) graph.pp
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/go32v2/Makefile.fpc

@@ -10,11 +10,11 @@ loaders=prt0 exceptn fpu
 units=system objpas strings \
       go32 dpmiexcp initc ports profile dxeload emu387 \
       dos crt objects printer graph \
-      sysutils math typinfo \
+      sysutils classes math typinfo \
       cpu mmx ucomplex getopts heaptrc lineinfo \
       msmouse charset varutils \
       video mouse keyboard variants vesamode types
-rsts=math varutils typinfo
+rsts=math varutils typinfo classes variants
 
 [require]
 nortl=y
@@ -148,9 +148,13 @@ graph$(PPUEXT) : graph.pp go32$(PPUEXT) ports$(PPUEXT) system$(PPUEXT) \
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) dos$(PPUEXT) go32$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
@@ -163,7 +167,7 @@ varutils$(PPUEXT) : $(OBJPASDIR)/cvarutil.inc $(OBJPASDIR)/varutils.inc \
         $(COMPILER) -I$(OBJPASDIR) varutils.pp
 
 types$(PPUEXT) : $(OBJPASDIR/types.pp objpas$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
-	$(COMPILER) $(OBJPASDIR)/types.pp
+        $(COMPILER) $(OBJPASDIR)/types.pp
 
 #
 # Other system-independent RTL Units

rtl/go32v2/classes.pp

@@ -0,0 +1,57 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for win32
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  typinfo,
+  sysutils;
+
+{$i classesh.inc}
+
+implementation
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+
+}

rtl/go32v2/tthread.inc

@@ -0,0 +1,102 @@
+{
+    $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.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.4  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+}

rtl/linux/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
@@ -235,9 +235,9 @@ GRAPHDIR=$(INC)/graph
 ifndef USELIBGGI
 USELIBGGI=NO
 endif
-override TARGET_UNITS+=$(SYSTEMUNIT) baseunix strings systhrds objpas syscall unixutil heaptrc lineinfo $(LINUXUNIT1) unix $(LINUXUNIT2) initc $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo math varutils charset ucomplex getopts errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types
+override TARGET_UNITS+=$(SYSTEMUNIT) baseunix strings systhrds objpas syscall unixutil heaptrc lineinfo $(LINUXUNIT1) unix $(LINUXUNIT2) initc $(CPU_UNITS) dos crt objects printer ggigraph sysutils typinfo classes math varutils charset ucomplex getopts errors sockets gpm ipc serial terminfo dl dynlibs video mouse keyboard variants types
 override TARGET_LOADERS+=prt0 dllprt0 cprt0 gprt0 cprt21 gprt21
-override TARGET_RSTS+=math varutils typinfo variants
+override TARGET_RSTS+=math varutils typinfo variants classes
 override CLEAN_UNITS+=syslinux linux
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(CPU_TARGET)
@@ -1356,7 +1356,7 @@ objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMUNIT)$(PPUEXT)
 strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\
 		   $(PROCINC)/strings.inc $(PROCINC)/stringss.inc\
 		   $(SYSTEMUNIT)$(PPUEXT)
-unix$(PPUEXT) : unix.pp strings$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
+unix$(PPUEXT) : unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
 		 syscalls.inc systypes.inc sysconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \
 		 unixsysc.inc
 baseunix$(PPUEXT) : errno.inc bunxtype.inc ptypes.inc ctypes.inc \
@@ -1380,9 +1380,12 @@ graph$(PPUEXT) : graph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \
 ggigraph$(PPUEXT) : $(UNIXINC)/ggigraph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \
 		 $(GRAPHINCDEPS)
 	$(COMPILER) -I$(GRAPHDIR) $(UNIXINC)/ggigraph.pp
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/linux/Makefile.fpc

@@ -11,11 +11,11 @@ units=$(SYSTEMUNIT) baseunix strings systhrds objpas syscall unixutil \
       heaptrc lineinfo \
       $(LINUXUNIT1) unix $(LINUXUNIT2) initc $(CPU_UNITS) \
       dos crt objects printer ggigraph \
-      sysutils typinfo math varutils \
+      sysutils typinfo classes math varutils \
       charset ucomplex getopts \
       errors sockets gpm ipc serial terminfo dl dynlibs \
       video mouse keyboard variants types
-rsts=math varutils typinfo variants
+rsts=math varutils typinfo variants classes
 
 [require]
 nortl=y
@@ -153,7 +153,7 @@ strings$(PPUEXT) : $(INC)/strings.pp $(INC)/stringsi.inc\
 # $(SYSTEMUNIT) Dependent Units
 #
 
-unix$(PPUEXT) : unix.pp strings$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
+unix$(PPUEXT) : unix.pp strings$(PPUEXT) baseunix$(PPUEXT) $(INC)/textrec.inc $(INC)/filerec.inc \
                  syscalls.inc systypes.inc sysconst.inc $(UNIXINC)/timezone.inc $(SYSTEMUNIT)$(PPUEXT) \
                  unixsysc.inc
 
@@ -200,9 +200,13 @@ ggigraph$(PPUEXT) : $(UNIXINC)/ggigraph.pp unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp

rtl/linux/classes.pp

@@ -0,0 +1,71 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ Require threading }
+{$ifndef ver1_0}
+  {$threading on}
+{$endif ver1_0}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+implementation
+
+uses
+  BaseUnix,unix,Linux
+  ;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+  if ThreadsInited then
+     DoneThreads;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * threading switch
+
+  Revision 1.5  2002/09/07 15:15:27  peter
+    * old logs removed and tabs fixed
+
+}

rtl/linux/tthread.inc

@@ -0,0 +1,320 @@
+{
+    $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: Baseunix.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^.sa_handler := @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.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+
+}

rtl/netbsd/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
@@ -230,14 +230,14 @@ GRAPHDIR=$(INC)/graph
 ifndef USELIBGGI
 USELIBGGI=NO
 endif
-override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix $(LINUXUNIT) unix initc dos crt objects printer sysutils typinfo math varutils charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard  serial variants types systhrds sysctl
+override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings baseunix $(LINUXUNIT) unix initc dos crt objects printer sysutils classes typinfo math varutils charset ucomplex getopts heaptrc lineinfo errors sockets gpm ipc terminfo video mouse keyboard  serial variants types systhrds sysctl
 ifeq ($(OS_TARGET),netbsd)
 ifeq ($(CPU_TARGET),i386)
 override TARGET_UNITS+=mmx cpu
 endif
 endif
 override TARGET_LOADERS+=prt0 cprt0
-override TARGET_RSTS+=math varutils typinfo
+override TARGET_RSTS+=math varutils typinfo variants classes
 override INSTALL_FPCPACKAGE=y y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC) $(BSDPROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC) $(UNIXINC) $(BSDINC)
@@ -1360,9 +1360,12 @@ dos$(PPUEXT) : $(UNIXINC)/dos.pp $(INC)/filerec.inc $(INC)/textrec.inc strings$(
 crt$(PPUEXT) : $(UNIXINC)/crt.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
 printer$(PPUEXT) : $(UNIXINC)/printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
-sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/netbsd/Makefile.fpc

@@ -13,12 +13,12 @@ loaders=prt0 cprt0
 units=$(SYSTEMUNIT) objpas strings baseunix \
       $(LINUXUNIT) unix initc \
       dos crt objects printer \
-      sysutils typinfo math varutils \
+      sysutils classes typinfo math varutils \
        charset ucomplex getopts heaptrc lineinfo \
       errors sockets gpm ipc terminfo \
       video mouse keyboard  serial variants types systhrds sysctl
 units_netbsd_i386=mmx cpu
-rsts=math varutils typinfo
+rsts=math varutils typinfo variants classes
 
 [require]
 nortl=y
@@ -165,9 +165,13 @@ printer$(PPUEXT) : $(UNIXINC)/printer.pp $(INC)/textrec.inc unix$(PPUEXT) $(SYST
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : $(UNIXINC)/sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) unix$(PPUEXT) errors$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) $(UNIXINC)/sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils $(UNIXINC)/sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp

rtl/netbsd/classes.pp

@@ -0,0 +1,64 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+implementation
+
+uses
+{$ifdef ver1_0}
+  linux
+{$else}
+  unix
+{$endif}
+  ;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+  if ThreadsInited then
+     DoneThreads;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.2  2002/09/07 15:15:27  peter
+    * old logs removed and tabs fixed
+
+}

rtl/netbsd/tthread.inc

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

rtl/netware/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
@@ -218,9 +218,9 @@ override FPCOPT+=-Ur
 override FPCOPT+=-dMT
 CREATESMART=0
 OBJPASDIR=$(RTL)/objpas
-override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings winsock dos crt objects sysutils typinfo math cpu mmx getopts heaptrc lineinfo sockets aio varutils video mouse keyboard types nwsnut nwserv nwnit nwprot
+override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings winsock dos crt objects sysutils classes typinfo math cpu mmx getopts heaptrc lineinfo sockets aio varutils video mouse keyboard types nwsnut nwserv nwnit nwprot
 override TARGET_LOADERS+=nwpre prelude
-override TARGET_RSTS+=math typinfo varutils
+override TARGET_RSTS+=math typinfo varutils classes
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC)
@@ -1338,9 +1338,12 @@ sockets$(PPUEXT) : sockets.pp netware$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \
 dos$(PPUEXT) : dos.pp $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 crt$(PPUEXT) : crt.pp $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT) objpas$(PPUEXT) dos$(PPUEXT)
 objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) dos$(PPUEXT) nwsys.inc
-	$(COMPILER) -I$(OBJPASDIR) sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/netware/Makefile.fpc

@@ -10,12 +10,12 @@ loaders=nwpre prelude
 units=$(SYSTEMUNIT) systhrds objpas strings \
       winsock \
       dos crt objects \
-      sysutils typinfo math \
+      sysutils classes typinfo math \
       cpu mmx getopts heaptrc lineinfo \
       sockets aio varutils \
       video mouse keyboard types \
       nwsnut nwserv nwnit nwprot
-rsts=math typinfo varutils
+rsts=math typinfo varutils classes
 
 [require]
 nortl=y
@@ -141,9 +141,13 @@ objects$(PPUEXT) : $(INC)/objects.pp $(SYSTEMUNIT)$(PPUEXT)
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) dos$(PPUEXT) nwsys.inc
-        $(COMPILER) -I$(OBJPASDIR) sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp

rtl/netware/classes.pp

@@ -0,0 +1,50 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for win32
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo,
+  systhrds;
+
+{$i classesh.inc}
+
+implementation
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2003/03/25 17:56:19  armin
+  * first fcl implementation for netware
+
+  Revision 1.3  2002/09/07 15:15:28  peter
+    * old logs removed and tabs fixed
+
+}

rtl/netware/tthread.inc

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

rtl/objpas/README

@@ -11,8 +11,8 @@ math.pp : Contains basic mathematical functions, as well as some financial
 
 sysutils.pp : Contains the exception support of the Free Pascal Compiler.
 
-*h.inc : Contain parts of the sysutils unit, with function declarations.
-*.inc  : Contain parts of the sysutils unit, with implementations of:
+sysutils/*h.inc : Contain parts of the sysutils unit, with function declarations.
+sysutils/*.inc  : Contain parts of the sysutils unit, with implementations of:
        dati : Date & Time handling functions.
        fina : FileName handling functions.
        sysstr : miscellaneous string handling functions, and conversion 

rtl/objpas/classes/action.inc

@@ -0,0 +1,196 @@
+{
+    $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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                           TBasicActionLink                               *}
+{****************************************************************************}
+
+constructor TBasicActionLink.Create(AClient: TObject);
+begin
+  inherited Create;
+  AssignClient(AClient);
+end;
+
+
+procedure TBasicActionLink.AssignClient(AClient: TObject);
+begin
+end;
+
+
+destructor TBasicActionLink.Destroy;
+begin
+  if FAction <> nil then
+    FAction.UnRegisterChanges(Self);
+  inherited Destroy;
+end;
+
+
+procedure TBasicActionLink.Change;
+begin
+  if Assigned(OnChange) then
+    OnChange(FAction);
+end;
+
+
+function TBasicActionLink.Execute(AComponent: TComponent): Boolean;
+begin
+  FAction.ActionComponent := AComponent;
+  try
+    Result := FAction.Execute;
+  finally
+    if FAction <> nil then
+      FAction.ActionComponent := nil;
+  end;
+end;
+
+
+procedure TBasicActionLink.SetAction(Value: TBasicAction);
+begin
+  if Value <> FAction then
+  begin
+    if FAction <> nil then FAction.UnRegisterChanges(Self);
+    FAction := Value;
+    if Value <> nil then Value.RegisterChanges(Self);
+  end;
+end;
+
+
+function TBasicActionLink.IsOnExecuteLinked: Boolean;
+begin
+  Result := True;
+end;
+
+
+procedure TBasicActionLink.SetOnExecute(Value: TNotifyEvent);
+begin
+end;
+
+
+function TBasicActionLink.Update: Boolean;
+begin
+  Result := FAction.Update;
+end;
+
+{****************************************************************************}
+{*                             TBasicAction                                 *}
+{****************************************************************************}
+
+constructor TBasicAction.Create(AOwner: TComponent);
+begin
+  inherited Create(AOwner);
+  FClients := TList.Create;
+end;
+
+
+destructor TBasicAction.Destroy;
+begin
+  inherited Destroy;
+  while FClients.Count > 0 do
+    UnRegisterChanges(TBasicActionLink(FClients.Last));
+  FClients.Free;
+end;
+
+
+function TBasicAction.HandlesTarget(Target: TObject): Boolean;
+begin
+  Result := False;
+end;
+
+
+procedure TBasicAction.ExecuteTarget(Target: TObject);
+begin
+end;
+
+
+procedure TBasicAction.UpdateTarget(Target: TObject);
+begin
+end;
+
+
+function TBasicAction.Execute: Boolean;
+begin
+  if Assigned(FOnExecute) then
+   begin
+     FOnExecute(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
+function TBasicAction.Update: Boolean;
+begin
+  if Assigned(FOnUpdate) then
+   begin
+     FOnUpdate(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
+procedure TBasicAction.SetOnExecute(Value: TNotifyEvent);
+var
+  I: Integer;
+begin
+  if (TMethod(Value).Code <> TMethod(OnExecute).Code) or
+     (TMethod(Value).Data <> TMethod(OnExecute).Data) then
+  begin
+    for I := 0 to FClients.Count - 1 do
+      TBasicActionLink(FClients[I]).SetOnExecute(Value);
+    FOnExecute := Value;
+    Change;
+  end;
+end;
+
+
+procedure TBasicAction.Change;
+begin
+  if Assigned(FOnChange) then
+    FOnChange(Self);
+end;
+
+
+procedure TBasicAction.RegisterChanges(Value: TBasicActionLink);
+begin
+  Value.FAction := Self;
+  FClients.Add(Value);
+end;
+
+
+procedure TBasicAction.UnRegisterChanges(Value: TBasicActionLink);
+var
+  I: Integer;
+begin
+  for I := 0 to FClients.Count - 1 do
+    if TBasicActionLink(FClients[I]) = Value then
+     begin
+       Value.FAction := nil;
+       FClients.Delete(I);
+       break;
+     end;
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2002/01/06 21:54:49  peter
+    * action classes added
+
+}

rtl/objpas/classes/bits.inc

@@ -0,0 +1,396 @@
+{
+    $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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                               TBits                                      *}
+{****************************************************************************}
+
+ResourceString
+  SErrInvalidBitIndex = 'Invalid bit index : %d';
+  SErrindexTooLarge   = 'Bit index exceeds array limit: %d';
+  SErrOutOfMemory     = 'Out of memory';
+
+Procedure BitsError (Msg : string);
+
+begin
+{$ifdef VER1_0}
+  Raise EBitsError.Create(Msg) at longint(get_caller_addr(get_frame));
+{$else VER1_0}
+  Raise EBitsError.Create(Msg) at get_caller_addr(get_frame);
+{$endif VER1_0}
+end;
+
+Procedure BitsErrorFmt (Msg : string; const Args : array of const);
+
+begin
+{$ifdef VER1_0}
+  Raise EBitsError.CreateFmt(Msg,args) at longint(get_caller_addr(get_frame));
+{$else VER1_0}
+  Raise EBitsError.CreateFmt(Msg,args) at get_caller_addr(get_frame);
+{$endif VER1_0}
+end;
+
+procedure TBits.CheckBitIndex (Bit : longint;CurrentSize : Boolean);
+
+begin
+ if (bit<0) or (CurrentSize and (Bit>Size)) then
+   BitsErrorFmt(SErrInvalidBitIndex,[bit]);
+ if (bit>=MaxBitFlags) then
+   BitsErrorFmt(SErrIndexTooLarge,[bit])
+
+end;
+
+{ ************* functions to match TBits class ************* }
+
+function TBits.getSize : longint;
+begin
+   result := (FSize shl BITSHIFT) - 1;
+end;
+
+procedure TBits.setSize(value : longint);
+begin
+   grow(value - 1);
+end;
+
+procedure TBits.SetBit(bit : longint; value : Boolean);
+begin
+   if value = True then
+      seton(bit)
+   else
+      clear(bit);
+end;
+
+function TBits.OpenBit : longint;
+var
+   loop : longint;
+   loop2 : longint;
+   startIndex : longint;
+begin
+   result := -1; {should only occur if the whole array is set}
+   for loop := 0 to FSize - 1 do
+   begin
+      if FBits^[loop] <> $FFFFFFFF then
+      begin
+         startIndex := loop * 32;
+         for loop2 := startIndex to startIndex + 31 do
+         begin
+            if get(loop2) = False then
+            begin
+               result := loop2;
+               break; { use this as the index to return }
+            end;
+         end;
+         break;  {stop looking for empty bit in records }
+      end;
+   end;
+
+   if result = -1 then
+      if FSize < MaxBitRec then
+          result := FSize * 32;  {first bit of next record}
+end;
+
+{ ******************** TBits ***************************** }
+
+constructor TBits.Create(theSize : longint);
+begin
+   FSize := 0;
+   FBits := nil;
+   findIndex := -1;
+   findState := True;  { no reason just setting it to something }
+   grow(theSize);
+end;
+
+destructor TBits.Destroy;
+begin
+   if FBits <> nil then
+      FreeMem(FBits, FSize * SizeOf(longint));
+   FBits := nil;
+
+   inherited Destroy;
+end;
+
+procedure TBits.grow(nbit : longint);
+var
+   newSize : longint;
+   loop : longint;
+begin
+   CheckBitindex(nbit,false);
+
+   newSize :=  (nbit shr BITSHIFT) + 1;
+
+   if newSize > FSize then
+   begin
+      ReAllocMem(FBits, newSize * SizeOf(longint));
+      if FBits <> nil then
+        begin
+         if newSize > FSize then
+            for loop := FSize to newSize - 1 do
+               FBits^[loop] := 0;
+         FSize := newSize;
+       end
+      else
+        BitsError(SErrOutOfMemory);
+   end;
+end;
+
+function TBits.getFSize : longint;
+begin
+   result := FSize;
+end;
+
+procedure TBits.seton(bit : longint);
+var
+   n : longint;
+begin
+   n := bit shr BITSHIFT;
+   grow(bit);
+   FBits^[n] := FBits^[n] or (longint(1) shl (bit and MASK));
+end;
+
+procedure TBits.clear(bit : longint);
+var
+   n : longint;
+begin
+   CheckBitIndex(bit,false);
+   n := bit shr BITSHIFT;
+   grow(bit);
+   FBits^[n] := FBits^[n] and not(longint(1) shl (bit and MASK));
+end;
+
+procedure TBits.clearall;
+var
+   loop : longint;
+begin
+   for loop := 0 to FSize - 1 do
+      FBits^[loop] := 0;
+end;
+
+function TBits.get(bit : longint) : Boolean;
+var
+   n : longint;
+begin
+   CheckBitIndex(bit,true);
+   result := False;
+   n := bit shr BITSHIFT;
+   if (n < FSize) then
+      result := (FBits^[n] and (longint(1) shl (bit and MASK))) <> 0;
+end;
+
+procedure TBits.andbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] and bitset.FBits^[loop];
+
+   for loop := n + 1 to FSize - 1 do
+      FBits^[loop] := 0;
+end;
+
+procedure TBits.notbits(bitset : TBits);
+var
+   n : longint;
+   jj : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+   begin
+      jj := FBits^[loop];
+      FBits^[loop] := FBits^[loop] and (jj xor bitset.FBits^[loop]);
+   end;
+end;
+
+procedure TBits.orbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := bitset.getFSize - 1
+   else
+      n := FSize - 1;
+
+   grow(n shl BITSHIFT);
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] or bitset.FBits^[loop];
+end;
+
+procedure TBits.xorbits(bitset : TBits);
+var
+   n : longint;
+   loop : longint;
+begin
+   if FSize < bitset.getFSize then
+      n := bitset.getFSize - 1
+   else
+      n := FSize - 1;
+
+   grow(n shl BITSHIFT);
+
+   for loop := 0 to n do
+      FBits^[loop] := FBits^[loop] xor bitset.FBits^[loop];
+end;
+
+function TBits.equals(bitset : TBits) : Boolean;
+var
+   n : longint;
+   loop : longint;
+begin
+   result := False;
+
+   if FSize < bitset.getFSize then
+      n := FSize - 1
+   else
+      n := bitset.getFSize - 1;
+
+   for loop := 0 to n do
+      if FBits^[loop] <> bitset.FBits^[loop] then exit;
+
+   if FSize - 1 > n then
+   begin
+      for loop := n to FSize - 1 do
+         if FBits^[loop] <> 0 then exit;
+   end
+   else if bitset.getFSize - 1 > n then
+      for loop := n to bitset.getFSize - 1 do
+         if bitset.FBits^[loop] <> 0 then exit;
+
+   result := True;  {passed all tests}
+end;
+
+
+{ us this in place of calling FindFirstBit. It sets the current }
+{ index used by FindNextBit and FindPrevBit                     }
+
+procedure TBits.SetIndex(index : longint);
+begin
+   findIndex := index;
+end;
+
+
+{ When state is set to True it looks for bits that are turned On (1) }
+{ and when it is set to False it looks for bits that are turned      }
+{ off (0).                                                           }
+
+function TBits.FindFirstBit(state : boolean) : longint;
+var
+   loop : longint;
+   loop2 : longint;
+   startIndex : longint;
+   compareVal : cardinal;
+begin
+   result := -1; {should only occur if none are set}
+
+   findState := state;
+
+   if state = False then
+      compareVal := $FFFFFFFF  { looking for off bits }
+   else
+      compareVal := $00000000; { looking for on bits }
+
+   for loop := 0 to FSize - 1 do
+   begin
+      if FBits^[loop] <> compareVal then
+      begin
+         startIndex := loop * 32;
+         for loop2 := startIndex to startIndex + 31 do
+         begin
+            if get(loop2) = state then
+            begin
+               result := loop2;
+               break; { use this as the index to return }
+            end;
+         end;
+         break;  {stop looking for bit in records }
+      end;
+   end;
+
+   findIndex := result;
+end;
+
+function TBits.FindNextBit : longint;
+var
+   loop : longint;
+   maxVal : longint;
+begin
+   result := -1;  { will occur only if no other bits set to }
+                  { current findState                        }
+
+   if findIndex > -1 then { must have called FindFirstBit first }
+   begin                  { or set the start index              }
+      maxVal := (FSize * 32) - 1;
+
+      for loop := findIndex + 1 to maxVal  do
+      begin
+         if get(loop) = findState then
+         begin
+            result := loop;
+            break;
+         end;
+      end;
+
+      findIndex := result;
+   end;
+end;
+
+function TBits.FindPrevBit : longint;
+var
+   loop : longint;
+begin
+   result := -1;  { will occur only if no other bits set to }
+                  { current findState                        }
+
+   if findIndex > -1 then { must have called FindFirstBit first }
+   begin                  { or set the start index              }
+      for loop := findIndex - 1 downto 0  do
+      begin
+         if get(loop) = findState then
+         begin
+            result := loop;
+            break;
+         end;
+      end;
+
+      findIndex := result;
+   end;
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+  Revision 1.7  2002/07/16 14:00:55  florian
+    * raise takes now a void pointer as at and frame address
+      instead of a longint, fixed
+
+}

rtl/objpas/classes/compon.inc

@@ -0,0 +1,554 @@
+{
+    $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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TComponent                                   *}
+{****************************************************************************}
+
+Type
+  Longrec = Record
+    Hi,lo : word;
+    end;
+
+Function  TComponent.GetComponent(AIndex: Integer): TComponent;
+
+begin
+  If not assigned(FComponents) then
+    Result:=Nil
+  else
+    Result:=TComponent(FComponents.Items[Aindex]);
+end;
+
+
+Function  TComponent.GetComponentCount: Integer;
+
+begin
+  If not assigned(FComponents) then
+    result:=0
+  else
+    Result:=FComponents.Count;
+end;
+
+
+Function  TComponent.GetComponentIndex: Integer;
+
+begin
+  If Assigned(FOwner) and Assigned(FOwner.FComponents) then
+    Result:=FOWner.FComponents.IndexOf(Self)
+  else
+    Result:=-1;
+end;
+
+
+Procedure TComponent.Insert(AComponent: TComponent);
+
+begin
+  If not assigned(FComponents) then
+    FComponents:=TList.Create;
+  FComponents.Add(AComponent);
+  AComponent.FOwner:=Self;
+end;
+
+
+Procedure TComponent.ReadLeft(Reader: TReader);
+
+begin
+  LongRec(FDesignInfo).Lo:=Reader.ReadInteger;
+end;
+
+
+Procedure TComponent.ReadTop(Reader: TReader);
+
+begin
+  LongRec(FDesignInfo).Hi:=Reader.ReadInteger;
+end;
+
+
+Procedure TComponent.Remove(AComponent: TComponent);
+
+begin
+  AComponent.FOwner:=Nil;
+  If assigned(FCOmponents) then
+    begin
+    FComponents.Remove(AComponent);
+    IF FComponents.Count=0 then
+      begin
+      FComponents.Free;
+      FComponents:=Nil;
+      end;
+    end;
+end;
+
+
+Procedure TComponent.RemoveNotification(AComponent: TComponent);
+
+begin
+  if FFreeNotifies<>nil then
+    begin
+    FFreeNotifies.Remove(AComponent);
+    if FFreeNotifies.Count=0 then
+      begin
+      FFreeNotifies.Free;
+      FFreeNotifies:=nil;
+      Exclude(FComponentState,csFreeNotification);
+      end;
+    end;
+end;
+
+
+Procedure TComponent.SetComponentIndex(Value: Integer);
+
+Var Temp,Count : longint;
+
+begin
+  If Not assigned(Fowner) then exit;
+  Temp:=getcomponentindex;
+  If temp<0 then exit;
+  If value<0 then value:=0;
+  Count:=Fowner.FComponents.Count;
+  If Value>=Count then value:=count-1;
+  If Value<>Temp then
+    begin
+    FOWner.FComponents.Delete(Temp);
+    FOwner.FComponents.Insert(Value,Self);
+    end;
+end;
+
+
+Procedure TComponent.SetReference(Enable: Boolean);
+
+var
+  Field: ^TComponent;
+begin
+  if Assigned(Owner) then
+  begin
+    Field := Owner.FieldAddress(Name);
+    if Assigned(Field) then
+      if Enable then
+        Field^ := Self
+      else
+        Field^ := nil;
+  end;
+end;
+
+
+Procedure TComponent.WriteLeft(Writer: TWriter);
+
+begin
+  Writer.WriteInteger(LongRec(FDesignInfo).Lo);
+end;
+
+
+Procedure TComponent.WriteTop(Writer: TWriter);
+
+begin
+  Writer.WriteInteger(LongRec(FDesignInfo).Hi);
+end;
+
+
+Procedure TComponent.ChangeName(const NewName: TComponentName);
+
+begin
+  FName:=NewName;
+end;
+
+
+Procedure TComponent.DefineProperties(Filer: TFiler);
+
+Var Ancestor : TComponent;
+    Temp : longint;
+
+begin
+  Temp:=0;
+  Ancestor:=TComponent(Filer.Ancestor);
+  If Assigned(Ancestor) then Temp:=Ancestor.FDesignInfo;
+  Filer.Defineproperty('left',@readleft,@writeleft,
+                       (longrec(FDesignInfo).Lo<>Longrec(temp).Lo));
+  Filer.Defineproperty('top',@readtop,@writetop,
+                       (longrec(FDesignInfo).Hi<>Longrec(temp).Hi));
+end;
+
+
+Procedure TComponent.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+begin
+  // Does nothing.
+end;
+
+
+Function  TComponent.GetChildOwner: TComponent;
+
+begin
+ Result:=Nil;
+end;
+
+
+Function  TComponent.GetChildParent: TComponent;
+
+begin
+  Result:=Self;
+end;
+
+
+Function  TComponent.GetNamePath: string;
+
+begin
+  Result:=FName;
+end;
+
+
+Function  TComponent.GetOwner: TPersistent;
+
+begin
+  Result:=FOwner;
+end;
+
+
+Procedure TComponent.Loaded;
+
+begin
+  Exclude(FComponentState,csLoading);
+end;
+
+
+Procedure TComponent.Notification(AComponent: TComponent;
+  Operation: TOperation);
+
+Var Runner : Longint;
+
+begin
+  If (Operation=opRemove) and Assigned(FFreeNotifies) then
+    begin
+    FFreeNotifies.Remove(AComponent);
+            If FFreeNotifies.Count=0 then
+      begin
+      FFreeNotifies.Free;
+      FFreenotifies:=Nil;
+      end;
+    end;
+  If assigned(FComponents) then
+    For Runner:=0 To FComponents.Count-1 do
+      TComponent(FComponents.Items[Runner]).Notification(AComponent,Operation);
+end;
+
+
+Procedure TComponent.ReadState(Reader: TReader);
+
+begin
+  Reader.ReadData(Self);
+end;
+
+
+Procedure TComponent.SetAncestor(Value: Boolean);
+
+Var Runner : Longint;
+
+begin
+  If Value then
+    Include(FComponentState,csAncestor)
+  else
+    Include(FCOmponentState,csAncestor);
+  if Assigned(FComponents) then
+    For Runner:=0 To FComponents.Count-1 do
+      TComponent(FComponents.Items[Runner]).SetAncestor(Value);
+end;
+
+
+Procedure TComponent.SetDesigning(Value: Boolean);
+
+Var Runner : Longint;
+
+begin
+  If Value then
+    Include(FComponentSTate,csDesigning)
+  else
+    Exclude(FComponentSTate,csDesigning);
+  if Assigned(FComponents) then
+    For Runner:=0 To FComponents.Count - 1 do
+      TComponent(FComponents.items[Runner]).SetDesigning(Value);
+end;
+
+
+Procedure TComponent.SetName(const NewName: TComponentName);
+
+begin
+  If FName=NewName then exit;
+  If not IsValidIdent(NewName) then
+    Raise EComponentError.CreateFmt(SInvalidName,[NewName]);
+  If Assigned(FOwner) Then
+    FOwner.ValidateRename(Self,FName,NewName)
+  else
+    ValidateRename(Nil,FName,NewName);
+  SetReference(False);
+  ChangeName(NewName);
+  Setreference(True);
+end;
+
+
+Procedure TComponent.SetChildOrder(Child: TComponent; Order: Integer);
+
+begin
+  // does nothing
+end;
+
+
+Procedure TComponent.SetParentComponent(Value: TComponent);
+
+begin
+  // Does nothing
+end;
+
+
+Procedure TComponent.Updating;
+
+begin
+  Include (FComponentState,csUpdating);
+end;
+
+
+Procedure TComponent.Updated;
+
+begin
+  Exclude(FComponentState,csUpdating);
+end;
+
+
+class Procedure TComponent.UpdateRegistry(Register: Boolean; const ClassID, ProgID: string);
+
+begin
+  // For compatibility only.
+end;
+
+
+Procedure TComponent.ValidateRename(AComponent: TComponent;
+  const CurName, NewName: string);
+
+begin
+//!! This contradicts the Delphi manual.
+  If (AComponent<>Nil) and (CurName<>NewName) and (AComponent.Owner = Self) and
+     (FindComponent(NewName)<>Nil) then
+      raise EComponentError.Createfmt(SDuplicateName,[newname]);
+  If (csDesigning in FComponentState) and (FOwner<>Nil) then
+    FOwner.ValidateRename(AComponent,Curname,Newname);
+end;
+
+
+Procedure TComponent.ValidateContainer(AComponent: TComponent);
+
+begin
+end;
+
+
+Procedure TComponent.ValidateInsert(AComponent: TComponent);
+
+begin
+  // Does nothing.
+end;
+
+
+Procedure TComponent.WriteState(Writer: TWriter);
+
+begin
+  Writer.WriteComponentData(Self);
+end;
+
+
+Constructor TComponent.Create(AOwner: TComponent);
+
+begin
+  FComponentStyle:=[csInheritable];
+  If Assigned(AOwner) then AOwner.InsertComponent(Self);
+end;
+
+
+Destructor TComponent.Destroy;
+
+Var Runner : Longint;
+
+begin
+  If Assigned(FFreeNotifies) then
+    begin
+    For Runner:=0 To FFreeNotifies.Count-1 do
+      TComponent(FFreeNotifies.Items[Runner]).Notification (self,opRemove);
+    FFreeNotifies.Free;
+    FFreeNotifies:=Nil;
+    end;
+  Destroying;
+  DestroyComponents;
+  If FOwner<>Nil Then FOwner.RemoveComponent(Self);
+  inherited destroy;
+end;
+
+
+Procedure TComponent.DestroyComponents;
+
+Var acomponent: TComponent;
+
+begin
+  While assigned(FComponents) do
+    begin
+    aComponent:=TComponent(FComponents.Last);
+    Remove(aComponent);
+    Acomponent.Destroy;
+    end;
+end;
+
+
+Procedure TComponent.Destroying;
+
+Var Runner : longint;
+
+begin
+  If csDestroying in FComponentstate Then Exit;
+  include (FComponentState,csDestroying);
+  If Assigned(FComponents) then
+    for Runner:=0 to FComponents.Count-1 do
+      TComponent(FComponents.Items[Runner]).Destroying;
+end;
+
+
+function TComponent.ExecuteAction(Action: TBasicAction): Boolean;
+begin
+  if Action.HandlesTarget(Self) then
+   begin
+     Action.ExecuteTarget(Self);
+     Result := True;
+   end
+  else
+   Result := False;
+end;
+
+
+Function  TComponent.FindComponent(const AName: string): TComponent;
+
+Var I : longint;
+
+begin
+  Result:=Nil;
+  If (AName='') or Not assigned(FComponents) then exit;
+  For i:=0 to FComponents.Count-1 do
+    if TComponent(FComponents[I]).Name=AName then
+      begin
+      Result:=TComponent(FComponents.Items[I]);
+      exit;
+      end;
+end;
+
+
+Procedure TComponent.FreeNotification(AComponent: TComponent);
+
+begin
+  If (Owner<>Nil) and (AComponent=Owner) then exit;
+  If not (Assigned(FFreeNotifies)) then
+    FFreeNotifies:=TList.Create;
+  If FFreeNotifies.IndexOf(AComponent)=-1 then
+    begin
+    FFreeNotifies.Add(AComponent);
+    AComponent.FreeNotification (self);
+    end;
+end;
+
+
+procedure TComponent.RemoveFreeNotification(AComponent: TComponent);
+begin
+  RemoveNotification(AComponent);
+  AComponent.RemoveNotification (self);
+end;
+
+
+Procedure TComponent.FreeOnRelease;
+
+begin
+  // Delphi compatibility only at the moment.
+end;
+
+
+Function  TComponent.GetParentComponent: TComponent;
+
+begin
+  Result:=Nil;
+end;
+
+
+Function  TComponent.HasParent: Boolean;
+
+begin
+  Result:=False;
+end;
+
+
+Procedure TComponent.InsertComponent(AComponent: TComponent);
+
+begin
+  AComponent.ValidateContainer(Self);
+  ValidateRename(AComponent,'',AComponent.FName);
+  Insert(AComponent);
+  AComponent.SetReference(True);
+  If csDesigning in FComponentState then
+    AComponent.SetDesigning(true);
+  Notification(AComponent,opInsert);
+end;
+
+
+Procedure TComponent.RemoveComponent(AComponent: TComponent);
+
+begin
+  Notification(AComponent,opRemove);
+  AComponent.SetReference(False);
+  Remove(AComponent);
+  Acomponent.Setdesigning(False);
+  ValidateRename(AComponent,AComponent.FName,'');
+end;
+
+
+Function  TComponent.SafeCallException(ExceptObject: TObject;
+  ExceptAddr: Pointer): Integer;
+
+begin
+  SafeCallException:=0;
+end;
+
+
+function TComponent.UpdateAction(Action: TBasicAction): Boolean;
+begin
+  if Action.HandlesTarget(Self) then
+    begin
+      Action.UpdateTarget(Self);
+      Result := True;
+    end
+  else
+    Result := False;
+end;
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.9  2003/04/27 21:16:11  sg
+  * Fixed TComponent.ValidateRename
+
+  Revision 1.8  2002/10/15 20:06:19  michael
+  + Fixed SetAncestor. Index was getting too big
+
+  Revision 1.7  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+  Revision 1.6  2002/01/09 10:40:24  michael
+  + re-enabled Top/Left property writing
+
+  Revision 1.5  2002/01/06 21:54:50  peter
+    * action classes added
+
+}

rtl/objpas/classes/constse.inc

@@ -0,0 +1,288 @@
+{
+    $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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s can not be assigned to %s';
+  SFCreateError = 'File %s can not be created';
+  SFOpenError = 'File %s can not be opened';
+  SReadError = 'Stream read error';
+  SWriteError = 'Stream write error';
+  SMemoryStreamError = 'Cannot expand memory stream';
+  SCantWriteResourceStreamError = 'Can not write to read-only ResourceStream';
+  SDuplicateReference = 'WriteObject was called twice for one instance';
+  SClassNotFound = 'Class %s not found';
+  SInvalidImage = 'Illegal stream image';
+  SResNotFound = 'Resource %s not found';
+  SClassMismatch = 'Resource %s has wrong class';
+  SListIndexError = 'List index exceeds bounds (%d)';
+  SListCapacityError = 'The maximum list capacity is reached (%d)';
+  SListCountError = 'List count too large (%d)';
+  SSortedListError = 'Operation not allowed on sorted StringLists';
+  SDuplicateString = 'Duplicate entries not allowed in StringList';
+  SInvalidTabIndex = 'Registerindex out of bounds';
+  SDuplicateName = 'A Component with name %s exists already';
+  SInvalidName = '"%s" is not a valid identifier name';
+  SDuplicateClass = 'A class with name %s exists already';
+  SNoComSupport = '%s is not registered as COM Class';
+  SLineTooLong = 'Line too long';
+  SRangeError = 'Range error';
+  SSeekNotImplemented = '64bit Seek not implemented for class %s';
+  SErrNoStreaming = 'Failed to initialize component: No streaming method available.';
+
+  SInvalidPropertyValue = 'Invalid property value';
+  SInvalidPropertyPath = 'Invalid property path';
+  SUnknownProperty = 'Unknown property';
+  SReadOnlyProperty = 'Read-only property';
+  SUnknownPropertyType = 'Unknown property type %d';
+  SPropertyException = 'Error while reading %s%s%s: %s';
+  SAncestorNotFound = 'Ancestor of ''%s'' not found';
+  SInvalidBitmap = 'Invalid Bitmap';
+  SInvalidIcon = 'Invalid Icon';
+  SInvalidMetafile = 'Invalid Metafile';
+  SInvalidPixelFormat = 'Invalid Pixelformat';
+  SBitmapEmpty = 'Bitmap is empty';
+  SScanLine = 'Line index out of bounds';
+  SChangeIconSize = 'Can not change icon size';
+  SOleGraphic = 'Invalid operation for TOleGraphic';
+  SUnknownExtension = 'Unknown extension (.%s)';
+  SUnknownClipboardFormat = 'Unknown clipboard format';
+  SOutOfResources = 'Out of system resources';
+  SNoCanvasHandle = 'Canvas handle does not allow drawing';
+  SInvalidImageSize = 'Invalid image size';
+  STooManyImages = 'Too many images';
+  SDimsDoNotMatch = 'Image size mismatch';
+  SInvalidImageList = 'Invalid ImageList';
+  SReplaceImage = 'Image can not be replaced';
+  SImageIndexError = 'Invalid ImageList index';
+  SImageReadFail = 'The ImageList data could not be read from stream';
+  SImageWriteFail = 'The ImageList data could not be written to stream';
+  SWindowDCError = 'Error when??';
+  SClientNotSet = 'Client of TDrag was not initialized';
+  SWindowClass = 'Error when initializing Window Class';
+  SWindowCreate = 'Error when creating Window';
+  SCannotFocus = 'A disbled or invisible Window cannot get focus';
+  SParentRequired = 'Element ''%s'' has no parent Window';
+  SMDIChildNotVisible = 'A MDI-Child Windows can not be hidden.';
+  SVisibleChanged = 'Visible property cannot be changed in OnShow or OnHide handlers';
+  SCannotShowModal = 'A visible Window can not be made modal';
+  SScrollBarRange = 'Scrollbar property out of range';
+  SPropertyOutOfRange = 'Property %s out of range';
+  SMenuIndexError = 'Menu Index out of range';
+  SMenuReinserted = 'Menu reinserted';
+  SMenuNotFound = 'Menu entry not found in menu';
+  SNoTimers = 'No timers available';
+  SNotPrinting = 'Printer is not printing';
+  SPrinting = 'Printer is busy';
+  SPrinterIndexError = 'PrinterIndex out of range';
+  SInvalidPrinter = 'Selected printer is invalid';
+  SDeviceOnPort = '%s on %s';
+  SGroupIndexTooLow = 'GroupIndex must be greater than preceding menu groupindex';
+  STwoMDIForms = 'There is only one MDI window available';
+  SNoMDIForm = 'No MDI form is available, none is active';
+  SRegisterError = 'Invalid registry';
+  SImageCanvasNeedsBitmap = 'A Canvas can only be changedif it contains a bitmap';
+  SControlParentSetToSelf = 'A component can not have itself as parent';
+  SOKButton = 'OK';
+  SCancelButton = 'Cancel';
+  SYesButton = '&Yes';
+  SNoButton = '&No';
+  SHelpButton = '&Help';
+  SCloseButton = '&Close';
+  SIgnoreButton = '&Ignore';
+  SRetryButton = '&Retry';
+  SAbortButton = 'Abort';
+  SAllButton = '&All';
+
+  SFB = 'VH';
+  SFG = 'VG';
+  SBG = 'HG';
+  SOldTShape = 'Can not load older version of TShape';
+  SVMetafiles = 'MetaFiles';
+  SVEnhMetafiles = 'Enhanced MetaFiles';
+  SVIcons = 'Icons';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Grid to large for this operation';
+  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Grid index out of range';
+  SFixedColTooBig = 'The number of fixed Columns must be less than the Column count';
+  SFixedRowTooBig = 'The number of fixed Rows must be less that the Row count';
+  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s in Line %d';
+
+  SIdentifierExpected = 'Identifier expected';
+  SStringExpected = 'String expected';
+  SNumberExpected = 'Number expected';
+
+  SCharExpected = '%s expected';
+
+  SSymbolExpected = '%s expected';
+
+  SInvalidNumber = 'Invalid numerical value';
+  SInvalidString = 'Invalid string constant';
+  SInvalidProperty = 'Invalid property value';
+  SInvalidBinary = 'Invalid binary';
+  SOutlineIndexError = 'Node index not found';
+  SOutlineExpandError = 'Parent node must be expanded';
+  SInvalidCurrentItem = 'Invalid item';
+  SMaskErr = 'Invalid mask';
+  SMaskEditErr = 'Invalid mask. Use the ESC-key to undo changes.';
+  SOutlineError = 'Invalid Node index';
+  SOutlineBadLevel = '???';
+  SOutlineSelection = 'Ungültige Auswahl';
+  SOutlineFileLoad = 'Fehler beim Dateiladen';
+  SOutlineLongLine = 'Zeile zu lang';
+  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Warning';
+  SMsgDlgError = 'Error';
+  SMsgDlgInformation = 'Information';
+  SMsgDlgConfirm = 'Confirm';
+  SMsgDlgYes = '&Yes';
+  SMsgDlgNo = '&No';
+  SMsgDlgOK = 'OK';
+  SMsgDlgCancel = 'Cancel';
+  SMsgDlgHelp = '&Help';
+  SMsgDlgHelpNone = 'No help available';
+  SMsgDlgHelpHelp = 'Help';
+  SMsgDlgAbort = '&Abort';
+  SMsgDlgRetry = '&Retry';
+  SMsgDlgIgnore = '&Ignore';
+  SMsgDlgAll = '&All';
+  SMsgDlgNoToAll = 'N&o to all';
+  SMsgDlgYesToAll = 'Yes to A&lle';
+
+  SmkcBkSp = 'Backspace';
+  SmkcTab = 'Tab';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Enter';
+  SmkcSpace = 'Space';
+  SmkcPgUp = 'Page up';
+  SmkcPgDn = 'Page down';
+  SmkcEnd = 'End';
+  SmkcHome = 'Home';
+  SmkcLeft = 'Left';
+  SmkcUp = 'Up';
+  SmkcRight = 'Right';
+  SmkcDown = 'Down';
+  SmkcIns = 'Insert';
+  SmkcDel = 'Delete';
+  SmkcShift = 'Shift+';
+  SmkcCtrl = 'Ctrl+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Ukknown)';
+  srNone = '(Empty)';
+  SOutOfRange = 'Value must be between %d and %d';
+  SCannotCreateName = 'Cannot use standard name for and unknown component';
+
+  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+  SCannotDragForm = 'Formulare können nicht gezogen werden';
+  SPutObjectError = 'PutObject auf undefiniertes Element';
+  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+  sAllFilter = 'Alle Dateien';
+  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+  SSelectDirCap = 'Verzeichnis auswählen';
+  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+  SDirNameCap = 'Verzeichnis&name:';
+  SDrivesCap = '&Laufwerke:';
+  SDirsCap = '&Verzeichnisse:';
+  SFilesCap = '&Dateien: (*.*)';
+  SNetworkCap = 'Ne&tzwerk...';
+
+  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+  SDefault = 'Vorgabe';
+
+  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+  SCustomColors = 'Selbstdefinierte Farben';
+  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+  SUntitled = '(Unbenannt)';
+
+  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+  SPreviewLabel = 'Vorschau';
+
+  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Fett kursiv';
+  SBoldFont = 'Fett';
+  SItalicFont = 'Kursiv';
+  SRegularFont = 'Normal';
+
+  SPropertiesVerb = 'Eigenschaften';
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/constsg.inc

@@ -0,0 +1,283 @@
+{
+    $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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s kann nicht zu  %s zugewiesen werden';
+  SFCreateError = 'Datei %s kann nicht erstellt werden';
+  SFOpenError = 'Datei %s kann nicht geöffnet werden';
+  SReadError = 'Stream-Read-Fehler';
+  SWriteError = 'Stream-Write-Fehler';
+  SMemoryStreamError = 'Expandieren des Speicher-Stream wegen Speichermangel nicht möglich';
+  SCantWriteResourceStreamError = 'In einen zum Lesen geöffneten Ressourcen-Stream kann nicht geschrieben werden';
+  SDuplicateReference = 'Zweimaliger Aufruf von WriteObject für die gleiche Instanz';
+  SClassNotFound = 'Klasse %s nicht gefunden';
+  SInvalidImage = 'Ungültiges Stream-Format';
+  SResNotFound = 'Ressource %s nicht gefunden';
+  SClassMismatch = 'Ressource %s hat die falsche Klasse';
+  SListIndexError = 'Der Index der Liste überschreitet das Maximum (%d)';
+  SListCapacityError = 'Die Kapazität der Liste ist erschöpft (%d)';
+  SListCountError = 'Zu viele Einträge in der Liste (%d)';
+  SSortedListError = 'Operation bei sortierten Stringlisten nicht erlaubt';
+  SDuplicateString = 'In der Stringliste sind Duplikate nicht erlaubt';
+  SInvalidTabIndex = 'Registerindex außerhalb des zulässigen Bereichs';
+  SDuplicateName = 'Eine Komponente mit der Bezeichnung %s existiert bereits';
+  SInvalidName = '''''%s'''' ist kein gültiger Komponentenname';
+  SDuplicateClass = 'Eine Klasse mit der Bezeichnung %s existiert bereits';
+  SNoComSupport = '%s wurde nicht als COM-Klasse registriert';
+  SInvalidInteger = '''''%s'''' ist kein gültiger Integerwert';
+  SLineTooLong = 'Zeile zu lang';
+
+  SInvalidPropertyValue = 'Ungültiger Wert der Eigenschaft';
+  SInvalidPropertyPath = 'Ungültiger Pfad für Eigenschaft';
+  SUnknownProperty = 'Eigenschaft existiert nicht';
+  SReadOnlyProperty = 'Eigenschaft kann nur gelesen werden';
+  SUnknownPropertyType = 'Unbekannter Eigenschaftstyp %d';
+  SPropertyException = 'Fehler beim Lesen von %s%s: %s';
+  SAncestorNotFound = 'Vorfahr für ''%s'' nicht gefunden';
+  SInvalidBitmap = 'Bitmap ist ungültig';
+  SInvalidIcon = 'Ungültiges Symbol';
+  SInvalidMetafile = 'Metadatei ist ungültig';
+  SInvalidPixelFormat = 'Ungültiges Pixelformat';
+  SBitmapEmpty = 'Bitmap ist leer';
+  SScanLine = 'Bereichsüberschreitung bei Zeilenindex';
+  SChangeIconSize = 'Die Größe eines Symbols kann nicht geändert werden';
+  SOleGraphic = 'Ungültige Operation für TOleGraphic';
+  SUnknownExtension = 'Unbekannte Bilddateierweiterung (.%s)';
+  SUnknownClipboardFormat = 'Format der Zwischenablage wird nicht unterstützt';
+  SOutOfResources = 'Systemressourcen erschöpft.';
+  SNoCanvasHandle = 'Leinwand/Bild erlaubt kein Zeichnen';
+  SInvalidImageSize = 'Ungültige Bildgröße';
+  STooManyImages = 'Zu viele Bilder';
+  SDimsDoNotMatch = 'Bildgröße und Bildlistengröße stimmen nicht überein';
+  SInvalidImageList = 'Ungültige ImageList';
+  SReplaceImage = 'Bild kann nicht ersetzt werden';
+  SImageIndexError = 'Ungültiger ImageList-Index';
+  SImageReadFail = 'Die ImageList-Daten konnten nicht aus dem Stream gelesen werden';
+  SImageWriteFail = 'Die ImageList-Daten konnten nicht in den Stream geschrieben werden';
+  SWindowDCError = 'Fehler beim Erstellen des Fenster-Gerätekontexts';
+  SClientNotSet = 'Client von TDrag wurde nicht initialisiert';
+  SWindowClass = 'Fehler beim Erzeugen einer Fensterklasse';
+  SWindowCreate = 'Fehler beim Erzeugen eines Fensters';
+  SCannotFocus = 'Ein deaktiviertes oder unsichtbares Fenster kann nicht den Fokus erhalten';
+  SParentRequired = 'Element ''%s'' hat kein übergeordnetes Fenster';
+  SMDIChildNotVisible = 'Ein MDI-Kindformular kann nicht verborgen werden';
+  SVisibleChanged = 'Eigenschaft Visible kann in OnShow oder OnHide nicht verändert werden';
+  SCannotShowModal = 'Aus einem sichtbaren Fenster kann kein modales gemacht werden';
+  SScrollBarRange = 'Eigenschaft Scrollbar außerhalb des zulässigen Bereichs';
+  SPropertyOutOfRange = 'Eigenschaft %s außerhalb des gültigen Bereichs';
+  SMenuIndexError = 'Menüindex außerhalb des zulässigen Bereichs';
+  SMenuReinserted = 'Menü zweimal eingefügt';
+  SMenuNotFound = 'Untermenü ist nicht im Menü';
+  SNoTimers = 'Nicht genügend Timer verfügbar';
+  SNotPrinting = 'Der Drucker ist nicht am Drucken';
+  SPrinting = 'Das Drucken ist im Gang';
+  SPrinterIndexError = 'Druckerindex außerhalb des zulässigen Bereichs';
+  SInvalidPrinter = 'Ausgewählter Drucker ist ungültig';
+  SDeviceOnPort = '%s an %s';
+  SGroupIndexTooLow = 'GroupIndex kann nicht kleiner sein als der GroupIndex eines vorhergehenden Menüelementes';
+  STwoMDIForms = 'Es ist nur ein MDI-Formular pro Anwendung möglich';
+  SNoMDIForm = 'Formular kann nicht erstellt werden. Zur Zeit sind keine MDI-Formulare aktiv';
+  SRegisterError = 'Ungültige Komponentenregistrierung';
+  SImageCanvasNeedsBitmap = 'Ein Bild kann nur geändert werden, wenn es ein Bitmap enthält';
+  SControlParentSetToSelf = 'Ein Steuerelement kann nicht sich selbst als Vorfahr haben';
+  SOKButton = 'OK';
+  SCancelButton = 'Abbrechen';
+  SYesButton = '&Ja';
+  SNoButton = '&Nein';
+  SHelpButton = '&Hilfe';
+  SCloseButton = '&Schließen';
+  SIgnoreButton = '&Ignorieren';
+  SRetryButton = '&Wiederholen';
+  SAbortButton = 'Abbruch';
+  SAllButton = '&Alles';
+
+  SFB = 'VH';
+  SFG = 'VG';
+  SBG = 'HG';
+  SOldTShape = 'Kann ältere Version von TShape nicht laden';
+  SVMetafiles = 'Metadateien';
+  SVEnhMetafiles = 'Erweiterte Metadateien';
+  SVIcons = 'Symbole';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Gitter zu groß für Operation';
+  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Gitterindex außerhalb des zulässigen Bereichs';
+  SFixedColTooBig = 'Die Anzahl fester Spalten muß kleiner sein als die Spaltenanzahl';
+  SFixedRowTooBig = 'Die Anzahl fester Zeilen muß kleiner sein als die Zeilenanzahl';
+  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s in Zeile %d';
+
+  SIdentifierExpected = 'Bezeichner erwartet';
+  SStringExpected = 'String erwartet';
+  SNumberExpected = 'Zahl erwartet';
+
+  SCharExpected = '%s erwartet';
+
+  SSymbolExpected = '%s erwartet';
+
+  SInvalidNumber = 'Ungültiger numerischer Wert';
+  SInvalidString = 'Ungültige Stringkonstante';
+  SInvalidProperty = 'Ungültiger Wert der Eigenschaft';
+  SInvalidBinary = 'Ungültiger Binärwert';
+  SOutlineIndexError = 'Gliederungsindex nicht gefunden';
+  SOutlineExpandError = 'Elternknoten muß expandiert sein';
+  SInvalidCurrentItem = 'Ungültiger Wert';
+  SMaskErr = 'Ungültiger Eingabewert';
+  SMaskEditErr = 'Ungültiger Eingabewert. Benutzen Sie die ESC-Taste, um die Änderungen rückgängig zu machen.';
+  SOutlineError = 'Ungültiger Gliederungsindex';
+  SOutlineBadLevel = 'Ungültige Zuweisung von Ebenen';
+  SOutlineSelection = 'Ungültige Auswahl';
+  SOutlineFileLoad = 'Fehler beim Dateiladen';
+  SOutlineLongLine = 'Zeile zu lang';
+  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Warnung';
+  SMsgDlgError = 'Fehler';
+  SMsgDlgInformation = 'Information';
+  SMsgDlgConfirm = 'Bestätigen';
+  SMsgDlgYes = '&Ja';
+  SMsgDlgNo = '&Nein';
+  SMsgDlgOK = 'OK';
+  SMsgDlgCancel = 'Abbrechen';
+  SMsgDlgHelp = '&Hilfe';
+  SMsgDlgHelpNone = 'Keine Hilfe verfügbar';
+  SMsgDlgHelpHelp = 'Hilfe';
+  SMsgDlgAbort = '&Abbrechen';
+  SMsgDlgRetry = '&Wiederholen';
+  SMsgDlgIgnore = '&Ignorieren';
+  SMsgDlgAll = '&Alles';
+  SMsgDlgNoToAll = '&Alle Nein';
+  SMsgDlgYesToAll = 'A&lle Ja';
+
+  SmkcBkSp = 'Rück';
+  SmkcTab = 'Tab';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Enter';
+  SmkcSpace = 'Leertaste';
+  SmkcPgUp = 'BildAuf';
+  SmkcPgDn = 'BildAb';
+  SmkcEnd = 'Ende';
+  SmkcHome = 'Pos1';
+  SmkcLeft = 'Linksbündig';
+  SmkcUp = 'Nach oben';
+  SmkcRight = 'Rechts';
+  SmkcDown = 'Nach unten';
+  SmkcIns = 'Einfg';
+  SmkcDel = 'Entf';
+  SmkcShift = 'Umsch+';
+  SmkcCtrl = 'Strg+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Unbekannt)';
+  srNone = '(Leer)';
+  SOutOfRange = 'Wert muß zwischen %d und %d liegen';
+  SCannotCreateName = 'Für eine unbenannte Komponente kann kein Standard-Methodennamen erstellt werden';
+
+  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+  SCannotDragForm = 'Formulare können nicht gezogen werden';
+  SPutObjectError = 'PutObject auf undefiniertes Element';
+  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+  sAllFilter = 'Alle Dateien';
+  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+  SSelectDirCap = 'Verzeichnis auswählen';
+  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+  SDirNameCap = 'Verzeichnis&name:';
+  SDrivesCap = '&Laufwerke:';
+  SDirsCap = '&Verzeichnisse:';
+  SFilesCap = '&Dateien: (*.*)';
+  SNetworkCap = 'Ne&tzwerk...';
+
+  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+  SDefault = 'Vorgabe';
+
+  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+  SCustomColors = 'Selbstdefinierte Farben';
+  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+  SUntitled = '(Unbenannt)';
+
+  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+  SPreviewLabel = 'Vorschau';
+
+  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Fett kursiv';
+  SBoldFont = 'Fett';
+  SItalicFont = 'Kursiv';
+  SRegularFont = 'Normal';
+
+  SPropertiesVerb = 'Eigenschaften';
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.4  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/constss.inc

@@ -0,0 +1,282 @@
+{
+    $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.
+
+ **********************************************************************}
+
+const
+  SAssignError = '%s no puede ser assignado a  %s';
+  SFCreateError = 'Fichero %s no puede ser creado';
+  SFOpenError = 'Fichero %s no puede ser abierto';
+  SReadError = 'Error-Lectura-Stream';
+  SWriteError = 'Error-Escritura-Stream';
+  SMemoryStreamError = 'No es posible expandir Memoria Stream';
+  SCantWriteResourceStreamError = 'No se puede escribir en un ResourceStream de solo lectura';
+  SDuplicateReference = 'WriteObject fue llamado dos veces por una sola instancia';
+  SClassNotFound = 'Clase %s no encontrada';
+  SInvalidImage = 'Imagen stream ilegal';
+  SResNotFound = 'No se encontro el resource %s';
+  SClassMismatch = 'El resource %s tiene una clase erronea';
+  SListIndexError = 'El indice de lista excede los limites (%d)';
+  SListCapacityError = 'La maxima capacidad de lista a sido alcanzada (%d)';
+  SListCountError = 'Contador de lista demasiado grande (%d)';
+  SSortedListError = 'Operacion no permitida en StringLists ordenado';
+  SDuplicateString = 'Entradas duplicadas no permitidas en StringList';
+  SInvalidTabIndex = 'Registerindex fuera de limites';
+  SDuplicateName = 'Un componente con el nombre %s existe actualmente';
+  SInvalidName = '"%s" no es un nombre identificador valido';
+  SDuplicateClass = 'Una Clase con el nombre %s existe actualmente';
+  SNoComSupport = '%s no esta registrado como COM-Class';
+  SLineTooLong = 'Linea demasiado larga';
+
+  SInvalidPropertyValue = 'Valor de propiedad no valido';
+  SInvalidPropertyPath = 'Path de propiedad no valido';
+  SUnknownProperty = 'Propiedad desconocidad';
+  SReadOnlyProperty = 'Propiedad de solo lectura';
+{N}  SUnknownPropertyType = 'Unknown property type %d';
+  SPropertyException = 'Error leyendo %s%s: %s';
+{N}  SAncestorNotFound = 'Ancestor of ''%s'' not found.';
+  SInvalidBitmap = 'Bitmap no valido';
+  SInvalidIcon = 'Icono no valido';
+  SInvalidMetafile = 'MetaFile no valido';
+  SInvalidPixelFormat = 'PixelFormat no valido';
+  SBitmapEmpty = 'El bitmap esta vacio';
+  SScanLine = 'Indice de linea fuera de limites';
+  SChangeIconSize = 'No se puede cambiar el tama¤o del icono';
+  SOleGraphic = 'Operacion no valida para TOleGraphic';
+  SUnknownExtension = 'Extension desconocida (.%s)';
+  SUnknownClipboardFormat = 'Formato de Portapapeles desconocido';
+  SOutOfResources = 'Recursos de sistema agotados';
+  SNoCanvasHandle = 'El manejador Canvas no permite dibujar';
+  SInvalidImageSize = 'Tama¤o de imagen no valido';
+  STooManyImages = 'Demasiadas imagenes';
+  SDimsDoNotMatch = 'El tama¤o de la imagen no coincide';
+  SInvalidImageList = 'ImageList no valido';
+  SReplaceImage = 'La imagen no puede ser reemplazada';
+  SImageIndexError = 'ImageList-Index no valido';
+  SImageReadFail = 'Los datos de ImageList no pueden ser leido desde Stream';
+  SImageWriteFail = 'Los datos de ImageList no pueden ser escritos en Stream';
+  SWindowDCError = 'Error cuando??';
+  SClientNotSet = 'El cliente de TDrag no fue iniciado';
+  SWindowClass = 'Error inicializando Window Class';
+  SWindowCreate = 'Error creando una Ventana';
+{?}  SCannotFocus = 'Una Ventana invisible or desactivada no puede obtener el foco';
+  SParentRequired = 'El elemento ''%s'' no tiene una ventana padre';
+  SMDIChildNotVisible = 'Una ventana MDI-Child no puede ser ocultada.';
+  SVisibleChanged = 'Una propiedad visual no puede ser cambiada en el manejador OnShow o OnHide';
+{?}  SCannotShowModal = 'Una Ventana visible no puede ser hecha modal';
+  SScrollBarRange = 'Propiedad de Scrollbar fuera de limites';
+  SPropertyOutOfRange = 'Propiedad %s fuera de limites';
+  SMenuIndexError = 'Indice de menu fuera de rango';
+  SMenuReinserted = 'Menu reinsertado';
+  SMenuNotFound = 'Entrada de menu no encontra en menu';
+  SNoTimers = 'No hay timers disponibles';
+  SNotPrinting = 'La impresora no esta imprimiendo';
+  SPrinting = 'La impresora esta ocupada';
+  SPrinterIndexError = 'PrinterIndex fuera de rango';
+  SInvalidPrinter = 'La impresora seleccionada no es valida';
+  SDeviceOnPort = '%s en %s';
+  SGroupIndexTooLow = 'GroupIndex tiene que ser mayor que el goupindex del menu predecesor';
+  STwoMDIForms = 'Solo hay una ventana MDI disponible';
+  SNoMDIForm = 'No hay ningun MDI form disponible, none esta activado';
+  SRegisterError = 'Registro invalido';
+  SImageCanvasNeedsBitmap = 'Un Canvas solo puede ser cambiado si contiene un bitmap';
+  SControlParentSetToSelf = 'Un componente no puede tenerse a si mismo como padre';
+  SOKButton = 'Aceptar';
+  SCancelButton = 'Cancelar';
+  SYesButton = '&Si';
+  SNoButton = '&No';
+  SHelpButton = '&Ayuda';
+  SCloseButton = '&Cerrar';
+  SIgnoreButton = '&Ignorar';
+  SRetryButton = '&Reintentar';
+  SAbortButton = 'Abortar';
+  SAllButton = '&Todo';
+
+{?}  SFB = 'VH';
+{?}  SFG = 'VG';
+{?}  SBG = 'HG';
+  SOldTShape = 'No es posible cargar versiones antiguas de TShape';
+  SVMetafiles = 'MetaFiles';
+  SVEnhMetafiles = 'MetaFiles ampliados';
+  SVIcons = 'Iconos';
+  SVBitmaps = 'Bitmaps';
+  SGridTooLarge = 'Malla demasiado grande para esta operacion';
+{?}  STooManyDeleted = 'Zu viele Zeilen oder Spalten gelöscht';
+  SIndexOutOfRange = 'Indice de malla fuera de rango';
+  SFixedColTooBig = 'El numero de columnas fijas tiene que ser menor que el contador Column';
+  SFixedRowTooBig = 'El numero de filas fijas tiene que ser menor que el contador Row';
+{?}  SInvalidStringGridOp = 'Es können keine Zeilen des ''Grids'' gelöscht oder eingefügt werden';
+  SParseError = '%s en Linia %d';
+
+  SIdentifierExpected = 'Falta identificador';
+  SStringExpected = 'Falta string';
+  SNumberExpected = 'Falta numero';
+
+  SCharExpected = 'Falta %s';
+
+  SSymbolExpected = 'Falta %s';
+
+  SInvalidNumber = 'Valor numerico no valido';
+  SInvalidString = 'Constante string no valida';
+  SInvalidProperty = 'Valor de propiedad no valido';
+  SInvalidBinary = 'Binario no valido';
+  SOutlineIndexError = 'Indice de nodo no encontrado';
+  SOutlineExpandError = 'El nodo padre tiene que ser expandido';
+  SInvalidCurrentItem = 'Item no valido';
+  SMaskErr = 'Mascara no valida';
+  SMaskEditErr = 'Mascara no valida. Usa la tecla ESC para deshacer los cambios.';
+  SOutlineError = 'Indice de nodo no valido';
+  SOutlineBadLevel = '???';
+{?}  SOutlineSelection = 'Ungültige Auswahl';
+{?}  SOutlineFileLoad = 'Fehler beim Dateiladen';
+{?}  SOutlineLongLine = 'Zeile zu lang';
+{?}  SOutlineMaxLevels = 'Maximale Gliederungstiefe überschritten';
+
+  SMsgDlgWarning = 'Atencion';
+  SMsgDlgError = 'Error';
+  SMsgDlgInformation = 'Informacion';
+  SMsgDlgConfirm = 'Confirmar';
+  SMsgDlgYes = '&Si';
+  SMsgDlgNo = '&No';
+  SMsgDlgOK = 'Aceptar';
+  SMsgDlgCancel = 'Cancelar';
+  SMsgDlgHelp = '&Ayuda';
+  SMsgDlgHelpNone = 'No hay ayuda disponible';
+  SMsgDlgHelpHelp = 'Ayuda';
+  SMsgDlgAbort = 'A&bortar';
+  SMsgDlgRetry = '&Reintentar';
+  SMsgDlgIgnore = '&Ignorar';
+  SMsgDlgAll = '&Todo';
+  SMsgDlgNoToAll = 'N&o a todo';
+  SMsgDlgYesToAll = 'Si a To&do';
+
+  SmkcBkSp = 'Backspace';
+  SmkcTab = 'Tabulador';
+  SmkcEsc = 'Esc';
+  SmkcEnter = 'Intro';
+  SmkcSpace = 'Espacio';
+  SmkcPgUp = 'Pagina arriva';
+  SmkcPgDn = 'Pagina abajo';
+  SmkcEnd = 'Fin';
+  SmkcHome = 'Inicio';
+  SmkcLeft = 'Izquierda';
+  SmkcUp = 'Arriba';
+  SmkcRight = 'Derecha';
+  SmkcDown = 'Abajo';
+  SmkcIns = 'Insertar';
+  SmkcDel = 'Suprimir';
+  SmkcShift = 'Shift+';
+  SmkcCtrl = 'Ctrl+';
+  SmkcAlt = 'Alt+';
+
+  srUnknown = '(Desconocido)';
+  srNone = '(Vacio)';
+  SOutOfRange = 'El valor tiene que estar entre %d y %d';
+  SCannotCreateName = 'No es posible use el nombre estandard para un componente desconocido';
+
+{?}  SDateEncodeError = 'Ungültiges Argument für Datumskodierung';
+{?}  STimeEncodeError = 'Ungültiges Argument für Zeitkodierung';
+{?}  SInvalidDate = '''''%s'''' ist kein gültiges Datum';
+{?}  SInvalidTime = '''''%s'''' ist keine gültige Zeit';
+{?}  SInvalidDateTime = '''''%s'''' ist kein gültiges Datum und Zeit';
+{?}  SInsertLineError = 'Zeile kann nicht eingefügt werden';
+
+{?}  SCannotDragForm = 'Formulare können nicht gezogen werden';
+{?}  SPutObjectError = 'PutObject auf undefiniertes Element';
+{?}  SCardDLLNotLoaded = 'CARDS.DLL kann nicht geladen werden';
+{?}  SDuplicateCardId = 'Doppelte CardId gefunden';
+
+{?}  SDdeErr = 'Ein Fehler wurde von der DDE zurückgeliefert  ($0%x)';
+{?}  SDdeConvErr = 'DDE Fehler - Konversation wurde nicht hergestellt ($0%x)';
+{?}  SDdeMemErr = 'Fehler trat auf, da unzureichender Speicher für DDE ($0%x)';
+{?}  SDdeNoConnect = 'DDE-Konversation kann nicht eingerichtet werden';
+
+
+{?}  SDefaultFilter = 'Alle Dateien (*.*)|*.*';
+{?}  sAllFilter = 'Alle Dateien';
+{?}  SNoVolumeLabel = ': [ - Ohne Namen - ]';
+
+{?}  SConfirmCreateDir = 'Das angegebene Verzeichnis existiert nicht. Soll es angelegt werden?';
+{?}  SSelectDirCap = 'Verzeichnis auswählen';
+{?}  SCannotCreateDir = 'Das Verzeichnis kann nicht erstellt werden';
+{?}  SDirNameCap = 'Verzeichnis&name:';
+{?}  SDrivesCap = '&Laufwerke:';
+{?}  SDirsCap = '&Verzeichnisse:';
+{?}  SFilesCap = '&Dateien: (*.*)';
+{?}  SNetworkCap = 'Ne&tzwerk...';
+
+{?}  SColorPrefix = 'Farbe';
+  SColorTags = 'ABCDEFGHIJKLMNOP';
+
+{?}  SInvalidClipFmt = 'Ungültiges Format der Zwischenablage';
+{?}  SIconToClipboard = 'Zwischenablage unterstützt keine Symbole';
+
+{?}  SDefault = 'Vorgabe';
+
+{?}  SInvalidMemoSize = 'Text überschreitet Memo-Kapazität';
+{?}  SCustomColors = 'Selbstdefinierte Farben';
+{?}  SInvalidPrinterOp = 'Operation auf ausgewähltem Drucker nicht verfügbar';
+{?}  SNoDefaultPrinter = 'Zur Zeit ist kein Standard-Drucker gewählt';
+
+{?}  SIniFileWriteError = 'nach %s kann nicht geschrieben werden';
+
+{?}  SBitsIndexError = 'Bits-Index außerhalb des zulässigen Bereichs';
+
+{?}  SUntitled = '(Unbenannt)';
+
+{?}  SInvalidRegType = 'Ungültiger Datentyp für ''%s''';
+{?}  SRegCreateFailed = 'Erzeugung von Schlüssel %s misslungen';
+{?}  SRegSetDataFailed = 'Konnte Daten für ''%s'' nicht setzen';
+{?}  SRegGetDataFailed = 'Konnte Daten für ''%s'' nicht holen';
+
+{?}  SUnknownConversion = 'Unbekannte Dateierweiterung für RichEdit-Konvertierung (.%s)';
+{?}  SDuplicateMenus = 'Menü ''%s'' wird bereits von einem anderen Formular benutzt';
+
+{?}  SPictureLabel = 'Bild:';
+  SPictureDesc = ' (%dx%d)';
+{?}  SPreviewLabel = 'Vorschau';
+
+{?}  SCannotOpenAVI = 'AVI kann nicht geöffnet werden';
+
+{?}  SNotOpenErr = 'Kein MCI-Gerät geöffnet';
+{?}  SMPOpenFilter = 'Alle Dateien (*.*)|*.*|Wave-Dateien (*.WAV)|*.WAV|Midi-Dateien (*.MID)|*.MID|Video für Windows (*.avi)|*.avi';
+  SMCINil = '';
+  SMCIAVIVideo = 'AVIVideo';
+  SMCICDAudio = 'CDAudio';
+  SMCIDAT = 'DAT';
+  SMCIDigitalVideo = 'DigitalVideo';
+  SMCIMMMovie = 'MMMovie';
+  SMCIOther = 'Andere';
+  SMCIOverlay = 'Overlay';
+  SMCIScanner = 'Scanner';
+  SMCISequencer = 'Sequencer';
+  SMCIVCR = 'VCR';
+  SMCIVideodisc = 'Videodisc';
+  SMCIWaveAudio = 'WaveAudio';
+  SMCIUnknownError = 'Unbekannter Fehlercode';
+
+  SBoldItalicFont = 'Negrita cursiva';
+  SBoldFont = 'Negrita';
+  SItalicFont = 'Cursiva';
+  SRegularFont = 'Normal';
+
+{?}  SPropertiesVerb = 'Eigenschaften';
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.4  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/cregist.inc

@@ -0,0 +1,209 @@
+{
+    $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.
+
+ **********************************************************************}
+
+
+
+{ Class registration routines }
+
+procedure RegisterClass(AClass: TPersistentClass);
+var
+aClassname : String;
+begin
+  //Classlist is created during initialization.
+  with Classlist.Locklist do
+     try
+      while Indexof(AClass) = -1 do
+         begin
+           aClassname := AClass.ClassName;
+           if GetClass(aClassName) <> nil then  //class alread registered!
+                 Begin
+                 //raise an error
+                 exit;
+                 end;
+          Add(AClass);
+          if AClass = TPersistent then break;
+          AClass := TPersistentClass(AClass.ClassParent);
+         end;
+     finally
+       ClassList.UnlockList;
+     end;
+end;
+
+
+procedure RegisterClasses(AClasses: array of TPersistentClass);
+var
+I : Integer;
+begin
+for I := low(aClasses) to high(aClasses) do
+       RegisterClass(aClasses[I]);
+end;
+
+
+procedure RegisterClassAlias(AClass: TPersistentClass; const Alias: string);
+
+begin
+end;
+
+
+procedure UnRegisterClass(AClass: TPersistentClass);
+
+begin
+end;
+
+
+procedure UnRegisterClasses(AClasses: array of TPersistentClass);
+
+begin
+end;
+
+
+procedure UnRegisterModuleClasses(Module: HMODULE);
+
+begin
+end;
+
+
+function FindClass(const AClassName: string): TPersistentClass;
+
+begin
+  Result := GetClass(AClassName);
+  if not Assigned(Result) then
+    raise EClassNotFound.CreateFmt(SClassNotFound, [AClassName]);
+end;
+
+
+function GetClass(const AClassName: string): TPersistentClass;
+var
+I : Integer;
+begin
+  with ClassList.LockList do
+   try
+    for I := 0 to Count-1 do
+       begin
+        Result := TPersistentClass(Items[I]);
+        if Result.ClassNameIs(AClassName) then Exit;
+       end;
+       I := ClassAliasList.Indexof(AClassName);
+       if I >= 0 then  //found
+          Begin
+          Result := TPersistentClass(ClassAliasList.Objects[i]);
+          exit;
+          end;
+       Result := nil;
+    finally
+      ClassList.Unlocklist;
+    end;
+end;
+
+{ Component registration routines }
+
+type
+  TComponentPage = class(TCollectionItem)
+  public
+    Name: String;
+    Classes: TList;
+    destructor Destroy; override;
+  end;
+
+{ TComponentPage }
+
+destructor TComponentPage.Destroy;
+begin
+  Classes.Free;
+  inherited Destroy;
+end;
+  
+var
+  ComponentPages: TCollection;
+
+procedure InitComponentPages;
+begin
+  ComponentPages := TCollection.Create(TComponentPage);
+  { Add a empty page which will be used for storing the NoIcon components }
+  ComponentPages.Add;
+end;
+
+procedure RegisterComponents(const Page: string;
+  ComponentClasses: array of TComponentClass);
+var
+  i: Integer;
+  pg: TComponentPage;
+begin
+  if Page = '' then exit;  { prevent caller from doing nonsense }
+
+  pg := nil;
+  if not Assigned(ComponentPages) then
+    InitComponentPages
+  else
+    for i := 0 to ComponentPages.Count - 1 do
+      if TComponentPage(ComponentPages.Items[i]).Name = Page then begin
+        pg := TComponentPage(ComponentPages.Items[i]);
+        break;
+      end;
+
+  if pg = nil then begin
+    pg := TComponentPage(ComponentPages.Add);
+    pg.Name := Page;
+  end;
+
+  if pg.Classes = nil then
+    pg.Classes := TList.Create;
+
+  for i := Low(ComponentClasses) to High(ComponentClasses) do
+    pg.Classes.Add(ComponentClasses[i]);
+
+  if Assigned(RegisterComponentsProc) then
+    RegisterComponentsProc(Page, ComponentClasses);
+end;
+
+
+procedure RegisterNoIcon(ComponentClasses: array of TComponentClass);
+var
+  pg: TComponentPage;
+  i: Integer;
+begin
+  if not Assigned(ComponentPages) then
+    InitComponentPages;
+
+  pg := TComponentPage(ComponentPages.Items[0]);
+  if pg.Classes = nil then
+    pg.Classes := TList.Create;
+
+  for i := Low(ComponentClasses) to High(ComponentClasses) do
+    pg.Classes.Add(ComponentClasses[i]);
+
+  if Assigned(RegisterNoIconProc) then
+    RegisterNoIconProc(ComponentClasses);
+end;
+
+
+procedure RegisterNonActiveX(ComponentClasses: array of TComponentClass;
+  AxRegType: TActiveXRegType);
+
+begin
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/dm.inc

@@ -0,0 +1,173 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    <What does this file>
+    
+    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.
+
+ **********************************************************************}
+
+Constructor TDataModule.Create(AOwner: TComponent);
+begin
+  CreateNew(AOwner);
+  if (ClassType <> TDataModule) and 
+     not (csDesigning in ComponentState) then
+    begin
+    if not InitInheritedComponent(Self, TDataModule) then 
+      raise EStreamError.CreateFmt(SErrNoSTreaming, [ClassName]);
+    if OldCreateOrder then 
+      DoCreate;
+    end;
+end;
+
+Constructor TDataModule.CreateNew(AOwner: TComponent); 
+
+begin
+  CreateNew(AOwner,0);
+end;
+
+constructor TDataModule.CreateNew(AOwner: TComponent; CreateMode: Integer);
+begin
+  inherited Create(AOwner);
+  if Assigned(AddDataModule) and (CreateMode>=0) then
+    AddDataModule(Self);
+end;
+
+Procedure TDataModule.AfterConstruction;
+begin
+   If not OldCreateOrder then 
+     DoCreate;
+end;
+
+Procedure TDataModule.BeforeDestruction;
+begin
+  Destroying;
+  RemoveFixupReferences(Self, '');
+  if not OldCreateOrder then 
+    DoDestroy;
+end;
+
+destructor TDataModule.Destroy;
+begin
+  if OldCreateOrder then 
+    DoDestroy;
+  if Assigned(RemoveDataModule) then
+    RemoveDataModule(Self);
+  inherited Destroy;
+end;
+
+Procedure TDataModule.DoCreate;
+begin
+  if Assigned(FOnCreate) then
+    try
+      FOnCreate(Self);
+    except
+      if not HandleCreateException then
+        raise;
+    end;
+end;
+
+Procedure TDataModule.DoDestroy;
+begin
+  if Assigned(FOnDestroy) then
+    try
+      FOnDestroy(Self);
+    except
+      if Assigned(ApplicationHandleException) then
+        ApplicationHandleException(Self);
+    end;
+end;
+
+procedure TDataModule.DefineProperties(Filer: TFiler);
+
+var
+  Ancestor : TDataModule;
+  HaveData : Boolean;
+  
+begin
+  inherited DefineProperties(Filer);
+  Ancestor := TDataModule(Filer.Ancestor);
+  HaveData:=(Ancestor=Nil) or 
+            (FDSize.X<>Ancestor.FDSize.X) or
+            (FDSize.Y<>Ancestor.FDSize.Y) or
+            (FDPos.Y<>Ancestor.FDPos.Y) or
+            (FDPos.X<>Ancestor.FDPos.X);
+  Filer.DefineProperty('Height', @ReadH, @WriteH, HaveData);
+  Filer.DefineProperty('HorizontalOffset', @ReadL, @WriteL, HaveData);
+  Filer.DefineProperty('VerticalOffset', @ReadT,@WriteT, HaveData);
+  Filer.DefineProperty('Width', @ReadW, @WriteW, HaveData);
+end;
+
+procedure TDataModule.GetChildren(Proc: TGetChildProc; Root: TComponent);
+
+var
+  I : Integer;
+  
+begin
+  inherited GetChildren(Proc, Root);
+  if (Root=Self) then 
+    for I:=0 to ComponentCount-1 do
+      If Not Components[I].HasParent then
+         Proc(Components[i]);
+end;
+
+
+function TDataModule.HandleCreateException: Boolean;
+begin
+  Result:=Assigned(ApplicationHandleException);
+  if Result then
+    ApplicationHandleException(Self);
+end;
+
+Procedure TDataModule.ReadState(Reader: TReader);
+begin
+  FOldOrder := false;
+  inherited ReadState(Reader);
+end;
+
+Procedure TDataModule.ReadT(Reader: TReader);
+begin
+  FDPos.Y := Reader.ReadInteger;
+end;
+
+Procedure TDataModule.WriteT(Writer: TWriter);
+begin
+  Writer.WriteInteger(FDPos.Y);
+end;
+
+Procedure TDataModule.ReadL(Reader: TReader);
+begin
+  FDPos.X := Reader.ReadInteger;
+end;
+
+Procedure TDataModule.WriteL(Writer: TWriter);
+begin
+  Writer.WriteInteger(FDPos.X);
+end;
+
+Procedure TDataModule.ReadW(Reader: TReader);
+begin
+  FDSIze.X := Reader.ReadInteger;
+end;
+
+Procedure TDataModule.WriteW(Writer: TWriter);
+begin
+  Writer.WriteInteger(FDSIze.X);
+end;
+
+Procedure TDataModule.ReadH(Reader: TReader);
+begin
+  FDSIze.Y := Reader.ReadInteger;
+end;
+
+Procedure TDataModule.WriteH(Writer: TWriter);
+begin
+  Writer.WriteInteger(FDSIze.Y);
+end;

rtl/objpas/classes/felog.inc

@@ -0,0 +1,73 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 2003 by the Free Pascal development team
+
+    Generic implementation of 'system log' event mechanism which maps to file log.
+    
+    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.
+
+ **********************************************************************}
+
+Function TEventLog.DefaultFileName : String;
+
+begin
+  Result:=ChangeFileExt(ExtractFileName(Paramstr(0)),'.log');
+end;
+
+Procedure TEventLog.ActivateSystemLog;
+
+begin
+  CheckIdentification;
+  ActivateFileLog;
+end;
+
+Procedure TEventLog.DeActivateSystemLog;
+
+begin
+  DeActivateFileLog;
+end;
+
+procedure TEventLog.WriteSystemLog(EventType : TEventType; Msg : String);
+
+begin
+  WriteFileLog(EventType,Msg);
+end;
+
+Function TEventLog.RegisterMessageFile(AFileName : String) : Boolean;
+
+begin
+  Result:=True;
+end;
+
+function TEventLog.MapTypeToCategory(EventType: TEventType): Word;
+begin
+  Result:=0;
+end;
+
+function TEventLog.MapTypeToEventID(EventType: TEventType): DWord;
+
+begin
+  Result:=0;
+end;
+
+function TEventLog.MapTypeToEvent(EventType: TEventType): DWord;
+
+begin
+  Result:=0;
+end;
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2003/02/19 20:25:16  michael
+  + Added event log
+
+}

rtl/objpas/classes/filer.inc

@@ -0,0 +1,32 @@
+{
+    $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.
+
+ **********************************************************************}
+{ *********************************************************************
+  *                         TFiler                                    *
+  *********************************************************************}
+
+procedure TFiler.SetRoot(ARoot: TComponent);
+begin
+  FRoot := ARoot;
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/filerec.inc

@@ -0,0 +1,44 @@
+{
+    $Id$
+    This file is part of the Free Pascal run time library.
+    Copyright (c) 1999-2000 by the Free Pascal development team
+
+    FileRec record definition
+
+
+    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.
+
+ **********************************************************************}
+
+{
+  This file contains the definition of the filerec record.
+  It is put separately, so it is available outside the system
+  unit without sacrificing TP compatibility.
+}
+
+const
+  filerecnamelength = 255;
+type
+  FileRec = Packed Record
+    Handle,
+    Mode,
+    RecSize   : longint;
+    _private  : array[1..32] of byte;
+    UserData  : array[1..16] of byte;
+    name      : array[0..filerecnamelength] of char;
+  End;
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 15:15:24  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/intf.inc

@@ -0,0 +1,126 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 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.
+
+ **********************************************************************}
+
+    constructor TInterfaceList.Create;
+      begin
+      end;
+
+
+    destructor TInterfaceList.Destroy;
+      begin
+      end;
+
+
+    function TInterfaceList.Get(i : Integer) : IUnknown;
+      begin
+      end;
+
+
+    function TInterfaceList.GetCapacity : Integer;
+      begin
+      end;
+
+
+    function TInterfaceList.GetCount : Integer;
+      begin
+      end;
+
+
+    procedure TInterfaceList.Put(i : Integer;item : IUnknown);
+      begin
+      end;
+
+
+    procedure TInterfaceList.SetCapacity(NewCapacity : Integer);
+      begin
+      end;
+
+
+    procedure TInterfaceList.SetCount(NewCount : Integer);
+      begin
+      end;
+
+
+    procedure TInterfaceList.Clear;
+      begin
+      end;
+
+
+    procedure TInterfaceList.Delete(index : Integer);
+      begin
+      end;
+
+
+    procedure TInterfaceList.Exchange(index1,index2 : Integer);
+      begin
+      end;
+
+
+    function TInterfaceList.First : IUnknown;
+      begin
+      end;
+
+
+    function TInterfaceList.IndexOf(item : IUnknown) : Integer;
+      begin
+      end;
+
+
+    function TInterfaceList.Add(item : IUnknown) : Integer;
+      begin
+      end;
+
+
+    procedure TInterfaceList.Insert(i : Integer;item : IUnknown);
+      begin
+      end;
+
+
+    function TInterfaceList.Last : IUnknown;
+      begin
+      end;
+
+
+    function TInterfaceList.Remove(item : IUnknown): Integer;
+      begin
+      end;
+
+
+    procedure TInterfaceList.Lock;
+      begin
+      end;
+
+
+    procedure TInterfaceList.Unlock;
+      begin
+      end;
+
+
+    function TInterfaceList.Expand : TInterfaceList;
+      begin
+      end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    + skeleton for TInterfaceList added
+
+}

rtl/objpas/classes/persist.inc

@@ -0,0 +1,169 @@
+{
+    $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.
+
+ **********************************************************************}
+
+{****************************************************************************}
+{*                             TPersistent                                  *}
+{****************************************************************************}
+
+procedure TPersistent.AssignError(Source: TPersistent);
+
+Var SourceName : String;
+
+begin
+  If Source<>Nil then
+    SourceName:=Source.ClassName
+  else
+    SourceName:='Nil';
+  Writeln ('Error assigning to ',ClassName,' from : ',SourceName);
+  raise EConvertError.CreateFmt (SAssignError,[SourceName,ClassName]);
+end;
+
+
+
+procedure TPersistent.AssignTo(Dest: TPersistent);
+
+
+begin
+  Dest.AssignError(Self);
+end;
+
+
+procedure TPersistent.DefineProperties(Filer: TFiler);
+
+begin
+end;
+
+
+function  TPersistent.GetOwner: TPersistent;
+
+begin
+  Result:=Nil;
+end;
+
+destructor TPersistent.Destroy;
+
+begin
+  Inherited Destroy;
+end;
+
+
+procedure TPersistent.Assign(Source: TPersistent);
+
+begin
+  If Source<>Nil then
+    Source.AssignTo(Self)
+  else
+    AssignError(Nil);
+end;
+
+function  TPersistent.GetNamePath: string;
+
+Var OwnerName :String;
+
+begin
+ Result:=ClassNAme;
+ If GetOwner<>Nil then
+   begin
+   OwnerName:=GetOwner.GetNamePath;
+   If OwnerName<>'' then Result:=OwnerName+'.'+Result;
+   end;
+end;
+
+
+{****************************************************************************}
+{*                          TInterfacedPersistent                           *}
+{****************************************************************************}
+
+{$ifdef HASINTF}
+procedure TInterfacedPersistent.AfterConstruction;
+begin
+  inherited;
+//  if GetOwner<>nil then
+//   GetOwner.GetInterface(IUnknown,FOwnerInterface);
+end;
+
+
+function TInterfacedPersistent._AddRef: Integer;stdcall;
+begin
+  if FOwnerInterface<>nil then
+    Result:=FOwnerInterface._AddRef
+  else
+    Result:=-1;
+end;
+
+
+function TInterfacedPersistent._Release: Integer;stdcall;
+begin
+  if FOwnerInterface <> nil then
+    Result:=FOwnerInterface._Release
+  else
+    Result:=-1;
+end;
+
+
+function TInterfacedPersistent.QueryInterface(const IID: TGUID; out Obj): HResult;stdcall;
+begin
+  if GetInterface(IID, Obj) then
+    Result:=0
+  else
+    Result:=HResult($80004002);
+end;
+{$endif HASINTF}
+
+
+{****************************************************************************}
+{*                                TRecall                                   *}
+{****************************************************************************}
+
+constructor TRecall.Create(AStorage,AReference: TPersistent);
+begin
+  inherited Create;
+  FStorage:=AStorage;
+  FReference:=AReference;
+  Store;
+end;
+
+
+destructor TRecall.Destroy;
+begin
+  if Assigned(FReference) then
+   FReference.Assign(FStorage);
+  Forget;
+  inherited;
+end;
+
+
+procedure TRecall.Forget;
+begin
+  FReference:=nil;
+  FreeAndNil(FStorage);
+end;
+
+
+procedure TRecall.Store;
+begin
+  if Assigned(FReference) then
+    FStorage.Assign(FReference);
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.4  2002/09/07 15:15:25  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/streams.inc

@@ -0,0 +1,810 @@
+{
+    $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.
+
+ **********************************************************************}
+{****************************************************************************}
+{*                             TStream                                      *}
+{****************************************************************************}
+
+{$ifdef seek64bit}
+  function TStream.GetPosition: Int64;
+
+    begin
+       Result:=Seek(0,soCurrent);
+    end;
+
+  procedure TStream.SetPosition(Pos: Int64);
+
+    begin
+       Seek(pos,soBeginning);
+    end;
+
+  procedure TStream.SetSize64(NewSize: Int64);
+
+    begin
+      // Required because can't use overloaded functions in properties
+      SetSize(NewSize);
+    end;
+
+  function TStream.GetSize: Int64;
+
+    var
+       p : longint;
+
+    begin
+       p:=GetPosition;
+       GetSize:=Seek(0,soEnd);
+       Seek(p,soBeginning);
+    end;
+
+  procedure TStream.SetSize(NewSize: Longint);
+
+    begin
+    // We do nothing. Pipe streams don't support this
+    // As wel as possible read-ony streams !!
+    end;
+
+  procedure TStream.SetSize(NewSize: Int64);
+
+    begin
+      // Backwards compatibility that calls the longint SetSize
+      if (NewSize<Low(longint)) or
+         (NewSize>High(longint)) then
+        raise ERangeError.Create(SRangeError);
+      SetSize(longint(NewSize));
+    end;
+
+  function TStream.Seek(Offset: Longint; Origin: Word): Longint;
+
+    type
+      TSeek64 = function(offset:Int64;Origin:TSeekorigin):Int64 of object;
+    var
+      CurrSeek,
+      TStreamSeek : TSeek64;
+      CurrClass   : TClass;
+    begin
+      // Redirect calls to 64bit Seek, but we can't call the 64bit Seek
+      // from TStream, because then we end up in an infinite loop
+      CurrSeek:=nil;
+      CurrClass:=Classtype;
+      while (CurrClass<>nil) and
+            (CurrClass<>TStream) do
+       CurrClass:=CurrClass.Classparent;
+      if CurrClass<>nil then
+       begin
+         CurrSeek:[email protected];
+         TStreamSeek:=@TStream(@CurrClass).Seek;
+         if TMethod(TStreamSeek).Code=TMethod(CurrSeek).Code then
+          CurrSeek:=nil;
+       end;
+      if CurrSeek<>nil then
+       Result:=Seek(Int64(offset),TSeekOrigin(origin))
+      else
+       raise EStreamError.CreateFmt(SSeekNotImplemented,[ClassName]);
+    end;
+
+  function TStream.Seek(Offset: Int64; Origin: TSeekorigin): Int64;
+
+    begin
+      // Backwards compatibility that calls the longint Seek
+      if (Offset<Low(longint)) or
+         (Offset>High(longint)) then
+        raise ERangeError.Create(SRangeError);
+      Result:=Seek(longint(Offset),ord(Origin));
+    end;
+
+{$else seek64bit}
+
+  function TStream.GetPosition: Longint;
+
+    begin
+       Result:=Seek(0,soFromCurrent);
+    end;
+
+  procedure TStream.SetPosition(Pos: Longint);
+
+    begin
+       Seek(pos,soFromBeginning);
+    end;
+
+  function TStream.GetSize: Longint;
+
+    var
+       p : longint;
+
+    begin
+       p:=GetPosition;
+       GetSize:=Seek(0,soFromEnd);
+       Seek(p,soFromBeginning);
+    end;
+
+  procedure TStream.SetSize(NewSize: Longint);
+
+    begin
+    // We do nothing. Pipe streams don't support this
+    // As wel as possible read-ony streams !!
+    end;
+
+{$endif seek64bit}
+
+  procedure TStream.ReadBuffer(var Buffer; Count: Longint);
+
+    begin
+       if Read(Buffer,Count)<Count then
+         Raise EReadError.Create(SReadError);
+    end;
+
+  procedure TStream.WriteBuffer(const Buffer; Count: Longint);
+
+    begin
+       if Write(Buffer,Count)<Count then
+         Raise EWriteError.Create(SWriteError);
+    end;
+
+  function TStream.CopyFrom(Source: TStream; Count: Int64): Int64;
+
+    var
+       i : Int64;
+       buffer : array[0..1023] of byte;
+
+    begin
+       CopyFrom:=0;
+       while Count>0 do
+         begin
+            if (Count>sizeof(buffer)) then
+              i:=sizeof(Buffer)
+            else
+              i:=Count;
+            i:=Source.Read(buffer,i);
+            i:=Write(buffer,i);
+            dec(count,i);
+            CopyFrom:=CopyFrom+i;
+            if i=0 then
+              exit;
+         end;
+    end;
+
+  function TStream.ReadComponent(Instance: TComponent): TComponent;
+
+    var
+      Reader: TReader;
+
+    begin
+
+      Reader := TReader.Create(Self, 4096);
+      try
+        Result := Reader.ReadRootComponent(Instance);
+      finally
+        Reader.Free;
+      end;
+
+    end;
+
+  function TStream.ReadComponentRes(Instance: TComponent): TComponent;
+
+    begin
+
+      ReadResHeader;
+      Result := ReadComponent(Instance);
+
+    end;
+
+  procedure TStream.WriteComponent(Instance: TComponent);
+
+    begin
+
+      WriteDescendent(Instance, nil);
+
+    end;
+
+  procedure TStream.WriteComponentRes(const ResName: string; Instance: TComponent);
+
+    begin
+
+      WriteDescendentRes(ResName, Instance, nil);
+
+    end;
+
+  procedure TStream.WriteDescendent(Instance, Ancestor: TComponent);
+
+    var
+       Driver : TAbstractObjectWriter;
+       Writer : TWriter;
+
+    begin
+
+       Driver := TBinaryObjectWriter.Create(Self, 4096);
+       Try
+         Writer := TWriter.Create(Driver);
+         Try
+           Writer.WriteDescendent(Instance, Ancestor);
+         Finally
+           Writer.Destroy;
+         end;
+       Finally
+         Driver.Free;
+       end;
+
+    end;
+
+  procedure TStream.WriteDescendentRes(const ResName: string; Instance, Ancestor: TComponent);
+
+    var
+      FixupInfo: Integer;
+
+    begin
+
+      { Write a resource header }
+      WriteResourceHeader(ResName, FixupInfo);
+      { Write the instance itself }
+      WriteDescendent(Instance, Ancestor);
+      { Insert the correct resource size into the resource header }
+      FixupResourceHeader(FixupInfo);
+
+    end;
+
+  procedure TStream.WriteResourceHeader(const ResName: string; {!!!: out} var FixupInfo: Integer);
+
+    begin
+       { Numeric resource type }
+       WriteByte($ff);
+       { Application defined data }
+       WriteWord($0a);
+       { write the name as asciiz }
+       WriteBuffer(ResName[1],length(ResName));
+       WriteByte(0);
+       { Movable, Pure and Discardable }
+       WriteWord($1030);
+       { Placeholder for the resource size }
+       WriteDWord(0);
+       { Return current stream position so that the resource size can be
+         inserted later }
+       FixupInfo := Position;
+    end;
+
+  procedure TStream.FixupResourceHeader(FixupInfo: Integer);
+
+    var
+       ResSize : Integer;
+
+    begin
+
+      ResSize := Position - FixupInfo;
+
+      { Insert the correct resource size into the placeholder written by
+        WriteResourceHeader }
+      Position := FixupInfo - 4;
+      WriteDWord(ResSize);
+      { Seek back to the end of the resource }
+      Position := FixupInfo + ResSize;
+
+    end;
+
+  procedure TStream.ReadResHeader;
+
+    begin
+       try
+         { application specific resource ? }
+         if ReadByte<>$ff then
+           raise EInvalidImage.Create(SInvalidImage);
+         if ReadWord<>$000a then
+           raise EInvalidImage.Create(SInvalidImage);
+         { read name }
+         while ReadByte<>0 do
+           ;
+         { check the access specifier }
+         if ReadWord<>$1030 then
+           raise EInvalidImage.Create(SInvalidImage);
+         { ignore the size }
+         ReadDWord;
+       except
+         on EInvalidImage do
+           raise;
+         else
+           raise EInvalidImage.create(SInvalidImage);
+       end;
+    end;
+
+  function TStream.ReadByte : Byte;
+
+    var
+       b : Byte;
+
+    begin
+       ReadBuffer(b,1);
+       ReadByte:=b;
+    end;
+
+  function TStream.ReadWord : Word;
+
+    var
+       w : Word;
+
+    begin
+       ReadBuffer(w,2);
+       ReadWord:=w;
+    end;
+
+  function TStream.ReadDWord : Cardinal;
+
+    var
+       d : Cardinal;
+
+    begin
+       ReadBuffer(d,4);
+       ReadDWord:=d;
+    end;
+
+  Function TStream.ReadAnsiString : String;
+  Type
+    PByte = ^Byte;
+  Var
+    TheSize : Longint;
+    P : PByte ;
+  begin
+    ReadBuffer (TheSize,SizeOf(TheSize));
+    SetLength(Result,TheSize);
+    // Illegal typecast if no AnsiStrings defined.
+    if TheSize>0 then
+     begin
+       ReadBuffer (Pointer(Result)^,TheSize);
+       P:=Pointer(Result)+TheSize;
+       p^:=0;
+     end;
+   end;
+
+  Procedure TStream.WriteAnsiString (S : String);
+
+  Var L : Longint;
+
+  begin
+    L:=Length(S);
+    WriteBuffer (L,SizeOf(L));
+    WriteBuffer (Pointer(S)^,L);
+  end;
+
+  procedure TStream.WriteByte(b : Byte);
+
+    begin
+       WriteBuffer(b,1);
+    end;
+
+  procedure TStream.WriteWord(w : Word);
+
+    begin
+       WriteBuffer(w,2);
+    end;
+
+  procedure TStream.WriteDWord(d : Cardinal);
+
+    begin
+       WriteBuffer(d,4);
+    end;
+
+
+{****************************************************************************}
+{*                             THandleStream                                *}
+{****************************************************************************}
+
+Constructor THandleStream.Create(AHandle: Integer);
+
+begin
+  FHandle:=AHandle;
+end;
+
+
+function THandleStream.Read(var Buffer; Count: Longint): Longint;
+
+begin
+  Result:=FileRead(FHandle,Buffer,Count);
+  If Result=-1 then Result:=0;
+end;
+
+
+function THandleStream.Write(const Buffer; Count: Longint): Longint;
+
+begin
+  Result:=FileWrite (FHandle,Buffer,Count);
+  If Result=-1 then Result:=0;
+end;
+
+{$ifdef seek64bit}
+
+Procedure THandleStream.SetSize(NewSize: Longint);
+
+begin
+  SetSize(Int64(NewSize));
+end;
+
+
+Procedure THandleStream.SetSize(NewSize: Int64);
+
+begin
+  FileTruncate(FHandle,NewSize);
+end;
+
+
+function THandleStream.Seek(Offset: Int64; Origin: TSeekOrigin): Int64;
+
+begin
+  Result:=FileSeek(FHandle,Offset,ord(Origin));
+end;
+
+{$else seek64bit}
+
+Procedure THandleStream.SetSize(NewSize: Longint);
+begin
+  FileTruncate(FHandle,NewSize);
+end;
+
+
+function THandleStream.Seek(Offset: Longint; Origin: Word): Longint;
+begin
+  Result:=FileSeek(FHandle,Offset,Origin);
+end;
+
+{$endif seek64bit}
+
+
+{****************************************************************************}
+{*                             TFileStream                                  *}
+{****************************************************************************}
+
+constructor TFileStream.Create(const AFileName: string; Mode: Word);
+
+begin
+  FFileName:=AFileName;
+  If Mode=fmcreate then
+    FHandle:=FileCreate(AFileName)
+  else
+    FHAndle:=FileOpen(AFileName,Mode);
+  If FHandle<0 then
+    If Mode=fmcreate then
+      raise EFCreateError.createfmt(SFCreateError,[AFileName])
+    else
+      raise EFOpenError.Createfmt(SFOpenError,[AFilename]);
+end;
+
+
+constructor TFileStream.Create(const AFileName: string; Mode: Word; Rights: Cardinal);
+
+begin
+  FFileName:=AFileName;
+  If Mode=fmcreate then
+    FHandle:=FileCreate(AFileName)
+  else
+    FHAndle:=FileOpen(AFileName,Mode);
+  If FHandle<0 then
+    If Mode=fmcreate then
+      raise EFCreateError.createfmt(SFCreateError,[AFileName])
+    else
+      raise EFOpenError.Createfmt(SFOpenError,[AFilename]);
+end;
+
+
+destructor TFileStream.Destroy;
+
+begin
+  FileClose(FHandle);
+end;
+
+{****************************************************************************}
+{*                             TCustomMemoryStream                          *}
+{****************************************************************************}
+
+procedure TCustomMemoryStream.SetPointer(Ptr: Pointer; ASize: Longint);
+
+begin
+  FMemory:=Ptr;
+  FSize:=ASize;
+end;
+
+
+function TCustomMemoryStream.Read(var Buffer; Count: Longint): Longint;
+
+begin
+  Result:=0;
+  If (FSize>0) and (FPosition<Fsize) then
+    begin
+    Result:=FSize-FPosition;
+    If Result>Count then Result:=Count;
+    Move ((FMemory+FPosition)^,Buffer,Result);
+    FPosition:=Fposition+Result;
+    end;
+end;
+
+
+function TCustomMemoryStream.Seek(Offset: Longint; Origin: Word): Longint;
+
+begin
+  Case Origin of
+    soFromBeginning : FPosition:=Offset;
+    soFromEnd       : FPosition:=FSize+Offset;
+    soFromCurrent   : FpoSition:=FPosition+Offset;
+  end;
+  Result:=FPosition;
+end;
+
+
+procedure TCustomMemoryStream.SaveToStream(Stream: TStream);
+
+begin
+  if FSize>0 then Stream.WriteBuffer (FMemory^,FSize);
+end;
+
+
+procedure TCustomMemoryStream.SaveToFile(const FileName: string);
+
+Var S : TFileStream;
+
+begin
+  Try
+    S:=TFileStream.Create (FileName,fmCreate);
+    SaveToStream(S);
+  finally
+    S.free;
+  end;
+end;
+
+
+{****************************************************************************}
+{*                             TMemoryStream                                *}
+{****************************************************************************}
+
+
+Const TMSGrow = 4096; { Use 4k blocks. }
+
+procedure TMemoryStream.SetCapacity(NewCapacity: Longint);
+
+begin
+  SetPointer (Realloc(NewCapacity),Fsize);
+  FCapacity:=NewCapacity;
+end;
+
+
+function TMemoryStream.Realloc(var NewCapacity: Longint): Pointer;
+
+Var MoveSize : Longint;
+
+begin
+  If NewCapacity>0 Then // round off to block size.
+    NewCapacity := (NewCapacity + (TMSGrow-1)) and not (TMSGROW-1);
+  // Only now check !
+  If NewCapacity=FCapacity then
+    Result:=FMemory
+  else
+    If NewCapacity=0 then
+      FreeMem (FMemory,Fcapacity)
+    else
+      begin
+      GetMem (Result,NewCapacity);
+      If Result=Nil then
+        Raise EStreamError.Create(SMemoryStreamError);
+      If FCapacity>0 then
+        begin
+        MoveSize:=FSize;
+        If MoveSize>NewCapacity then MoveSize:=NewCapacity;
+        Move (Fmemory^,Result^,MoveSize);
+        FreeMem (FMemory,FCapacity);
+        end;
+      end;
+end;
+
+
+destructor TMemoryStream.Destroy;
+
+begin
+  Clear;
+  Inherited Destroy;
+end;
+
+
+procedure TMemoryStream.Clear;
+
+begin
+  FSize:=0;
+  FPosition:=0;
+  SetCapacity (0);
+end;
+
+
+procedure TMemoryStream.LoadFromStream(Stream: TStream);
+
+begin
+  Stream.Position:=0;
+  SetSize(Stream.Size);
+  If FSize>0 then Stream.ReadBuffer(FMemory^,FSize);
+end;
+
+
+procedure TMemoryStream.LoadFromFile(const FileName: string);
+
+Var S : TFileStream;
+
+begin
+  S:=TFileStream.Create (FileName,fmOpenRead);
+  Try
+    LoadFromStream(S);
+  finally
+    S.free;
+  end;
+end;
+
+
+procedure TMemoryStream.SetSize(NewSize: Longint);
+
+begin
+  SetCapacity (NewSize);
+  FSize:=NewSize;
+  IF FPosition>FSize then
+    FPosition:=FSize;
+end;
+
+
+function TMemoryStream.Write(const Buffer; Count: Longint): Longint;
+
+Var NewPos : Longint;
+
+begin
+  If Count=0 then
+    exit(0);
+  NewPos:=FPosition+Count;
+  If NewPos>Fsize then
+    begin
+    IF NewPos>FCapacity then
+      SetCapacity (NewPos);
+    FSize:=Newpos;
+    end;
+  System.Move (Buffer,(FMemory+FPosition)^,Count);
+  FPosition:=NewPos;
+  Result:=Count;
+end;
+
+
+{****************************************************************************}
+{*                             TStringStream                                *}
+{****************************************************************************}
+
+procedure TStringStream.SetSize(NewSize: Longint);
+
+begin
+ Setlength(FDataString,NewSize);
+ If FPosition>NewSize then FPosition:=NewSize;
+end;
+
+
+constructor TStringStream.Create(const AString: string);
+
+begin
+  Inherited create;
+  FDataString:=AString;
+end;
+
+
+function TStringStream.Read(var Buffer; Count: Longint): Longint;
+
+begin
+  Result:=Length(FDataString)-FPosition;
+  If Result>Count then Result:=Count;
+  // This supposes FDataString to be of type AnsiString !
+  Move (Pchar(FDataString)[FPosition],Buffer,Result);
+  FPosition:=FPosition+Result;
+end;
+
+
+function TStringStream.ReadString(Count: Longint): string;
+
+Var NewLen : Longint;
+
+begin
+  NewLen:=Length(FDataString)-FPosition;
+  If NewLen>Count then NewLen:=Count;
+  SetLength(Result,NewLen);
+  Read (Pointer(Result)^,NewLen);
+end;
+
+
+function TStringStream.Seek(Offset: Longint; Origin: Word): Longint;
+
+begin
+  Case Origin of
+    soFromBeginning : FPosition:=Offset;
+    soFromEnd       : FPosition:=Length(FDataString)+Offset;
+    soFromCurrent   : FpoSition:=FPosition+Offset;
+  end;
+  If FPosition>Length(FDataString) then FPosition:=Length(FDataString);
+  If FPosition<0 then FPosition:=0;
+  Result:=FPosition;
+end;
+
+
+function TStringStream.Write(const Buffer; Count: Longint): Longint;
+
+begin
+  Result:=Count;
+  SetSize(FPosition+Count);
+  // This supposes that FDataString is of type AnsiString)
+  Move (Buffer,PCHar(FDataString)[Fposition],Count);
+  FPosition:=FPosition+Count;
+end;
+
+
+procedure TStringStream.WriteString(const AString: string);
+
+begin
+  Write (PChar(Astring)[0],Length(AString));
+end;
+
+
+
+{****************************************************************************}
+{*                             TResourceStream                              *}
+{****************************************************************************}
+
+procedure TResourceStream.Initialize(Instance: THandle; Name, ResType: PChar);
+
+begin
+end;
+
+
+constructor TResourceStream.Create(Instance: THandle; const ResName: string; ResType: PChar);
+
+begin
+end;
+
+
+constructor TResourceStream.CreateFromID(Instance: THandle; ResID: Integer; ResType: PChar);
+
+begin
+end;
+
+
+destructor TResourceStream.Destroy;
+
+begin
+end;
+
+
+function TResourceStream.Write(const Buffer; Count: Longint): Longint;
+
+begin
+  Write:=0;
+end;
+
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.13  2003/07/26 16:20:50  michael
+  + Fixed readstring from TStringStream (
+
+  Revision 1.12  2002/04/25 19:14:13  sg
+  * Fixed TStringStream.ReadString
+
+  Revision 1.11  2002/12/18 16:45:33  peter
+    * set function result in TStream.Seek(int64) found by Mattias Gaertner
+
+  Revision 1.10  2002/12/18 16:35:59  peter
+    * fix crash in Seek()
+
+  Revision 1.9  2002/12/18 15:51:52  michael
+  + Hopefully fixed some issues with int64 seek
+
+  Revision 1.8  2002/10/22 09:38:39  michael
+  + Fixed TmemoryStream.LoadFromStream, reported by Mattias Gaertner
+
+  Revision 1.7  2002/09/07 15:15:25  peter
+    * old logs removed and tabs fixed
+
+ }

rtl/objpas/classes/twriter.inc

@@ -0,0 +1,224 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    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.
+
+ **********************************************************************}
+
+(*Procedure TTextWriter.WriteLn(Const Msg : String);
+
+Const CRLF = #10;
+
+begin
+  Write(Msg+CRLF);
+end;
+
+Procedure TTextWriter.Write(Const Msg : String);
+
+Var S : String;
+
+begin
+  S:=FPrefix+Msg;
+  FStream.Write(Pointer(S)^,Length(S));
+end;
+
+
+Procedure TTextWriter.WriteFmt(Fmt : String; Args :  Array of const);
+
+begin
+  Writeln(Format(Fmt,Args));
+end;
+
+Procedure TTextWriter.StartObject(Const AClassName, AName : String);
+
+begin
+  WriteFmt('Object %s %s',[AName,AClassName]);
+  FPrefix:=FPrefix+'  ';
+end;
+
+Procedure TTextWriter.EndObject;
+
+Var L : longint;
+
+begin
+  L:=Length(FPrefix);
+  If L>2 Then
+    SetLength(FPrefix,L-2);
+  Writeln('end');
+end;
+
+Procedure TTextWriter.StartCollection(Const AName : String);
+
+begin
+  WriteFmt('%s = (',[AName]);
+  FPrefix:=FPrefix+'  ';
+end;
+
+Procedure TTextWriter.StartCollectionItem;
+
+begin
+end;
+
+Procedure TTextWriter.EndCollectionItem;
+
+begin
+end;
+
+Procedure TTextWriter.EndCollection;
+
+Var L : longint;
+
+begin
+  L:=Length(FPrefix);
+  If L>2 Then
+    SetLength(FPrefix,L-2);
+  Writeln(')');
+end;
+
+
+Procedure TTextWriter.WritePropName(const PropName: string);
+
+begin
+  Writeln(PropName);
+end;
+
+Constructor TTextWriter.Create(S : TStream);
+
+begin
+  Inherited Create;
+  FStream:=S;
+  FPrefix:='';
+end;
+
+Destructor TTextWriter.Destroy;
+
+begin
+end;
+
+Procedure TTextWriter.WriteIntegerProperty(Const Name : Shortstring;Value : Longint);
+
+begin
+  WriteFmt('%s = %d',[Name,Value]);
+end;
+
+Procedure TTextWriter.WriteSetProperty (Const Name : ShortString;Value : longint; BaseType : TTypeInfo);
+
+begin
+  //!! needs implementing.
+  WriteFmt('%s = []',[Name]);
+end;
+
+Procedure TTextWriter.WriteEnumerationProperty (Const Name : ShortString;Value : Longint; Const EnumName : ShortSTring);
+
+begin
+  WriteFmt('%s = %s',[Name,EnumName])
+end;
+
+Procedure TTextWriter.WriteStringProperty(Const Name : ShortString; Const Value : String);
+
+Type
+  TMode = (quoted,unquoted);
+
+Var
+  Mode : TMode;
+  S : String;
+  I,L : Longint;
+  c : char;
+
+   Procedure Add (A : String);
+
+   begin
+     S:=S+A;
+   end;
+
+begin
+  L:=Length(Value);
+  Mode:=unquoted;
+  S:=Name+' = ';
+  For I:=1 to L do
+    begin
+    C:=Value[i];
+    If (ord(C)>31) and (Ord(c)<=128) and (c<>'''') then
+      begin
+      If mode=Quoted then
+        Add(c)
+      else
+        begin
+        Add(''''+c);
+        mode:=quoted
+        end
+      end
+    else
+      begin
+      If Mode=quoted then
+        begin
+        Add('''');
+        mode:=unquoted;
+        end;
+      Add(Format('#%d',[ord(c)]));
+      end;
+    If Length(S)>72 then
+      begin
+      if mode=quoted then
+        Add ('''');
+      Add('+');
+      Writeln(S);
+      Mode:=unQuoted;
+      end;
+    end;
+ if mode=quoted then Add('''');
+ Writeln(S);
+end;
+
+Procedure TTextWriter.WriteFloatProperty(Const Name : ShortString; Value : Extended);
+
+begin
+  WriteFmt('%s = %e',[Name,Value])
+end;
+
+Procedure TTextWriter.WriteCollectionProperty(Const Name : ShortString;Value : TCollection);
+
+begin
+
+end;
+
+Procedure TTextWriter.WriteClassProperty(Instance : TPersistent;Propinfo :PPropInfo);
+
+begin
+end;
+
+Procedure TTextWriter.WriteComponentProperty(Const Name : ShortSTring; Value : TComponent);
+
+begin
+  WriteFmt ('%s = %s',[Name,Value.Name]);
+end;
+
+Procedure TTextWriter.WriteNilProperty(Const Name : Shortstring);
+
+begin
+  system.Writeln(stderr,'Nil : ',Name);
+  WriteFmt ('%s = Nil',[Name])
+end;
+
+Procedure TTextWriter.WriteMethodProperty(Const Name,AMethodName : ShortString);
+
+begin
+  WriteFmt ('%s = %s',[Name,AMethodName]);
+end;*)
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 15:15:26  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/classes/util.inc

@@ -0,0 +1,35 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    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.
+
+ **********************************************************************}
+
+Function IntToStr (I : Longint) : String;
+
+begin
+  Str(I,Result);
+end;
+
+function IsValidIdent(const Ident: string): Boolean;
+
+begin
+  Result:=True;
+end;
+
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 15:15:26  peter
+    * old logs removed and tabs fixed
+
+}

rtl/objpas/makefile.op

@@ -1,13 +0,0 @@
-objpas$(PPUEXT): $(OBJPASDIR)/objpas.pp $(INC)/except.inc $(SYSTEMPPU)
-	$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/objpas.pp $(REDIR)
-
-SYSUTILINC = $(wildcard $(OBJPASDIR)/*.inc)
-sysutils$(PPUEXT) : $(OBJPASDIR)/sysutils.pp $(SYSUTILINC) filutil.inc disk.inc \
-		    objpas$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) $(OBJPASDIR)/sysutils.pp $(REDIR)
-
-typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
-	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
-
-math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)
-	$(COMPILER) $(OBJPASDIR)/math.pp $(REDIR)

rtl/objpas/dati.inc → rtl/objpas/sysutils/dati.inc

@@ -728,7 +728,10 @@ end;
 
 {
   $Log$
-  Revision 1.10  2003-09-06 21:52:24  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.10  2003/09/06 21:52:24  marco
    * commited.
 
   Revision 1.9  2003/01/18 23:45:37  michael

rtl/objpas/datih.inc → rtl/objpas/sysutils/datih.inc

@@ -128,7 +128,10 @@ Procedure GetLocalTime(var SystemTime: TSystemTime);
 
 {
   $Log$
-  Revision 1.8  2003-01-18 23:45:37  michael
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.8  2003/01/18 23:45:37  michael
   + Fixed EncodeDate/Time so they use TryEncodeDate/Time
 
   Revision 1.7  2002/12/25 01:03:48  peter

rtl/objpas/diskh.inc → rtl/objpas/sysutils/diskh.inc

@@ -23,7 +23,10 @@ Function RemoveDir (Const Dir : String) : Boolean;
 
 {
   $Log$
-  Revision 1.5  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.5  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/filutilh.inc → rtl/objpas/sysutils/filutilh.inc

@@ -82,7 +82,10 @@ Function FileSearch (Const Name, DirList : String) : String;
 
 {
   $Log$
-  Revision 1.10  2003-04-01 15:57:41  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.10  2003/04/01 15:57:41  peter
     * made THandle platform dependent and unique type
 
   Revision 1.9  2003/03/29 18:21:41  hajny

rtl/objpas/fina.inc → rtl/objpas/sysutils/fina.inc

@@ -238,7 +238,10 @@ end;
 
 {
   $Log$
-  Revision 1.10  2003-09-06 21:52:24  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.10  2003/09/06 21:52:24  marco
    * commited.
 
   Revision 1.9  2003/01/10 21:02:13  marco

rtl/objpas/finah.inc → rtl/objpas/sysutils/finah.inc

@@ -45,7 +45,10 @@ Function GetDirs (Var DirName : String; Var Dirs : Array of pchar) : Longint;
 
 {
   $Log$
-  Revision 1.8  2002-10-22 21:57:54  michael
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.8  2002/10/22 21:57:54  michael
   + Added some missing path functions
 
   Revision 1.7  2002/09/07 16:01:22  peter

rtl/objpas/intf.inc → rtl/objpas/sysutils/intf.inc

@@ -151,7 +151,10 @@ end;
 
 {
   $Log$
-  Revision 1.1  2002-01-25 17:42:03  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2002/01/25 17:42:03  peter
     * interface helpers
 
 }

rtl/objpas/intfh.inc → rtl/objpas/sysutils/intfh.inc

@@ -34,7 +34,10 @@ function IsEqualGUID(const guid1, guid2: TGUID): Boolean;
 
 {
   $Log$
-  Revision 1.1  2002-01-25 17:42:03  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2002/01/25 17:42:03  peter
     * interface helpers
 
 }

rtl/objpas/osutilsh.inc → rtl/objpas/sysutils/osutilsh.inc

@@ -19,7 +19,10 @@ Function GetEnvironmentVariable(Const EnvVar : String) : String;
 
 {
   $Log$
-  Revision 1.3  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/stre.inc → rtl/objpas/sysutils/stre.inc

@@ -76,7 +76,10 @@ Const
 
 {
   $Log$
-  Revision 1.8  2003-01-01 20:58:07  florian
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.8  2003/01/01 20:58:07  florian
     + added invalid instruction exception
 
   Revision 1.7  2002/09/07 16:01:22  peter

rtl/objpas/strg.inc → rtl/objpas/sysutils/strg.inc

@@ -36,7 +36,10 @@ Const
 
 {
   $Log$
-  Revision 1.3  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/sysansi.inc → rtl/objpas/sysutils/sysansi.inc

@@ -49,6 +49,9 @@ function AnsiStrScan(Str : PChar;Chr: Char) : PChar;
 
 {
   $Log$
-  Revision 1.1  2002-10-07 19:43:24  florian
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2002/10/07 19:43:24  florian
     + empty prototypes for the AnsiStr* multi byte functions added
 }

rtl/objpas/sysansih.inc → rtl/objpas/sysutils/sysansih.inc

@@ -29,6 +29,9 @@ function AnsiStrScan(Str : PChar;Chr: Char) : PChar;
 
 {
   $Log$
-  Revision 1.1  2002-10-07 19:43:24  florian
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.1  2002/10/07 19:43:24  florian
     + empty prototypes for the AnsiStr* multi byte functions added
 }

rtl/objpas/sysinth.inc → rtl/objpas/sysutils/sysinth.inc

@@ -130,7 +130,10 @@ Const
 
 {
   $Log$
-  Revision 1.4  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.4  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/syspch.inc → rtl/objpas/sysutils/syspch.inc

@@ -122,7 +122,10 @@ end ;
 
 {
   $Log$
-  Revision 1.8  2003-09-06 21:52:24  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.8  2003/09/06 21:52:24  marco
    * commited.
 
   Revision 1.7  2003/09/01 20:46:59  peter

rtl/objpas/syspchh.inc → rtl/objpas/sysutils/syspchh.inc

@@ -51,7 +51,10 @@ procedure StrDispose(Str: PChar);
 
 {
   $Log$
-  Revision 1.3  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/sysstr.inc → rtl/objpas/sysutils/sysstr.inc

@@ -2000,7 +2000,10 @@ const
 
 {
   $Log$
-  Revision 1.26  2003-09-06 21:22:07  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.26  2003/09/06 21:22:07  marco
    * More objpas fixes
 
   Revision 1.25  2002/12/23 23:26:08  florian

rtl/objpas/sysstrh.inc → rtl/objpas/sysutils/sysstrh.inc

@@ -160,7 +160,10 @@ function BCDToInt(Value: integer): integer;
 
 {
   $Log$
-  Revision 1.17  2003-09-06 21:22:08  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.17  2003/09/06 21:22:08  marco
    * More objpas fixes
 
   Revision 1.16  2002/12/24 23:33:37  peter

rtl/objpas/systhrdh.inc → rtl/objpas/sysutils/systhrdh.inc

@@ -31,7 +31,10 @@ function InterLockedExchangeAdd (var Target: integer;Source : integer) : Integer
 
 {
   $Log$
-  Revision 1.3  2002-09-07 16:01:22  peter
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.3  2002/09/07 16:01:22  peter
     * old logs removed and tabs fixed
 
 }

rtl/objpas/sysutilh.inc → rtl/objpas/sysutils/sysutilh.inc

@@ -213,7 +213,10 @@ Type
 
 {
   $Log$
-  Revision 1.20  2003-09-06 20:49:54  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.20  2003/09/06 20:49:54  marco
    * Two minimal VP fixes
 
   Revision 1.19  2003/01/01 20:58:07  florian

rtl/objpas/sysutils.inc → rtl/objpas/sysutils/sysutils.inc

@@ -394,7 +394,10 @@ end;
 
 {
   $Log$
-  Revision 1.17  2003-09-06 20:46:07  marco
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.17  2003/09/06 20:46:07  marco
    * 3 small VP fixes from Noah Silva. One (OutOfMemory error) failed.
 
   Revision 1.16  2003/04/06 11:06:39  michael

rtl/openbsd/classes.pp

@@ -0,0 +1,67 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2000 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for linux
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+implementation
+
+uses
+{$ifdef ver1_0}
+  linux
+{$else}
+  unix
+{$endif}
+  ;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+  if ThreadsInited then
+     DoneThreads;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  Revision 1.2  2002/09/07 15:15:27  peter
+    * old logs removed and tabs fixed
+
+  Revision 1.1  2002/07/30 16:03:29  marco
+   * Added for OpenBSD. Plain copy of NetBSD
+
+}

rtl/openbsd/tthread.inc

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

rtl/os2/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
@@ -220,9 +220,9 @@ override FPCOPT+=-Ur
 endif
 OBJPASDIR=$(RTL)/objpas
 GRAPHDIR=$(INC)/graph
-override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings ports os2def doscalls moncalls kbdcalls moucalls viocalls pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl pmshl pmwp pmwsock pmbidi dos crt objects printer sysutils math typinfo varutils winsock charset ucomplex cpu mmx getopts heaptrc lineinfo dynlibs video mouse keyboard variants types
+override TARGET_UNITS+=$(SYSTEMUNIT) objpas strings ports os2def doscalls moncalls kbdcalls moucalls viocalls pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl pmshl pmwp pmwsock pmbidi dos crt objects printer sysutils classes math typinfo varutils winsock charset ucomplex cpu mmx getopts heaptrc lineinfo dynlibs video mouse keyboard variants types
 override TARGET_LOADERS+=prt0 prt1
-override TARGET_RSTS+=math varutils typinfo variants pmhelp
+override TARGET_RSTS+=math varutils typinfo variants pmhelp classes
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC)
@@ -1356,9 +1356,12 @@ dos$(PPUEXT) : dos.pas $(INC)/filerec.inc $(INC)/textrec.inc strings$(PPUEXT) \
 crt$(PPUEXT) : crt.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
 objects$(PPUEXT) : $(INC)/objects.pp dos$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT)
 printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) dos$(PPUEXT) doscalls$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/os2/Makefile.fpc

@@ -11,10 +11,10 @@ units=$(SYSTEMUNIT) objpas strings \
       ports os2def doscalls moncalls kbdcalls moucalls viocalls \
       pmbitmap pmwin pmgpi pmstddlg pmhelp pmdev pmspl pmshl pmwp pmwsock pmbidi \
       dos crt objects printer \
-      sysutils math typinfo varutils winsock \
+      sysutils classes math typinfo varutils winsock \
       charset ucomplex cpu mmx getopts heaptrc lineinfo dynlibs \
       video mouse keyboard variants types
-rsts=math varutils typinfo variants pmhelp
+rsts=math varutils typinfo variants pmhelp classes
 
 [require]
 nortl=y
@@ -165,9 +165,13 @@ printer$(PPUEXT) : printer.pas $(INC)/textrec.inc $(SYSTEMUNIT)$(PPUEXT)
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) dos$(PPUEXT) doscalls$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) sysutils.pp $(REDIR)
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp $(REDIR)

rtl/os2/classes.pp

@@ -0,0 +1,67 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1999-2002 by the Free Pascal development team
+
+    Classes unit for OS/2
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  strings,
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+
+implementation
+
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:06  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+  Revision 1.5  2002/02/10 13:38:14  hajny
+    * DosCalls dependency removed to avoid type redefinitions
+
+}

rtl/os2/tthread.inc

@@ -0,0 +1,258 @@
+{
+    $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.1  2003-10-06 21:01:07  peter
+    * moved classes unit to rtl
+
+  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
+
+}

rtl/win32/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
@@ -225,9 +225,9 @@ OBJPASDIR=$(RTL)/objpas
 GRAPHDIR=$(INC)/graph
 include $(WININC)/makefile.inc
 WINDOWS_SOURCE_FILES=$(addprefix $(WININC)/,$(addsuffix .inc,$(WINDOWS_FILES)))
-override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings lineinfo heaptrc windows ole2 activex winsock initc dos crt objects graph messages sysutils typinfo math varutils variants cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer dynlibs video mouse keyboard types comobj dateutils rtlconst sysconst
+override TARGET_UNITS+=$(SYSTEMUNIT) systhrds objpas strings lineinfo heaptrc windows ole2 activex winsock initc dos crt objects graph messages sysutils classes typinfo math varutils variants cpu mmx charset ucomplex getopts wincrt winmouse winevent sockets printer dynlibs video mouse keyboard types comobj dateutils rtlconst sysconst
 override TARGET_LOADERS+=wprt0 wdllprt0 gprt0
-override TARGET_RSTS+=math varutils typinfo
+override TARGET_RSTS+=math varutils typinfo variants classes dateutils
 override INSTALL_FPCPACKAGE=y
 override COMPILER_INCLUDEDIR+=$(INC) $(PROCINC)
 override COMPILER_SOURCEDIR+=$(INC) $(PROCINC)
@@ -1362,9 +1362,12 @@ GRAPHINCDEPS=$(addprefix $(GRAPHDIR)/,$(GRAPHINCNAMES))
 graph$(PPUEXT) : graph.pp strings$(PPUEXT) windows$(PPUEXT) $(SYSTEMUNIT)$(PPUEXT) \
 		 $(GRAPHINCDEPS)
 	$(COMPILER) -I$(GRAPHDIR) graph.pp
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
 		    objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
-	$(COMPILER) -I$(OBJPASDIR) sysutils.pp
+	$(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+		   sysutils$(PPUEXT) typinfo$(PPUEXT)
+	$(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
 	$(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp
 math$(PPUEXT): $(OBJPASDIR)/math.pp objpas$(PPUEXT) sysutils$(PPUEXT)

rtl/win32/Makefile.fpc

@@ -11,11 +11,11 @@ units=$(SYSTEMUNIT) systhrds objpas strings \
       lineinfo heaptrc \
       windows ole2 activex winsock initc \
       dos crt objects graph messages \
-      sysutils typinfo math varutils variants \
+      sysutils classes typinfo math varutils variants \
       cpu mmx charset ucomplex getopts \
       wincrt winmouse winevent sockets printer dynlibs \
       video mouse keyboard types comobj dateutils rtlconst sysconst
-rsts=math varutils typinfo
+rsts=math varutils typinfo variants classes dateutils
 
 [require]
 nortl=y
@@ -172,9 +172,13 @@ graph$(PPUEXT) : graph.pp strings$(PPUEXT) windows$(PPUEXT) $(SYSTEMUNIT)$(PPUEX
 # Delphi Compatible Units
 #
 
-sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/*.inc) \
+sysutils$(PPUEXT) : sysutils.pp $(wildcard $(OBJPASDIR)/sysutils/*.inc) \
                     objpas$(PPUEXT) dos$(PPUEXT) windows$(PPUEXT)
-        $(COMPILER) -I$(OBJPASDIR) sysutils.pp
+        $(COMPILER) -Fi$(OBJPASDIR)/sysutils sysutils.pp
+
+classes$(PPUEXT) : classes.pp $(wildcard $(OBJPASDIR)/classes/*.inc) \
+                   sysutils$(PPUEXT) typinfo$(PPUEXT)
+        $(COMPILER) -Fi$(OBJPASDIR)/classes classes.pp
 
 typinfo$(PPUEXT): $(OBJPASDIR)/typinfo.pp objpas$(PPUEXT)
         $(COMPILER) -Sg $(OBJPASDIR)/typinfo.pp

rtl/win32/classes.pp

@@ -0,0 +1,68 @@
+{
+    $Id$
+    This file is part of the Free Component Library (FCL)
+    Copyright (c) 1998 by Michael Van Canneyt and Florian Klaempfl
+
+    Classes unit for win32
+
+    See the file COPYING.FPC, included in this distribution,
+    for details about the copyright.
+
+    This program is distributed in the hope that it will be useful,
+    but WITHOUT ANY WARRANTY; without even the implied warranty of
+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+ **********************************************************************}
+
+{$mode objfpc}
+
+{ Require threading }
+{$ifndef ver1_0}
+  {$threading on}
+{$endif ver1_0}
+
+{ determine the type of the resource/form file }
+{$define Win16Res}
+
+unit Classes;
+
+interface
+
+uses
+  sysutils,
+  typinfo;
+
+{$i classesh.inc}
+
+implementation
+
+uses
+  windows;
+
+{ OS - independent class implementations are in /inc directory. }
+{$i classes.inc}
+
+initialization
+  CommonInit;
+
+finalization
+  CommonCleanup;
+
+end.
+{
+  $Log$
+  Revision 1.1  2003-10-06 21:01:07  peter
+    * moved classes unit to rtl
+
+  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
+    * old logs removed and tabs fixed
+
+}

rtl/win32/tthread.inc

@@ -0,0 +1,234 @@
+{ 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.1  2003-10-06 21:01:07  peter
+    * moved classes unit to rtl
+
+  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
+
+}