Programmer 7500/MAX_PROGRAMMERS.iso/PASCAL/STAY50.ZIP/SRMSGU.PAS

Pascal/Delphi Source File | 1988-11-28 | 12.0 KB | 283 lines

{$I direct.inc}
{───────────────────────────────────────────────────────────────────────────}
{  SRMSGU.PAS                                                               }
{                                                                           }
{  Copyright (C) 1988  L.H.Ferris                                           }
{───────────────────────────────────────────────────────────────────────────}

  unit SRMSGU  ;
  {────────────────────────────────────────────────────────────────────────}
                               interface
  {────────────────────────────────────────────────────────────────────────}


  type
     string8 = string[8]  ;
     msgptr  = pointer    ;


   Procedure MakeMailbox (pMailboxname : string8) ;
   Procedure Send   (pMailboxname : string8 ; pmsgptr: pointer ) ;
   Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
  {────────────────────────────────────────────────────────────────────────}
                              implementation
  {────────────────────────────────────────────────────────────────────────}
  uses  sr50,                     { StayResident Kernel           }
        sr50subs  ;               { StayResident subroutines      }
   type

     msgrecptr   = ^msgrec      ;    { pointer to msgrec in mailbox    }
     msgrec = record
       msgreclink   : msgrecptr ;    { ptr to next msg in mailbox   }
       msgprocid    : word      ;    { id of sending process        }
       msgrecdata   : pointer   ;    { ptr to user data             }
     end {msgrec}               ;

     mailboxptr = ^ mailbox     ;
     mailbox = record
      maillink     : mailboxptr  ;
      mailname     : string8     ;
      mailLock     : word        ;
      mailsendhead : msgrecptr   ;   { pointer to head of message   queue }
      mailsendtail : msgrecptr   ;   { pointer to tail of message   queue }
      mailwaithead : msgrecptr   ;   { pointer to head of waiting   queue }
      mailwaittail : msgrecptr   ;   { pointer to tail of waiting   queue }
     end {mailbox}               ;


   var
    f1stMailbox : mailboxptr    ;    { anchor for first mailbox     }
  {────────────────────────────────────────────────────────────────────}
  {                  Dummy routines for testing                        }
  {────────────────────────────────────────────────────────────────────}
