Power-Programmierung/CD1.mdf/pascal/library/dos/multtsk/multi/multi.pas

Pascal/Delphi Source File | 1993-02-27 | 4.6 KB | 220 lines

{$G-}

{$IFDEF DPMI}
 {$C FIXED PRELOAD PERMANENT}
{$ENDIF}

{*
* ┌───────────────────────────────────────────────────────────────┐
* │ Multi.PAS  Version 1.00                                       │
* │                                                               │
* │ Dos Multi Threader unit for Turbo pascal                      │
* │                                                               │
* │ Copyright (c) 1993 by Bill McKee, all rights reserved.        │
* └───────────────────────────────────────────────────────────────┘
*
*
*
*
*  Registration and payment of a license fee is required for any use, whether
*  in whole or part, of this source code.
*
*}

Unit Multi;

  Interface
   Type
       YieldProcType = procedure;

   Procedure MakeTask(ProcAddr : Pointer ; StackSize : Word);

   Procedure Wait(n : Longint);Far;

   Procedure DummyYield;

   Procedure Start;


  Var
     ActiveTasks : Integer;
  Const
     TicksNow        : ^longint = ptr($40,$6c);
     Yield : YieldProcType = DummyYield;

  Implementation
   Uses
       Memory;

   Const
        MaxTasks = 24;
   var
        CurrentTask     : Integer;
        Task            : array[1..MaxTasks] of Pointer;
        Dispatcher,main : Pointer;

   Procedure DummyYield;
   begin
   end;

   Procedure newprocess( Var task : Pointer; ProcAddr : Pointer; stacka : Pointer; stacksize : word);
   var
      Temp         : Pointer;
      tw,nss,nsp   : Word;

   begin

      fillchar(stacka^,StackSize,$00);

{$ifdef StonyBrook}
      task  := ptr(seg(stacka^),Stacksize-30);
{$else}
      task  := ptr(seg(stacka^),Stacksize-16);
{$endif}
      temp  := ptr(seg(stacka^),Stacksize-12);

      move(procaddr,temp^,4);
      nss   := seg(stacka^);
      nsp   := StackSize-14;
      asm
        mov   cx,ss
        mov   dx,sp
        mov   ax,nss
        mov   bx,nsp
        cli
        mov   ss,ax
        mov   sp,bx
        sti
{$ifdef StonyBrook}
        push  ax
        push  bx
        push  cx
        push  dx
        push  es
        push  si
        push  di
{$endif}
        Pushf
        cli
        mov   ss,cx
        mov   sp,dx
        sti
      end;
   end;

   Procedure Wait(n : Longint);
   Var
      LastTicks : Longint;
      NowTicks  : Longint;
   begin
      LastTicks := TicksNow^ ;
      Repeat
       Yield;
       NowTicks := TicksNow^ ;
       if LastTicks <> NowTicks then begin
         if LastTicks<NowTicks then
           Dec(n,NowTicks-LastTicks)
         else
           Dec(n,NowTicks);  {TickNow^ is reset to zero at midnight}
         if n<=0 then exit;
         LastTicks := NowTicks;
       end;
      Until False;
   end;

   Procedure NewTask(ProcAddr : Pointer; Stacka : Pointer; StackSize : Word);
   begin
      inc(activeTasks);
      newProcess(task[activeTasks],procaddr,stacka,Stacksize);
   end;

   Procedure MakeTask(ProcAddr : Pointer; StackSize : Word);
   Var p  : Pointer;
   begin
     p := memAllocSeg(StackSize);
     if p = nil then Halt(8);
     newTask(ProcAddr , p , StackSize);
   end;

{$S-,R-}
   Procedure Transfer( Var op,np : Pointer);Far;
   begin
     asm
{$ifdef StonyBrook}
       push  ax
       push  bx
       push  cx
       push  dx
       push  es
       push  si
       push  di
{$endif}
       Pushf
       les   di,[bp+10]
       mov   es:[di],sp
       mov   es:[di+2],ss
       les   di,[bp+6]
     end;

{$ifdef DPMI}
    inline(
       $26/$0F/$B2/$25   {  lss   sp,es:[di] }
       );
{$else}
     asm
       cli
       mov   sp,es:[di]
       mov   ss,es:[di+2]
     end;
{$endif}

     asm
       popf
{$ifdef StonyBrook}
       pop   di
       pop   si
       pop   es
       pop   dx
       pop   cx
       pop   bx
       pop   ax
{$endif}
     end;
   end;

   Procedure RealYield; Far;
   begin
     Transfer(Task[currentTask],dispatcher);
   end;

   Procedure dispatcherTask; Far;
   begin
      CurrentTask := 1;
      Repeat
        transfer(dispatcher,task[currentTask]);
        inc(CurrentTask);
        if CurrentTask  > ActiveTasks then CurrentTask := 1;
      Until false;
   end;

   Procedure Start;
   Var p : Pointer;
   begin
     yield := RealYield;
     p := memAllocSeg(2048);
     if p = nil then halt(8);
     newprocess(dispatcher,@dispatcherTask,p,2048);
     transfer(main,dispatcher);
   end;

   Function HeapFunc(Size : Word): Integer;  FAR;
     begin
       HeapFunc := 1;
     end;


begin
     TicksNow    := ptr(Seg0040,$6C);
     ActiveTasks := 0;
     HeapError := @HeapFunc;   { Add a heap function so errors return nil  }
end.