! 2 meg H-protocol interpreter.  Version for raw-mode slow ether handler.

! Ether contexts are now tagged to fix a race when an already-known client
! was rebooted.

%externalstring(47) copyright %alias "GDMR_(C)_P_H2" = %c
   "Copyright (C) 1987, 1988 George D.M. Ross"

! To do: zero-length files (delete?? (may not be possible/desirable))
!        uniquification?
!        truncation for new files (reset) (only?)

%option "-nonstandard-nocheck-nodiag-noline-nostack"
!%option "-nonstandard"

%constinteger processes = 6
%constinteger internal copy limit = 3

%constinteger max Uno = 12
%constinteger max Xno = 24

%constinteger max contexts = 63
%constinteger ether max = 536

%conststring(31) facility name = "PORT_0_FACILITY_2"

%constinteger process size = 20480

%constinteger separator = ':'
%constinteger redirector = '>'

%include "Moose:Mouse.Inc"
%include "GDMR_E:2Meg.Inc"
%include "GDMR_H:FSysAcc.Inc";  ! To keep FSys.Inc happy
%include "GDMR_H:FSys.Inc";     ! For protection bits
!%include "GDMR_H:NFac.Inc"
%include "GDMR_H:IO_F.Inc"
%include "GDMR_H:DateTime.Inc"
%include "GDMR_H:Auth.Inc"

%include "GDMR_H:Lights.Inc"

%externalroutinespec get user data(%string(31) user, domain,
                                   %string(*)%name home, name)

%systemintegerfnspec global heap get(%integer amount)

%constinteger autotruncate flag = 1
%constinteger improper close flag = 2

%constinteger improperly closed file = 16_0008

%constinteger directory flag = 16_40000000

%systemroutinespec phex(%integer i)
%systemroutinespec phex2(%integer i)
%systemstring(127)%fnspec itos(%integer i, j)
%systemintegerfnspec stoi(%string(255) s)
%systemintegerfnspec free store

%externalroutinespec FS insert(%string(31) what, %integer where)
%externalpredicatespec FS lookup(%string(15) what, %integername result)

%conststring(31) fsys state name = "FSYS_STATE"
%ownintegername fsys state == nil


!! %routine zprint symbol(%integer i)
!!    %if ' ' <= i <= '~' %start
!!       print symbol(i)
!!    %else
!!       print symbol('?')
!!    %finish
!! %end

!! %routine zprintstring(%string(255) s)
!!    %integer i, ch
!!       %return %if s = ""
!!       %for i = 1, 1, length(s) %cycle
!!          ch = charno(s, i)
!!          %if ' ' <= ch <= '~' %start
!!             print symbol(ch)
!!          %else
!!             print symbol('<')
!!             write(ch, 0)
!!             print symbol('>')
!!          %finish
!!       %repeat
!! %end

%routine pdate
   %string(31) d, t
      unpack date(get datestamp, d, t)
      printstring(d);  space;  printstring(t)
      !spaces(2)
%end


! Trace buffer

%constinteger trace size = 127
%conststring(31) trace buffer name = "P_H2_TRACE_BUFFER"

%recordformat trace fm(%integer context, direction, n, datestamp,
                       %bytearray b(0 : 47))
%recordformat trace buffer fm(%integer p, s,
                              %record(trace fm)%array t(0 : trace size))
%ownrecord(trace buffer fm) trace buffer = 0
%ownrecord(semaphore fm) trace semaphore = 0

%routine trace(%integer context, direction, n, %bytename x)
   %constbytearray deleted(2 : 23) =
      '<', 'D', 'e', 'l',  'e', 't', 'e', 'd',
      ' ', 'f', 'o', 'r',  ' ', 's', 'e', 'c',
      'u', 'r', 'i', 't',  'y', '>'
   %record(trace fm)%name t
   %integer i
      n = 47 %if n > 47
      !! printstring("Trace: ");  print symbol(direction);  space
      !! zprint symbol(x [i]) %for i = 0, 1, n;  newline
      semaphore wait(trace semaphore)
      t == trace buffer_t(trace buffer_p)
      trace buffer_p = (trace buffer_p + 1) & trace size
      signal semaphore(trace semaphore)
      t_context = context;  t_direction = direction;  t_n = n
      t_datestamp = get datestamp
      %if n > 0 %start
         %if direction = '<' %and (x = 'L' %or x = 'P' %or x = 'Q') %start
            t_b(0) = x;  t_b(1) = x [1]
            t_b(i) = deleted(i) %for i = 2, 1, 23
            t_n = 24
         %else
            t_b(i) = x [i] %for i = 0, 1, n - 1
         %finish
      %finish
%end


! Communications stuff follows...

%conststring(31) context table name = "P_H2_PORT_TABLE"
%recordformat context fm(%integer remote address, remote port, local port,
                         %integer tag,
                         %integer open datestamp, transmit datestamp,
                         %record(ether request fm) ether request,
                         %bytename buffer)
%ownrecord(context fm)%array context info(1 : max contexts) = 0(*)

%ownrecord(semaphore fm) our request semaphore = 0
%ownrecord(mailbox fm) our request mailbox = 0
%ownrecord(mailbox fm)%name ether request mailbox == nil

%integerfn new context tag
   %owninteger tag = 0
      tag = tag + 1
      %result = tag
%end

%routine print context info(%integer context)
   %record(context fm)%name context data
      pdate
      %if 0 < context <= max contexts %start
         context data == context info(context)
         write(context, -3);  print symbol('.')
         phex(context data_tag);  print symbol('.')
         phex2(context data_local port);  print symbol('/')
         phex2(context data_remote address)
         print symbol('.');  phex2(context data_remote port)
      %else
         printstring("  Unknown context ");  write(context, 0)
      %finish
      printstring(": ")
%end

%routine receive next request(%integername context, tag, bytes, status)
   %record(ether request fm)%name r
      !! printstring("Receive next request");  newline
      r == receive message(our request mailbox)
      context = r_context
      tag = r_tag
      bytes = r_bytes
      status = r_status
      !! printstring("Received ");  write(bytes, 0)
      !! printstring(" from context ");  write(context, 0)
      !! printstring(" status ");  write(status, 0);  newline
%end

%routine start receive(%integer context, tag)
   %record(context fm)%name p
      !! printstring("Start receive on context ");  write(context, 0);  newline
      %unless 0 < context <= max contexts %start
         printstring("*** Starting receive on dud context ");  write(context, 0)
         printstring(" ???");  newline
         %return
      %finish
      p == context info(context)
      %if p_remote address = 0 %start
         printstring("P_H2: starting receive on closed context ")
         write(context, 0);  printstring(" ??"); newline
      %else
         p_ether request_code = ether old read
         p_ether request_context = context
         p_ether request_tag = tag
         p_ether request_timeout = -1;  ! None
         p_ether request_buffer == p_buffer
         send message(p_ether request, ether request mailbox, our request mailbox)
      %finish
%end

%predicate send response(%integer context, tag, bytes)
   %record(semaphore fm) semaphore = 0
   %record(mailbox fm) mailbox = 0
   %record(ether request fm) request = 0
   %record(ether request fm)%name reply
   %record(context fm)%name p
