! 2 meg H-protocol interpreter.  This version converses with the ether driver
! directly to take filestore protocol requests.

%externalstring(47) copyright %alias "GDMR_(C)_P_H2" = %c
   "Copyright (C) 1987 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"

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

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

%constinteger max ports = 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 "Sys:Ether.Inc"
%include "GDMR_H:FSysAcc.Inc"
!include "GDMR_H:FACMess.Inc"
%include "GDMR_H:IO_F.Inc"
%include "GDMR_H:FSys.Inc";    ! For protection bits
%include "GDMR_H:DateTime.Inc"

!constinteger auto truncate 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)

%include "GDMR_H:L_Admin.Inc"


%conststring(31) PH2 state name = "P_H2_STATE"
%owninteger PH2 state = 0
! 01 set    local file system ready


!! %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


! Trace buffer

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

%recordformat trace fm(%integer port, 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

%routine trace(%integer port, 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
      t == trace buffer_t(trace buffer_p)
      t_port = port;  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
      trace buffer_p = (trace buffer_p + 1) & trace size
%end


! Communications stuff follows...

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

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

%routine print port info(%integer port)
   %record(port fm)%name port data
      port data == port info(port)
      printstring("  Port ");  write(port, 0)
      printstring(" client ");  phex2(port data_remote address)
      print symbol('.');  phex2(port data_remote port)
%end

%routine receive next request(%integername port, bytes, status)
   %record(ether req fm)%name r
      r == receive message(our request mailbox)
      port = r_port
      bytes = r_res bytes
      status = r_result
      !! printstring("Received ");  write(bytes, 0);  printstring(" on ")
      !! write(port, 0);  printstring(", status ");  write(status, 0);  newline
%end

%routine start receive(%integer port)
   %record(port fm)%name p
      !! printstring("Start receive on port ");  write(port, 0);  newline
      %unless 0 < port <= max ports %start
         printstring("*** Starting receive on dud port ");  write(port, 0)
         printstring(" ???");  newline
         %return
      %finish
      p == port info(port)
      %if p_remote address = 0 %start
         printstring("P_H2: starting receive on closed port ")
         write(port, 0);  printstring(" ??"); newline
      %else
         p_ether request_code = ether receive req
         p_ether request_port = port
         p_ether request_tag = port;  ! **meantime**
         p_ether request_buffer == p_buffer
         p_ether request_max bytes = ether max
         send message(p_ether request, ether request mailbox,
                      our request mailbox)
      %finish
%end

%predicate send response(%integer port, bytes)
   %record(port fm)%name p
!! %bytename b
!! %integer i
      %on 15 %start
         printstring("P_H2: Ether error sending to port ")
         write(port, 0);   printstring(" -- ")
         printstring(event_message);  newline
         %false
      %finish
      %if 0 <= port <= max ports %start
         p == port info(port)
         !! printstring("Send response to port ");  write(port, 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(port, '>', bytes, p_buffer)
         %if p_remote address = 0 %start
            {} printstring("P_H2: sending to closed port ")
            {} write(port, 0);  newline
            %false
         %else
            p_transmit datestamp = get datestamp
            ether transmit block(port, bytes, p_buffer)
            %true
         %finish
      %else
         printstring("*** Sending to dud port ");  write(port, 0)
         printstring(" ???");  newline
         %false
      %finish
%end

%routine drop port(%integer port)
   %record(port fm)%name p
      %on 15 %start
         printstring("P_H2: Drop port ");  write(port, 0)
         printstring(" failed: ");  printstring(event_message)
         newline
      %finish
      !! printstring("Drop port ");  write(port, 0);  newline
      %unless 0 < port <= max ports %start
         printstring("P_H2: Drop dud port ");  write(port, 0)
         printstring(" ???");  newline
         %return
      %finish
      p == port info(port);  p_remote address = 0
      ether close port(port)
      ether free port(port)
%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
      %finish
      b == b [1]
      bytes = bytes - 1
   %repeat
%end


%conststring(31) Uno table name = "P_H2_UNO_TABLE"
%recordformat Uno info fm(%integer port,
                          %integer opened datestamp, used datestamp,
                          %string(31) username,
                          %record(access fm) access,
                          %record(fsys access fm) fsys access,
                          %string(127) login path, default path)

%conststring(31) Xno table name = "P_H2_XNO_TABLE"
%recordformat Xno info fm(%record(access fm)%name access,
                          %string(31) filename,
                          %integer opened datestamp, used datestamp,
                          %integer Uno, port, mode, file token, 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 port)
   %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_port = 0 %start
            ! Free one
            U_port = port
            signal semaphore(UXno allocation semaphore)
            %result = i
         %finish
      %repeat
      signal semaphore(UXno allocation semaphore)
      %result = -1
%end

%predicate validate Uno(%integer Uno, port)
   %false %unless 0 <= Uno <= max Uno
   %true %if Uno = 0
   %false %unless Uno info(Uno)_port = port
   %true
%end

%integerfn allocate Xno(%integer Uno, port)
   %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_port = port
            signal semaphore(UXno allocation semaphore)
            %result = i
         %finish
      %repeat
      signal semaphore(UXno allocation semaphore)
      %result = -1
%end
         
%predicate validate Xno(%integer Xno, port)
   %false %unless 0 < Xno <= max Xno
   %false %unless Xno info(Xno)_port = port
   %false %unless 0 <= Xno info(Xno)_Uno <= max Uno
   %true
%end

%routine cleardown port(%integer port, Uno)
   %ownrecord(access fm) full authority = 0;  ! Hence nil local authority
   %record(Xno info fm)%name X
   %record(Uno info fm)%name U
   %string(255) textual response
   %integer i, status
      !! printstring("Cleardown port ");  write(port, 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_port = port %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(full authority, X_file token,
                                     auto truncate flag ! improper close flag,
                                     textual response)
               !! %if status # 0 %start
               !!    printstring("Cleardown close: status ")
               !!    write(status, 0);  newline
               !! %finish
               X_port = 0;  X_uno = -1
            %finish
         %finish
      %repeat
      %return %if Uno # 0
      %for i = 1, 1, max Uno %cycle
         U == Uno info(i)
         %if U_port = port %start
            !! printstring("Cleardown: logoff Uno ")
            !! write(i, 0);  printstring(", user ")
            !! printstring(U_username);  newline
            U_port = 0
         %finish
      %repeat
%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

%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_user"
      U_access_local == U_fsys access
      U_default path = ""
      U_login path = ""
      U_fsys access_user ID = 1
      U_fsys access_supervisor ID = -1
      U_fsys access_privileges = no local privilege
      U_fsys access_groups = 0
      U_opened datestamp = get datestamp
      U_used datestamp = U_opened datestamp
%end


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

%routine interpret request(%integer port, request bytes, %bytename buffer,
                           %integername response bytes)
   %bytearray data(0 : ether max)
   %bytename data buffer == data(0)
   %string(255) p1, p2, textual response
   %record(fsys access fm) fsys access
   %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)

      %routine new numeric attribute(%integer code, value 1, value 2)
         %record(attributes list fm)%name a
            a == new(a)
            a_code = code
            a_numeric = value 1
            a_numeric2 = value 2
            a_next == nil
            %if attr list == nil %start
               attr list == a
               attr tail == a
            %else
               attr tail_next == a
               attr tail == a
            %finish
      %end

      %predicate construct protection(%string(*)%name P)
         %bytename ch
         %integer n, mask, ID, sign, groups = 0
         
         %predicate obtain protection
            mask = 0
            %cycle
               %true %if n = 0 %or ch = ';'
               %if ch = 'R' %or ch = 'r' %start
                  mask = mask ! read access
               %else %if ch = 'M' %or ch = 'm'
                  mask = mask ! modify access
               %else %if ch = 'A' %or ch = 'a'
                  mask = mask ! append access
               %else %if ch = 'X' %or ch = 'x'
                  mask = mask ! exchange access
               %else %if ch = 'L' %or ch = 'l'
                  mask = mask ! link access
               %else %if ch = 'C' %or ch = 'c'
                  mask = mask ! control access
               %else %if ch = '\'
                  mask = mask ! deny access
               %else
                  %false
               %finish
               ch == ch [1];  n = n - 1
            %repeat
         %end

         %predicate obtain ID
            ID = 0
            %if ch = '-' %start
               sign = -1
               ch == ch [1];  n = n - 1
               %false %if n = 0 %or ch = ':' %or ch = ';'
            %else
               sign = 0
            %finish
            %cycle
               %if n = 0 %or ch = ':' %or ch = ';' %start
                  ID = -ID %if sign # 0
                  %true
               %finish
               %if '0' <= ch <= '9' %start
                  ID = 10 * ID + ch - '0'
               %else
                  %false
               %finish
               ch == ch [1];  n = n - 1
            %repeat
         %end

            ch == charno(P, 1);  n = length(P)
            %if ch # ';' %start
               ! Owner defined
               %false %unless obtain protection
               %false %if mask & deny access # 0
               new numeric attribute(owner access attribute, mask, 0)
            %finish
            ch == ch [1];  n = n - 1;  ! Skip the separator
            %while n > 0 %and (ch = '-' %or '0' <= ch <= '9') %cycle
               ! Look for the group protections.  First the group ID...
               %false %unless obtain ID
               %if ID = 0 %start
                  ! Cancel all groups.  This must be specified on
                  ! its own (without any other group definitions).
                  %false %if groups > 0
                  groups = -1;  ! Note cleardown
               %else
                  ! A real group specified
                  %false %if groups < 0
                  groups = 1;  ! Note group
               %finish
               ! Now try for the protection mask.
               %if n = 0 %or ch = ';' %start
                  ! Default if nothing specified
                  mask = read access
               %else
                  ! Skip the separator and try to interpret it
                  ch == ch [1];  n = n - 1
                  %false %if n <= 0
                  %false %unless obtain protection
               %finish
               new numeric attribute(group access attribute, mask, ID)
               ch == ch [1];  n = n - 1;  ! Skip the separator
            %repeat
            %true %if n <= 0;  ! No world protection defined
            %if n = 1 %and ch = '.' %start
               mask = 0;  n = 0
            %else
               %false %unless obtain protection
               %false %if mask & deny access # 0
            %finish
            new numeric attribute(world access attribute, mask, 0)
            %false %unless n = 0
            %true
      %end

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

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

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

      %unless split request(buffer, request bytes, command, UXno,
                            P1, P2, data buffer, data bytes) %start
         -> protocol error
      %finish
      !! printstring("Port ");  write(port, 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(port)
      %if Uno <= 0 %start
         copy string("-? No Unos", 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)
      status = LA validate user(P1, P2, U_fsys access, U_default path)
      !! printstring("Validate status ");  write(status, 0);  newline
      !! printstring("Default path: """);  printstring(U_default path)
      !! print symbol('"');  newline
      %if status # 0 %or U_default path = "" %start
         U_port = 0;  ! Free it up again
         {} unpack date(get datestamp, textual response, P2)
         {} printstring(textual response);  space;  printstring(P2)
         {} print port info(port)
         {} printstring(": logon ");  printstring(P1)
         {} printstring(" fails ");  write(status, 0);  newline
         copy string("-? User validation fails", buffer, buffer pos)
         -> send with newline
      %finish
      U_username = P1;  ! Have to remember for FC pass, etc
      U_opened datestamp = get datestamp;  U_used datestamp = U_opened datestamp
      U_access_local == U_fsys access
      U_fsys access_privileges = U_fsys access_privileges ! no local privilege
      U_default path = U_default path . ":" %c
         %unless charno(U_default path, length(U_default path)) = ':'
      U_login path = U_default path
      {} unpack date(U_opened datestamp, P1, P2)
      {} printstring(P1);  space;  printstring(P2)
      {} print port info(port)
      {} printstring(": logon ");  printstring(U_username);  printstring(" as ")
      {} write(Uno, 0);  printstring(", default path ")
      {} printstring(U_default path);  newline
      ! Now return the allocated Uno to the user, together with the default path
      copy byte(Uno + '0', buffer, buffer pos)
   !P copy string(U_default path, buffer, buffer pos)
      -> send with newline

op(FC logoff):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, port)
      U == Uno info(UXno)
      cleardown port(port, UXno)
      {} i = get datestamp
      {} unpack date(i, P1, P2)
      {} printstring(P1);  space;  printstring(P2)
      {} print port info(port)
      {} printstring(": logoff ");  printstring(U_username)
      {} printstring(" from ");  write(UXno, 0);  newline
      U_port = 0
      -> send with newline

op(FC delete):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, port)
      -> protocol error %if P1 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      prepend default(U, P1)
      status = F delete file(U_access, 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, port)
      -> 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_access, 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_access, 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_access, 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, port)
      -> protocol error %if P1 = ""
      P2 = "RMAXLC;R" %if P2 = ""
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      %if charno(P2, 1) = '!' %start
         ! Change owner
         -> protocol error %if length(P2) <= 1
         P2 = sub string(P2, 2, length(P2))
         %if charno(P2, 1) = '-' %start
            ! Group ownership (numeric)
            i = StoI(P2)
            !! printstring("Changing ownership of ");  printstring(P1)
            !! printstring(" to ");  write(i, 0);  newline
            new numeric attribute(file owner attribute, i, 0)
         %else
            ! Single owner (by username)
            status = LA enquire user(P2, fsys access, P2, textual response)
            %if status # 0 %start
               copy string("-? Unknown user ", buffer, buffer pos)
               copy string(P2, buffer, buffer pos)
               -> send with newline
            %finish
            new numeric attribute(file owner attribute, fsys access_user ID, 0)
         %finish
      %else
         ! Set protection
         -> dud protection %unless construct protection(P2)
      %finish
      prepend default(U, P1)
      status = F modify attributes(U_access, P1, attr list, textual response)
      %while attr list ## nil %cycle
         attr == attr list
         attr list == attr list_next
         %if status = 0 %and attr_status # 0 %start
            status = attr_status
            textual response = "Change attribute " . itos(attr_code, 0) . %c
                               " failed " . itos(attr_status, 0)
         %finish
         dispose(attr)
      %repeat
      -> send textual error %if status # 0
      -> send with newline

dud protection:
      %while attr list ## nil %cycle
         attr == attr list
         attr list == attr list_next
         dispose(attr)
      %repeat
      copy string("-? Invalid protection specified", buffer, buffer pos)
      -> send with newline

op(FC credir):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, port)
      -> protocol error %if P1 = ""
      U == Uno info(UXno)
      %if P2 = "" %start
         n = -1
      %else
         -> no privilege %if U_fsys access_privileges & admin privilege = 0
         n = charno(P2, 1) - '0'
         -> protocol error %unless 0 < n <= 9;  ! May be errors later, of course
      %finish
      U_used datestamp = get datestamp
      prepend default(U, P1)
      status = F create directory P(U_access, 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, port)
      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, buffer, buffer pos)
      copy string(P1, buffer, buffer pos)
      buffer pos = buffer pos - 1;  ! Lose the ':'
      copy string(" (", buffer, buffer pos)
      copy string(U_username, buffer, buffer pos)
      copy string(", ", buffer, buffer pos)
      copy string(itos(U_fsys access_user ID, 0), buffer, buffer pos)
      copy string(", ", buffer, buffer pos)
      copy string(U_login path, buffer, buffer pos)
      copy string(") on ", buffer, buffer pos)
      datestamp = get datestamp
      unpack date(datestamp, P1, P2)
      copy string(day of week(datestamp), buffer, buffer pos)
      copy byte(' ', buffer, buffer pos)
      copy string(P1, buffer, buffer pos)
      copy string(" at ", buffer, buffer pos)
      copy string(P2, buffer, buffer pos)
