˙{ Central queueing agency for mouses Version 2 }

!==================================================================!
!   dact              p1       p2      p3     p4     p5      p6    !
!==================================================================!
!   1   Offer         queue    -       file1  file2  alias1  alias2!
!   2   Attach        queue    sact    -      -      -       -     !
!   3   Detach        -        -       -      -      -       -     !
!   4   Claim         -        -       -      -      -       -     !
!   5   Take          id       -       new1   new2   -       -     !
!   6   Identify      id       -       -      -      -       -     !
!   7   Locate        id       -       -      -      -       -     !
!   8   Request       -        -       -      -      -       -     !
!   9   Delete        id       -       -      -      -       -     !
!  10   Reprime       -        -       -      -      -       -     !
!  11   Stop proc     proc     -       -      -      -       -     !
!  12   Create Q      queue    -       -      -      -       -     !
!  13   Relay messge  queue    code    ?      ?      ?       ?     !
!  14   Offer*        unit     owner   file1  file2  pass    alias2!
!==================================================================!


%begin

  %constinteger max logons = 6
   %constinteger max queues = 6
   %constinteger batch id = 2566987;      !BATCH:

   %recordformat parmfm(%shortinteger dsno, dact, ssno, sact, %c
                        %integer p1, p2, p3, p4, p5, p6)
   %recordformat knownfm(%integer queue, %shortinteger process, dact)
   %recordformat entryfm(%integer sender unit, sender id,       %c
                                  sender name1, sender name2,   %c
                                  owner unit, owner id,         %c
                                  owner name1, owner name2,    %c
                                  queue, date, time, %c
                                  %shortinteger priority, mode)
   %recordformat datafm(%integer t1,t2,t3,t4,t5,t6,t˙7,t8, %c
                        %record(entryfm)%array e(0:9))
   %ownrecord(datafm) b

   %ownrecord(knownfm)%array known(1:max logons)
   %ownrecord(parmfm) p, q
   %ownrecord(entryfm)%name e
   %owninteger potter sno,  potter unit, potter id
   %owninteger process, process unit, process id
   %owninteger queue, reply sact
   %owninteger sender unit, errorx
   %owninteger j, priv, dact
   %owninteger error, key, cell, id, this block
   %owninteger null = 0
   %owninteger who asl, cell asl
   %owninteger processes, queues
   %ownintegername  queue head, proc head

   %integerarray who, heads(1:max queues)
   %byteintegerarray whol(1:max queues)
   %byteintegerarray link(1:255)

   %switch cqa(1:14)

   %routinespec write block

   %routine report(%string(23) s)
      %record(parmfm) p
      string(addr(p_p1)) = s
      p_dsno = 0;         !tell oper
      svc(120, p)
   %end
   %routine crash(%string(23) S)
      report(s)
      svc(1, p);         !stop
   %end
   %routine pack(%record(parmfm)%name p, %string(23) file)
      string(addr(p_sact)) = file
      svc(17, p)
   %end
   %routine unpack(%record(entryfm)%name e, %string(31)%name s)
      %record(parmfm) p
      p_p1 = e_sender unit
      p_p2 = e_sender id
      p_p3 = e_sender name1
      p_p4 = e_sender name2
      svc(18, p)
      s = string(addr(p_sact))
   %end
   %routine connect queue
      %record(parmfm) p, q
      pack(p, "QUEUE")
      q = p
      q_dact = 6;  svc(20, q)
      %if q_p6 # 0 %start;                  !failed
         q = p
         p_dact = 2;                        !create file
         p_p5 = 27
         svc(20, p)
         crash(string(addr(p_p1))) %if p_p6 # 0
         q_dact = 6;  svc(20, q)
         crash(string(addr(q_p1))) %if q_p6 # 0
         key = q_p5
         b = 0
         write block %for this block = 0, 1, 26
      %finish
      key = q_p5
   %end

   %routine notify started
      %record(parmfm) p
      svc(119, p)
      potter unit = p_p1
      potter id   = p_p2
      potter sno  = p_p6
   %end
   %routine pu˙t on hat(%integer unit, owner)
      %record(parmfm) p
      p_dact = 36
      p_p1 = unit
      p_p2 = owner
      p_p3 = 0;               !password
      p_p6 = 0;               !this process
      svc(20, p)
      error = -111 %if p_p6 # 0
   %end

   %routine doff cap
      put on hat(potter unit, potter id)
      crash("Cannot locate potter") %if error # 0
   %end
   %routine delete(%record(entryfm)%name e)
      %record(parmfm) p
      put on hat(e_owner unit, e_owner id)
      %if error = 0 %start
         p_dact = 14
         p_p1 = 0
         p_p2 = 0
         p_p3 = e_owner name1
         p_p4 = e_owner name2
         svc(20, p)
         doff cap
         error = -104 %if p_p6 # 0
      %finish
   %end

   %routine get process info
      %record(parmfm) p
      p_p1 = process&31;  p_dact = 29;  svc(20, p)
      %if p_p6 < 0 %start
         error = -111
      %else
         process unit = p_p1
         process id= p_p2
      %finish
   %end
   %routine transfer file(%record(entryfm)%name from, %record(parmfm)%name to)
      %record(parmfm) pp, qq
      %integer keyin, keyout
      %byteintegerarray buf(0:511)
      %routine close(%integer key)
         %record(parmfm) p
         p_dact = 11
         p_p5 = key
         svc(20, p)
      %end

      pp_p1 = from_owner unit
      pp_p2 = from_owner id
      pp_p3 = from_owner name1
      pp_p4 = from_owner name2
      %if from_owner unit = process unit %c
         %and from_owner id = process id %start
         to_p1 = from_owner unit
         to_p2 = from_owner id
         to_p3 = from_owner name1
         to_p4 = from_owner name2
         %return
      %finish
      to_p1 = pp_p1;  to_p2 = process id
      put on hat(pp_p1, process id);     !try same unit first
      %if error # 0 %start;              !no luck, try any
         error = 0
         to_p1 = process unit
         put on hat(process unit, process id)
         %return %if error # 0;          !give up
      %finish
      qq_dact = 25;  svc(20, qq);         !create unique file
      to_p4 = qq_p˙4;      !QUE.???
      to_p3 = 0
      qq = pp

      pp_dact = 34;                        !transfer
      pp_p5 = to_p3;                        !new name
      pp_p6 = to_p4
      svc(20, pp)
      %if pp_p6 # 0 %start
         %if pp_p6 # -7 %and pp_p6 # -17 %start