!! %bytename b
!! %integer i
      %if 0 <= context <= max contexts %start
         p == context info(context)
         !! printstring("Send response to context ");  write(context, 0)
         !! printstring(": ");  write(bytes, 0)
         !! printstring(" bytes, text is """);  b == p_buffer
         !! i = 30
         !! zprint symbol(b) %and b == b [1] %and i = i - 1 %c
         !!    %while b # NL %and i >= 0
         !! print symbol('"');  newline
         trace(context, '>', bytes, p_buffer)
         %if p_remote address = 0 %start
            !! pdate
            !! printstring("  P_H2: sending to closed context ")
            !! write(context, 0);  newline
            %false
         %else
            p_transmit datestamp = get datestamp
            setup semaphore(semaphore)
            setup mailbox(mailbox, semaphore)
            setup message(request, size of(request))
            request_code = ether old write
            request_context = context
            request_tag = tag
            request_buffer == p_buffer
            request_bytes = bytes
            send message(request, ether request mailbox, mailbox)
            reply == receive message(mailbox)
            %if reply_status < 0 %start
               print context info(context)
               printstring("Send response: ")
               printstring(ether errors(reply_status))
               newline
               %false
            %else
               %true
            %finish
         %finish
      %else
         pdate
         printstring("  *** Sending to dud context ");  write(context, 0)
         printstring(" ???");  newline
         %false
      %finish
%end

%integerfn initialise client comms(%integer ra, rp)
   %record(semaphore fm) semaphore = 0
   %record(mailbox fm) mailbox = 0
   %record(ether request fm) request = 0
   %record(ether request fm)%name reply == nil
   %record(context fm)%name p
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old define
      request_ra = ra
      request_rp = rp
      send message(request, ether request mailbox, mailbox)
      reply == receive message(mailbox)
      %result = reply_status %if reply_status < 0
      p == context info(reply_context)
      p_remote address = ra
      p_remote port = rp
      p_local port = reply_lp
      p_open datestamp = get datestamp
      p_tag = new context tag
      {} print context info(reply_context);  printstring("connected");  newline
      setup message(p_ether request, size of(p_ether request))
      start receive(reply_context, p_tag)
      %result = reply_lp
%end

%routine drop context(%integer context, tag)
   %record(semaphore fm) semaphore = 0
   %record(mailbox fm) mailbox = 0
   %record(ether request fm) request = 0
   %record(ether request fm)%name reply == nil
   %record(context fm)%name p
      !! printstring("Drop context ");  write(context, 0);  newline
      %unless 0 < context <= max contexts %start
         print context info(context)
         printstring("drop??");  newline
         %return
      %finish
      p == context info(context);  p_remote address = 0
      setup semaphore(semaphore)
      setup mailbox(mailbox, semaphore)
      setup message(request, size of(request))
      request_code = ether old undefine
      request_context = context
      request_tag = tag
      send message(request, ether request mailbox, mailbox)
      reply == receive message(mailbox)
      %if reply_status < 0 %start
         print context info(context)
         printstring(ether errors(reply_status));  newline
      %finish
%end


! Protocol interpreter.  Take a request (context, bytes, buffer), interpret it,
! and return a response in the same buffer.  Special request (bytes < 0) asks
! for the context to be cleared down (reconnect, probably).  These are
! sorted alphabetically so we can see easily what hasn't been used.