finfo send:
      response bytes = buffer pos;  buffer pos = 0;  ! Go back for the length
      copy I to H2(response bytes - 3, buffer, buffer pos)
      %return

finfo n:
      status = F enquire nth directory entry(U_access, P1, n, P2,
                                             textual response)
      -> send textual error %if status # 0
      %if P2 = "" %start
         ! No such file (number) in directory
         copy string("00", 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, buffer, buffer pos)
      copy string(P2, buffer, buffer pos)
      copy string("  ", 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_access, P1, P2, textual response)
      %if status = 0 %start
         copy string(P2, buffer, buffer pos)
      %else
         copy string("-> ", buffer, buffer pos) %if status > 0
         copy string(textual response, buffer, buffer pos)
      %finish
      convert metacharacters(buffer, buffer pos)
      -> finfo send

op(FC ninfo):
      -> dud Uno %unless validate Uno(UXno, port)
      -> 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_access, P1, P2, textual response)
      -> send textual error %if status # 0
      buffer pos = 2
      copy byte(NL, buffer, buffer pos)
      copy string(P1, buffer, buffer pos)
      copy string("  ", buffer, buffer pos)
      copy string(P2, buffer, buffer pos)
      convert metacharacters(buffer, buffer pos)
      -> finfo send

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

op(FC pass):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, port)
      U == Uno info(UXno)
      U_used datestamp = get datestamp
      to upper(P1);  to upper(P2)
      !! printstring("Password change: ");  zprintstring(P1)
      !! space;  zprintstring(P2);  newline
   !X -> no privilege %if "" # P2 # U_username %c
   !X                     %and U_fsys access_privileges & admin privilege = 0
   !X P2 = U_username %if P2 = ""
   {} P2 = U_username
      status = LA modify password(P2, "", P1)
      {} unpack date(U_used datestamp, P1, P2)
      {} printstring(P1);  space;  printstring(P2)
      {} print port info(port)
      {} printstring(": change password ");  printstring(U_username)
      {} printstring(", status ");  write(status, 0);  newline
      copy string("-? Modify password failed", buffer, buffer pos) %c
         %if status # 0
      -> send with newline