OOPS:       doff cap
            error = -109
            %return
         %finish
         pp = qq
         pp_dact = 4;                         !open input
         svc(20, pp);  ->OOPS %if pp_p6 # 0
         key in = pp_p5
         pp_dact = 5;                         !open output
         pp_p1 = 0
         pp_p2 = 0
         pp_p3 = to_p3
         pp_p4 = to_p4
         pp_p5 = 1                  {R/W  ??}
         svc(20, pp)
         %if pp_p6 # 0 %start
            close(key in);  ->OOPS
         %finish
         key out = pp_p5

         %cycle
            pp_dact = 7;                        !read
            pp_p4 = addr(buf(0))
            pp_p5 = key in
            svc(20, pp);  %exit %if pp_p6 < 0
            pp_dact = 8;                        !write
            pp_p4 = addr(buf(0))
            pp_p5 = key out
            svc(20, pp);  %exit %if pp_p6 # 0
         %repeat
         close(key in);  close(key out)
         ->oops %if pp_p6 # -4;                  !input ended
         !transferred ok, now delete the old copy

         delete(from)
         error = 0
      %finish

      !update queue info

      from_owner unit  = to_p1
      from_owner id    = to_p2
      from_owner name1 = to_p3
      from_owner name2 = to_p4

      doff cap
      write block;         !update queue
   %end

   %routine set error
      %switch e(-112:-100)
      ->e(error) %if -112 <= error <= -100
      string(addr(p_p1)) = "Unknown error";  %return