! reserved                   '@'       { Can't be used for some reason!
%constinteger FC openmod   = 'A'       { Uno: filename                : Xno
%constinteger FC rename    = 'B'       { Uno: filename, filename      :
%constinteger FC dchange   = 'C'       { Uno: filename, date          :
%constinteger FC delete    = 'D'       { Uno: filename                :
%constinteger FC permit    = 'E'       { Uno: filename, permissions   :
%constinteger FC finfo     = 'F'       { Uno: ownername, file-number  : packet
%constinteger FC general   = 'G'       { Uno:                         : packet
%constinteger FC uclose    = 'H'       { Xno:                         :
%constinteger FC readback  = 'I'       { Xno:                         : packet
%constinteger FC setdir    = 'J'       { Uno: ownername               :
%constinteger FC close     = 'K'       { Xno:                         :
%constinteger FC logon     = 'L'       { 0  : ownername, password     : Uno
%constinteger FC logoff    = 'M'       { Uno:                         :
%constinteger FC ninfo     = 'N'       { Uno: filename                : packet
%constinteger FC copyfile  = 'O'       { Uno: filename, filename      :
%constinteger FC pass      = 'P'       { Uno: password, username      :
%constinteger FC quote     = 'Q'       { Uno: password                :
%constinteger FC readda    = 'R'       { Xno: block-number, blocks    : packet
%constinteger FC openr     = 'S'       { Uno: filename                : Xno
%constinteger FC openw     = 'T'       { Uno: filename                : Xno
%constinteger FC reset     = 'U'       { Xno: block-number            :
%constinteger FC credir    = 'V'       { Uno: new-diectory-name       :
%constinteger FC writeda   = 'W'       { Xno: block-number, ...packet :
%constinteger FC readsq    = 'X'       { Xno: blocks                  : packet
%constinteger FC writesq   = 'Y'       { Xno: ...packet               :
%constinteger FC readfile  = 'Z'       { Uno: filename                : ...file
%constinteger FC new owner = '['       { Uno: <p>ownername, quota     :
%constinteger FC owners    = '\'       { Uno: partition number        : packet
%constinteger FC fcomm     = ']'       { Uno: system command          : packet
%constinteger FC new quota = '^'       { Uno: ownername, delta        :
! unused                     '_'       {

%constinteger first FC = '@';  ! This one is reserved.
%constinteger last  FC = '_'


%routine copy string(%string(255) s, %bytename buffer, %integername pos)
   ! **Assume** that there's room!
   %integer i
      %return %if s = ""
      %for i = 1, 1, length(s) %cycle
         buffer [pos] = charno(s, i)
         pos = pos + 1
      %repeat
%end

%routine copy byte(%integer what, %bytename buffer, %integername pos)
   buffer [pos] = what
   pos = pos + 1
%end

%routine copy bytes(%bytename from, %integer bytes,
                    %bytename buffer, %integername pos)
   %while bytes > 0 %cycle
      buffer [pos] = from;  pos = pos + 1
      from == from [1];  bytes = bytes - 1
   %repeat
%end

%routine copy I to H2(%integer what, %bytename buffer, %integername pos)
   buffer [pos    ] = what >> 4      + '0'
   buffer [pos + 1] = what      & 15 + '0'
   pos = pos + 2
%end

%routine copy I to H4(%integer what, %bytename buffer, %integername pos)
   %integer i
      %for i = 12, -4, 0 %cycle
         buffer [pos] = (what >> i) & 15 + '0'
         pos = pos + 1
      %repeat
%end

%integerfn H to I(%string(*)%name s)
   %integer i, j
      %result = 0 %if s = ""
      i = 0
      i = (i << 4) + charno(s, j) - '0' %for j = 1, 1, length(s)
      %result = i
%end

%predicate zero P(%string(*)%name s)
   %integer i
      %true %if s = ""
      %for i = 1, 1, length(s) %cycle
         %false %unless charno(s, i) = '0'
      %repeat
      %true
%end

%predicate split request(%bytename request, %integer request bytes,
                         %integername command, UXno,
                         %string(*)%name P1, P2,
                         %bytename data, %integername data bytes)
   ! Break the client's request into its component parts: command, UXno,
   ! (optionally) P1, (optionally) P2, (optionally) data.  Note that we
   ! strip out any spaces from the parameters.
   command = request;  command = command - 'a' + 'A' %if 'a' <= command <= 'z'
   %false %unless first FC <= command <= last FC
   UXno = request [1] - '0'
   request == request [2];  request bytes = request bytes - 2
   P1 = "";  P2 = ""

   %while request bytes > 0 %cycle
      -> get P2 %if request = ','
      -> get data %if request = NL
      P1 = P1 . to string(request) %if request # ' '
      request == request [1]
      request bytes = request bytes - 1
   %repeat
   %false;  ! No NewLine in the packet

get P2:
   request == request [1]
   request bytes = request bytes - 1
   %while request bytes > 0 %cycle
      -> get data %if request = NL
      P2 = P2 . to string(request) %if request # ' '
      request == request [1]
      request bytes = request bytes - 1
   %repeat
   %false;  ! No NewLine in the packet

get data:
   request == request [1]
   request bytes = request bytes - 1
   data bytes = request bytes
   %while request bytes > 0 %cycle
      data = request
      data == data [1];  request == request [1]
      request bytes = request bytes - 1
   %repeat
   %true
%end

%routine convert metacharacters(%bytename b, %integer bytes)
   %while bytes > 0 %cycle
      %if b = 0 %start
         b = separator
      %else %if b = 1
         b = redirector
      %else %if b = 2
         b = '?'
      %finish
      b == b [1]
      bytes = bytes - 1
   %repeat
%end


! Uno and Xno table formats.  Note that access to these tables is implicitly
! synchronised by the protocol: Uno 0 is read-only, while all other Unos and
! Xnos are context-specific.  We only have a read outstanding on a context while
! we are not processing a request, hence each Uno or Xno can only be active
! once.

%conststring(31) Uno table name = "P_H2_UNO_TABLE"
%recordformat Uno info fm(%integer context, tag,
                          %integer opened datestamp, used datestamp,
                          %string(31) username, domain,
                          %record(*)%name user token,
                          %string(127) login path, default path)

%conststring(31) Xno table name = "P_H2_XNO_TABLE"
%recordformat Xno info fm(%record(*)%name user token,
                          %string(31) filename,
                          %integer opened datestamp, used datestamp,
                          %integer Uno, context, tag, mode,
                          %integer file token1, file token2, flags,
                          %integer size, blocks, next block)

%constinteger Xno read access = 1
%constinteger Xno modify access = 2

%ownrecord(Uno info fm)%array Uno info(0 : max Uno) = 0(*)
%ownrecord(Xno info fm)%array Xno info(1 : max Xno) = 0(*)
%ownrecord(semaphore fm) UXno allocation semaphore = 0

%integerfn allocate Uno(%integer context, tag)
   %record(Uno info fm)%name U
   %integer i
      semaphore wait(UXno allocation semaphore)
      %for i = 1, 1, max Uno %cycle
         U == Uno info(i)
         %if U_context = 0 %start
            ! Free one
            U_context = context;  U_tag = tag
            signal semaphore(UXno allocation semaphore)
            %result = i
         %finish
      %repeat
      signal semaphore(UXno allocation semaphore)
      %result = -1
%end

%predicate validate Uno(%integer Uno, context)
   %unless 0 <= Uno <= max Uno %start
      !! print context info(context)
      !! printstring("Uno out of range: ")
      !! write(Uno, 0);  newline
      %false
   %finish
   %true %if Uno = 0;  ! Always valid
   %unless Uno info(Uno)_context = context %start
      !! print context info(context)
      !! printstring("Uno context for ");  write(Uno, 0)
      !! printstring(" is ");  write(Uno info(Uno)_context, 0)
      !! newline
      %false
   %finish
   ! Must be OK
   %true
%end

%integerfn allocate Xno(%integer Uno, context, tag)
   %record(Xno info fm)%name X
   %integer i
      semaphore wait(UXno allocation semaphore)
      %for i = 1, 1, max Xno %cycle
         X == Xno info(i)
         %if X_Uno < 0 %start
            ! Free one
            X_Uno = Uno
            X_context = context;  X_tag = tag
            signal semaphore(UXno allocation semaphore)
            %result = i
         %finish
      %repeat
      signal semaphore(UXno allocation semaphore)
      %result = -1
%end
         
%predicate validate Xno(%integer Xno, context)
   %unless 0 < Xno <= max Xno %start
      !! print context info(context)
      !! printstring("Xno out of range: ")
      !! write(Xno, 0);  newline
      %false
   %finish
   %unless Xno info(Xno)_context = context %start
      !! print context info(context)
      !! printstring("Xno context for ");  write(Xno, 0)
      !! printstring(" is ");  write(Xno info(Xno)_context, 0)
      !! newline
      %false
   %finish
   %unless 0 <= Xno info(Xno)_Uno <= max Uno %start
      !! print context info(context)
      !! printstring("Uno out of range for Xno ");  write(Xno, 0)
      !! printstring(": ");  write(Xno info(Xno)_Uno, 0)
      !! newline
      %false
   %finish
   %true
%end

%routine cleardown context(%integer tag, Uno)
   %record(Xno info fm)%name X
   %record(Uno info fm)%name U
   %string(255) textual response
   %integer i, status
   %record(semaphore fm) auth sem = 0
   %record(mailbox fm) auth box = 0
   %record(authority request fm) auth req
   %record(authority request fm)%name auth rep
   %ownrecord(mailbox fm)%name auth == nil
      %if auth == nil %start
         %if FS lookup(authority mailbox name, i) %start
            auth == record(i)
         %else
            auth == nil
         %finish
      %finish
      setup semaphore(auth sem)
      setup mailbox(auth box, auth sem)
      setup message(auth req, size of(auth req))
      !! pdate
      !! printstring("  Cleardown context: tag ");  write(tag, 0)
      !! printstring(", Uno ");  write(Uno, 0)
      !! %if Uno # 0 %start
      !!    printstring(", user ")
      !!    printstring(Uno info(Uno)_username)
      !! %finish
      !! newline
      %for i = 1, 1, max Xno %cycle
         X == Xno info(i)
         %if X_tag = tag %start
            %if (Uno = 0 %and X_Uno >= 0) %or 0 # Uno = X_Uno %start
               !! printstring("Cleardown: Uclose Xno ")
               !! write(i, 0);  newline
               status = F close file(X_user token,
                                     X_file token1, X_file token2,
                                     auto truncate flag ! improper close flag,
                                     textual response)
               !! %if status # 0 %start
               !!    printstring("Cleardown close: status ")
               !!    write(status, 0);  newline
               !! %finish
               X_context = 0;  X_tag = 0;  X_uno = -1
            %finish
         %finish
      %repeat
      %if Uno # 0 %start
         ! Uno supplied, so zap the record and free the token
         U == Uno info(Uno)
         !! printstring("Cleardown: logoff Uno ")
         !! write(Uno, 0);  printstring(", user ")
         !! printstring(U_username);  newline
         U_context = 0;  U_tag = 0
         %if U_user token ## nil %and auth ## nil %start
            auth req_code = authority void token
            auth req_token = addr(U_user token)
            send message(auth req, auth, auth box)
            auth rep == receive message(auth box)
            !! printstring("Cleardown: void status ")
            !! write(auth rep_status, 0);  newline
            U_user token == nil
         %finish
      %else
         ! No Uno, so must scan the tables looking for things
         ! to zap/free.
         %for i = 1, 1, max Uno %cycle
            U == Uno info(i)
            %if U_tag = tag %start
               !! printstring("Cleardown: logoff Uno ")
               !! write(i, 0);  printstring(", user ")
               !! printstring(U_username);  newline
               U_context = 0;  U_tag = 0
               %if U_user token ## nil %and auth ## nil %start
                  auth req_code = authority void token
                  auth req_token = addr(U_user token)
                  send message(auth req, auth, auth box)
                  auth rep == receive message(auth box)
                  !! printstring("Cleardown: void status ")
                  !! write(auth rep_status, 0);  newline
                  U_user token == nil
               %finish
            %finish
         %repeat
      %finish
%end

%routine prepend default(%record(Uno info fm)%name U, %string(*)%name s)
   %integer i
      !! printstring("Prepending """);  zprintstring(U_default path)
      !! printstring(""" to """);  zprintstring(s)
      !! print symbol('"');  newline
      %return %if U_default path = ""
      s = U_default path %and %return %if s = ""
      %if charno(s, 1) = ':' %start
         s = U_default path %and %return %if s = ":"
         s = U_default path . sub string(s, 2, length(s))
         !! printstring("Defaulted via sub-path: """)
         !! zprintstring(s);  print symbol('"');  newline
         %return
      %finish
      %for i = 1, 1, length(s) %cycle
         ! Check for a separator that isn't followed by a version number...
         %return %if charno(s, i) = separator %and %c
                     (i = length(s) %or charno(s, i + 1) # '-')
      %repeat
      ! No separator, so prepend the new path
      s = U_default path . s
%end

%routine split off username(%string(*)%name f, t)
   %integer i, c
      t = ""
      %return %if f = ""
      %for i = length(f), -1, 1 %cycle
         c = i %and -> copy %if charno(f, i) = ':'
      %repeat
      c = 0
copy: %for i = c + 1, 1, length(f) %cycle
         t = t . to string(charno(f, i))
      %repeat
%end

%predicate check for separator(%string(255) path)
   %integer i
      %false %if path = ""
      %for i = 1, 1, length(path) %cycle
         %true %if charno(path, i) = separator
      %repeat
      %false
%end

%routine construct anon
   %record(Uno info fm)%name U
   %integer status
      !! printstring("Constructing ""Anon""");  newline
      U == Uno info(0)
      U_username = "Default"
      U_default path = ""
      U_login path = ""
      U_opened datestamp = get datestamp
      U_used datestamp = U_opened datestamp
      U_user token == record(1);  ! Guaranteed dud
%end


%ownrecord(semaphore fm) internal copy semaphore = 0
%owninteger internal copy count = internal copy limit


%ownrecord(attributes list fm)%name attributes lookaside list == nil
%ownrecord(semaphore fm) attributes lookaside semaphore = 0

%record(attributes list fm)%map new attribute
   %record(attributes list fm)%name a
      semaphore wait(attributes lookaside semaphore)
      %if attributes lookaside list == nil %start
         a == record(global heap get(size of(attributes lookaside list)))
      %else
         a == attributes lookaside list
         attributes lookaside list == a_next
      %finish
      a_next == nil
      signal semaphore(attributes lookaside semaphore)
      %result == a
%end

%routine dispose attribute(%record(attributes list fm)%name a)
   semaphore wait(attributes lookaside semaphore)
   a_next == attributes lookaside list
   attributes lookaside list == a
   signal semaphore(attributes lookaside semaphore)
%end


%routine interpret request(%integer context, tag,
                           %bytename request buffer,
                           %integer request bytes,
                           %bytename response buffer,
                           %integername response bytes)
   %record(semaphore fm) auth sem = 0
   %record(mailbox fm) auth box = 0
   %record(authority request fm) auth req
   %record(authority request fm)%name auth rep
   %ownrecord(mailbox fm)%name auth == nil
   %bytearray data(0 : ether max)
   %bytename data buffer == data(0)
   %string(255) p1, p2, textual response
   %record(Uno info fm)%name U
   %record(Xno info fm)%name X
   %integer buffer pos = 0, command, Uno, Xno, UXno, data bytes = -1, status
   %integer wanted, bytes in last, notified bytes, i, datestamp, n
   %record(attributes list fm)%name attr, attr list == nil, attr tail
   %record(attributes list fm) one attr
   %switch op(first FC : last FC)

      %on 4 %start
         ! Dud number (probably from StoI)
         -> protocol error
      %finish

      !! printstring("Interpret request: context: ");  write(context, 0)
      !! printstring(", bytes: ");  write(request bytes, 0);  newline

      %if request bytes < 0 %or request buffer = 4 %or request buffer = 12 %start
         ! Cleardown request
         cleardown context(tag, 0)
         drop context(context, tag) %if request bytes > 0
         response bytes = -1
         %return
      %finish

      %unless split request(request buffer, request bytes, command, UXno,
                            P1, P2, data buffer, data bytes) %start
         -> protocol error
      %finish
      !! printstring("Context ");  write(context, 0)
      !! printstring(": ");  print symbol(command)
      !! space;  print symbol(UXno + '0')
      !! printstring(" """);  printstring(P1)
      !! printstring(""" """);  printstring(P2)
      !! printstring(""" + ");  write(data bytes, 0);  newline
      -> op(command)

op(FC logon):
      -> dud Uno %unless UXno = 0
      -> protocol error %if P1 = ""
      Uno = allocate Uno(context, tag)
      %if Uno <= 0 %start
         copy string("-? No Unos", response buffer, buffer pos)
         -> send with newline
      %finish
      !! printstring("Logon ");  printstring(P1)
      !! printstring(", Uno ");  write(Uno, 0);  newline
      U == Uno info(Uno)
      ! Check the username & password
      !? to upper(P1);  to upper(P2)
      %if auth == nil %start
         %if FS lookup(authority mailbox name, i) %start
            auth == record(i)
         %else
            copy string("-? No authority server", response buffer, buffer pos)
            -> send with newline
         %finish
      %finish
      setup semaphore(auth sem)
      setup mailbox(auth box, auth sem)
      setup message(auth req, size of(auth req))
      auth req_code = authority issue token
      auth req_user == P1
      auth req_pass == P2
      auth req_token = 0
      auth req_domain == U_domain
      send message(auth req, auth, auth box)
      auth rep == receive message(auth box)
      !! printstring("Validate status ");  write(auth rep_status, 0);  newline
      %if auth rep_status # 0 %start
         U_context = 0;  ! Free it up again
         print context info(context)
         printstring("Failed logon ");  printstring(P1)
         space;  write(auth rep_status, 0);  newline
fail validation:
         copy string("-? User validation fails", response buffer, buffer pos)
         -> send with newline
      %finish
      U_user token == record(auth req_token)
      split off username(P1, U_username);  ! Have to remember for FC pass, etc
      U_opened datestamp = get datestamp;  U_used datestamp = U_opened datestamp
      get user data(U_username, U_domain, U_default path, textual response)
      %if u_default path = "" %start
         U_context = 0
         print context info(context)
         printstring("No user data for ");  printstring(U_username)
         newline
         -> fail validation
      %finish
      U_default path = U_default path . ":" %c
         %unless charno(U_default path, length(U_default path)) = ':'
      U_login path = U_default path
      print context info(context)
      printstring("Logon ");  write(Uno, 0);  space
      printstring(U_username);  !printstring(" at ");  printstring(U_domain)
      space;  printstring(textual response)
      space;  printstring(U_default path);  newline
      ! Now return the allocated Uno to the user, together with the default path
      copy byte(Uno + '0', response buffer, buffer pos)
   !P copy string(U_default path, response buffer, buffer pos)
      -> send with newline

op(FC logoff):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      U == Uno info(UXno)
      cleardown context(context, UXno)
      print context info(context)
      printstring("Logoff ");  write(UXno, 0);  space
      printstring(U_username);  newline
      U_context = 0
      -> send with newline

op(FC delete):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      status = F delete file(U_user token, P1, textual response)
      -> send textual error %if status # 0
      -> send with newline

op(FC rename):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = "" %or P2 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      prepend default(U, P2)
      status = F rename file(U_user token, P1, P2, textual response)
      -> send textual error %if status # 0
      one attr_next == nil
      one attr_code = file flags attribute
      status = F obtain attributes(U_user token, P2, one attr, textual response)
      -> send textual error %if status # 0
      -> send with newline %if one attr_numeric & improperly closed file = 0
      one attr_numeric = one attr_numeric & (\ improperly closed file)
      status = F modify attributes(U_user token, P2, one attr, textual response)
      -> send textual error %if status # 0
      -> send with newline

op(FC permit):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      P2 = "RMAXLC;R" %if P2 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      status = F permit file(U_user token, P1, P2, textual response)
      -> send textual error %if status # 0
      -> send with newline

op(FC credir):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      %if P2 = "" %start
         n = -1
      %else
         n = charno(P2, 1) - '0'
         -> protocol error %unless 0 < n <= 9;  ! May be errors later, of course
      %finish
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      status = F create directory P(U_user token, P1, n, 0, textual response)
      -> send textual error %if status # 0
      -> send with newline

op(FC finfo):
      -> not logged on %if UXno = 0 %and P1 = ""
      -> dud Uno %unless validate Uno(UXno, context)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if P1 = "" %start
         P1 = U_default path
      %else %if charno(P1, length(P1)) # ':'
         P1 = P1 . ":"
      %finish
      n = H to I(P2);  -> finfo n %if n # 0
      buffer pos = 2;  ! Nasty hack -- skip the length meantime
      copy byte(NL, response buffer, buffer pos)
      copy string(P1, response buffer, buffer pos)
      buffer pos = buffer pos - 1;  ! Lose the ':'
!      copy string(" (", response buffer, buffer pos)
!      copy string(U_username, response buffer, buffer pos)
!      copy string(", ", response buffer, buffer pos)
!      copy string(itos(U_fsys access_user ID, 0), response buffer, buffer pos)
!      copy string(", ", response buffer, buffer pos)
!      copy string(U_login path, response buffer, buffer pos)
!      copy byte(')', response buffer, buffer pos)
      copy string(" on ", response buffer, buffer pos)
      datestamp = get datestamp
      unpack date(datestamp, P1, P2)
      copy string(day of week(datestamp), response buffer, buffer pos)
      copy byte(' ', response buffer, buffer pos)
      copy string(P1, response buffer, buffer pos)
      copy string(" at ", response buffer, buffer pos)
      copy string(P2, response buffer, buffer pos)

finfo send:
      response bytes = buffer pos;  buffer pos = 0;  ! Go back for the length
      copy I to H2(response bytes - 3, response buffer, buffer pos)
      %return

finfo n:
      status = F enquire nth directory entry(U_user token, P1, n, P2,
                                             textual response)
      -> send textual error %if status # 0
      %if P2 = "" %start
         ! No such file (number) in directory
         copy string("00", response buffer, buffer pos)
         -> send with newline
      %finish
      %if length(P1) + length(P2) > 255 %start
         textual response = "Dud filename (too long)"
         -> send textual error
      %finish
      P1 = P1 . P2
      buffer pos = 2
      copy byte(NL, response buffer, buffer pos)
      copy string(P2, response buffer, buffer pos)
      copy string("  ", response buffer, buffer pos)
      length(P1) = length(P1) - 1 %if charno(P1, length(P1)) <= ' '
      convert metacharacters(charno(P1, 1), length(P1))
      status = F short form attributes(U_user token, P1, P2, textual response)
      %if status = 0 %start
         copy string(P2, response buffer, buffer pos)
      %else
         copy string("-> ", response buffer, buffer pos) %if status > 0
         copy string(textual response, response buffer, buffer pos)
      %finish
      convert metacharacters(response buffer, buffer pos)
      -> finfo send

op(FC ninfo):
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if UXno = 0 %start
         -> not logged on %unless check for separator(P1)
      %else
         prepend default(U, P1)
      %finish
      !! printstring("Ninfo: ");  zprintstring(P1);  newline
      status = F short form attributes(U_user token, P1, P2, textual response)
      -> send textual error %if status # 0
      buffer pos = 2
      copy byte(NL, response buffer, buffer pos)
      copy string(P1, response buffer, buffer pos)
      copy string("  ", response buffer, buffer pos)
      copy string(P2, response buffer, buffer pos)
      convert metacharacters(response buffer, buffer pos)
      -> finfo send

op(FC general):
      -> dud Uno %unless validate Uno(UXno, context)
      -> not implemented %unless zero P(P1)
      datestamp = get datestamp
      unpack date(datestamp, P1, P2)
      copy I to H2(18, response buffer, buffer pos)
      copy byte(NL, response buffer, buffer pos)
      copy string(P1, response buffer, buffer pos)
      copy string("  ", response buffer, buffer pos)
      copy string(P2, response buffer, buffer pos)
      response bytes = buffer pos
      %return

op(FC pass):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if U_domain # "local" %start
         copy string("-? Can't change remote password", response buffer, buffer pos)
         -> send with newline
      %finish
      !! printstring("Password change: ");  zprintstring(P1)
      !! space;  zprintstring(P2);  newline
      setup semaphore(auth sem)
      setup mailbox(auth box, auth sem)
      setup message(auth req, size of(auth req))
      auth req_code = authority set password
      auth req_user == U_username
      auth req_pass == P1
      auth req_pass2 == P2
      auth req_token = addr(U_user token)
      send message(auth req, auth, auth box)
      auth rep == receive message(auth box)
      print context info(context)
      printstring(U_username);  printstring(" change password")
      %if auth rep_status # 0 %start 
         printstring(", status ");  write(auth rep_status, 0)
         copy string("-? Modify password failed", response buffer, buffer pos)
      %finish
      newline
      -> send with newline

op(FC setdir):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if P1 = "" %start
         P1 = U_login path
      %else
         prepend default(U, P1)
      %finish
      P1 = P1 . ":" %unless charno(P1, length(P1)) = ':'
      status = F obtain attributes(U_user token, P1, nil, textual response)
      -> send textual error %if status # 0
      U_default path = P1
      -> send with newline

op(FC copyfile):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      semaphore wait(internal copy semaphore)
      %if internal copy count <= 0 %start
         signal semaphore(internal copy semaphore)
         copy string("-? Too many internal copies already active",
                     response buffer, buffer pos)
         -> send with newline
      %finish
      internal copy count = internal copy count - 1
      signal semaphore(internal copy semaphore)
      U == Uno info(UXno)
      -> protocol error %if P1 = "" %or P2 = ""
      prepend default(U, P1)
      prepend default(U, P2)
      status = F initiate copy(U_user token, P1, P2, i, textual response)
      %if status # 0 %start
         semaphore wait(internal copy semaphore)
         internal copy count = internal copy count + 1
         signal semaphore(internal copy semaphore)
         -> send textual error
      %finish
      copy byte(NL, response buffer, buffer pos)
      %if send response(context, tag, buffer pos) %start;  %finish
      ! Now finish the copy operation
      status = F complete copy(i, textual response)
      %if status # 0 %start
         printstring("Internal copy: complete copy status ")
         write(status, 0);  newline
      %finish
      semaphore wait(internal copy semaphore)
      internal copy count = internal copy count + 1
      signal semaphore(internal copy semaphore)
      response bytes = -1
      %return

op(FC openr):
      !! printstring("OpenR ");  printstring(P1);  newline
      -> dud Uno %unless validate Uno(UXno, context)
      Xno = allocate Xno(UXno, context, tag)
      %if Xno <= 0 %start
         copy string("-? No Xnos", response buffer, buffer pos)
         -> send with newline
      %finish
      X == Xno info(Xno)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if UXno = 0 %start
         -> not logged on %unless check for separator(P1)
      %else
         prepend default(U, P1)
      %finish
      x_filename = "<opening>"
      X_opened datestamp = get datestamp;  X_used datestamp = X_opened datestamp
      status = F open file(U_user token, P1, read file mode, read file mode,
                           0, X_file token1, X_file token2, X_size, X_flags,
                           textual response)
      %if status # 0 %start
         X_Uno = -1;  ! Free it up again
         -> send textual error
      %finish
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      copy byte(Xno + '0', response buffer, buffer pos)
      copy byte(',', response buffer, buffer pos)
      X_mode = Xno read access
      X_user token == U_user token
      %if X_size <= 0 %start
         ! Empty file, must return 0,0 (not 0,P0)
         X_blocks = -1
         bytes in last = 512
      %else
         X_blocks = X_size >> 9
         bytes in last = X_size & 511
         %if bytes in last = 0 %start
            ! Exact multiple of block-size
            X_blocks = X_blocks - 1
            bytes in last = 512
         %finish
      %finish
      X_next block = 0
      !! printstring("OpenR: ");  write(X_size, 0);  space;  write(X_blocks + 1, 0)
      !! space;  write(bytes in last, 0);  newline
      copy I to H4(X_blocks + 1, response buffer, buffer pos)
      copy byte(',', response buffer, buffer pos)
      copy I to H2(512 - bytes in last, response buffer, buffer pos)
      -> send with newline

op(FC openw):
      !! printstring("OpenW ");  printstring(P1);  newline
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, context, tag)
      %if Xno <= 0 %start
         copy string("-? No Xnos", response buffer, buffer pos)
         -> send with newline
      %finish
      X == Xno info(Xno)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      X_filename = "<opening>"
      X_opened datestamp = get datestamp;  X_used datestamp = X_opened datestamp
      status = F open file(U_user token, P1, 
                           read file mode ! modify file mode, 0,
                           create flag, X_file token1, X_file token2,
                           X_size, X_flags, textual response)
      %if status # 0 %start
         X_Uno = -1;  ! Free it up again
         -> send textual error
      %finish
      copy byte(Xno + '0', response buffer, buffer pos)
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      X_mode = Xno modify access
      X_user token == U_user token
      X_blocks = 0
      X_next block = 0
      -> send with newline

op(FC openmod):
      !! printstring("OpenMod ");  printstring(P1);  newline
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, context, tag)
      %if Xno <= 0 %start
         copy string("-? No Xnos", response buffer, buffer pos)
         -> send with newline
      %finish
      X == Xno info(Xno)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      X_filename = "<opening>"
      X_opened datestamp = get datestamp;  X_used datestamp = X_opened datestamp
      status = F open file(U_user token, P1,
                           read file mode ! modify file mode, 0,
                           create if flag, X_file token1, X_file token2,
                           X_size, X_flags, textual response)
      %if status # 0 %start
         X_Uno = -1;  ! Free it up again
         -> send textual error
      %finish
      copy byte(Xno + '0', response buffer, buffer pos)
      copy byte(',', response buffer, buffer pos)
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      X_mode = Xno read access ! Xno modify access
      X_user token == U_user token
      %if X_size <= 0 %start
         ! Empty file, must return 0,0 (not 0,P0)
         X_blocks = -1
         bytes in last = 512
      %else
         X_blocks = X_size >> 9
         bytes in last = X_size & 511
         %if bytes in last = 0 %start
            ! Exact multiple of block-size
            X_blocks = X_blocks - 1
            bytes in last = 512
         %finish
      %finish
      X_next block = 0
      copy I to H4(X_blocks + 1, response buffer, buffer pos)
      copy byte(',', response buffer, buffer pos)
      copy I to H2(512 - bytes in last, response buffer, buffer pos)
      -> send with newline

op(FC reset):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      wanted = H to I(P1)
      -> protocol error %if wanted < 0
      -> off file %unless wanted <= X_blocks
      X_next block = wanted
      -> send with newline

op(FC close):
op(FC uclose):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      %if command = FC close %then i = auto truncate flag %c
                             %else i = auto truncate flag ! improper close flag
      status = F close file(X_user token, X_file token1, X_file token2,
                            i, textual response)
      X_Uno = -1
      -> send textual error %if status # 0
      -> send with newline

op(FC readsq):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      -> not allowed %if X_mode & Xno read access = 0
      X_used datestamp = get datestamp
      wanted = H to I(P1);  wanted = 1 %if wanted <= 0
      !! printstring("ReadSQ ");  write(UXno, 0)
      !! printstring(", wanting ");  write(wanted, 0)
      !! printstring(", next is ");  write(X_next block, 0)
      !! printstring(" of ");  write(X_blocks, 0);  newline
      %cycle
do block read:
         %if X_next block > X_blocks %start
            !! printstring("Off the end, sending conventional zero")
            !! newline
            copy string("00", response buffer, buffer pos)
            -> send with newline
         %finish
         status = F read block(X_user token, X_file token1, X_file token2,
                               X_next block << 9, data bytes, data(0),
                               textual response)
         !! printstring("Block ");  write(X_next block, 0)
         !! printstring(", status ");  write(status, 0)
         !! printstring(", bytes ");  write(data bytes, 0)
         !! newline
         X_next block = X_next block + 1
         -> send textual error %if status # 0
         convert metacharacters(data(0), data bytes) %if X_flags & directory flag # 0
         copy I to H2(data bytes, response buffer, buffer pos)
         copy byte(NL, response buffer, buffer pos)
         copy bytes(data(0), data bytes, response buffer, buffer pos)
         wanted = wanted - 1
         %exit %if wanted = 0 %or data bytes < 512
         buffer pos = -1 %and %return %c
            %unless send response(context, tag, buffer pos)
         buffer pos = 0
      %repeat
      response bytes = buffer pos
      %return

op(FC writesq):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      -> not allowed %if X_mode & Xno modify access = 0
      X_used datestamp = get datestamp
      notified bytes = H to I(P1)
do block write:
      -> protocol error %unless notified bytes = data bytes
      status = F write block(X_user token, X_file token1, X_file token2,
                             X_next block << 9, data bytes, data(0),
                             textual response)
      -> send textual error %if status # 0
      X_next block = X_next block + 1
      X_blocks = X_next block %if X_next block > X_blocks
      -> send with newline

op(FC readda):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      -> not allowed %if X_mode & Xno read access = 0
      X_used datestamp = get datestamp
      X_next block = H to I(P1)
      wanted = H to I(P2);  wanted = 1 %if wanted <= 0
      -> do block read

op(FC writeda):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      -> not allowed %if X_mode & Xno modify access = 0
      X_used datestamp = get datestamp
      notified bytes = H to I(P2)
      wanted = H to I(P1)
      -> off file %unless 0 <= wanted <= X_blocks
      X_next block = wanted
      -> do block write

op(FC readback):
      -> dud Xno %unless validate Xno(UXno, context)
      X == Xno info(UXno)
      -> not allowed %if X_mode & Xno read access = 0
      X_used datestamp = get datestamp
      X_next block = X_next block - 1
      X_next block = 0 %if X_next block < 0
      wanted = 1
      -> do block read

op(FC readfile):
      !! printstring("ReadFile ");  printstring(P1);  newline
      -> dud Uno %unless validate Uno(UXno, context)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, context, tag)
      %if Xno <= 0 %start
         copy string("-? No Xnos", response buffer, buffer pos)
         -> send with newline
      %finish
      X == Xno info(Xno)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if UXno = 0 %start
         -> not logged on %unless check for separator(P1)
      %else
         prepend default(U, P1)
      %finish
      X_filename = "<opening>"
      X_opened datestamp = get datestamp;  X_used datestamp = X_opened datestamp
      !! printstring("Opening ");  printstring(P1);  newline
      status = F open file(U_user token, P1, read file mode, read file mode,
                           0, X_file token1, X_file token2, X_size, X_flags,
                           textual response)
      !! printstring("Status: ");  write(status, 0);  newline
      %if status # 0 %start
         X_Uno = -1;  ! Free it up again
         -> send textual error
      %finish
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      X_mode = Xno read access
      X_user token == U_user token
      X_blocks = X_size >> 9;  wanted = X_blocks
      bytes in last = X_size - (X_blocks << 9)
      X_next block = 0
      copy I to H4(X_blocks + 1, response buffer, buffer pos)
      copy byte(',', response buffer, buffer pos)
      copy I to H2(512 - bytes in last, response buffer, buffer pos)
      copy byte(NL, response buffer, buffer pos)
      buffer pos = -1 %and %return %c
         %unless send response(context, tag, buffer pos)
      ! Now ship the file itself
      %cycle
         !! printstring("Reading block ");  write(x_next block, 0);  newline
         X_used datestamp = get datestamp
         status = F read block(X_user token, X_file token1, X_file token2,
                               X_next block << 9, data bytes,
                               byteinteger(addr(response buffer)),
                               textual response)
         %exit %if status # 0
         !! printstring("Got block ");  write(X_next block, 0)
         !! printstring(", ");  write(wanted, 0)
         !! printstring(" remaining, size ");  write(data bytes, 0);  newline
         %exit %if wanted = 0 %or data bytes < 512
         convert metacharacters(data(0), data bytes) %if X_flags & directory flag # 0
         buffer pos = -1 %and %return %c
            %unless send response(context, tag, data bytes)
         wanted = wanted - 1
         X_next block = X_next block + 1
      %repeat
      ! Close the file and send the last block (or error response)
      i = F close file(X_user token, X_file token1, X_file token2, 0, P2)
      ! Ignore any errors.  Free the Xno, then send the last packet
      X_Uno = -1
      -> send textual error %if status # 0
      convert metacharacters(data(0), data bytes) %if X_flags & directory flag # 0
      %if data bytes = 512 %start
         %if send response(context, tag, data bytes) %then data bytes = 0 %c
                                                     %else data bytes = -1
      %finish
      response bytes = data bytes
      %return

op(FC new owner):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> not implemented

op(FC owners):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> not implemented

op(FC new quota):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, context)
      -> not implemented

op(*):
not implemented:
      !! printstring("Unimplemented request ");  print symbol(command);  newline
      copy string("-? Request '", response buffer, buffer pos)
      copy byte(command, response buffer, buffer pos)
      copy string("' not implemented (yet)", response buffer, buffer pos)
send with newline:
      response buffer [buffer pos] = NL;  response bytes = buffer pos + 1
      %return

send textual error:
      %if status < 0 %start
         copy string("-? ", response buffer, buffer pos)
      %else
         copy string("-> ", response buffer, buffer pos)
      %finish
      copy string(textual response, response buffer, buffer pos)
      -> send with newline

op(FC quote):
op(FC dchange):
op(FC fcomm):
not meaningful:
      !! printstring("Non-meaningful request ");  print symbol(command);  newline
      copy string("-? Request '", response buffer, buffer pos)
      copy byte(command, response buffer, buffer pos)
      copy string("' not meaningful", response buffer, buffer pos)
      -> send with newline

not allowed:
      copy string("-? Previously requested mode precludes operation",
                  response buffer, buffer pos)
      -> send with newline

no privilege:
      copy string("-? No privilege for attempted operation",
                  response buffer, buffer pos)
      -> send with newline

protocol error:
      copy string("-6 Protocol error", response buffer, buffer pos)
      -> send with newline

off file:
      copy string("-? Attempting to reset outwith file", response buffer, buffer pos)
      -> send with newline

dud Uno:
      copy string("-? Dud Uno ", response buffer, buffer pos)
      copy byte(UXno + '0', response buffer, buffer pos)
      -> send with newline

dud Xno:
      copy string("-? Dud Xno ", response buffer, buffer pos)
      copy byte(UXno + '0', response buffer, buffer pos)
      -> send with newline

not logged on:
      copy string("-? Not logged on", response buffer, buffer pos)
      -> send with newline
%end

%owninteger which = 0
%ownrecord(semaphore fm) which sem = 0

%routine interpreter process
   %record(context fm)%name p
   %integer bytes, context, tag, status
   %bytearray x(0 : 3)
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name process
   %integer i, L set, L clear
      %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
         ! Last-chance disaster-trap
         process == POA
         printstring("P_H2: unexpected event ");  write(process_event, 0)
         space;  write(process_event sub, 0);  space;  phex(process_event extra)
         space;  printstring(process_event message)
         printstring(" at or about PC ");  phex(process_event PC)
         newline
         %for i = 0, 1, 15 %cycle
            phex(process_event r(i));  space
            newline %if i & 7 = 7
         %repeat
         semaphore wait(disaster)
      %finish
      open input(3, ":N");  select input(3)
      open output(3, ":T");  select output(3)
      setup semaphore(disaster)
      semaphore wait(which sem)
      L set = 16_10000 << which
      which = which + 1
      signal semaphore(which sem)
      L clear = \ L set
      !mark %if POA_heap_level = 1
      %cycle
!L!      lights and B(L clear)
         receive next request(context, tag, bytes, status)
!L!      lights or B(L set)
         %if 0 < context <= max contexts %and status = ether success %start
            !! write(bytes, 0);  printstring(" received from ")
            !! write(context, 0);  newline
            p == context info(context)
            %if p_buffer = 4 %or p_buffer = 12 %start
               trace(context, '*', bytes, p_buffer)
               interpret request(context, tag, p_buffer, bytes, p_buffer, bytes)
               ! Don't start another receive operation.
            %else
               trace(context, '<', bytes, p_buffer)
               interpret request(context, tag, p_buffer, bytes, p_buffer, bytes)
               %if bytes >= 0 %and send response(context, tag, bytes) %start;  %finish
               start receive(context, tag)
            %finish
         %else
            %if status # ether operation aborted %start
               print context info(context)
               printstring("Interpret: ")
               printstring(ether errors(status))
               newline
            %finish
            trace(context, '*', 0, x(0))
            interpret request(context, tag, x(0), -1, x(0), bytes) %c
               %if 0 < context <= max contexts
            ! Don't start another receive operation.  It'll be done for
            ! us when the (re)connection is completed.
         %finish
      %repeat
%end

%recordformat p0 buffer fm(%record(message fm) system part,
                           %byte ra, rp,
                           (%bytearray x(0 : 532) %c
                        %or %byte facility %c
                            %or %string(127) reply text))

%begin
   %record(p0 buffer fm)%name p0 buffer
   %record(mailbox fm) our p0 mailbox = 0
   %record(semaphore fm) our p0 semaphore = 0
   %record(process fm)%name created
   %record(context fm)%name p
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name process
   %integer i
   %label x
      %on 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 %start
         ! Last-chance disaster-trap
         process == POA
         printstring("P_H2 (Port 0): unexpected event ");  write(process_event, 0)
         space;  write(process_event sub, 0);  space;  phex(process_event extra)
         space;  printstring(process_event message)
         printstring(" at or about PC ");  phex(process_event PC)
         newline
         %for i = 0, 1, 15 %cycle
            phex(process_event r(i));  space
            newline %if i & 7 = 7
         %repeat
         semaphore wait(disaster)
      %finish
      open input(3, ":N");  select input(3)
      open output(3, ":T");  select output(3)
      setup semaphore(disaster)
      %if FS lookup(ether mailbox name, i) %start
         ether request mailbox == record(i)
      %else
         printstring("P_H2: No ether mailbox??")
         newline
         %stop
      %finish
      setup semaphore(our p0 semaphore)
      setup mailbox(our p0 mailbox, our p0 semaphore)
      FS insert(facility name, addr(our p0 mailbox))
      setup semaphore(our request semaphore)
      setup mailbox(our request mailbox, our request semaphore)
      setup semaphore(trace semaphore)
      signal semaphore(trace semaphore)
      setup semaphore(UXno allocation semaphore)
      signal semaphore(UXno allocation semaphore)
      setup semaphore(internal copy semaphore)
      signal semaphore(internal copy semaphore)
      setup semaphore(attributes lookaside semaphore)
      signal semaphore(attributes lookaside semaphore)
      setup semaphore(which sem)
      signal semaphore(which sem)
      !mark %if POA_heap_level = 1
      construct anon
      Xno info(i)_Uno = -1 %for i = 1, 1, max Xno
      trace buffer_s = trace size
      context info(i)_buffer == byteinteger(global heap get(ether max + 16)) %c
         %for i = 1, 1, max contexts
      FS insert(trace buffer name, addr(trace buffer))
      FS insert(context table name, addr(context info(1)))
      FS insert(Uno table name, addr(Uno info(0)))
      FS insert(Xno table name, addr(Xno info(1)))
      F external redirect level = 3
      F old style handling = 1
      F no explicit device = 1
      F enable dot dot = 1
      F default request flags = 16_00010000;  ! Non-local
      ! Start the interpreter processes here....
      created == create process(process size, addr(x), 6, nil) %c
         %for i = 1, 1, processes
      created == nil;  ! Don't want junk diagnostics
      {} printstring("P_H2: ");  write(free store, 0)
      {} printstring(" free");  newline
      ! Now wait for port 0 messages and act on them
      %cycle
!L!      lights and B(\ 16_00800000)
         p0 buffer == receive message(our p0 mailbox)
!L!      lights or B(16_00800000)
         !! printstring("Connect request from ");  phex2(p0 buffer_ra)
         !! print symbol('.');  phex2(p0 buffer_rp);  newline
         %if fsys state == nil %start
            %if FS lookup(fsys state name, i) %start
               fsys state == integer(i)
               %if fsys state & 1 = 0 %start
                  ! Local file system isn't running yet
                  p0 buffer_reply text = "-? Local filesystem not initialised" . SNL
                  -> reply
               %finish
            %else
               p0 buffer_reply text = "-? No local filesystem??"
               -> reply
            %finish
         %else %if fsys state & 1 = 0
            ! Local file system isn't running yet
            p0 buffer_reply text = "-? Local filesystem not initialised" . SNL
            -> reply
         %finish
         ! First have a look to see if we already know about this
         ! client -- we'll have to clear it down if we find one.
         %for i = 1, 1, max contexts %cycle
            p == context info(i)
            %if p_remote address = p0 buffer_ra %c
                  %and p_remote port = p0 buffer_rp %start
               !! printstring("Client already known at ")
               !! write(i, 0);  newline
               drop context(i, p_tag)
               %exit
            %finish
         %repeat
         ! Now get a new port for the client and make the initial read.
         i = initialise client comms(p0 buffer_ra, p0 buffer_rp)
         %if i > 0 %then p0 buffer_reply text = to string(i + '0') . SNL %c
                   %else p0 buffer_reply text = "-? No free contexts" . SNL
reply:   send message(p0 buffer, p0 buffer_system part_reply, nil)
      %repeat
x:    interpreter process
%end %of %program