(*************
   const
     msgwait = 0010 ;
   Procedure Suspend(pSRBid : word; msgwait : word)  ;
    begin end ;
   Procedure UnSuspend(pSRBid : word; msgwait:word ) ;
    begin end ;
   Function Getsrbid : word ;
    begin
    Getsrbid := 1 ;
    end ;
   Procedure Yield ;
   Begin end;
******************)
  {────────────────────────────────────────────────────────────────────}
  {                       Lock/UnLock                                  }
  {────────────────────────────────────────────────────────────────────}
  {              Loop until exclusive control of a semaphore           }
  {────────────────────────────────────────────────────────────────────}
   Procedure Lock(var Lockword : word ) ;
     Begin
      Repeat
        while Lockword <>0 do ;   { spin for available lock }
        inc(Lockword)         ;   { try to get the lock     }
        if Lockword = 1 then exit { if locked, exit with it }
         else dec(Lockword)   ;   { else, reset lock        }
      Until false             ;   { spin for available lock }
    End {Lock} ;

   Procedure UnLock(var Lockword : word ) ;
     Begin
      Lockword := 0 ;
    End {UnLock} ;
  {────────────────────────────────────────────────────────────────────}
  {                           Make Mail Box                            }
  {────────────────────────────────────────────────────────────────────}
  {     Make a mailbox by "Mailboxname" and place on mailbox chain     }
  {────────────────────────────────────────────────────────────────────}
   Procedure MakeMailbox(pMailboxname : string8) ;
    var
     mbptr : mailboxptr ;
    begin
      getmem(mbptr, sizeof(mailbox) );
      if mbptr = nil then
       errormsg(haltlevel,'MakeMailbox: memory exhausted') ;
      mbptr^.mailname      := UpperCase(pmailboxname) ;
      mbptr^.maillock      := 0            ;
      mbptr^.mailsendhead  := nil          ;
      mbptr^.mailsendtail  := nil          ;
      mbptr^.mailwaithead  := nil          ;
      mbptr^.mailwaittail  := nil          ;
      SingleTask                        ;
      mbptr^.maillink   := f1stMailbox  ;
      f1stMailbox       := mbptr        ;
      Multitask                         ;

   End {Procedure MakeMailbox} ;
  {────────────────────────────────────────────────────────────────────}
  {                             OnWaitList                             }
  {────────────────────────────────────────────────────────────────────}
  {   Return "true" if this procid is waiting on Receive mailbox chain }
  {────────────────────────────────────────────────────────────────────}
   Function OnWaitList( pMailboxptr:mailboxptr ;
                        pmsgprocid :word  )    : boolean ;
    var
     mbptr  : mailboxptr ;
     recptr : msgrecptr  ;
     found  : boolean    ;
    Begin
     OnWaitList := false      ;
     found      := false      ;
     with pMailboxptr^ do begin
       if mailwaithead = nil then exit ; { wait list is empty }

       recptr := mailwaithead     ;

       while (recptr <> nil) and (NOT found) do begin
        if recptr^.msgprocid = pmsgprocid then begin
             found      := true ;
             OnWaitList := true ;
             exit          ;
             end           ;
          recptr := recptr^.msgreclink ;
       end {while recptr..}       ;

     end {with pMail...}    ;
    End { OnWaitList } ;
  {────────────────────────────────────────────────────────────────────}
  {                             Send                                   }
  {────────────────────────────────────────────────────────────────────}
  {            Enque message ptr on Send (Named) Mailbox chain         }
  {────────────────────────────────────────────────────────────────────}
   Procedure Send( pMailboxname:string8 ; pmsgptr:pointer ) ;
    var
     mbptr  : mailboxptr ;
     recptr : msgrecptr  ;
     found  : boolean    ;
     tid    : word       ;

    begin
      tid   := GetSRBid    ;
      mbptr := f1stMailbox ;
      found := false  ;

        while (mbptr <> nil) and (NOT found) do    { find named mailbox }
          if mbptr^.mailname = UpperCase(pMailboxname)
             then found := true
             else mbptr := mbptr^.maillink ;
        if NOT found then
          errormsg(warnlevel,'Send: Mailbox name error: '+pMailboxname) ;

      Lock(mbptr^.maillock)     ; { get exclusive control of mailbox }

      WITH mbptr^ do begin
        new(recptr)           ;
        recptr^.msgrecdata := pmsgptr  ;        { store ptr to user data }
        recptr^.msgprocid  := tid      ;        { store id of sender     }

        if mailsendhead = nil then              { Queue the message ptr  }
            mailsendhead := recptr
        else
           mailsendtail^.msgreclink := recptr   ;

         recptr^.msgreclink := nil              ;
         mailsendtail := recptr                 ;

     { Unsuspend first process (which is not this id )waiting for }
     { messages in this mailbox                                   }

        if mailwaithead = nil then {nothing}     { Nobody waiting for msg  }
        else begin                               { Unsuspend waiting tasks }
          Recptr := mailwaithead               ; { ptr to waiting queue    }
          mailwaithead := Recptr^.msgreclink   ; { ptr to nxt waiting proc }
          if mailwaithead = nil                  { Tail get nil if head is }
             then mailwaittail := nil          ;
          UnSuspend(recptr^.msgprocid,msgwait) ; { remove suspended status }
          dispose(Recptr)                      ; { release chained element }
        end {else mailwaithead..}              ;
        UnLock(maillock)                       ; { release mailbox control }
      end {with mbptr..} ;
   End {Procedure Send} ;
  {────────────────────────────────────────────────────────────────────}
  {                             Receive                                }
  {────────────────────────────────────────────────────────────────────}
  {        Receive/wait for message ptr from Receive mailbox chain.    }
  {────────────────────────────────────────────────────────────────────}
   Procedure Receive( pMailboxname:string8 ; var pmsgptr:pointer ) ;
    var
     mbptr  : mailboxptr ;       { mailbox pointer }
     recptr : msgrecptr  ;       { receive msg ptr }
     found  : boolean    ;       { success flag    }
     tid    : word       ;
    begin

      tid   := GetSRBid ;
      mbptr := f1stMailbox  ;           { first mainbox pointer }
      found := false  ;
                                        { find mailbox by name }
      while (mbptr <> nil) and (NOT found) do
          if mbptr^.mailname = UpperCase(pMailboxname)
             then found := true
             else mbptr := mbptr^.maillink ;
        if NOT found then begin
          if debug then
             errormsg(warnlevel,
               'Receive: Mailbox name error: ' +pMailboxname) ;
          pmsgptr := nil ; exit ;
          end ;

        found := false                ;

        Lock(mbptr^.MailLock)         ; { Get exclusive control of mailbox }

        REPEAT
          WITH mbptr^ do begin
           if mailsendhead <> nil then begin       { Return available message }
             recptr := mailsendhead          ;     { but not ones we sent     }
             if recptr^.msgprocid <> tid then begin
               mailsendhead := recptr^.msgreclink ;
               if mailsendhead = nil then
                  mailsendtail := nil        ;
               pmsgptr := recptr^.msgrecdata ; { pointer to user data }
               dispose(recptr)               ; { free message record  }
               found   := true               ;
             end {if..tid}                   ;
           end {if msgsendhead..}            ;


          if NOT found then begin                { suspend caller when no msgs }
            if NOT onwaitlist(mbptr,tid)         { and place  on waiting chain }
              then begin                         { if not there already        }
              new(recptr)                    ;
              recptr^.msgrecdata := pmsgptr  ;        { store ptr to user data }
              recptr^.msgprocid  := tid      ;        { store id of caller     }
              if mailwaithead = nil then              { Queue the message ptr  }
                 mailwaithead := recptr
              else
                 mailwaittail^.msgreclink
                                  := recptr  ;
              recptr^.msgreclink := nil      ;
              mailwaittail := recptr         ;
              end {if NOT onwaitlist}        ;
          end {if NOT found..}               ;


          if NOT found then begin
            SingleTask                       ;   {** Critical section **}
            UnLock(mbptr^.mailLock)          ;   { release the mailbox  }
            suspend(tid,msgwait)             ;   { without a taskswitch }
            MultiTask                        ;
            Yield                            ;   { release CPU control here }
            Lock(mbptr^.mailLock)            ;   { reacquire mailbox lock   }
          end {if NOT found}                 ;
         end {with mbptr^..}  ;

        UNTIL found           ;
     UnLock(mbptr^.MailLock)         ; { Release control of mailbox }

   End {Procedure Receive} ;
  {────────────────────────────────────────────────────────────────────}
  {                           initialization                           }
  {────────────────────────────────────────────────────────────────────}

  begin { SRMSGU initialization }

   f1stMailbox := nil ;

  end   { SRMSGU initialization } .