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

Pascal/Delphi Source File | 1994-04-28 | 14.4 KB | 423 lines

{$I cpmswitc.inc}
{$M 16384,0,655360 }

{--------------------------------------------------------------------------

PRO_CON.PAS  (Demo: The producer-consumer problem)

This program requires the CPMULTI Multitasking Toolkit and Turbo Pascal
5.0 or later.

January 1994

Copyright (C) 1994 (USA)        Copyright (C) 1989-1994
Hypermetrics                    Christian Philipps Software-Technik
PO Box 9700 Suite 363           Duesseldorfer Str. 316
Austin, TX  78758-9700          D-47447 Moers
                                Germany

This is a presentation of the producer-consumer problem as an example of
keyboard I/O control.

Functional description:
  Input characters from the keyboard and output to the screen.
  Esc terminates the program.
  ^S  suspends the output until ^Q is received; in the meanwhile,
      incoming characters are stored in a circular queue and not
      displayed yet.
  ^Q  reactivates screen output; the stored buffer contents are
      immediately displayed.

---------------------------------------------------------------------------}

program ProducerConsumer;

uses CRT, CPMulti;

const RBuffSize = 36;                      { Size of the circular queue. }
      CritLin   = 15;
      CritCol   = 51;
      FullLin   = 15;
      FullCol   = 34;
      EmptyLin  = 15;
      EmptyCol  = 42;
      PEndLin   = 15;
      PEndCol   = 12;
      OutLin    = 15;
      OutCol    = 24;