e(-101):string(addr(p_p1)) = "Illegal request";  %return
e(-102):string(addr(p_p1)) = "Invalid queue";  %return
e(-103):string(addr(p_p1)) = "No such queue";  %return
e(-104):string(addr(p_p1)) = "No free space";  %return
e(-105):string(addr(p_p1)) = "No free queue";  %return
e(-106):string(addr(p_p1)) = "Que˙ues full";  %return
e(-107):string(addr(p_p1)) = "Queue empty";  %return
e(-108):string(addr(p_p1)) = "No such entry";  %return
e(-109):string(addr(p_p1)) = "Transfer fails";  %return
e(-110):string(addr(p_p1)) = "Queue already exists";  %return
e(-111):string(addr(p_p1)) = "No process";  %return
e(-112):string(addr(p_p1)) = "No such file";  %return
e(-100):
   %end
   %integerfn new cell
      %integer c
      c = cell asl
      cell asl = link(cell asl) %if c # 0
      %result = c
   %end
   %routine return cell(%integer c)
      link(c) = cell asl
      cell asl = c
   %end
   %routine read block(%integer n)
      %record(parmfm) p
      %return %if this block = n
      this block = n
      p_p4 = addr(b)
      p_p5 = key
      p_p6 = n
      p_dact = 9;  svc(20, p)
      crash(string(addr(p_p1))) %if p_p6 # 0
   %end
   %routine write block
      %record(parmfm) p
      p_p4 = addr(b)
      p_p5 = key
      p_p6 = this block
      p_dact = 10;  svc(20, p)
      crash(string(addr(p_p1))) %if p_p6 # 0
   %end
   %integermap find(%integername head, %integer item)
      %integer first, n
      %result == null %if head = 0
      first = head
      %cycle
         n = who l(head)
         %result == heads(n) %if who(n) = item
         head = n
         %result == null %if head = first
      %repeat
   %end
   %routine insert(%integername head, %integer cell)
      head = cell %if head = 0
      link(cell) = link(head)
      link(head) = cell
      head = cell
   %end
   %routine extract(%integername head, cell)
      %if head = 0 %start;            !empty
         cell = 0
      %else
         cell = link(head)
         link(head) = link(cell)
         head = 0 %if head = cell;    !now empty
      %finish
   %end
   %integerfn locate(%integername head, %integer cell)
      %integer first
      %result = 0 %if head = 0
      first = head
      %cycle
         %result = cell %if link(head) = cell
         head = link(head)
         %result = 0 %if head = first
      %repeat
   %end
   %routine set date and time(%rec˙ord(entryfm)%name e)
      %record(parmfm) p
      svc(19, p)
      e_date = p_p4
      e_time = p_p5
   %end
   %record(entryfm)%map entry(%integer n)
      %integer block, index
      index = rem(n, 10)
      block = n//10
      read block(block)
      %result == b_e(index)
   %end
   %routine select queue
      %integer j
      error = -103
      %for j = 1, 1, max logons %cycle
         %if known(j)_process = process %start
            queue = known(j)_queue
            error = 0
            %exit
         %finish
      %repeat
   %end
   %integermap attach(%integername q, %integer item)
      %integer cell
      cell = who asl
      error = -106 %and %result == null %if cell = 0
      who asl = who l(cell)
      q = cell %if q = 0
      who l(cell) = who l(q)
      who l(q) = cell
      who(cell) = item
      heads(cell) = 0
      q = cell
      %result == heads(cell)
   %end
   %routine detach(%integername q, %integer item)
      %integer c
      %integername h
      %return %if q = 0
      h == find(q, item)
      %return %if h == null
      c = who l(h)
      who l(h) = who l(c)
      who l(c) = who asl
      who asl = c
      q = 0 %if q = c
   %end
   %routine log off(%integer process)
      %integer j, c
      %integername q, p
      %for j = 1, 1, max logons %cycle
         %if known(j)_process = process %start
            known(j)_process = 0
            q == find(queues, known(j)_queue)
            p == find(processes, process)
            %return %if p == null
            %unless q == null %start
               !restore pending lists
               %while p # 0 %cycle
                  extract(p, c)
                  insert(q, c)
               %repeat
            %finish
            detach(processes, process)
            %return
         %finish
      %repeat
   %end
   %routine close down
      %integer j
      %record(parmfm) p
      %for j = 1, 1, max logons %cycle
         %if known(j)_process # 0 %start
            p_dsno = known(j)_process
            p_dact = 2
            p_ssno = 0
     ˙       p_sact = 0
            p_p1 = 0
            p_p2 = 7
            svc(115, p)
         %finish
      %repeat
   %end
   %routine notify owner(%integer queue)
      %record(parmfm) p
      %integer j
      %for j = 1, 1, max logons %cycle
         %if known(j)_queue = queue %start
            p_dsno = known(j)_process
            p_dact = known(j)_dact
            p_ssno = 0
            svc(115, p)
            %return
         %finish
      %repeat
   %end
   %predicate exists(%integer unit, owner, n1, n2)
      %record(parmfm) p
      p_p1 = unit
      p_p2 = owner
      p_p3 = n1
      p_p4 = n2
      p_dact = 18;  svc(20, p);            !status
      errorx = p_p6
      %true %if p_p6 = 0
      %false
   %end
   %routine initialise
      %integer j, n1
      %string(31) temp
      connect queue
      whol(j) = j-1 %for j = 1, 1, max queues
      who asl = max queues
      this block = -1
      queues = 0
      cell asl = 0
      processes = 0

      !create internal queues

      %for j = 1, 1, 255 %cycle
         e == entry(j)
         n1 = e_ownername1;  n1 = 0 %if e_mode = 2
         %unless e_queue # 0 %and %c
            exists(e_ownerunit,e_ownerid,n1,e_ownername2) %start
            link(j) = cell asl;  cell asl = j
            %if e_queue # 0 %and errorx = -1 %start
               unpack(e, temp)
               report(temp." removed")
               e = 0
               write block
            %finish
            %continue
         %finish
         queue head == find(queues, e_queue)
         queue head == attach(queues, e_queue) %if queue head == null
         crash("Q inconsistent") %if error # 0
         insert(queue head, j)
      %repeat
      report("Q full!") %if cell asl = 0
   %end

   notify started
   initialise

   %cycle
      error = 0
      p_sact = 0;  svc(16, p);               !poff
      dact = p_dact&255
      priv = p_dact>>8
      process = (p_ssno&31)!64
      reply sact = p_sact
      ->cqa(dact) %if 0 < dact <= 14
      report("Bad dact")
      error = -101
