home *** CD-ROM | disk | FTP | other *** search
/ Simtel MSDOS 1992 June / SIMTEL_0692.cdr / msdos / turbopas / concr4.arc / CPEXEC.PAS < prev    next >
Pascal/Delphi Source File  |  1988-04-17  |  6KB  |  173 lines
  1. (****************************************************************************
  2.  
  3. Program     : Concurrent Programming Executive
  4.  
  5. Author      : J.F.J. Passant
  6. Version     : 1.00
  7. Date        : December 3, 1986
  8.  
  9. Modified  : March 31, 1987
  10. Author    : Gary Black
  11. Purpose   : Correct bug in TaskSwitch
  12. Version   : 1.01
  13.  
  14. Modified  : April 17, 1988
  15. Author    : Steve Fox
  16. Purpose   : Modify for use under TP 4.0
  17. Version   : 2.0
  18.  
  19. *****************************************************************************)
  20.  
  21. {$S-}              { Stack checking off }
  22.  
  23. Unit CpExec;
  24.  
  25. Interface
  26.  
  27. Uses
  28.   TPCrt;
  29.  
  30. procedure ClaimInput;
  31. procedure ReleaseInput;
  32. procedure Delay(ms: word);
  33. procedure TaskInstall(address: Pointer; size: word;
  34.   var task: word; var heap: pointer);
  35. procedure TaskRemove(task: word; sp: pointer; size: word);
  36. procedure TaskWindow(X1, Y1, X2, Y2, FAttr, HAttr, WAttr: byte;
  37.   cursor: boolean; title: string);
  38. procedure TaskSwitch;
  39.  
  40. {============================================================================}
  41.  
  42. Implementation
  43.  
  44. const
  45.   InputBusy    : boolean = False;
  46.   FrameSize    = 18;                           { Context frame size          }
  47.   MaxTask      = 15;                           { Highest numbered task       }
  48. type
  49.   TaskArea     = array[1..FrameSize] of word;  { Start of context frame      }
  50.   StackPointer = ^TaskArea;
  51. var
  52.   ActiveTasks  : array[0..MaxTask] of byte;    { Active task flags           }
  53.   StackSize    : array[0..MaxTask] of word;    { Size of stack allocated     }
  54.   SPTable      : array[0..MaxTask] of Pointer; { Active task stack pointers  }
  55.   CurrentTask  : word;                         { Currently active task       }
  56.  
  57. {$I TPINLINE.INC}
  58.  
  59. (***************************** Support Routines *****************************)
  60.  
  61. procedure ClaimInput;
  62. { Wait for keyboard }
  63.   begin
  64.     while InputBusy do
  65.       TaskSwitch;                           { Wait until task releases input }
  66.     InputBusy := True
  67.   end;
  68.  
  69. procedure ReleaseInput;
  70. { Release keyboard for another task to use }
  71.   begin
  72.     InputBusy := False
  73.   end;
  74.  
  75. procedure Delay(ms: word);
  76. { Delay task for <ms> milliseconds.
  77.   The resolution of this operation is limited to approximately 55 ms (one
  78.   clock tick). }
  79.   const
  80.     TicsMSec = 0.01820648193;               { Ticks per millisecond          }
  81.     TicsDay = 1573040;                      { Ticks per day                  }
  82.   var
  83.     CurrentTime: LongInt absolute $0040:$006C; { Ticks since midnight        }
  84.     timer: LongInt;
  85.   begin
  86.     timer := CurrentTime + round(ms * TicsMSec) mod TicsDay;
  87.     while (CurrentTime < timer) or (CurrentTime > (timer + 1092)) do
  88.       TaskSwitch
  89.   end;
  90.  
  91. procedure TaskError(msg: string; val: word);
  92. { Display a fatal error message and terminate the program. }
  93.   begin
  94.     write(msg);
  95.     if val = -1
  96.       then writeln
  97.       else writeln(val:1);
  98.     write('--- Program Terminated ---');
  99.     halt(1)
  100.   end;
  101.  
  102. (**************************** Task Installation *****************************)
  103.  
  104. procedure TaskInstall(address: Pointer; size: word;
  105.   var task: word; var heap: pointer);
  106. { Install task number <task> at <address> and allocate <size> bytes for its
  107.   stack.  The stack is initialized, ready for <TaskSwitch> to activate the
  108.   task. }
  109.   var
  110.     sp: StackPointer;
  111.   begin
  112.     task := 1;
  113.     while (task <= MaxTask) and (ActiveTasks[task] = 1) do
  114.       Inc(task);
  115.     if task > MaxTask
  116.       then TaskError('Too many tasks ', task);
  117.     if MaxAvail < size
  118.       then TaskError('Not enough memory to install task ', task);
  119.  
  120.     StackSize[task] := size;
  121.  
  122.     GetMem(sp, size);                       { Point <sp> to top of stack     }
  123.     heap := sp;
  124.     sp := Normalized(sp);
  125.     sp := Normalized(ptr(Seg(sp^), Ofs(sp^) + size - SizeOf(TaskArea)));
  126.     SPTable[task] := sp;                    { Save the task stack pointer    }
  127.  
  128.     FillChar(sp^, SizeOf(TaskArea), #0);    { Initialize the task registers  }
  129.     sp^[FrameSize    ] := Seg(address^);    { IP                             }
  130.     sp^[FrameSize - 1] := Ofs(address^);
  131.     sp^[FrameSize - 2] := $0200;            { Flags, interrupts enabled      }
  132.     sp^[FrameSize - 3] := DSeg;             { DS                             }
  133.  
  134.     ActiveTasks[task] := 1                  { Task enabled                   }
  135.   end;
  136.  
  137. procedure TaskRemove(task: word; sp: pointer; size: word);
  138. { Remove a previously installed task }
  139.   begin
  140.     if CurrentTask <> task
  141.       then
  142.         begin
  143.           ActiveTasks[task] := 0;
  144.           FreeMem(sp, size)
  145.         end
  146.   end;
  147.  
  148. procedure TaskWindow(X1, Y1, X2, Y2, Fattr, HAttr, WAttr: byte;
  149.   cursor: boolean; title: string);
  150. { Prepare a portion of the screen for a task }
  151.   begin
  152.     FrameWindow(X1, Y1, X2, Y2, FAttr, HAttr, title);
  153.     Window(succ(X1), succ(Y1), pred(X2), pred(Y2));
  154.     TextColor(WAttr and $0F);
  155.     TextBackground(WAttr shr 4);
  156.     if not cursor
  157.       then HiddenCursor
  158.   end;
  159.  
  160. (****************************** Task Switching ******************************)
  161.  
  162. procedure TaskSwitch; external;
  163. { The task switcher }
  164. {$L CPEXEC.OBJ}                             { External assembly code         }
  165.  
  166. (**************************** Unit Initialization ***************************)
  167.  
  168.   begin
  169.     FillChar(ActiveTasks, SizeOf(ActiveTasks), #0); { Disable all tasks      }
  170.     ActiveTasks[0] := 1;                    { Activate main program (task 0) }
  171.     CurrentTask := 0                        {   and make it current          }
  172.   End.
  173.