! Special file system, implementing '$' pseudo-files.  One process only,
! so no semaphores needed.

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

%option "-low-nonstandard-nocheck-nodiag-noline"

%constinteger buffer size = 4095
%constinteger buffers = 6

%include "Moose:Mouse.Inc"
%include "Sys:Ether.Inc"

%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:FacMess.Inc"
%include "GDMR_H:Dir.Inc";       ! For path fm
%include "GDMR_H:DateTime.Inc"

!! %include "GDMR_H:Dump.Inc"

%externalpredicatespec FS lookup(%string(31) what, %integername result)

%systemroutinespec phex(%integer i)
%systemroutinespec phex2(%integer i)
%systemstring(31)%fnspec itos(%integer i, j)
%systemintegerfnspec free store

%externalroutinespec FS insert(%string(31) name, %integer value)

%ownrecord(mailbox fm) request mailbox = 0
%ownrecord(semaphore fm) request semaphore = 0


!! %routine xprintstring(%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


! Buffers and buffer manipulation

%recordformat buffer fm(%record(mailbox fm)%name followup mailbox,
                        %integer buffer ID, size,
                        %bytename file,
                        %bytearray x(0 : buffer size))
%ownrecord(buffer fm)%array buffer(0 : buffers) = 0(*)
%owninteger buffer mask = 0

%integerfn claim buffer
   %record(buffer fm)%name b
   %integer i, m
      %for i = 0, 1, buffers %cycle
         m = 1 << i
         %if buffer mask & m = 0 %start
            !! printstring("Buffer ");  write(i, 0)
            !! printstring(" claimed");  newline
            buffer mask = buffer mask ! m
            b == buffer(i)
            b_size = 0
            b_buffer ID = i
            b_file == b_x(0)
            b_followup mailbox == request mailbox
            %result = i
         %finish
      %repeat
      !! printstring("No free special buffer");  newline
      %result = -1
%end

%routine free buffer(%integer which)
   !! printstring("Buffer ");  write(which, 0)
   !! printstring(" released");  newline
   buffer mask = buffer mask & (\ (1 << which))
%end

%routine put byte(%integer what, %record(buffer fm)%name b)
   !! printstring("Put byte ");  write(what, 0)
   !! %if ' ' <= what <= '~' %start
   !!    printstring(" (");  print symbol(what)
   !!    print symbol(')')
   !! %finish
   !! newline
   %return %if b_size >= buffer size
   b_x(b_size) = what
   b_size = b_size + 1
%end

%routine put text(%string(255) what, %record(buffer fm)%name b)
   %integer i
      !! printstring("Put text """);  xprintstring(what)
      !! print symbol('"');  newline
      %return %if what = ""
      %for i = 1, 1, length(what) %cycle
         %return %if b_size >= buffer size
         b_x(b_size) = charno(what, i)
         b_size = b_size + 1
      %repeat
%end

%routine put integer(%integer n, f, %record(buffer fm)%name b)
   put text(itos(n, f), b)
%end

%routine put hex2(%integer n, %record(buffer fm)%name b)
   %integer x
      x = (n >> 4) & 15;  %if x <= 9 %then x = x + '0' %else x = x - 10 + 'A'
      put byte(x, b)
      x =  n       & 15;  %if x <= 9 %then x = x + '0' %else x = x - 10 + 'A'
      put byte(x, b)
%end

%routine put hex8(%integer n, %record(buffer fm)%name b)
   %integer x, i
      %for i = 1, 1, 8 %cycle
         x = (n >> 28) & 15
         %if x <= 9 %then put byte(x + '0', b) %c
                    %else put byte(x - 10 + 'A', b)
         n = n << 4
      %repeat
%end

%routine put spaces(%integer n, %record(buffer fm)%name b)
   %while n > 0 %and b_size < buffer size %cycle
      b_x(b_size) = ' '
      b_size = b_size + 1;  n = n - 1
   %repeat
%end

%routine put date and time(%integer dt stamp, %record(buffer fm)%name b)
   %string(15) d, t
      unpack date(dt stamp, d, t)
      put text(d, b);  put byte(' ', b)
      put text(t, b)
%end

%routine copy data(%integer n, %bytename from, %record(*)%name to)
   !! printstring("Copy data: ");  write(n, 0)
   !! printstring(" bytes from ");  phex(addr(from))
   !! printstring(" to ");  phex(addr(to));  newline
   !! A0 = addr(from);  A1 = addr(to)
   D0 = n - 1
L: *move.b (A0)+, (A1)+
   *dbra D0, L
%end


! Formats, constants and names (copied from other modules).

! From P_H2...

%constinteger max Uno = 12
%constinteger max Xno = 24
%constinteger max ports = 63
%constinteger ether max = 536

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

%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


! From FSys...

%constinteger partitions = 7
%constinteger open file limit = 48

! File header formats & constants.

! Access definitions (conventionally ID > 0 for user, < 0 for group)
%recordformat header access fm(%integer ID, access)

! Extent definition
%recordformat extent fm(%integer start, size)

! Header definition
%constinteger non extent size = 8 + 2 + 2 + 12 + 8 + %c
                                12 + 12 + 16 + 4 + 2 + 2

%constinteger extent limit = (512 - non extent size) // 8
%constinteger access table size = extent limit;  ! One grows up, other down

%recordformat file header fm((%integer checksum, ID,
                              %short header refcount,
                              %short flags,
                              %integer owner, owner access, supervisor,
                              %integer world access, local access,
                              %integer creator, static ID, audit ID,
                              %integer created, modified, accessed,
                              %string(15) creation name,
                              %integer blocks used,
                              %short bytes in last block,
                              %short extent limit,
                              ( %record(header access fm)%array %c
                                    access(1 : access table size) %c
                            %or %record(extent fm)%array %c
                                    extent(1 : extent limit)) %c
                             ) %or %integerarray x(1 : 128))

! File header modes

%constinteger no        access =   0   { File is inaccessible
%constinteger read      access =   1   { File can be read
%constinteger modify    access =   2   { File can be modified
%constinteger append    access =   4   { File can be appended to
%constinteger exchange  access =   8   { File can be (extent) exchanged
%constinteger link      access =  16   { File can be (un)linked
%constinteger control   access =  32   { File attributes can be modified
%constinteger deny      access =  64   { Invert sense of access bits

! Partition tables

%recordformat partition fm(%integer size, flags, index site, index size, bitmap,
                           %bytename header allocation bitmap,
                           %record(file header fm) index header)
%constinteger partition valid      = 1
%constinteger partition hazarded   = 2
%constinteger partition structured = 4

! Open file tables

%recordformat header cache fm(%integer refcount, dirty,
                              %record(semaphore fm) semaphore,
                              %record(file header fm) h)

%recordformat open file table fm(%integer ID,
                                 %integer mode,
                                 %integer compatible,
                                 %record(header cache fm)%name fh)
! Should be something about access here too?

%constinteger slot allocated = 16_80000000

! Process-common tables (including interlock semaphores) -> dictionary

%recordformat header lookaside fm(%record(header lookaside fm)%name next,
                                  %record(header cache fm) h)
! Needed, since we can't (easily) share the heap

%recordformat common tables fm(%record(semaphore fm) initialisation semaphore,
                               %record(semaphore fm) open file table semaphore,
                               %record(partition fm)%array %c
                                  partition(1 : partitions),
                               %record(open file table fm)%array %c
                                  open file table(1 : open file limit),
                               %record(header lookaside fm)%name hll)

%conststring(31) fsys tables name = "FS_FSYS_TABLES"


! From Bitmap...

%recordformat bitmap fm(%integer size, next, increment,
                        %integername map,
                        %record(semaphore fm) semaphore)


! Special file creation routines

%routine fill Unos(%record(buffer fm)%name b)
   %ownrecord(Uno info fm)%name Uno table == nil
   %record(Uno info fm)%name U
   %integer i, n
      %if Uno table == nil %start
         Uno table == record(i) %if FS lookup(Uno table name, i)
         %if Uno table == nil %start
            put text("** No Uno table available", b)
            put byte(NL, b)
            %return
         %finish
      %finish
      U == Uno table
      %for n = 0, 1, max Uno %cycle
         %if U_port # 0 %or n = 0 %start
            put integer(n, 2, b)
            put integer(U_port, 2, b);  put spaces(2, b)
            put text(U_username, b)
            put spaces(12 - length(U_username), b)
            put byte(' ', b);  put text(U_default path, b)
            put spaces(22 - length(U_default path), b)
            put byte(' ', b);  put date and time(U_opened datestamp, b)
            put spaces(2, b);  put date and time(U_used datestamp, b)
            put byte(NL, b)
         %finish
         U == U [1]
      %repeat
%end

%routine fill Xnos(%record(buffer fm)%name b)
   %ownrecord(Xno info fm)%name Xno table == nil
   %record(Xno info fm)%name X
   %integer i, n
      %if Xno table == nil %start
         Xno table == record(i) %if FS lookup(Xno table name, i)
         %if Xno table == nil %start
            put text("** No Xno table available", b)
            put byte(NL, b)
            %return
         %finish
      %finish
      X == Xno table
      %for n = 1, 1, max Xno %cycle
         %if X_Uno >= 0 %start
            put integer(n, 2, b)
            put integer(X_Uno, 2, b)
            put spaces(2, b);  put text(X_filename, b)
            put spaces(31 - length(X_filename), b)
            put byte(' ', b);  put date and time(X_opened datestamp, b)
            put spaces(2, b);  put date and time(X_used datestamp, b)
            put spaces(2, b)
            put byte('R', b) %if X_mode & Xno read access # 0
            put byte('M', b) %if X_mode & Xno modify access # 0
            put byte(NL, b)
         %finish
         X == X [1]
      %repeat
%end

%routine fill ports(%record(buffer fm)%name b)
   %ownrecord(port fm)%name port table == nil
   %record(port fm)%name P
   %integer i, n
      %if port table == nil %start
         port table == record(i) %if FS lookup(port table name, i)
         %if port table == nil %start
            put text("** No port table available", b)
            put byte(NL, b)
            %return
         %finish
      %finish
      P == port table
      %for n = 1, 1, max ports %cycle
         %if P_remote address # 0 %start
            put integer(n, 2, b);  put spaces(2, b)
            put hex2(P_remote address, b);  put byte('.', b)
            put hex2(P_remote port, b);  put spaces(2, b)
            put date and time(P_open datestamp, b);  put spaces(2, b)
            put date and time(P_transmit datestamp, b)
            put byte(NL, b)
         %finish
         P == P [1]
      %repeat
%end

%constinteger trace buffer size = 8 + 128 * (16 + 48)
%conststring(31) trace buffer name = "P_H2_TRACE_BUFFER"

%routine map trace buffer(%record(buffer fm)%name b)
   %integer i
      %if FS lookup(trace buffer name, i) %start
         b_file == byteinteger(i)
         b_size = trace buffer size
      %finish
      ! Else, size will be zero
%end

%record(common tables fm)%map fsys tables
   %ownrecord(common tables fm)%name tables == nil
   %integer i
      %if tables == nil %start
         tables == record(i) %if FS lookup(fsys tables name, i)
      %finish
      !! printstring("FSys tables at ");  phex(addr(tables));  newline
      %result == tables
%end

%routine map bitmap(%integer which, %record(buffer fm)%name b)
   %record(common tables fm)%name tables
   %record(bitmap fm)%name bitmap
   %record(partition fm)%name p
      tables == fsys tables
      %return %if tables == nil
      !! printstring("Map bitmap ");  print symbol(which);  newline
      %if '0' <= which <= '9' %start
         which = which - '0'
      %else %if 'A' <= which <= 'Z'
         which = which - 'A' + 10
      %else %if 'a' <= which <= 'z'
         which = which - 'a' + 10
      %finish
      %return %unless 0 < which <= partitions
      p == tables_partition(which)
      !! printstring("Partition table at ");  phex(addr(p))
      !! printstring(", flags ");  phex(p_flags);  newline
      %return %if p_flags & partition valid = 0 %c
              %or p_flags & partition structured = 0
      bitmap == record(p_bitmap)
      b_file == byteinteger(addr(bitmap_map))
      b_size = bitmap_size // 8
%end


%routine fill open files(%record(buffer fm)%name b)
   %record(common tables fm)%name tables
   %record(open file table fm)%name oft
   %integer i
      tables == fsys tables
      %return %if tables == nil
      %for i = 1, 1, open file limit %cycle
         oft == tables_open file table(i)
         %if oft_mode # 0 %start
            put hex8(oft_ID, b);  put spaces(3, b)
            %if oft_mode = 0 %start
               put text("*none*", b)
            %else
               put byte('R', b) %if oft_mode & read     access # 0
               put byte('M', b) %if oft_mode & modify   access # 0
               put byte('A', b) %if oft_mode & append   access # 0
               put byte('X', b) %if oft_mode & exchange access # 0
               put byte('L', b) %if oft_mode & link     access # 0
               put byte('C', b) %if oft_mode & control  access # 0
            %finish
            put spaces(3, b)
            %if oft_compatible = 0 %start
               put text("*none*", b)
            %else
               put byte('R', b) %if oft_compatible & read     access # 0
               put byte('M', b) %if oft_compatible & modify   access # 0
               put byte('A', b) %if oft_compatible & append   access # 0
               put byte('X', b) %if oft_compatible & exchange access # 0
               put byte('L', b) %if oft_compatible & link     access # 0
               put byte('C', b) %if oft_compatible & control  access # 0
            %finish
            put byte(NL, b)
         %finish
      %repeat
%end


! Action routines for each of the meaningful request codes (open, read, close)

%routine do open file(%record(fs message fm)%name m)
   %record(buffer fm)%name b
   %record(path fm)%name p
   %string(255) name, s
   %integer assigned
      %if m_access mode # read file mode %start
         !! printstring("Trying to write to a special file");  newline
         m_components translated = 0
         m_error code = -1;  m_status = -1
         m_error text = "Invalid operation on read-only special file"
         %return
      %finish
      !! p == m_filename
      !! printstring("Open special file: name at ");  phex(addr(p))
      !! %if p ## nil %start
      !!    printstring(", name is """);  printstring(p_key)
      !!    print symbol('"')
      !! %finish
      !! newline
      assigned = claim buffer
      %if assigned < 0 %start
         m_components translated = 0
         m_error code = -1;  m_status = -1
         m_error text = "No free special buffer"
         %return
      %finish
      b == buffer(assigned)
      p == m_filename
      %if p == nil %or p_key = "" %start
         ! Null name specified, assume we want the "directory" listing
         !! printstring("Generating ""directory"" listing");  newline
         put text("BITMAP.x",     b);  put byte(NL, b)
         put text("OPEN_FILES",   b);  put byte(NL, b)
         put text("PORTS",        b);  put byte(NL, b)
         put text("TRACE_BUFFER", b);  put byte(NL, b)
         put text("UNOS",         b);  put byte(NL, b)
         put text("XNOS",         b);  put byte(NL, b)
         -> success response
      %finish
      name = p_key;  to upper(name)
      !! printstring("Do open ");  printstring(name);  newline
      %if name = "UNOS" %start
         fill Unos(b)
      %else %if name = "XNOS"
         fill Xnos(b)
      %else %if name = "PORTS"
         fill ports(b)
      %else %if name = "OPEN_FILES"
         fill open files(b)
      %else %if name = "TRACE_BUFFER"
         map trace buffer(b)
      %else %if name -> ("BITMAP.") . s %and s # ""
         map bitmap(charno(s, 1), b)
      %else
         ! Come in here if the name wasn't recognised
         free buffer(assigned)
         m_components translated = 0
         m_error code = -1;  m_status = -1
         m_error text = "Unrecognised special file"
         %return
      %finish
      ! Drop through here on success: return token, size and status to caller
success response:
      m_file token = addr(b);  m_bytes = b_size
      m_response flags = 0
      %if p == nil %then m_components translated = 0 %c
                   %else m_components translated = 1
      m_error code = 0;  m_status = 0
      !! printstring("Common success: token ");  phex(m_file token)
      !! printstring(", size ");  write(m_bytes, 0);  newline
%end

%routine do close file(%record(fs message fm)%name m)
   %record(buffer fm)%name b
      !! printstring("Do close (special) file");  newline
      b == record(m_file token)
      free buffer(b_buffer ID)
      m_error code = 0;  m_status = 0
%end

%routine do read data(%record(fs message fm)%name m)
   %record(buffer fm)%name b
   %integer p, n
      !! printstring("Do read (special) data: block ");  write(m_block, 0)
      !! printstring(", bytes ");  write(m_bytes, 0);  newline
      b == record(m_file token)
      p = m_block << 9
      %if 0 <= p <= b_size %start
         n = m_bytes
         n = b_size - p %if p + n > b_size
         copy data(n, b_file [p], m_buffer)
         m_bytes = n
         m_error code = 0;  m_status = 0
         !! dump(m_bytes, byteinteger(addr(m_buffer)))
      %else
         m_error code = -1;  m_status = -1
         m_error text = "End of (special) file"
      %finish
%end

%routine data access(%record(fs message fm)%name m)
   %if m_subcode = open file subcode %start
      do open file(m)
   %else %if m_subcode = read data subcode
      do read data(m)
   %else %if m_subcode = close file subcode
      do close file(m)
   %else
      m_error code = -1;  m_status = -1
      m_error text = "Subrequest not recognised or not implemented"
   %finish
%end

%begin
   %record(fs message fm)%name m
      open input(0, ":T");  select input(0)
      open output(0, ":T");  select output(0)
      setup semaphore(request semaphore)
      setup mailbox(request mailbox, request semaphore)
      FS insert(special file system mailbox, addr(request mailbox))
      {} printstring("F_Special: ");  write(free store, 0)
      {} printstring(" free");  newline
      %cycle
         m == receive message(request mailbox)
         %if m_code = data access code %start
            data access(m)
         %else
            m_error code= -1;  m_status = -1
            m_error text = "Unknown or unimplemented request code"
         %finish
         send message(m, m_system part_reply, nil)
      %repeat
%end %of %program
