OS/2 implementation started

fcl/os2/classes.pp

@@ -31,7 +31,9 @@ uses
 
 implementation
 
-uses typinfo;
+uses
+  doscalls,
+  typinfo;
 
 { OS - independent class implementations are in /inc directory. }
 {$i classes.inc}
@@ -39,7 +41,10 @@ uses typinfo;
 end.
 {
   $Log$
-  Revision 1.8  2000-01-07 01:24:34  peter
+  Revision 1.9  2000-04-01 10:45:52  hajny
+    OS/2 implementation started
+
+  Revision 1.8  2000/01/07 01:24:34  peter
     * updated copyright to 2000
 
   Revision 1.7  2000/01/06 01:20:34  peter

fcl/os2/pipes.inc

@@ -3,7 +3,7 @@
     This file is part of the Free Pascal run time library.
     Copyright (c) 1999-2000 by Michael Van Canneyt
 
-    DOS/go32v2 specific part of pipe stream.
+    OS/2 specific part of pipe stream.
     
     See the file COPYING.FPC, included in this distribution,
     for details about the copyright.
@@ -14,10 +14,8 @@
 
  **********************************************************************}
 
-// No pipes under dos, sorry...
-
 Function CreatePipeHandles (Var Inhandle,OutHandle : Longint) : Boolean;
 
 begin
-  Result := False;
+  CreatePipeHandles := DosCreatePipe (InHandle, OutHandle, PipeBufSize) = 0;
 end;

fcl/os2/thread.inc

@@ -15,84 +15,154 @@
 {*                             TThread                                      *}
 {****************************************************************************}
 
+const
+ Priorities: array [TThreadPriority] of word = ($100, $200, $207, $20F, $217
+  $21F, $300);
 
-procedure TThread.CallOnTerminate;
 
+procedure AddThread;
 begin
+ Inc (ThreadCount);
 end;
 
 
-function TThread.GetPriority: TThreadPriority;
+procedure RemoveThread;
+begin
+ Dec (ThreadCount);
+end;
 
+
+procedure TThread.CallOnTerminate;
 begin
-  GetPriority:=tpNormal;
+ FOnTerminate (Self);
 end;
 
 
-procedure TThread.SetPriority(Value: TThreadPriority);
+function TThread.GetPriority: TThreadPriority;
+var
+ PTIB: PThreadInfoBlock;
+ I: TThreadPriority;
+begin
+ DosGetInfoBlocks (@PTIB, nil);
+ 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;
 begin
+ DosGetInfoBlocks (@PTIB, nil);
+(*
+ 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;
 
 
-constructor TThread.Create(CreateSuspended: Boolean);
+function ThreadProc(Thread: TThread): Integer; cdecl;
+var
+  FreeThread: Boolean;
+begin
+  Thread.Execute;
+  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_Committed;
+  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;
 end;
 
 
 destructor TThread.Destroy;
-
 begin
+ if not FFinished and not Suspended then
+ begin
+  Terminate;
+  WaitFor;
+ end;
+ if FHandle <> -1 then DosKillThread (FHandle);
+ 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:=0;
+ WaitFor := DosWaitThread (FHandle, dtWait);
 end;
 
 
 {
   $Log$
-  Revision 1.4  2000-01-07 01:24:34  peter
+  Revision 1.5  2000-04-01 10:45:52  hajny
+    OS/2 implementation started
+
+  Revision 1.4  2000/01/07 01:24:34  peter
     * updated copyright to 2000
 
   Revision 1.3  2000/01/06 01:20:34  peter