home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / CONCUR.ZIP / CONCUR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1987-03-12  |  17.9 KB  |  563 lines
  1. (******************************************************
  2.  
  3.   CONCUR.PAS     : CONCURRENT PROGRAMMING EXECUTIVE
  4.  
  5.   AUTHOR         : J.F.J. PASSANT
  6.   VERSION        : 1.00  {Use with turbo.com, version 3.01A}
  7.   DATE           : 3-DEC-86
  8.  
  9.   UPDATE         :
  10.   MODIFICATION   :
  11.  
  12.   EXTERNALS      : biosdec.pas, libdec.pas
  13.  
  14.   USE            : 1. taskinit (stacksize);
  15.                    2. installtask;  {for each task}
  16.                    3. .....
  17.  
  18.   ENTRIES        : - taskinit (stacksize);
  19.                    - installtask (ofs (procedure), stack, taskno);
  20.                    - switchtask;
  21.                    - clearscreen;
  22.                    - window (x1, y1, x2, y2);
  23.                    - border (taskname);
  24.  
  25. ******************************************************)
  26.  
  27.  
  28. {Turbo pascal library variables : }
  29. var       libdata          : array [0..filescratch] of byte absolute dseg:0;
  30.  
  31.  
  32. const     maxtask          = 16;         {Maximal number of tasks + 1}
  33.           framesize        = 14;         {Initial task stack frame size}
  34.  
  35. type      stack_area       = array [0..framesize] of integer;
  36.           stackpointer     = ^stack_area;
  37.           address          = array [1..2] of integer;
  38.           astring          = string [79];
  39.  
  40. const     datasegment      : integer = 0;       {Turbo DS}
  41.  
  42.  
  43. var       currenttask      : integer;           {Currently active task}
  44.           sptable          : array [0..maxtask] of address;  {Task SP's}
  45.           activetasks      : array [0..maxtask] of byte;     {Install flags}
  46.           taskarea         : stackpointer;      {Start of task stack area}
  47.           taskareasize     : integer;           {Size of task stack area}
  48.  
  49.  
  50.  
  51. (*************************** TASK SWITCHING ************************)
  52.  
  53.  
  54. procedure taskerror (msg : astring; val : integer);
  55. {Prints a "fatal error"-message and aborts the program}
  56. begin
  57.   currenttask := 0;    {Use window of main program}
  58.   write (msg);
  59.   if val <> - 1 then write (val:1);
  60.   writeln;
  61.   write ('------ Program Aborted ------');
  62.   halt (1);
  63. end;
  64.  
  65.  
  66.  
  67. procedure stackoverflow;
  68. {Called by <switchtask> when a task stack runs over its boundaries.
  69.  Aborts the program}
  70. begin
  71. {$K-}
  72.   taskerror ('Stack overflow in task ', currenttask);
  73. {$K+}
  74. end;
  75.  
  76.  
  77. procedure switchtask;
  78. {The task switcher}
  79. {Note : to run this program on 8088/86 systems, replace the PUSHA and POPA
  80.  instructions with the following inline code :
  81.  PUSHA ($60) : inline ($50/$51/$52/$53/$54/$55/$56/$57);
  82.  POPA  ($61) : inline ($5F/$5E/$5D/$5B/$5B/$5A/$59/$58);
  83.  ($5B appearing twice is NOT a typo !!!)}
  84.  
  85. begin
  86. Inline(
  87.   $5D                    {        POP  BP                  ; UNDO TURBO CODE}
  88.   /$5D                   {        POP  BP                  ; RESTORE BP}
  89.   /$9C                   {        PUSHF                    ; SAVE REGISTERS}
  90.   /$1E                   {        PUSH DS}
  91.                          {        ; Replace the next instruction for 8088}
  92.   /$60                   {        DB   $60                 ; 286 PUSH ALL !!!}
  93.   /$06                   {        PUSH ES}
  94.   /$2E                   {        CS:}
  95.   /$A1/>DATASEGMENT      {        MOV  AX,[>DATASEGMENT]   ; GET TURBO DS}
  96.   /$8E/$D8               {        MOV  DS,AX}
  97.   /$FF/$36/>LIBERROR     {        PUSH [>liberror]}
  98.   /$81/$FC/$00/$02       {        CMP  SP,$200             ; STACK OVERFLOW ?}
  99.   /$72/<STACKOVERFLOW+3-*{        JB   >STACKOVERFLOW+3-*  ; THEN ABORT PROGRAM}
  100.   /$BF/>SPTABLE          {        MOV  DI,>SPTABLE         ; DI --> SPTABLE}
  101.   /$8B/$1E/>CURRENTTASK  {        MOV  BX,[>CURRENTTASK]   ; BX = CURRENT TASK}
  102.   /$B1/$02               {        MOV  CL,2                ; 4 BYTES PER ENTRY}
  103.   /$D3/$E3               {        SHL  BX,CL               ;   IN TASKSTACK TABLE}
  104.   /$89/$21               {        MOV  [BX+DI],SP          ; SAVE CURRENT STACK PTR}
  105.   /$8C/$51/$02           {        MOV  [BX+DI+2],SS}
  106.   /$BE/>ACTIVETASKS      {        MOV  SI,>ACTIVETASKS}
  107.   /$D3/$EB               {        SHR  BX,CL               ; RESTORE BX}
  108.                          {FINDNEXT:}
  109.   /$43                   {        INC  BX                  ; NEXT TASK NUMBER}
  110.   /$81/$E3/$0F/$00       {        AND  BX,$0F              ; MAX 16 TASKS}
  111.   /$80/$38/$00           {        CMP  BYTE PTR [BX+SI],0  ; TASK INSTALLED ?}
  112.   /$74/$F6               {        JZ   FINDNEXT            ; NO, KEEP INCR. BX}
  113.   /$89/$1E/>CURRENTTASK  {        MOV  [>CURRENTTASK],BX   ; SAVE NEW TASK NUMBER}
  114.   /$D3/$E3               {        SHL  BX,CL               ; 4 BYTES PER ENTRY}
  115.   /$8B/$21               {        MOV  SP,[BX+DI]          ; LOAD STACK PTR NEW TASK}
  116.   /$8E/$51/$02           {        MOV  SS,[BX+DI+2]}
  117.   /$8F/$06/>LIBERROR     {        POP  [>liberror]}
  118.   /$07                   {        POP  ES                  ; RESTORE REGISTERS}
  119.                          {        ; Replace the next instruction for 8088}
  120.   /$61                   {        DB   $61                 ; 286 POP ALL !!!}
  121.   /$1F                   {        POP  DS}
  122.   /$9D                   {        POPF}
  123.   /$C3                   {        RET                      ; ACTIVATE NEXT TASK}
  124.   );
  125. end;
  126.  
  127.  
  128.  
  129. procedure taskterminate;
  130. {Activated when an installed task aborts operation. The program is aborted}
  131. begin
  132.   taskerror ('Unexpected abortion of task ', currenttask);
  133. end;
  134.  
  135.  
  136.  
  137. (************************* TASK INSTALLATION ************************)
  138.  
  139.  
  140. procedure normalize_stackpointer (var p : stackpointer);
  141. {Normalizes a pointer, making the offset as small as possible}
  142. var segm, offs : integer;
  143. begin
  144.   segm := seg (p^);
  145.   offs := ofs (p^);
  146.   segm := segm + (offs shr 4);
  147.   offs := offs and $000F;
  148.   p    := ptr (segm, offs);
  149. end;
  150.  
  151.  
  152. procedure allocate_taskarea (size : integer);
  153. {Allocates <size> paragraphs on the stack area to be used by the stacks
  154.  for concurrent tasks. The Turbo stack is consequently moved down in memory.
  155.  <Size> should be equal or higher than the sum of the sizes of the stack
  156.  needed by each installed task}
  157.  
  158. begin
  159. Inline(
  160.   $1E                    {        PUSH DS}
  161.   /$8B/$0E/>INITIALSTACK {        MOV  CX,[>INITIALSTACK]  ; DETERMINE CURRENT}
  162.   /$29/$E1               {        SUB  CX,SP               ;   STACK FRAME SIZE}
  163.   /$8C/$D0               {        MOV  AX,SS               ; DS --> STACK SEGMENT}
  164.   /$8E/$D8               {        MOV  DS,AX}
  165.   /$2B/$46/$04           {        SUB  AX,[BP+4]           ; MOVE SS <SIZE> DOWN}
  166.   /$8E/$C0               {        MOV  ES,AX               ; ES --> NEW SS}
  167.   /$89/$E6               {        MOV  SI,SP               ; PREPARE FRAME COPY}
  168.   /$89/$F7               {        MOV  DI,SI}
  169.   /$FC                   {        CLD}
  170.   /$F2/$A4               {        REP  MOVSB               ; COPY STACK FRAME}
  171.   /$1F                   {        POP  DS}
  172.   /$8C/$C0               {        MOV  AX,ES               ; SAVE PTR TO ALLOCATED}
  173.   /$89/$3E/>TASKAREA     {        MOV  [>TASKAREA],DI      ;   TASK STACK AREA}
  174.   /$A3/>TASKAREA+2       {        MOV  [>TASKAREA+2],AX    ; FOR USE BY installtask}
  175.   /$8C/$C0               {        MOV  AX,ES               ; SS --> NEW STACK SEG}
  176.   /$8E/$D0               {        MOV  SS,AX}
  177.   );
  178.   normalize_stackpointer (taskarea);
  179.   taskareasize := size;
  180. end;
  181.  
  182.  
  183. procedure installtask (address, stacksize, tasknumber : integer);
  184. {Installs a task with task number <tasknumber> and start address <address>
  185.  and allocates <stacksize> paragraphs for its stack. The stack is initialized,
  186.  ready for <switchtask> to activate the task}
  187.  
  188. var segm : integer;
  189.     offs : integer;
  190.     sp   : stackpointer;
  191.     i    : integer;
  192.  
  193. begin
  194.   if (tasknumber <= 0) or (tasknumber >= maxtask) then
  195.     taskerror ('Illegal task number ', tasknumber);
  196.   if taskareasize - stacksize < 0 then
  197.     taskerror ('Not enough stack to install task ', tasknumber);
  198.   if activetasks [tasknumber] = 1 then
  199.     taskerror ('Double installation of task ', tasknumber);
  200.   taskareasize := taskareasize - stacksize;
  201.  
  202.   sp   := taskarea;          {SP = bottom of stack area}
  203.   normalize_stackpointer (sp);
  204.                              {Reduce available taskarea}
  205.   taskarea := ptr (seg (taskarea^), ofs (taskarea^) + stacksize shl 4);
  206.   offs := ofs (sp^);
  207.   segm := seg (sp^);
  208.  
  209.   {Move SP to end of stack area, adjust for registers (framesize)}
  210.   offs := offs + $200 + stacksize shl 4 - 2*framesize;
  211.   segm := segm - $20;        {Adjust for $200 offset}
  212.   sp   := ptr (segm, offs);
  213.  
  214.   sptable [tasknumber, 1] := offs;    {Write SP in stack table}
  215.   sptable [tasknumber, 2] := segm;
  216.  
  217.   {Initialize registers for the task in the stack frame}
  218.   sp ^[0] := libdata [liberror] + 256*libdata [liberror+1];
  219.   for i := 1 to 9 do sp^ [i] := 0;    {General registers}
  220.   i := 9;
  221.   sp^ [i+1] := Dseg;                  {DS}
  222.   sp^ [i+2] := $0200;                 {Flags, interrupts enabled}
  223.   sp^ [i+3] := address;               {IP}
  224.   sp^ [i+4] := ofs (TaskTerminate);   {Task terminate handler}
  225.   activetasks [tasknumber] := 1;      {Task enabled}
  226. end;
  227.  
  228.  
  229. (************************* SCREEN OUTPUT DRIVER **********************)
  230.  
  231. {This section replaces the Turbo screen output routines. Multi tasking
  232.  windows are supported. Each task may claim an area of the screen for its
  233.  indivial screen output. All screen related Turbo standard identifiers are
  234.  replaced. Initially, each task has control over the full screen.
  235.  <Window> should be called by each task to avoid overlapping screen output}
  236.  
  237.  
  238. type   windowrec = record
  239.                      x1, y1, x2, y2 : byte;     {Window position}
  240.                      attr           : byte;     {Attributes}
  241.                      border         : boolean;  {Border shown flag}
  242.                      row, col       : byte;     {Cursor position}
  243.                    end;
  244.  
  245.  
  246. var    windows   : array [0..maxtask] of windowrec;
  247.  
  248.  
  249.  
  250. {The following routines replace their equivalent in the Turbo library}
  251.  
  252.  
  253. procedure lowvideo;
  254. begin
  255.   windows [currenttask].attr := libdata [lowattr];
  256. end;
  257.  
  258. procedure normvideo;
  259. begin
  260.   windows [currenttask].attr := libdata [normattr];
  261. end;
  262.  
  263. procedure textcolor (c : integer);
  264. begin
  265.   c := c and 31;
  266.   if c and 16 <> 0 then c := (c and 15) or 128;
  267.   with windows [currenttask] do attr := (attr and 112) or c;
  268. end;
  269.  
  270. procedure textbackground (c : integer);
  271. begin
  272.   c := (c and 7) shl 4;
  273.   with windows [currenttask] do attr := (attr and $8f) or c;
  274. end;
  275.  
  276. function wherex : integer;
  277. begin
  278.   wherex := windows [currenttask].col - windows [currenttask].x1 + 1;
  279. end;
  280.  
  281. function wherey : integer;
  282. begin
  283.   wherey := windows [currenttask].row - windows [currenttask].y1 + 1;
  284. end;
  285.  
  286. procedure gotoxy (x, y : integer);
  287. begin
  288.   with windows [currenttask] do
  289.     begin
  290.       x := x + x1 - 1;
  291.       y := y + y1 - 1;
  292.       if (x >= 0) and (y >= 0) and (x < x2) and (y < y2) then
  293.         begin
  294.           row := y; col := x;
  295.         end;
  296.     end;
  297. end;
  298.  
  299. procedure scroll (lines : integer; x1, y1, x2, y2, attr : byte);
  300. var regs : registers;
  301. begin
  302.   if lines < 0 then regs.ah := 7 else regs.ah := 6;
  303.   regs.al := abs (lines);
  304.   regs.bh := attr;
  305.   regs.ch := y1;  regs.cl := x1;
  306.   regs.dh := y2;  regs.dl := x2;
  307.   intr ($10, regs);
  308. end;
  309.  
  310. procedure clrscr;
  311. begin
  312.   with windows [currenttask] do scroll (0, x1, y1, x2-1, y2-1, attr);
  313. end;
  314.  
  315. procedure clreol;
  316. begin
  317.   with windows [currenttask] do scroll (0, col, row, x2-1, row, attr);
  318. end;
  319.  
  320. procedure clearscreen;
  321. {Enables clearing the entire screen}
  322. begin
  323.   scroll (0, 0, 0, nrofcols-1, nrofrows-1, libdata [normattr]);
  324. end;
  325.  
  326.  
  327. procedure insline;
  328. begin
  329.   with windows [currenttask] do scroll (-1, x1, row, x2-1, y2-1, attr);
  330. end;
  331.  
  332. procedure delline;
  333. begin
  334.   with windows [currenttask] do scroll (1, x1, row, x2-1, y2-1, attr);
  335. end;
  336.  
  337. procedure window (x3, y3, x4, y4 : integer);
  338. {Sets up a window for the current task}
  339. begin
  340.   with windows [currenttask] do
  341.     begin
  342.       if y4 <= nrofrows then y2 := y4;
  343.       if x4 <= nrofcols then x2 := x4;
  344.       if y3 <= y2 then y1 := y3-1;
  345.       if x3 <= x2 then x1 := x3-1;
  346.       row := y1;  col := x1;
  347.     end;
  348. end;
  349.  
  350.  
  351. (**************************** CONOUTPTR SCREEN DRIVER *******************)
  352.  
  353.  
  354. procedure conout (ch : char);
  355. {Replacement CON: output driver}
  356. var regs : registers;
  357.  
  358. begin
  359.   with windows [currenttask] do
  360.     begin
  361.       case ch of
  362.         #13 : col := x1;                      {Carriage return}
  363.         #10 : begin                           {Line feed}
  364.                 row := row+1;
  365.                 if row >= y2 then
  366.                   begin
  367.                     row := row-1;
  368.                     scroll (1, x1, y1, x2-1, y2-1, attr);
  369.                   end;
  370.               end;
  371.         #8  : if col > x1 then col := col-1;  {Back space}
  372.         #7  : ;                               {Bell}
  373.         else
  374.         begin
  375.           regs.ah := 2;    regs.bh := 0;        {Set cursor}
  376.           regs.dl := col;  regs.dh := row;
  377.           intr ($10, regs);
  378.           regs.ah := 9;    regs.al := ord (ch); {Write character}
  379.           regs.bh := 0;    regs.bl := attr;
  380.           regs.cx := 1;
  381.           intr ($10, regs);
  382.           col := col + 1;                     {Update cursor position}
  383.           if col >= x2 then
  384.             begin
  385.               col := x1;
  386.               row := row+1;
  387.               if row >= y2 then
  388.                 begin
  389.                   row := row-1;
  390.                   scroll (1, x1, y1, x2-1, y2-1, attr);
  391.                 end;
  392.             end;
  393.         end;
  394.       end;
  395.       regs.ah := 2;    regs.bh := 0;            {Set cursor}
  396.       regs.dl := col;  regs.dh := row;
  397.       intr ($10, regs);
  398.     end;
  399. end;
  400.  
  401.  
  402. (************************ CONINPTR INPUT DRIVER *********************)
  403.  
  404. var    inputbusy  : boolean;             {Keyboard sharing flag}
  405.  
  406. function conin : char;
  407. {Calls switchtask if no input character is available}
  408. var regs : registers;
  409.     ch   : char;
  410.  
  411. begin
  412.   if not keypressed then             {Wait for character avail}
  413.     begin
  414.       Inline(
  415.         $FF/$36/>RETADDR       {        PUSH [>retaddr]    ; SAVE LIBRARY DATA}
  416.         /$FF/$36/>FILEPTR      {        PUSH [>fileptr]}
  417.         /$FF/$36/>FILEPTR+2    {        PUSH [>fileptr+2]}
  418.         );
  419.         repeat
  420.           switchtask;
  421.         until keypressed;
  422.       Inline(
  423.         $8F/$06/>FILEPTR+2     {        POP  [>fileptr+2]  ; RELOAD LIB DATA}
  424.         /$8F/$06/>FILEPTR      {        POP  [>fileptr]}
  425.         /$8F/$06/>RETADDR      {        POP  [>retaddr]}
  426.       );
  427.     end;
  428.   ch := chr (libdata [secondchar]);  {Any escape sequence char pending?}
  429.   libdata [secondchar] := 0;
  430.   if ch = #0 then                  {No char pending, read keyboard}
  431.     begin
  432.       regs.ah := 0;                {Read kbd}
  433.       intr ($16, regs);
  434.       if regs.al = 0 then          {Special key ?}
  435.         begin                      {Then translate into escape sequence}
  436.           libdata [secondchar] := regs.ah;
  437.           regs.al := 27;
  438.           if regs.ah = 0 then regs.al := 3;
  439.         end;
  440.       if (libdata [ctrlcflag] = 1) and (regs.al = 3) then  {^C ?}
  441.         begin
  442.           inline ($E9/CTRLCJUMP-*-2);               {Abort program}
  443.         end;
  444.       ch := chr (regs.al);
  445.     end;
  446.   conin := ch;
  447. end;
  448.  
  449.  
  450. procedure claiminput;
  451. {Claims input}
  452. begin
  453.   while inputbusy do switchtask;   {Wait until task releases input}
  454.   inputbusy := true;
  455. end;
  456.  
  457.  
  458. procedure releaseinput;
  459. {Releases input for another task to use}
  460. begin
  461.   inputbusy := false;
  462. end;
  463.  
  464.  
  465. (************************ MULTI-TASKING WINDOW SUPPORT ********************)
  466.  
  467.  
  468. procedure initwindows;
  469. {Initializes the screen and window variables. Every concurrent task gets
  470.  control over the full screen. They should call <window> to reserve a
  471.  portion of the screen for their own use}
  472.  
  473. var i : integer;
  474.  
  475. begin
  476.   clearscreen;
  477.   for i := 0 to 16 do
  478.     with windows [i] do
  479.     begin
  480.       x1 := 0;
  481.       y1 := 0;
  482.       x2 := nrofcols;
  483.       y2 := nrofrows;
  484.       attr := libdata [normattr];
  485.       row := 0; col := 0;
  486.     end;
  487.   conoutptr := ofs (conout);
  488.   coninptr  := ofs (conin);
  489.   inputbusy := false;
  490. end;
  491.  
  492.  
  493. {$v-}
  494. procedure border (name : astring);
  495. {Displays a window border with <name> for the current task}
  496. const wchar : array [1..8] of char =
  497.               (#$da, #$c4, #$bf, #$b3, #$c0, #$c4, #$d9, #$b3);
  498. var wx, w, i : integer;
  499.  
  500. procedure putchar (ch : char; x, y : byte);
  501. {Writes <ch> at <x, y>}
  502. var regs : registers;
  503. begin
  504.   regs.ah := 2;    regs.bh := 0;
  505.   regs.dl := x;    regs.dh := y;
  506.   intr ($10, regs);
  507.   regs.ah := 9;
  508.   regs.bh := 0;    regs.al := ord (ch);
  509.   regs.cx := 1;    regs.bl := windows [currenttask].attr;
  510.   intr ($10, regs);
  511. end;
  512.  
  513. procedure edge (x, y : integer);
  514. var i : integer;
  515. begin
  516.   with windows [currenttask] do
  517.     begin
  518.       putchar (wchar [wx], x1, y); wx := wx+1;
  519.       for i := x1+1 to x2-2 do putchar (wchar [wx], i, y); wx := wx+1;
  520.       putchar (wchar [wx], x2-1, y); wx := wx+1;
  521.       for i := y1+1 to y2-2 do putchar (wchar [wx], x, i); wx := wx+1;
  522.     end;
  523. end;
  524.  
  525. begin
  526.   wx := 1;
  527.   with windows [currenttask] do
  528.     begin
  529.       border := true;
  530.       edge (x2-1, y1);
  531.       edge (x1, y2-1);
  532.       x1 := x1+1;  x2 := x2-1;
  533.       y1 := y1+1;  y2 := y2-1;
  534.       col := x1;   row := y1;
  535.       w := x2-x1;
  536.       if w >= length (name) then
  537.         begin
  538.           w := (w-length (name)) div 2;
  539.           for i := 1 to length (name) do putchar (name [i], x1+w+i-1, y1-1);
  540.         end;
  541.     end;
  542. end;
  543. {$v+}
  544.  
  545.  
  546. (************************** MODULE INITIALIZATION ********************)
  547.  
  548.  
  549. procedure taskinit (stackreq : integer);
  550. {Initializes the task variables. Reserves <stackreq> paragraphs in the
  551.  Turbo Pascal stack segment for the stacks of concurrent tasks}
  552.  
  553. var i : integer;
  554.  
  555. begin
  556.   datasegment := dseg;           {Needed by <switchtask>}
  557.   for i := 0 to maxtask do activetasks [i] := 0;
  558.   activetasks [0] := 1;          {Task 0 = main program enabled}
  559.   currenttask     := 0;          {Main program is now active}
  560.   allocate_taskarea (stackreq);  {Allocate stack space}
  561.   initwindows;                   {Initialize task windows}
  562. end;
  563.