op(FC setdir):
      -> not logged on %if UXno = 0
      -> dud Uno %unless validate Uno(UXno, port)
      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_access, 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, port)
      semaphore wait(internal copy semaphore)
      %if internal copy count <= 0 %start
         signal semaphore(internal copy semaphore)
         copy string("-? Too many internal copies already active",
                     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_access, 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, buffer, buffer pos)
      %if send response(port, 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, port)
      Xno = allocate Xno(UXno, port)
      %if Xno <= 0 %start
         copy string("-? No Xnos", 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_access, P1, read file mode, read file mode,
                           -1, 0, X_file token, 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', buffer, buffer pos)
      copy byte(',', buffer, buffer pos)
      X_mode = Xno read access
      X_access == U_access
      %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, buffer, buffer pos)
      copy byte(',', buffer, buffer pos)
      copy I to H2(512 - bytes in last, 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, port)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, port)
      %if Xno <= 0 %start
         copy string("-? No Xnos", 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_access, P1, read file mode ! modify file mode, 0,
                           -1, create flag, X_file token, 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', buffer, buffer pos)
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      X_mode = Xno modify access
      X_access == U_access
      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, port)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, port)
      %if Xno <= 0 %start
         copy string("-? No Xnos", 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_access, P1, read file mode ! modify file mode, 0,
                           -1, create if flag, X_file token, 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', buffer, buffer pos)
      copy byte(',', buffer, buffer pos)
      length(P1) = 31 %if length(P1) > 31;  X_filename = P1
      X_mode = Xno read access ! Xno modify access
      X_access == U_access
      %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, buffer, buffer pos)
      copy byte(',', buffer, buffer pos)
      copy I to H2(512 - bytes in last, buffer, buffer pos)
      -> send with newline