reply:set error˙ %if error < 0
      p_p6 = error %if error <= 0
      p_dsno = p_ssno;  p_dact = reply sact
      p_ssno = 0
      svc(115, p)
   %repeat

cqa(14):!!offer (in process)
      dact = 2
      sender unit = p_p1;  p_p1 = batch id
cqa(1):!! offer
      queue = p_p1
      error = -102 %and ->reply %if queue <= 0
      get process info;  ->reply %if error # 0

      !check that the file exists

      j = p_p5;  j = 0 %if dact = 2
      %unless exists(process unit, process id, j, p_p6) %start
         error = -112
         ->reply
      %finish

      queue head == find(queues, queue)
      error = -103 %and ->reply %if queue head == null
      cell = new cell
      error = -104 %and ->reply %if cell = 0

      e == entry(cell)
      e_owner unit = process unit
      e_owner id   = process id
      e_owner name1= p_p5
      e_owner name2= p_p6

      e_sender unit = process unit
      e_sender id   = process id
      e_sender name1= p_p3
      e_sender name2= p_p4

      set date and time(e)

      e_queue = queue
      e_priority = 0
      e_mode = dact
      %if dact = 2 %start
         e_sender unit = sender unit
         e_sender id = p_p2
      %finish
      write block

      insert(queue head, cell)
      notify owner(queue)
      ->reply