var   RBuff     : record
                    Buff     : array[0..RBuffSize] of Char;
                                                 { Queue; 1 element reserved
                                                   for easier manipulation. }
                    Critical : Pointer;          { Semaphore for synchronizing
                                                  access. }
                    Full     : Pointer;          { Semaphore: Used buffer
                                                   slots. }
                    Empty    : Pointer;          { Semaphore: Free buffer
                                                   slots. }
                    Head     : Byte;             { Head and tail pointers. }
                    Tail     : Byte;
                  end;

      OutputSem : Pointer;                       { Semaphore for output
                                                   control. }
      ProgramEnd: Pointer;                       { Signal program end. }
      ConsumerNo,                                { Task ID's. }
      ProducerNo: TaskNoType;

{-----------------------------------------------------------------------------}

function NextSlot(S:Byte):Byte;

{ Determine next buffer slot following S. }

begin
  NextSlot := Succ(S) mod RBuffSize;
end;

{-----------------------------------------------------------------------------}

procedure WriteCharXY(X,Y:Byte; C:Char);

{ Output a character at position X,Y. By means of appropriate
  CPU-blocking it is ensured that the sequence GotoXY-and-Write
  is never interrupted by a task switch. }

begin
  BindCPU;
  GotoXY(X,Y);
  Write(C);
  ReleaseCPU;
end;

{-----------------------------------------------------------------------------}

procedure WriteByteXY(X,Y,B:Byte);

{ Output a byte value at position X,Y. See also WriteCharXY. }

begin
  BindCPU;
  GotoXY(X,Y);
  Write(B:2);
  ReleaseCPU;
end;  {WriteByteXY}

{-----------------------------------------------------------------------------}

procedure Status;

{ Display the task status. }

begin
  BindCPU;
  GotoXY(65,9);
  Write(StateText[GetTaskState(ConsumerNo)]:10);
  GotoXY(65,22);
  Write(StateText[GetTaskState(ProducerNo)]:10);
  ReleaseCPU;
end;

{-----------------------------------------------------------------------------}

procedure SW(S:Pointer; c,l:byte);

{ Call SemWait with visual feedback. }

begin
  WriteByteXY(C,L,SemGetSignals(S));
  SemWait(S);
  WriteByteXY(C,L,SemGetSignals(S));
  Status;
end;

{-----------------------------------------------------------------------------}

procedure SS(S:Pointer; c,l:byte);

{ Call SemSignal with visual feedback. }

begin
  SemSignal(S);
  WriteByteXY(C,L,SemGetSignals(S));
  Status;
end;

{-----------------------------------------------------------------------------}

function RBuffPut(C:Char):Boolean;

{---------------------------------------------------------------------------
Store a character in the buffer. Return True if successful, False if a
buffer overflow occurred. Since the output control influences the behavior of
the output task (^S and ^Q), the input control will never be blocked for a
longer time with the storing of characters in the buffer. But this would be
the case, if it always waited for the freeing of a buffer slot. If the output
control after receipt of a ^S is not in the position to empty a slot and the
input control is blocked by a Wait for a storage slot, the entire system will
hang irrevocably!

WARNING! Note that the positioning of the Wait call on the synchronization
semaphore is critical! Since a blocking through a Wait for Empty is dependent
on the signal count of the Empty semaphore, THEORETICALLY in the time between
accessing the signal count and the Wait on the Empty semaphore, another task
could have grabbed the last slot in the buffer. You must ensure by proper
delimiting of the critical section that until the final occupying of the
buffer slot, no other task can gain access to the buffer.
----------------------------------------------------------------------------}

begin
  with RBuff do
  begin
    SW(Critical,CritCol,CritLin);                { Exclusive buffer access. }
    if SemGetSignals(Empty) = 0 then             { Buffer full. }
      RBuffPut := False                          { Prevent blocking. }
    else
    begin
      RBuffPut := True;
      SW(Empty,EmptyCol,EmptyLin);       { Reserve a slot. }
      Buff[Tail] := c;                   { Store characters. }
      WriteCharXY(21+Tail,19,' ');
      if C = #13 then
        WriteCharXY(21+Tail,21,#188)
      else
        WriteCharXY(21+Tail,21,c);
      Tail := NextSlot(Tail);            { Head pointer to next slot. }
      WriteCharXY(21+Tail,19,#25);
      SS(Full,FullCol,FullLin);          { One more character in the
                                           buffer. }
    end;
    SS(Critical,CritCol,CritLin);                { Release the buffer. }
  end;
end;

{-----------------------------------------------------------------------------}

function RBuffGet:Char;

{ Take the first character from the buffer and make it available to the
  application. If the buffer is empty, wait for the arrival of a character. }

begin
  with RBuff do
  begin
    SW(Full,FullCol,FullLin);                    { Request characters. }
    SW(Critical,CritCol,CritLin);                { Exclusive access. }
    RBuffGet := Buff[Head];                      { Grab characters. }
    WriteCharXY(21+Head,23,' ');
    Head := NextSlot(Head);                      { Update the head pointer. }
    WriteCharXY(21+Head,23,#24);
    SS(Critical,CritCol,CritLin);                { Release the buffer. }
    SS(Empty,EmptyCol,EmptyLin);                 { One more slot free. }
  end;
end;

{-----------------------------------------------------------------------------}

{$F+}
procedure Producer(P:Pointer);

{ Input control: Accepts all available characters from the keyboard into the
buffer. If a ^S is received, the output of characters is postponed until the
receipt of a ^Q. }

var   C       : Char;
      Display : Boolean;
      Col     : Byte;
begin
  Display := True;                               { Display enabled. }
  Col := 1;
  repeat                                         { Infinite loop. }
    while Keypressed do
    begin
      C := ReadKey;
      case C of
        ^S: if Display then
            begin
              SW(OutputSem,OutCol,OutLin); { Output turned off. }
              Display := False;            { Note the status. }
            end;
        ^Q: if not Display then            { Output turned off? }
            begin
              SS(OutputSem,OutCol,OutLin); { Output released. }
              Display := True;             { Store new status. }
            end;
      else                                 { No special characters. }
        if not RBuffPut(C) then         { Overflow. }
        begin
          BindCPU;                      { Atomic action. }
          GotoXY(34,18);
          TextBackground(White);
          TextColor(Black);
          Write(' Overflow ');
          TextColor(White);
          TextBackground(Black);
          ReleaseCPU;                   { End atomic action. }
        end;
      end; {Case}
    end;
    Sched;                              { All characters processed; }
  until False;                          {   yield the timeslice.    }

end;

{-----------------------------------------------------------------------------}

procedure Consumer(P:Pointer);

{---------------------------------------------------------------------------
This is the task which takes waiting characters from the buffer and outputs
them to the screen. If a ^S is received from the input controller, then
this grabs the output semaphore and so takes care of blocking the output
task the next time it tries to output a character onto the screen. With the
arrival of a ^Q, this semaphore is released again. If the ESC character is
taken from the buffer, this task effects the termination of the program
by incrementing the signal count of the semaphore ProgramEnd. The consumer
task runs with highest priority (since it spends most of its time waiting for
input anyway) and therefore does not hinder other tasks. If there are
characters waiting, these are processed immediately in the interest of a
fast reaction time.
---------------------------------------------------------------------------- }

const  MaxCols = 50;
var  C   : Char;
     Col : Byte;
begin
  Col := 1;
  repeat                                         { Infinite loop. }
    C := RBuffGet;                               { Get characters. }
    GotoXY(34,18);                               { Erase overflow text. }
    Write('          ');
    if C = #27 then
      SS(ProgramEnd,PendCol,PendLin)       { End the program. }
    else
    begin
      SW(OutPutSem,OutCol,OutLin);         { Wait for permission to output. }
      if (Col >= MaxCols) or (C=#13) then  { Display overflow or CR. }
      begin
        BindCPU;                           { Critical section. }
        GotoXY(7,8);
        for Col := 1 to MaxCols do
          Write(' ');
        ReleaseCPU;                        { End critical section. }
        Col := 1;
      end;
      if C <> #13 then                     { Character output. }
      begin
        WriteCharXY(6+Col,8,C);
        Inc(Col);
      end;
      SS(OutPutSem,OutCol,OutLin);         { Set sempahore again. }
    end;
  until False;
end;
{$F-}

{-----------------------------------------------------------------------------}

procedure DrawScreen;
begin
  ClrScr;
  BindCPU;
  GotoXY(15,1);
  Write('P R O C E S S     S Y N C H R O N I Z A T I O N');
  GotoXY(18,3);
  Write('Illustration of the producer-consumer problem.');
  GotoXY(24,4);
  Write('Author: Christian Philipps, 6/88');
  GotoXY(5,7);
  Write('┌───────────────────────────────────────────────────┐');
  GotoXY(5,8);
  Write('│                                                   │ Consumer Task');
  GotoXY(5,9);
  Write('└───────────────────────────────────────────────────┘');
  GotoXY(6,12);
  Write('┌────────────┬───────────┬──────┬───────┬──────────┐');
  GotoXY(6,13);
  Write('│ ProgramEnd │ OutputSem │ Full │ Empty │ Critical │ Semaphores for');
  GotoXY(6,14);
  Write('├────────────┼───────────┼──────┼───────┼──────────┤ task and access');
  GotoXY(6,15);
  Write('│            │           │      │       │          │ synchronization');
  GotoXY(6,16);
  Write('└────────────┴───────────┴──────┴───────┴──────────┘');
  GotoXY(5,19);
  Write('Head pointer');
  GotoXY(20,20);
  Write('┌────────────────────────────────────┐');
  GotoXY(5,21);
  Write('  Buffer   ->  │                                    │ Producer Task');
  GotoXY(20,22);
  Write('└────────────────────────────────────┘');
  GotoXY(5,23);
  Write('Tail pointer');
  TextColor(Black);
  TextBackground(White);
  GotoXY(1,25);
  Write(' Ctrl-S: Stop output   Ctrl-Q: Resume output   ESC: Exit program  ');
  TextColor(White);
  TextBackground(Black);
  ReleaseCPU;
  WriteCharXY(25,11,#30);
  WriteCharXY(35,11,#30);
  WriteCharXY(42,11,#30);
  WriteCharXY(51,11,#30);
  WriteCharXY(25,17,#30);
  WriteCharXY(35,17,#30);
  WriteCharXY(42,17,#30);
  WriteCharXY(51,17,#30);
  WriteCharXY(21,19,#25);
  WriteCharXY(21,23,#24);
end;

{-----------------------------------------------------------------------------}

function InitConPro:Boolean;

{ Initialize the data structures and start the tasks. If an error occurs here,
  the value False will be returned. }

begin
  InitConPro := False;
  with RBuff do
  begin
    FillChar(Buff,RBuffSize,' ');                { Blank the buffer. }
    Head := 0;
    Tail := 0;
    if CreateSem(Critical) <> Sem_OK then        { Create the semaphores. }
      Exit;
    if CreateSem(Full) <> Sem_OK then
      Exit;
    if CreateSem(Empty) <> Sem_OK then
      Exit;
    SemSet(Empty,RBuffSize);                     { All slots are empty and }
    SemClear(Full);                              { likewise, none are full. }
  end;
  if CreateSem(ProgramEnd) <> Sem_OK then        { Program-end flag. }
    Exit;
  SemClear(ProgramEnd);                          { Clear the flag.}
  if CreateSem(OutputSem) <> Sem_OK then         { Semaphore for output }
    Exit;                                        {   control.           }

  ConsumerNo := CreateTask(Consumer,nil,Pri_Kernel,500); { Create producer & }
  ProducerNo := CreateTask(Producer,nil,Pri_User,500);   { consumer tasks.   }
  if (ConsumerNo < 0) or (ProducerNo < 0) then
    Exit;
  DrawScreen;
  InitConPro := True;
end;

{-----------------------------------------------------------------------------}

begin
  if not InitConPro then
  begin
    Writeln('Error in initialization!');
    Halt;
  end;
  { The main program stays "hung" in this case because of the SemWait
    until a SemSignal on the semaphore ProgramEnd is issued. }
  SW(ProgramEnd,PendCol,PendLin);
end.