op(FC reset):
      -> dud Xno %unless validate Xno(UXno, port)
      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, port)
      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_access, X_file token, i, textual response)
      X_Uno = -1
      -> send textual error %if status # 0
      -> send with newline

op(FC readsq):
      -> dud Xno %unless validate Xno(UXno, port)
      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", buffer, buffer pos)
            -> send with newline
         %finish
         status = F read block(X_access, X_file token, X_next block,
                               data bytes, record(addr(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, buffer, buffer pos)
         copy byte(NL, buffer, buffer pos)
         copy bytes(data(0), data bytes, buffer, buffer pos)
         wanted = wanted - 1
         %exit %if wanted = 0 %or data bytes < 512
         buffer pos = -1 %and %return %unless send response(port, buffer pos)
         buffer pos = 0
      %repeat
      response bytes = buffer pos
      %return

op(FC writesq):
      -> dud Xno %unless validate Xno(UXno, port)
      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_access, X_file token, X_next block,
                             data bytes, record(addr(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, port)
      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, port)
      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, port)
      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, port)
      -> protocol error %if P1 = ""
      Xno = allocate Xno(UXno, port)
      %if Xno <= 0 %start
         copy string("-? No Xnos", 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_access, P1, read file mode, read file mode,
                           -1, 0, X_file token, 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_access == U_access
      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, buffer, buffer pos)
      copy byte(',', buffer, buffer pos)
      copy I to H2(512 - bytes in last, buffer, buffer pos)
      copy byte(NL, buffer, buffer pos)
      buffer pos = -1 %and %return %unless send response(port, 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_access, X_file token, X_next block,
                               data bytes, record(addr(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 %unless send response(port, 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_access, X_file token, 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(port, 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, port)
      -> not implemented

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

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

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

send textual error:
      %if status < 0 %start
         copy string("-? ", buffer, buffer pos)
      %else
         copy string("-> ", buffer, buffer pos)
      %finish
      copy string(textual 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 '", buffer, buffer pos)
      copy byte(command, buffer, buffer pos)
      copy string("' not meaningful", buffer, buffer pos)
      -> send with newline

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

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

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

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

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

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

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

%routine interpreter process
   %record(port fm)%name p
   %integer bytes, port, status
   %bytearray x(0 : 3)
   %ownrecord(semaphore fm) disaster = 0
   %record(poa fm)%name process
   %integer i
      %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(0, ":N");  select input(0)
      open output(0, ":T");  select output(0)
      setup semaphore(disaster)
      %cycle
         receive next request(port, bytes, status)
         %if 0 < port <= max ports %and status = ether success %start
            !! write(bytes, 0);  printstring(" received from ")
            !! write(port, 0);  newline
            p == port info(port)
            %if p_buffer = 4 %or p_buffer = 12 %start
               trace(port, '*', bytes, p_buffer)
               interpret request(port, bytes, p_buffer, bytes)
               ! Don't start another receive operation.
            %else
               trace(port, '<', bytes, p_buffer)
               interpret request(port, bytes, p_buffer, bytes)
               %if bytes >= 0 %and send response(port, bytes) %start;  %finish
               start receive(port)
            %finish
         %else
            printstring("P_H2: receive -- ether error ")
            write(status, 0);  printstring(", port ");  write(port, 0)
            newline
            trace(port, '*', 0, x(0))
            interpret request(port, -1, x(0), bytes) %c
               %if 0 < port <= max ports
            ! 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, z1, z2, z3, z4, req fac,
                           %bytearray x(0 : 532))

%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(port 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
         %if event_event = 15 %start
            printstring("Ether error (port 0 H2 listener): ")
            printstring(event_message)
            newline
            string(addr(p0 buffer_z4)) = "-? Ether error: " . %c
                                         event_message . SNL
            -> reply
         %finish
         ! 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(0, ":N");  select input(0)
      open output(0, ":T");  select output(0)
      setup semaphore(disaster)
      FS insert(PH2 state name, addr(PH2 state))
      i = Find Entry("ETHER_REQ", poa_logdict)
      %if i = 0 %start
         printstring("No ether request mailbox??");  newline
         %stop
      %finish
      ether request mailbox == record(integer(i))
      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(UXno allocation semaphore)
      signal semaphore(UXno allocation semaphore)
      setup semaphore(internal copy semaphore)
      signal semaphore(internal copy semaphore)
      construct anon
      Xno info(i)_Uno = -1 %for i = 1, 1, max Xno
      trace buffer_s = trace size
      port info(i)_buffer == byteinteger(heap get(ether max)) %c
         %for i = 1, 1, max ports
      FS insert(trace buffer name, addr(trace buffer))
      FS insert(port table name, addr(port info(1)))
      FS insert(Uno table name, addr(Uno info(0)))
      FS insert(Xno table name, addr(Xno info(1)))
      F external redirect off = 1
      F old style handling = 1
      F no explicit device = 1
      F enable dot dot = 1
      ! 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
         p0 buffer == receive message(our p0 mailbox)
         !! printstring("Connect request from ");  phex2(p0 buffer_ra)
         !! print symbol('.');  phex2(p0 buffer_rp);  newline
         %if PH2 state & 1 = 0 %start
            ! Local file system isn't running yet
            string(addr(p0 buffer_Z4)) = "-? 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 ports %cycle
            p == port 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 port(i)
               %exit
            %finish
         %repeat
         ! Now get a new port for the client
         i = ether allocate port
         %if i > 0 %start
            !! printstring("Port ");  write(i, 0)
            !! printstring(" allocated to ");  phex2(p0 buffer_ra)
            !! print symbol('.');  phex2(p0 buffer_rp);  newline
            p == port info(i)
            ether open port(i, p0 buffer_ra, p0 buffer_rp)
            p_remote address = p0 buffer_ra
            p_remote port = p0 buffer_rp
            p_open datestamp = get datestamp
            start receive(i)
            p0 buffer_z4 = 2
            p0 buffer_req fac = i + '0'
            p0 buffer_x(0) = NL
         %else
            string(addr(p0 buffer_z4)) = "-? No free ports" . SNL
         %finish
reply:   send message(p0 buffer, p0 buffer_system part_reply, nil)
      %repeat
x:    interpreter process
%end %of %program