cqa(2):!! attach

      queue = p_p1
      error = -102 %and ->reply %if queue <= 0
      error = -105
      %for j = 1, 1, max logons %cycle
         known(j)_process = 0 %if known(j)_process = process
         %if known(j)_process = 0 %and error # 0 %start
            error = 0
            known(j)_process = process
            known(j)_dact = p_p2
            known(j)_queue = queue
         %finish
      %repeat

      queue head == find(queues, queue)
      %if queue head == null %start
         queue head == attach(queues, queue)
         ->reply %if error # 0
      %finish

      queue head == find(processes, process)
      %if queue head == null %start
         queue head == attach(processes, process)
      %finish

      %if error = 0 %start
         queue head == find˙(queues, queue)
         notify owner(queue) %if queue head # 0
      %finish
      ->reply

cqa(3):!! detach

      log off(process)
      ->reply

cqa(11):!! stop

      log off(p_p1)
      ->reply

cqa(12):!! create queue

      queue = p_p1
      error = -102 %and ->reply %if queue <= 0
      queue head == find(queues, queue)
      %if error # 0 %start
         error = 0
         queue head == attach(queues, queue)
      %finish
      ->reply

cqa(4):!! claim

      select queue;  ->reply %if error # 0
      queue head == find(queues, queue)
      proc head == find(processes, process)
      error = -103 %and ->reply %if queue head == null %c
                                %or proc head == null
      extract(queue head, cell)
      error = -107 %and ->reply %if cell = 0
      p_p1 = cell
      insert(proc head, cell)
      ->reply

cqa(5):!! take

      get process info;  ->reply %if error # 0
      proc head == find(processes, process)
      error = -107 %and ->reply %if proc head = 0
      cell = locate(proc head, p_p1)
      error = -108 %and -> reply %if cell = 0
      e == entry(cell)
      transfer file(e, p)
      %if error # 0 %start;            !remove it!!!!!
         extract(proc head, cell)
         return cell(cell)
      %finish
      ->reply

cqa(8):!! request

      p_p1 = 0

cqa(6):!! identify
cqa(7):!! locate

      proc head == find(processes, process)
      cell = proc head
      cell = locate(proc head, p_p1) %if p_p1 # 0
      error = -108 %and ->reply %if cell = 0
      e == entry(cell)
      p_p1 = cell
      %if dact = 6 %start;            !identify
         p_p1 = e_sender unit
         p_p2 = e_sender id
         p_p3 = e_sender name1
         p_p4 = e_sender name2
         p_p5 = e_date
         p_p6 = e_time
         error = 1;         !special flag
      %else %if dact = 7      ;      !locate
         p_p1 = e_owner unit
         p_p2 = e_owner id
         p_p3 = e_owner name1
         p_p4 = e_owner name2
         p_p5 = 0;      !password
         %if e_mode = 2 %start
            p_p5 = p_p3
            p_p3 = 0
         %finish
      %finish
      p_sact = e_mode
      ->reply

cqa(9):!! delete

      proc head == find(processes, process)
      cell = locate(proc head, p_p1)
      error = -108 %and ->reply %if cell = 0
      e == entry(cell)
      extract(proc head, cell)
      return cell(cell)
      delete(e)
      e = 0
      write block
      ->reply

cqa(10):!! reprime

      close down
      initialise
      ->reply

cqa(13):!relay message

      queue = p_p1
      error = -102 %and ->reply %if queue <= 0
      error = -101 %and ->reply %unless 0 < p_p2 <= 6
      %for j = 1, 1, max logons %cycle;      !look for the queue
         %if known(j)_queue = queue %start;  !found
            q = p
            q_dsno = known(j)_process
            q_dact = 2
            svc(115, q)
            ->reply
         %finish
      %repeat
      error = -111
      ->reply

%endofprogram