! File system for new filestores using Mouse kernel

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

! To do: interaction between delete and open files
!        support for append-mode
!        improved handling for improperly-closed files

%constinteger partitions = 31
%constinteger open file limit = 48
%constinteger header cache size = 96
%constinteger bitmap increment = 6113;  ! Prime
%constinteger auto extend blocks = 32
%constinteger default initial blocks = 32
%constinteger access update interval = 1024;  ! Seconds, ~17 minutes

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

%constinteger infinity = 16_3FFFFFFF;  ! Large enough

%constinteger interrupts off = 16_0700;  ! SR with IPL 7

%include "Moose:Mouse.Inc"
%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:DateTime.Inc"

!! %include "GDMR_H:Dump.Inc"

%systemintegerfnspec global heap get(%integer size)

%externalstring(127)%fnspec itos(%integer i, j)
%systemroutinespec phex(%integer i)


! Dictionary access

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

%conststring(31) state name = "FSYS_STATE"
%owninteger fsys state = 0

! File access mode flags

%constinteger auto truncate  flag = 1
%constinteger improper close flag = 2

%constinteger non local flag = 16_00010000


! Error codes

%constinteger bugcheck                       = -100
%constinteger end of file              error = -101
%constinteger file header checksum     error = -102
%constinteger index file full          error = -103
%constinteger file table full          error = -104
%constinteger no such file             error = -105
%constinteger no authority             error = -106
%constinteger bad token                error = -107
%constinteger invalid size             error = -108
%constinteger bad operation            error = -109
%constinteger file header full         error = -110
%constinteger not file structured      error = -111
%constinteger partition ID             error = -112
%constinteger not implemented          error = -113
%constinteger incompatible mode        error = -114
%constinteger invalid block            error = -115
%constinteger no privilege             error = -116
%constinteger partition full           error = -117
%constinteger bad refcount increment   error = -118
%constinteger non zero refcount        error = -119
%constinteger dud file index           error = -120
%constinteger improperly closed file   error = -121
%constinteger file structured          error = -122


! Bitmap stuff

%include "GDMR_H:BitMap"


! File header formats & constants.

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

%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
%constinteger admin   required = 128   { Admin privilege needed to use field

%constinteger an altering access mode = modify access ! append access ! %c
                                        exchange access

%constinteger new owner access = read   access ! modify   access ! %c
                                 append access ! exchange access ! %c
                                 link   access ! control  access
%constinteger new local access = read access
%constinteger new world access = no access;  ! nil access -> local

%constinteger system ID = -1

! Flag word definitions
%constinteger overlapping        file  = 16_0002
%constinteger bad block          file  = 16_0004
%constinteger improperly closed  file  = 16_0008

%constinteger backup   required        = 16_0100
%constinteger archive  required        = 16_0200

%constinteger directory flags          = 16_C000;  ! Two bits for the dir layer

%constinteger multiple references      = 16_40000000;  ! Pseudo-flag
%constinteger world read access        = 16_20000000;  ! Pseudo-flag

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

! ID fields:
!     directory | partition | sequence | index
!       2 bits  |   6 bits  |  8 bits  | 16 bits

%constinteger index              part = 16_0000FFFF
%constinteger file ID            part = 16_00FFFFFF
%constinteger partition          part = 16_3F000000
%constinteger partition         shift = 24
%constinteger partition number   mask = partition part >> partition shift
%constinteger file ID            mask = 16_3FFFFFFF

%constinteger file sequence increment = 16_00010000


! Partition access.  Forward specs for procedures included at the end of
! this module to enforce proper layering.

%recordformat partition bad list fm(%integer n,
                                    %integerarray b(0 : 511))

%integerfnspec partition read(%integer block, %record(*)%name buffer)
%integerfnspec partition write(%integer block, %record(*)%name buffer)
%routinespec   partition enquiry(%integername v, s, h)
%routinespec   partition info(%integer pn,
                              %integername unit, disc start, size, flags)
%routinespec   partition bad list(%integer pn,
                                  %record(partition bad list fm)%name b)
%routinespec   partition prefetch(%integer block)

%recordformat partition fm(%integer size, flags, index site, index size, bitmap,
                           %bytename header allocation bitmap,
                           %record(file header fm) index header)
%constinteger partition valid          = 16_0001
%constinteger partition hazarded       = 16_0002
%constinteger partition structured     = 16_0004
%constinteger access logging enabled   = 16_0100


%recordformat partition header fm((%integer checksum, size, index, flags %c
                                  ) %or %integerarray x(1 : 128))
! Various extra stuff can go on the end later....


! Open file tables.  There are two "structures" involved here.  The simpler
! of the two is the open file table: this contains details of the user's
! (client's) use of the file; several concurrent users' entries are chained
! together for ease of access on a doubly-linked list.  The header cache
! table contains the (shared) header details: in parallel for convenience of
! machine-code access is an array containing the header's ID.

%recordformatspec header cache fm

%recordformat open file table fm(%integer ID,
                                 %integer mode,
                                 %integer compatible,
                                 %integer last block read,
                                 %integer header cache slot,
                                 %record(header cache fm)%name fhce,
                                 %record(open file table fm)%name last, next)
! Should be something about access here too?

%recordformat header cache fm(%integer stamp, refcount, status, dirty,
                              %record(semaphore fm) semaphore,
                              %record(open file table fm)%name use list,
                              %record(file header fm) h)

%constinteger slot allocated = 16_80000000


! Common file system tables

%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),
                               %integer header cache stamp,
                               %integerarray header ID(1 : header cache size),
                               %record(header cache fm)%array %c
                                  header cache(1 : header cache size),
                               %integer header cache hits, header cache misses)

%conststring(31) tables name = "FS__FSYS_TABLES"

%ownrecord(common tables fm)%name tables == nil


! File header checksum generation & verification

%routine set header checksum(%record(file header fm)%name h)
   %integer i, c
      c = 0
      c <- c + h_x(i) %for i = 2, 1, 128
      h_checksum = -c
%end

%predicate check header checksum(%record(file header fm)%name h)
   %integer i, c, x
   %label L, F
      ! (already) A0 = addr(h)
      D0 = 0;  D1 = 127
   L: *add.l (A0)+, D0
      *dbra D1, L
      *bne F
      %true
   F: !%false
      *move.l D0, x
      {} printstring("Suspect checksum ");  write(x, 0)
      {} printstring(" for ");  phex(h_ID);  newline
      c = 0
      c <- c + h_x(i) %for i = 1, 1, 128
      %true %if c = 0
      !! dump(512, byteinteger(addr(h)))
      %false
%end


! File I/O
! Scan through the extent list in the file header looking for the extent
! containing the requested block.  Apply the partition offset and do the
! transfer if found.

%integerfn read file block(%integer p,
                           %record(file header fm)%name h,
                           %integer block,
                           %record(*)%name buffer,
                           %integername next disc address)
   %record(extent fm)%name e
   %integer i, status, partition bits
      !! printstring("Read file block: partition ");  write(p, 0)
      !! printstring(", header at ");  phex(addr(h))
      !! printstring(", block ");  write(block, 0)
      !! printstring(", buffer ");  phex(addr(buffer));  newline
      %result = end of file error %if h_extent limit > extent limit
      partition bits = p << partition shift
      %for i = extent limit, -1, h_extent limit %cycle
         e == h_extent(i)
         %if block < e_size %start
            ! It's in this extent.  Read the block, then check for prefetch.
            status = partition read(partition bits + e_start + block, buffer)
            %result = status %if status < 0
            %if block = e_size - 1 %start
               ! Last block in the extent, tell our caller what the next
               ! one on disc will be (for prefetch).
               %if i = h_extent limit %start
                  ! No more extents -- indicate no prefetch
                  next disc address = 0
               %else
                  next disc address = h_extent(i - 1)_start ! partition bits
               %finish
            %else %if status > 0
               ! End of current cache chunk.  We know that there must be
               ! another block in the extent, else the previous condition
               ! would have held and we wouldn't be here.
               next disc address = (e_start + block + 1) ! partition bits
            %else
               ! No prefetch called for immediately
               next disc address = 0
            %finish
            %result = 0
         %else
            block = block - e_size
         %finish
      %repeat
      !! printstring("Read file block: out of extents")
      !! newline
      %result = end of file error
%end

%integerfn translate file block(%record(file header fm)%name h,
                                %integer block,
                                %integername disc address)
   %record(extent fm)%name e
   %integer i
      %result = end of file error %if h_extent limit > extent limit
      %for i = extent limit, -1, h_extent limit %cycle
         e == h_extent(i)
         %if block < e_size %start
            disc address = e_start + block
            %result = 0
         %else
            block = block - e_size
         %finish
      %repeat
      %result = end of file error
%end


%integerfn write file block(%integer p,
                            %record(file header fm)%name h,
                            %integer block,
                            %record(*)%name buffer)
   %record(extent fm)%name e
   %integer i
      %result = end of file error %if h_extent limit > extent limit
      %for i = extent limit, -1, h_extent limit %cycle
         e == h_extent(i)
         %if block < e_size %start
            %result = partition write((p << partition shift) + e_start + block,
                                      buffer)
         %else
            block = block - e_size
         %finish
      %repeat
      %result = end of file error
%end


! Index file I/O
! Since the index is just another file we can use the normal block
! transfer routines above.  The index's header is cached.

%integerfn read index block(%integer pn, n,
                            %record(file header fm)%name h)
   %integer status, prefetch block
      !! printstring("Read index block: partition ");  write(pn, 0)
      !! printstring(", slot ");  write(n, 0);  newline
      n = n & index part
      %unless 0 < n <= tables_partition(pn)_index size %start
         !! printstring("Read index block: n = ");  write(n, 0)
         !! printstring(", pn = ");  write(pn, 0);  newline
         %result = dud file index error
      %finish
      status = read file block(pn, tables_partition(pn)_index header,
                               n - 1, h, prefetch block)
      %result = status %if status < 0
      %result = file header checksum error %unless check header checksum(h)
      %result = 0
%end

%integerfn write index block(%integer pn, n,
                             %record(file header fm)%name h)
   !! printstring("Write index block: partition ");  write(pn, 0)
   !! printstring(", slot ");  write(n, 0);  newline
   set header checksum(h)
   n = n & index part
   %unless 0 < n <= tables_partition(pn)_index size %start
      !! printstring("Write index block: n = ");  write(n, 0)
      !! printstring(", pn = ");  write(pn, 0);  newline
      %result = dud file index error
   %finish
   %result = write file block(pn, tables_partition(pn)_index header, n - 1, h)
%end


! File size determination
! Scan the extent list adding up the sizes.

%integerfn file size(%record(file header fm)%name h)
   %integer i, s
      !! display header(h)
      s = 0
      s = s + h_extent(i)_size %for i = extent limit, -1, h_extent limit
      %result = s
%end


! File slot allocation stuff
! Slots in the file header are allocated from a bitmap for each
! partition, access to which is interlocked via the open file table
! semaphore (ASSUMED claimed).
! *Should really cycle through slots*

%integerfn allocate file slot(%record(partition fm)%name p)
   %integer i, j, k
   %bytename b
      b == p_header allocation bitmap
      %for i = 1, 1, p_index size // 8 %cycle
         %if b # 255 %start
            k = 1
            %for j = 0, 1, 7 %cycle
               %if b & k = 0 %start
                  ! Found one
                  b = b ! k
                  %result = 8 * i + j - 7
               %finish
               k = k << 1
            %repeat
         %finish
         b == b [1]
      %repeat
      %result = index file full error
%end

%routine free file slot(%record(partition fm)%name p, %integer slot)
   %integer byte, bit
   %bytename b
      %signal 13, 99, bugcheck %unless 0 < slot <= p_index size
      slot = slot - 1
      byte = slot // 8;  bit = slot & 7
      b == p_header allocation bitmap
      b [byte] = b [byte] & (\ (1 << bit))
%end

%routine claim file slot(%record(partition fm)%name p, %integer slot)
   %integer byte, bit
   %bytename b
      slot = slot - 1
      byte = slot // 8;  bit = slot & 7
      b == p_header allocation bitmap
      b [byte] = b [byte] ! (1 << bit)
%end


! Initialisation
! Obtain the partition details from the partition module and the
! partition headers (conventionally block 0 of each).  If the
! partition is structured, scan the index file and verify and build
! the bitmaps.

%routine load claim(%record(file header fm)%name h, %integer bitmap,
                    %integername tally)
   %record(extent fm)%name e
   %integer i
      tally = 0
      %for i = extent limit, -1, h_extent limit %cycle
         e == h_extent(i)
         %unless claim extent(e_start, e_size, bitmap) %start
            printstring("Claim extent fails for file ")
            phex(h_ID);  printstring(" extent ");  write(i, 0)
            printstring(": start ");  write(e_start, 0)
            printstring(", size ");  write(e_size, 0)
            newline
         %finish
         tally = tally + e_size
      %repeat
%end

%bytemap zapped map(%integer bytes)
   %integer where
      bytes = (bytes + 7) & (\ 3)
      where = global heap get(bytes)
      D0 = bytes // 4 - 1
      A0 = where
   L: *clr.l (A0)+
      *dbra D0, L
      %result == byteinteger(where)
%end

%routine load partition(%integer pn, structured, hazarded)
   %record(partition header fm) partition header
   %record(partition bad list fm) pbl
   %record(file header fm) fh
   %record(partition fm)%name p
   %integer c, j, k, status, px, i, tally, size tally, size
   %integer unit, disc start, partition size, partition flags
      !! printstring("Load partition ");  write(pn, 0)
      !! printstring(" structured") %if structured # 0
      !! printstring(" hazarded") %if hazarded # 0
      !! newline
      p == tables_partition(pn)
      px = pn << partition shift
      p_flags = partition valid ! access logging enabled;  !<<<<<<<<<
      p_flags = p_flags ! partition hazarded %if hazarded # 0
      partition info(pn, unit, disc start, partition size, partition flags)
      !! printstring("Partition ");  write(pn, 0)
      !! printstring(": unit ");  write(unit, 0)
      !! printstring(", disc start ");  phex(disc start)
      !! printstring(", size ");  write(partition size, 0)
      !! printstring(", flags ");  phex(partition flags);  newline
      p_size = partition size
      %return %if structured = 0
      ! Obtain the bad list
      partition bad list(pn, pbl)
      !! printstring("Partition ");  write(pn, 0)
      !! printstring(" bad list:");  newline
      !! %if pbl_n = 0 %start
      !!    printstring("  No bad blocks");  newline
      !! %else
      !!    %for i = 1, 1, pbl_n %cycle
      !!       write(pbl_b(i), 9)
      !!       newline %if i & 7 = 0
      !!    %repeat
      !!    newline %if i & 7 # 0
      !! %finish
      ! Scan the index file.
      p_flags = p_flags ! partition structured
      status = partition read(px, partition header)
      %if status < 0 %start
         printstring(" *disc error reading header*")
         newline
         %return
      %finish
      !! printstring("Got header");  newline
      c = 0
      c <- c + partition header_x(j) %for j = 1, 1, 128
      %if c # 0 %start
         printstring(" *header checksum error*")
         newline
         p_flags = 0
         %return
      %finish
      tally = 1
      ! Extract size and index offset, and set up bitmaps
      p_size = partition header_size
      %if p_size # partition size %start
         printstring("Partition ");  write(pn, 0)
         printstring(": header size ");  write(p_size, 0)
         printstring(" # disc header size ");  write(partition size, 0)
         printstring(" ??");  newline
      %finish
      p_index site = partition header_index
      p_bitmap = new bitmap(p_size, bitmap increment)
      status = partition read(px ! p_index site, p_index header)
      %if status < 0 %start
         printstring(" *index header checksum error*")
         newline
         p_flags = p_flags & (\ partition structured)
         %return
      %finish
      p_index size = file size(p_index header) & (\ 7)
      p_header allocation bitmap == zapped map(p_index size // 8)
      p_header allocation bitmap = 1;  ! Claim the index file
      load claim(p_index header, p_bitmap, size)
      size tally = size
      ! Preallocate the bad spots.  If any of these happen to overlap the
      ! index file then there may be complaints...
      %if pbl_n > 0 %start
         %for i = 1, 1, pbl_n %cycle
            %if claim extent(pbl_b(i) & (\ 7), 8, p_bitmap) %start;  %finish
         %repeat
      %finish
      !! printstring("Index size is ");  write(p_index size, 0);  newline
      %for i = 2, 1, p_index size %cycle
         !! printstring("Reading ");  write(i, 0);  newline
         status = translate file block(p_index header, i - 1, j)
         %if status = 0 %start
            ! Check to see if this index block is bad (we'll do this
            ! the hard way for now...)
            %for k = 1, 1, pbl_n %cycle
               %if pbl_b(k) & (\ 7) = j & (\ 7) %start
                  ! Dud block in the current index chunk -- ignore
                  ! the lot as otherwise adjacent files will cause
                  ! lots of errors....
                  !! printstring("Index slot ");  write(i, 0)
                  !! printstring(" at ");  write(j, 0)
                  !! printstring(" marked bad");  newline
                  claim file slot(p, i)
                  -> the next one
               %finish
            %repeat
         %else
            printstring("Failed to translate index slot address: ")
            write(status, 0);  newline
            p_flags = p_flags & (\ partition hazarded)
            %continue
         %finish
         status = read index block(pn, i, fh)
         %if status < 0 %start
            printstring("Failed to read file header ");  write(i, 0)
            space;  write(status, 0)
            newline
            !fh = 0
            !status = write index block(pn, i, fh)
            !printstring("Zap status ");  write(status, 0);  newline
            p_flags = p_flags & (\ partition hazarded);  ! Minimise damage
            %continue
         %finish
         %unless check header checksum(fh) %start
            printstring("File header checksum error for ")
            write(i, 0)
            newline
            p_flags = p_flags & (\ partition hazarded);  ! Minimise damage
            %continue
         %finish
         %if fh_ID & index part # 0 %start
            ! File slot is in use
            claim file slot(p, i)
            load claim(fh, p_bitmap, size)
            tally = tally + 1
            size tally = size tally + size
         %finish
the next one:
      %repeat
      printstring("Partition ");  write(pn, 0)
      printstring(": ");  write(tally, 0)
      printstring(" file");  print symbol('s') %if tally # 1
      printstring(" (max ");  write(p_index size, 0);  printstring(", ")
      write(100 * tally // p_index size, 0)
      printstring("%), ");  write(size tally, 0);  printstring(" blocks (")
      write(100 * size tally // p_size, 0);  printstring("%)")
      newline
%end

%externalroutine fsys initialise
   %integer v, s, h, i, m, t
   %record(semaphore fm)%name dt set sem
      !! printstring("FSys initialise");  newline
      %if tables == nil %start
         %if FS lookup(tables name, t) %start
            ! Tables are already in the dictionary.  Map them.
            tables == record(t)
            !! printstring("Tables found at ");  phex(addr(tables));  newline
            semaphore wait(tables_initialisation semaphore)
            signal semaphore(tables_initialisation semaphore)
         %else
            ! Tables weren't in the dictionary, so we must create them
            ! and initialise them.
            FS insert(state name, addr(fsys state))
            !! printstring("Tables size: ");  write(size of(tables), 0);  newline
            tables == record(global heap get(size of(tables)));  tables = 0
            setup semaphore(tables_initialisation semaphore)
            FS insert(tables name, addr(tables))
            !! printstring("Tables created at ");  phex(addr(tables));  newline
            setup semaphore(tables_open file table semaphore)
            signal semaphore(tables_open file table semaphore)
            ! Tables initialised, now do the partitions.
            partition enquiry(v, s, h)
            %for i = 1, 1, 31 %cycle
               m = 1 << i
               load partition(i, s & m, h & m) %if v & m # 0
            %repeat
            %if FS lookup("DATE_SET_SEMAPHORE", i) %start
               dt set sem == record(i)
               !! printstring("FSys finds set sem at ");  phex(addr(dt set sem))
               !! newline
               semaphore wait(dt set sem)
               signal semaphore(dt set sem)
            %else
               printstring("No date/time set semaphore??");  newline
            %finish
            fsys state = 1
            signal semaphore(tables_initialisation semaphore)
            t = -1
         %finish
      %finish
%end


! Return valid partition map

%externalroutine fsys valid partitions(%integername v, s)
   %integer i, j
      v = 0;  s = 0
      %for i = 1, 1, partitions %cycle
         j = tables_partition(i)_flags
         v = v ! (1 << i) %if j & partition valid # 0
         s = s ! (1 << i) %if j & partition structured # 0
      %repeat
%end


! Authority checks

%predicate file access authority OK(%record(file header fm)%name h,
                                    %record(fsys access fm)%name access,
                                    %integer mode, flags)
   %record(header access fm)%name a
   %integer permitted access, i, j, have owner access
      %true %if access == nil %or access_privileges & bypass privilege # 0
      permitted access = 0
      %for j = 1, 1, h_extent limit - 1 %cycle
         a == h_access(j)
         %exit %if a_ID = 0;  ! No more groups defined
         %for i = 1, 1, access_groups %cycle
            %if access_group(i) = a_ID %start
               %if a_access & deny access = 0 %start
                  permitted access = permitted access ! a_access %c
                     %if a_access & admin required = 0 %c
                     %or access_privileges & admin privilege # 0
               %else
                  permitted access = permitted access & (\ a_access)
               %finish
            %finish
         %repeat
      %repeat
      permitted access = permitted access ! h_world access %c
         %if h_world access & admin required = 0 %c
         %or access_privileges & admin privilege # 0
      permitted access = permitted access ! h_local access %c
         %if flags & non local flag = 0 %c
         %and (h_local access & admin required = 0 %c
               %or access_privileges & admin privilege # 0)
      %if h_owner access & admin required = 0 %c
      %or access_privileges & admin privilege # 0 %start
         have owner access = 0
         %for i = 1, 1, access_groups %cycle
            j = access_group(i)
            %if j = h_owner %or j = h_supervisor # 0 %or j = h_creator %start
               have owner access = 1
               %exit
            %finish
         %repeat
         permitted access = permitted access ! h_owner access ! control access %c
            %if h_owner = access_user ID %or h_creator = access_user ID %c
            %or 0 # h_supervisor = access_user ID %or have owner access # 0
      %finish
      permitted access = permitted access ! read access %c
         %if access_privileges & readall privilege # 0
      permitted access = permitted access ! append access ! exchange access %c
         %if permitted access & modify access # 0;  ! Implied
      %true %if permitted access & mode = mode
      %false
%end


! Open file table access.
! Each open file has a record here, containing access modes etc and a
! pointer to the file's header cache entry.  Files which are open more
! than once share the same header cache entry, which has a reference
! count, a dirty-bit, and an access semaphore as well as the header.
! Semaphore strategy: any manipulations of the headers themselves require
! that the per-header semaphore be claimed.  Any manipulations of the
! tables, as opposed to the headers, require that the global semaphore
! be claimed.

! ASSUME the global semaphore has been claimed when these are called.
! For convenience, RELEASE it should an error condition arise.

%integerfn get open file slot
   %record(open file table fm)%name o
   %integer i
      ! Scan the tables looking for an unused slot
      %for i = 1, 1, open file limit %cycle
         o == tables_open file table(i)
         %if o_mode = 0 %start
            o_mode = slot allocated
            o_ID = -2
            %result = i
         %finish
      %repeat
      ! None found
      signal semaphore(tables_open file table semaphore)
      %result = file table full error
%end


! WHATEVER happens, this one will RELEASE the file table semaphore.  If it
! succeeds it will return with the file header semaphore claimed.

%integerfn get header(%record(open file table fm)%name o)
   %constinteger header cache loop = header cache size - 1
   %record(header cache fm)%name h
   %record(open file table fm)%name others
   %integer x, i, oldest, oldest slot
   %label IDL, found it
      !! printstring("Get header for ");  phex(o_ID);  newline
      ! First off, search the cache for the header.  This loop is based on the
      ! one used by the partition cache manager.
      x = addr(tables_header ID(1))
      D1 = o_ID               { The file ID we're looking for
      *move.l x, A0           { The address of the first ID
      *move.l #header cache loop, D0
  IDL:*cmp.l (A0)+, D1        { Compare file IDs
      *dbeq D0, IDL           { Test comparison, decrement & loop
      ! NB: for the DBcc instruction, the cc tests true for NOT performing
      ! the decrement and branch!!  Either the cc test has succeeded, or we've
      ! reached the end of the loop.  The cc are still the same so we can just
      ! perform the appropriate conditional branch....
      *beq found it           { Test was true, we've found the entry

      ! If we drop through here the entry wasn't in the header cache.  We'll
      ! have to allocate a new slot and fetch it in.  It's not worth using
      ! loop mode here as there are too many comparisons involved.
      oldest = infinity
      %for i = 1, 1, header cache size %cycle
         h == tables_header cache(i)
         %if h_refcount <= 0 %and h_stamp < oldest %start
            oldest = h_stamp
            oldest slot = i
         %finish
      %repeat

      ! Found an unused-recently slot.  Initialise table entries, knitting.
      !! printstring("Header cache miss, using ");  write(oldest slot, 0);  newline
      o_header cache slot = oldest slot
      tables_header ID(oldest slot) = o_ID
      h == tables_header cache(oldest slot)
      setup semaphore(h_semaphore);  ! Implicitly claims it
      h_refcount = 1
      o_last == nil;  o_next == nil
      h_use list == o
      o_fhce == h
      tables_header cache misses = tables_header cache misses + 1
      tables_header cache stamp = tables_header cache stamp + 1
      h_stamp = tables_header cache stamp

      ! Release the tables semaphore, read in the header (header semaphore
      ! is still implicitly claimed).
      signal semaphore(tables_open file table semaphore)
      i = read index block(o_ID >> partition shift, o_ID, h_h)
      %if i < 0 %start
         ! Readin failed: dump it all
         semaphore wait(tables_open file table semaphore)
         h_refcount = h_refcount - 1
         %if h_refcount <= 0 %start
            ! Only ourselves interested.
            tables_header cache(oldest slot) = 0;  ! Anonymous slot ID
            h_stamp = 1;                           ! Force reuse
         %else
            ! Someone else now waiting.  Just note the status, then
            ! signal the semaphore to let them proceed.
            h_status = i
            signal semaphore(h_semaphore)
         %finish
         o = 0
         o_header cache slot = infinity
         signal semaphore(tables_open file table semaphore)
      %finish
      ! All done, return whatever status we have
      %result = i

found it:
      ! The entry was in the cache.  Check for compatibility with other users,
      ! bump the refcount and link us on.
      *move.l A0, x
      o_header cache slot = (x - addr(tables_header ID(1))) >> 2
      !! printstring("Header cache hit at ");  write(o_header cache slot, 0);  newline
      tables_header cache hits = tables_header cache hits + 1
      h == tables_header cache(o_header cache slot)
      %if h_status < 0 %start
         ! A previous readin failed.  Just return the same error for now....
         i = h_status
         o = 0
         o_header cache slot = infinity
         signal semaphore(tables_open file table semaphore)
         %result = i
      %finish
      tables_header cache stamp = tables_header cache stamp + 1
      h_stamp = tables_header cache stamp
      %if h_refcount <= 0 %start
         ! No one else interested.  No need to check compatibility, just
         ! link us on and return success....
         h_refcount = 1
         o_last == nil;  o_next == nil
         h_use list == o
         o_fhce == h
         setup semaphore(h_semaphore);  ! Implicitly claim it
         signal semaphore(tables_open file table semaphore)
         %result = 0
      %finish
      ! The refcount is non-zero, so someone else is already interested in
      ! this file.  Before we link ourselves in we have to check that our
      ! intended access is allowed by those other users.
      others == h_use list
      %if others == nil %start
         ! Apparently there were no other users!?
         !! printstring("Bogus refcount for ");  phex(o_ID);  newline
         o = 0
         o_header cache slot = infinity
         signal semaphore(tables_open file table semaphore)
         %result = bugcheck
      %finish
      %while others ## nil %cycle
         %if others_compatible & o_mode # o_mode %c
         %or o_compatible & others_mode # others_mode %start
            ! Either they've disallowed us or we've disallowed them
            o = 0
            o_header cache slot = infinity
            signal semaphore(tables_open file table semaphore)
            %result = incompatible mode error
         %finish
         others == others_next
      %repeat
      ! No complaints, so bump the refcount and link us in.  Easiest is at
      ! the front of the list.
      h_refcount = h_refcount + 1
      others == h_use list
      o_next == others;  o_last == nil
      others_last == o;  h_use list == o
      o_fhce == h
      ! Finally, switch semaphores and return success
      signal semaphore(tables_open file table semaphore)
      semaphore wait(h_semaphore)
      %result = 0
%end

! This one is entered with the per-header semaphore claimed.  It releases
! that one and claims the global semaphore.

%routine forget header(%record(open file table fm)%name o)
   %record(header cache fm)%name h
!! %record(open file table fm)%name x
      !! printstring("Forget header ");  phex(o_ID);  newline
      h == o_fhce
      !! %if h_dirty # 0 %start
      !!    printstring("Forgetting dirty header ??")
      !!    newline
      !! %finish
      signal semaphore(h_semaphore)
      semaphore wait(tables_open file table semaphore)
      h_refcount = h_refcount - 1
      %if h_refcount <= 0 %start
         ! Header reference count indicates no-one is interested in
         ! the header.  This is the easy case, as we can just zap the
         ! necessary fields.
         h_use list == nil
      %else
         ! Someone else is interested in this file.  We'll have to disentangle
         ! ourselves the hard way....
         !! printstring("Refcount now ");  write(h_refcount, 0);  newline
         !! x == h_use list
         !! %while x ## nil %cycle
         !!    phex(addr(x));  printstring("  -> ");  phex(addr(x_next))
         !!    printstring("  <- ");  phex(addr(x_last))
         !!    printstring("  us") %if x == o
         !!    newline
         !!    x == x_next
         !! %repeat
         %if o_last == nil %start
            ! We were at the head of the list
            !! printstring("At the head");  newline
            h_use list == o_next
            o_next_last == nil %unless o_next == nil
         %else %if o_next == nil
            ! We're at the end of the list
            !! printstring("At the tail");  newline
            o_last_next == nil
         %else
            ! We're in the middle, so two others to adjust
            !! printstring("In the middle");  newline
            o_next_last == o_last
            o_last_next == o_next
         %finish
      %finish
      o = 0;  ! Zap the open file entry for safety
      o_header cache slot = infinity
%end


! User-visible interface
! Open, close, read, write, delete, extend etc.

%externalintegerfn fsys open file(%record(fsys access fm)%name access,
                                  %integer ID, mode, compatible, request flags,
                                  %integername token, size, flags)
   %record(file header fm)%name h
   %record(extent fm)%name e
   %record(open file table fm)%name f
   %record(partition fm)%name p
   %integer i, pn
      !! printstring("FSys open file ");  phex(ID)
      !! printstring(" mode ");  phex(mode)
      !! printstring(" compatible ");  phex(compatible);  newline
      ID = ID & file ID mask
      ! Find the partition record
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %if p_flags & partition structured = 0 %start
         %result = no privilege error %c
            %if access ## nil %and access_privileges & bootarea privilege = 0
         token = 16_80000000 ! pn
         !! printstring("Unstructured open: partition ");  write(pn, 0)
         !! printstring(", size ");  write(p_size, 0)
         !! printstring(" -> ");  phex(token);  newline
         size = p_size << 9
         flags = 0
         %result = 0
      %finish
      ! Need access to the tables, so interlock.
      semaphore wait(tables_open file table semaphore)
      token = get open file slot
      %result = token %if token < 0
      f == tables_open file table(token)
      f_ID = ID;  f_mode = mode;  f_compatible = compatible ! control access
      ! Need the file's header to check.
      i = get header(f)
      %result = i %if i < 0
      h == f_fhce_h
      %if h_ID # ID & file ID part %start
         forget header(f)
         signal semaphore(tables_open file table semaphore)
         %result = no such file error
      %finish
      %unless file access authority OK(h, access, mode, request flags) %start
         forget header(f)
         signal semaphore(tables_open file table semaphore)
         %result = no authority error
      %finish
      %if h_flags & improperly closed file # 0 %start
         forget header(f)
         signal semaphore(tables_open file table semaphore)
         %result = improperly closed file error
      %finish
      %if p_flags & access logging enabled # 0 %start
         i = get datestamp
         h_accessed = i %and f_fhce_dirty = 1 %c
            %if i - h_accessed >= access update interval
      %finish
      %if h_blocks used > 0 %start
         size = (h_blocks used - 1) << 9 + h_bytes in last block
      %else
         ! Empty file, so can't use above calculation
         size = 0
      %finish
      flags = h_flags & 16_FFFF
      flags = flags ! multiple references %if h_header refcount >= 2
      flags = flags ! world read access %if h_world access & read access # 0
      %if mode & an altering access mode # 0 %start
         ! Update stamp on open (for RWT)
         h_modified = get datestamp;  f_fhce_dirty = 1
      %finish
      f_last block read = -2
      %if h_extent limit <= extent limit %start
         !! printstring("Prefetch first block");  newline
         e == h_extent(extent limit)
         partition prefetch(e_start ! (pn << partition shift))
         %if e_size < 6 {arbitrary} %and h_extent limit # extent limit %start
            ! Prefetch the start of the next extent too
            e == e [-1]
            partition prefetch(e_start ! (pn << partition shift))
         %finish
      %finish
      signal semaphore(f_fhce_semaphore)
      %result = 0
%end

%externalintegerfn fsys flush header(%record(fsys access fm)%name access,
                                     %integer token)
   %record(open file table fm)%name f
   %record(header cache fm)%name fhce
   %record(file header fm)%name h
   %integer status, pn
      %result = 0 %if token & 16_80000000 # 0;  ! Unstructured (probably)
      %result = bad token error %unless 0 < token <= open file limit
      semaphore wait(tables_open file table semaphore)
      f == tables_open file table(token)
      fhce == f_fhce;  h == fhce_h
      pn = f_ID >> partition shift
      signal semaphore(tables_open file table semaphore)
      semaphore wait(fhce_semaphore)
      status = 0;  ! Provisionally
      %if fhce_dirty # 0 %start
         ! The header has been modified, so we'll have to write
         ! it out to disc.  Maybe it wasn't us, but.....
         status = write index block(pn, f_ID, h)
         %if status < 0 %start
            !! printstring("Flush header: put index status ")
            !! phex(status);  newline
         %else
            fhce_dirty = 0
         %finish
      %finish
      signal semaphore(fhce_semaphore)
      %result = status
%end

%externalintegerfn fsys close file(%record(fsys access fm)%name access,
                                   %integer token, flags)
   ! If the refcount is zero we should delete the file too.
   %record(open file table fm)%name f
   %record(partition fm)%name p
   %record(header cache fm)%name fhce
   %record(file header fm)%name h
   %record(extent fm)%name e
   %integer status, i, alloc, keep, pn
      %result = 0 %if token & 16_80000000 # 0;  ! Unstructured (probably)
      %result = bad token error %unless 0 < token <= open file limit
      semaphore wait(tables_open file table semaphore)
      f == tables_open file table(token)
      %if f_mode = 0 %start
         signal semaphore(tables_open file table semaphore)
         %result = bad token error
      %finish
      fhce == f_fhce;  h == fhce_h
      pn = f_ID >> partition shift
      p == tables_partition(pn)
      signal semaphore(tables_open file table semaphore)
      semaphore wait(fhce_semaphore)
      %if f_mode & (modify access ! append access) # 0 %start
         %if flags & auto truncate flag # 0 %start
            ! Excess extents at the end may need to be freed.
            ! (Note that they wouldn't have been readable by the user.)
            %if flags & improper close flag # 0 %start
               h_flags = h_flags ! improperly closed file
               fhce_dirty = 1
            %finish
            %if h_flags & overlapping file # 0 %start
               -> close it
            %finish
            alloc = 0
            %for i = extent limit, -1, h_extent limit %cycle
               e == h_extent(i)
               %if alloc >= 0 %start
                  ! All used so far...
                  alloc = alloc + e_size
                  %if alloc > h_blocks used %start
                     keep = e_size - alloc + h_blocks used
                     %unless free extent(e_start + keep, e_size - keep, p_bitmap) %start
                        printstring("Free extent failed");  newline
                     %finish
                     %if keep = 0 %start
                        ! Nothing to keep, so forget the entire extent
                        e_start = -infinity;  e_size = -1;  ! Just in case...
                        h_extent limit = i + 1
                     %else
                        ! Something still in use, so note the new size
                        e_size = keep
                        h_extent limit = i
                     %finish
                     alloc = -1
                     fhce_dirty = 1
                  %finish
               %else
                  ! Free from here on
                  %unless free extent(e_start, e_size, p_bitmap) %start
                     printstring("Free extent failed");  newline
                  %finish
                  e = 0
                  fhce_dirty = 1
               %finish
            %repeat
         %finish
         %if flags & directory flags # 0 %start
            h_flags <- (h_flags & \directory flags) ! (flags & directory flags)
            fhce_dirty = 1
         %finish
      %finish
close it:
      status = 0;  ! Provisionally
      %if fhce_dirty # 0 %start
         ! The header has been modified, so we'll have to write
         ! it out to disc.  Maybe it wasn't us, but.....
         status = write index block(pn, f_ID, h)
         %if status < 0 %start
            printstring("Close file: put index status ")
            phex(status);  newline
         %else
            fhce_dirty = 0
         %finish
      %finish
      forget header(f)
      signal semaphore(tables_open file table semaphore)
      %result = status
%end

%externalintegerfn fsys truncate open file(%record(fsys access fm)%name access,
                                           %integer token, bytes)
   %record(header cache fm)%name fhce
   %record(open file table fm)%name f
   %record(file header fm)%name h
   %integer mode, blocks
      !! printstring("FSys truncate open file: access ");  phex(addr(access))
      !! printstring(", token: ");  write(token, 0)
      !! printstring(", blocks: ");  write(blocks, 0)
      !! printstring(", bytes: ");  write(bytes, 0);  newline
      %result = bad token error %unless 0 < token <= open file limit
      %if bytes = 0 %start
         blocks = 0;  bytes = 0
      %else %if bytes > 0
         blocks = bytes >> 9;  bytes = bytes & 511
         blocks = blocks - 1 %and bytes = 512 %if bytes = 0
         ! NB blocks now one too small
      %else
         %result = invalid block error
      %finish
      semaphore wait(tables_open file table semaphore)
      f == tables_open file table(token)
      %if f_mode = 0 %start
         signal semaphore(tables_open file table semaphore)
         %result = bad token error
      %finish
      fhce == f_fhce;  mode = f_mode
      signal semaphore(tables_open file table semaphore)
      %result = bad operation error %if mode & modify access = 0
      semaphore wait(fhce_semaphore)
      h == fhce_h
      !! printstring("File header at ");  phex(addr(h));  newline
      %if blocks > h_blocks used %c
            %or (blocks = h_blocks used %c
                 %and bytes > h_bytes in last block) %start
         signal semaphore(fhce_semaphore)
         %result = end of file error
      %finish
      h_blocks used = blocks + 1
      h_bytes in last block = bytes
      fhce_dirty = 1
      signal semaphore(fhce_semaphore)
      %result = 0
%end

%externalintegerfn fsys read file block(%record(fsys access fm)%name access,
                                        %integer token, block,
                                        %integername bytes,
                                        %record(*)%name buffer)
   %record(partition fm)%name p
   %record(header cache fm)%name fhce
   %record(open file table fm)%name f
   %record(file header fm)%name h
   %integer pn, status, mode, prefetch block
      !! printstring("FSys read file block: access ");  phex(addr(access))
      !! printstring(", token: ");  write(token, 0)
      !! printstring(", block: ");  write(block, 0)
      !! printstring(", buffer: ");  phex(addr(buffer));  newline
      %if token & 16_80000000 # 0 %start
         ! Unstructured.
         %result = no privilege error %c
            %if access ## nil %and access_privileges & bootarea privilege = 0
         pn = token & 16_7FFFFFFF
         %result = partition ID error %unless 0 < pn <= partitions
         p == tables_partition(pn)
         %result = partition ID error %if p_flags & partition valid = 0
         %result = file structured error %if p_flags & partition structured # 0
         !! printstring("Unstructured read: partition ");  write(pn, 0)
         !! printstring(", block ");  write(block, 0);  newline
         bytes = 512;  ! Assuming we succeed....
         status = partition read((pn << partition shift) + block, buffer)
         %result = status %if status < 0
         ! +ve result means we could prefetch, but we won't bother for now....
         %result = 0
      %finish
      %result = bad token error %unless 0 < token <= open file limit
      %result = invalid block error %if block < 0
      semaphore wait(tables_open file table semaphore)
      f == tables_open file table(token)
      %if f_mode = 0 %start
         signal semaphore(tables_open file table semaphore)
         %result = bad token error
      %finish
      fhce == f_fhce;  mode = f_mode
      signal semaphore(tables_open file table semaphore)
      %result = bad operation error %if mode & read access = 0
      pn = f_ID >> partition shift
      semaphore wait(fhce_semaphore)
      h == fhce_h
      !! printstring("File header at ");  phex(addr(h));  newline
      %if block >= h_blocks used %start
         !! phex(f_ID);  printstring(" (");  phex(h_ID)
         !! printstring("): asking for ");  write(block, 0)
         !! printstring(", found ");  write(h_blocks used, 0);  newline
         !! display header(h)
         %if block = h_blocks used %start
            signal semaphore(fhce_semaphore)
            bytes = 0
            %result = 0
         %else
            signal semaphore(fhce_semaphore)
            %result = end of file error
         %finish
      %finish
      %if block = h_blocks used - 1 %then bytes = h_bytes in last block %c
                                    %else bytes = 512
      status = read file block(pn, h, block, buffer, prefetch block)
      %if prefetch block # 0 %and block = f_last block read + 1 %start
         !! printstring("Sequential, prefetch indicated");  newline
         partition prefetch(prefetch block)
      %finish
      f_last block read = block
      signal semaphore(fhce_semaphore)
      !! printstring("Got block, status ");  write(status, 0);  newline
      %result = status
%end

%externalintegerfn fsys write file block(%record(fsys access fm)%name access,
                                         %integer token, block, bytes,
                                         %record(*)%name buffer)
   %record(partition fm)%name p
   %record(open file table fm)%name f
   %record(header cache fm)%name fhce
   %record(file header fm)%name h
   %record(extent fm)%name e
   %integer status, pn, mode, extended = 0, actual, start, i
      %if token & 16_80000000 # 0 %start
         ! Unstructured.
         %result = no privilege error %c
            %if access ## nil %and access_privileges & bootarea privilege = 0
         pn = token & 16_7FFFFFFF
         %result = partition ID error %unless 0 < pn <= partitions
         p == tables_partition(pn)
         %result = partition ID error %if p_flags & partition valid = 0
         %result = file structured error %if p_flags & partition structured # 0
         %result = no authority error %if p_flags & partition hazarded = 0
         !! printstring("Unstructured write: partition ");  write(pn, 0)
         !! printstring(", block ");  write(block, 0);  newline
         ! <bytes> ignored.
         %result = partition write((pn << partition shift) + block, buffer)
      %finish
      %result = bad token error %unless 0 < token <= open file limit
      %result = invalid block error %if block < 0
      semaphore wait(tables_open file table semaphore)
      f == tables_open file table(token)
      %if f_mode = 0 %start
         signal semaphore(tables_open file table semaphore)
         %result = bad token error
      %finish
      fhce == f_fhce;  mode = f_mode
      signal semaphore(tables_open file table semaphore)
      %result = bad operation error %if mode & modify access = 0
      pn = f_ID >> partition shift
      p == tables_partition(pn)
      semaphore wait(fhce_semaphore)
      h == fhce_h
      %if block > h_blocks used %start
         ! Can't leave (security) holes in the file
         signal semaphore(fhce_semaphore)
         %result = bad operation error
      %finish
      %if block = h_blocks used %start
         ! One beyond the (current) end
         h_blocks used = block + 1
         h_bytes in last block = bytes
         fhce_dirty = 1
      %else %if block = h_blocks used - 1
         ! Update of current last block
         h_bytes in last block = bytes
         fhce_dirty = 1
      %else %if bytes # 512
         ! Can't put a short block in the middle.
         signal semaphore(fhce_semaphore)
         %result = bad operation error
      %finish
try write again:
      status = write file block(pn, h, block, buffer)
      %if status # end of file error %or extended # 0 %start
         signal semaphore(fhce_semaphore)
         %result = status
      %finish
      ! No space, get some more
      e == h_extent(h_extent limit)
      %unless allocate extent(auto extend blocks, e_start + e_size,
                              p_bitmap, actual, start) %start
         signal semaphore(fhce_semaphore)
         printstring("Extend failed");  newline
         %result = partition full error
      %finish
      %if start = e_start + e_size %start
         ! New extent is contiguous with the old one
         !! printstring("Contiguous, appending");  newline
         e_size = e_size + actual
         fhce_dirty = 1
         extended = 1
         -> try write again
      %finish
      i = h_extent limit - 1
      %if i > 0 %start
         e == h_extent(i)
         %if e_start = 0 %start
            ! Found a slot -- block 0 is reserved
            e_start = start
            e_size = actual
            h_extent limit = i
            fhce_dirty = 1
            extended = 1
            -> try write again
         %finish
      %finish
      signal semaphore(fhce_semaphore)
      %result = file header full error
%end

%externalintegerfn fsys create file(%record(fsys access fm)%name access,
                                    %string(255) creation name,
                                    %integer pn, benefactor ID, flags,
                                    %integer initial allocation,
                                    %integername ID)
   %record(file header fm) bh
   %record(partition fm)%name p, bp
   %record(file header fm)%name h
   %record(header access fm)%name g, bg
   %record(open file table fm)%name o
   %integer slot, status, start, size, i, bpn
      !! printstring("FSys create file: partition ");  write(pn, 0)
      !! printstring(", benefactor ");  phex(benefactor ID);  newline
      pn = pn & partition number mask
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %result = not file structured error %if p_flags & partition structured = 0
      ! Get the benefactor's file header here
      %if benefactor ID # 0 %start
         !! printstring("Create: benefactor is ");  phex(benefactor ID);  newline
         benefactor ID = benefactor ID & file ID mask
         bpn = benefactor ID >> partition shift
         %result = partition ID error %unless 0 < bpn <= partitions
         bp == tables_partition(bpn)
         %result = partition ID error %if bp_flags & partition valid = 0
         %result = not file structured error %if bp_flags & partition structured = 0
         ! Should use the cache here<<<<<<
         i = read index block(bpn, benefactor ID, bh)
         %result = i %if i < 0
         %result = no such file error %if bh_ID # benefactor ID & file ID part
         %result = no authority error %c
            %unless file access authority OK(bh, access, modify access, flags)
         ! NB we check for modify access above so that users can't replace files
         ! which they otherwise wouldn't have write access to.  There's a
         ! similar check in the file system process for "do rename".
      %finish
      ! Now try for some disc allocation
      initial allocation = default initial blocks %if initial allocation <= 0
      %unless allocate extent(initial allocation, -1, p_bitmap, size, start) %start
         !! printstring("Allocate failed");  newline
         %result = partition full error %if size < 0
      %finish
      semaphore wait(tables_open file table semaphore)
      slot = allocate file slot(p)
      %if slot < 0 %start
         signal semaphore(tables_open file table semaphore)
         %result = slot
      %finish
      i = get open file slot
      %result = i %if i < 0
      o == tables_open file table(i)
      o_compatible = 0;  o_ID = pn << partition shift ! slot
      status = get header(o)
      %result = status %if status < 0
      h == o_fhce_h
      %if h_ID & index part # 0 %start
         printstring("Duplicate index allocation for file ")
         phex(h_ID + file sequence increment);  newline
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = bugcheck
      %finish
      h_ID = (h_ID + file sequence increment ! slot) & file ID part
      o_ID = h_ID ! (pn << partition shift)
      tables_header ID(o_header cache slot) = o_ID
      h_header refcount = 0;  ! Nobody (yet)
      h_flags = backup required
      %if benefactor ID = 0 %start
         ! No previous version, so use defaults
         %if access == nil %start
            ! System
            h_owner = system ID
            h_supervisor = system ID
            h_local access = new local access
            h_world access = new local access;  !<<<<<
         %else
            ! A real user
            !! printstring("NO benefactor, using user defaults");  newline
            h_owner = access_user ID
            h_supervisor = access_supervisor ID
            h_local access = no access;   !<<<<<
            h_world access = no access;   !<<<<<
         %finish
         h_owner access = new owner access
         h_access(1) = 0;  ! No groups
      %else
         ! There's a previous version, so we take our defaults from that.
         !! printstring("Defaulting from benefactor: ")
         !! write(bh_owner, 0);  space;  write(bh_supervisor, 0);  newline
         h_owner = bh_owner;  h_supervisor = bh_supervisor
         h_owner access = bh_owner access
         h_local access = bh_local access
         h_world access = bh_world access
         ! Now copy the groups (if any)
         g == h_access(1);  bg == bh_access(1);  i = 1
         %while i < bh_extent limit %and bg_ID # 0 %cycle
            !! printstring("Group: ");  write(bg_ID, 0);  newline
            g = bg
            bg == bg [1];  g == g [1]
            i = i + 1
         %repeat
         g = 0 %if i < extent limit;  ! Terminate list
      %finish
      length(creation name) = 15 %if length(creation name) > 15
      h_creation name = creation name
      h_created = get datestamp
      h_modified = h_created;  h_accessed = h_created
      %if access == nil %then h_creator = system ID %c
                        %else h_creator = access_user ID
      h_static ID = 0
      h_audit ID = 0
      h_blocks used = 0
      h_bytes in last block = 0
      h_extent limit = extent limit
      h_extent(extent limit)_start = start
      h_extent(extent limit)_size = size
      status = write index block(pn, slot, h)
      ID = h_ID ! pn << partition shift
      forget header(o)
      signal semaphore(tables_open file table semaphore)
      %result = status
%end

%externalintegerfn fsys delete file(%record(fsys access fm)%name access,
                                    %integer ID, flags)
   %record(open file table fm)%name o
   %record(file header fm)%name h
   %record(partition fm)%name p
   %record(extent fm)%name e
   %integer i, status, pn
      ID = ID & file ID mask
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %result = not file structured error %if p_flags & partition structured = 0
      semaphore wait(tables_open file table semaphore)
      i = get open file slot
      %result = i %if i < 0
      o == tables_open file table(i)
      o_mode = control access;  o_compatible = 0;  o_ID = ID
      status = get header(o)
      %result = status %if status < 0
      h == o_fhce_h
      %if h_ID # ID & file ID part %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no such file error
      %finish
      %unless file access authority OK(h, access, link access, flags) %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no authority error
      %finish
      %if access ## nil %and h_header refcount > 0 %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = non zero refcount error
      %finish
      h_ID = h_ID & (\ index part)
      %if h_flags & overlapping file = 0 %start
         %for i = extent limit, -1, h_extent limit %cycle
            e == h_extent(i)
            %unless free extent(e_start, e_size, p_bitmap) %start
               printstring("Free extent failed");  newline
            %finish
            e = 0
         %repeat
      %finish
      h_blocks used = 0;  h_bytes in last block = 0
      status = write index block(pn, ID, h)
      %if o_fhce_refcount # 1 %start
         printstring("Delete: bad file tables refcount ")
         write(o_fhce_refcount, 0);  printstring(" for ");  phex(ID)
         newline
      %finish
      forget header(o)
      free file slot(p, ID & index part)
      signal semaphore(tables_open file table semaphore)
      %result = status
%end

! BEWARE deadlocks....
!%externalintegerfn fsys exchange(%record(fsys access fm)%name access,
!                                 %integer ID1, ID2, flags)
!   %record(partition fm)%name p
!   %record(file header fm)%name h1, h2
!   %record(open file table fm)%name f1, f2
!   %record(extent fm)%name e1, e2
!   %integer t1, t2
!   %record(extent fm) e
!   %integer i, j, pn
!   %short q
!      ID1 = ID1 & file ID mask;  ID2 = ID2 & file ID mask
!      pn = ID1 >> partition shift
!      %result = bad operation error %unless pn = ID2 >> partition shift
!      %result = partition ID error %unless 0 < pn <= partitions
!      p == tables_partition(pn)
!      %result = partition ID error %if p_flags & partition valid = 0
!      %result = not file structured error %if p_flags & partition structured = 0
!      semaphore wait(tables_open file table semaphore)
!      %result = incompatible mode error %unless compatible mode(-1, ID1, 0)
!      t1 = get open file slot;  %result = t1 %if t1 < 0
!      f1 == tables_open file table(t1)
!      f1_ID = ID1;  f1_compatible = 0
!      f1_mode = 0 %and %result = incompatible mode error %c
!         %unless compatible mode(-1, ID2, 0);  !???
!      t2 = get open file slot
!      f1_mode = 0 %and %result = t2 %if t2 < 0
!      f2 == tables_open file table(t2)
!      f2_ID = ID1;  f2_compatible = 0
!      i = get header(f1)
!      f1_mode = 0 %and f2_mode = 0 %and %result = i %if i < 0
!      h1 == f1_fh_h
!      f1_mode = 0 %and f2_mode = 0 %and %result = no such file error %c
!         %if h1_ID # ID1 & file ID part
!      semaphore wait(tables_open file table semaphore);  ! Released by 'get header'
!      i = get header(f2)
!      %if i < 0 %start
!         forget header(f1_fh);  f1_fh == nil
!         f1_mode = 0
!         f2_mode = 0
!         %result = i
!      %finish
!      h2 == f2_fh_h
!      %if h2_ID # ID2 & file ID part %start
!         forget header(f1_fh);  f1_fh == nil
!         forget header(f2_fh);  f2_fh == nil
!         f1_mode = 0
!         f2_mode = 0
!         %result = no such file error
!      %finish
!      i = h1_static ID;  h1_static ID = h2_static ID;  h2_static ID = i
!      q = h1_bytes in last block
!      h1_bytes in last block = h2_bytes in last block
!      h2_bytes in last block = q
!      i = h1_blocks used
!      h1_blocks used = h2_blocks used
!      h2_blocks used = i
!      %for i = 1, 1, extent limit %cycle
!         e1 == h1_extent(i);  e2 == h2_extent(i)
!         %exit %if e1_size = 0 = e2_size;  ! All done
!         e = e1;  e1 = e2;  e2 = e
!      %repeat
!      i = write index block(pn, ID1, h1)
!      forget header(f1_fh);  f1_fh == nil
!      f1_mode = 0
!      j = write index block(pn, ID2, h2)
!      forget header(f2_fh);  f2_fh == nil
!      f2_mode = 0
!      %result = i %if i < 0
!      %result = j
!%end

%externalintegerfn fsys bump refcount(%record(fsys access fm)%name access,
                                      %integer ID, flags, increment)
   ! Deletion is implied if the refcount -> 0
   %record(open file table fm)%name o
   %record(file header fm)%name h
   %record(partition fm)%name p
   %record(extent fm)%name e
   %integer i, status, pn, final refcount
      %result = bad refcount increment error %unless -1 <= increment <= 1
      ID = ID & file ID mask
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = 0 %if p_flags & partition structured = 0;  ! Ignore it
      semaphore wait(tables_open file table semaphore)
      i = get open file slot
      %result = i %if i < 0
      o == tables_open file table(i)
      o_mode = control access;  o_compatible = control access;  o_ID = ID
      status = get header(o)
      %result = status %if status < 0
      h == o_fhce_h
      %if h_ID # ID & file ID part %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no such file error
      %finish
      %unless file access authority OK(h, access, link access, flags) %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no authority error
      %finish
      ! Now modify the file's refcount
      h_header refcount = h_header refcount + increment
      final refcount = h_header refcount
   !? h_modified = get datestamp
      !! phex(ID);  printstring(" refcount -> ")
      !! write(h_header refcount, 0);  newline
      status = write index block(pn, ID, h)
      o_fhce_dirty = 0;  !???
      forget header(o)
      signal semaphore(tables_open file table semaphore)
      %result = status %if status < 0
      %result = fsys delete file(access, ID, flags) %if final refcount <= 0 
      %result = 0
%end


%externalintegerfn fsys get full ID(%integer partial ID, %integername full ID)
   %record(file header fm) h
   %integer status
      partial ID = partial ID & file ID mask
      status = read index block(partial ID >> partition shift, partial ID, h)
      %result = status %if status # 0
      %result = no such file error %if h_ID & index part = 0
      full ID = h_ID ! (partial ID & partition part)
      %result = 0
%end

%externalintegerfn fsys read file header(%record(fsys access fm)%name access,
                                         %integer ID, flags, %record(*)%name fh)
   %record(file header fm) h
   %record(partition fm)%name p
   %integer i, pn
      ID = ID & file ID mask
      ! Find the partition record
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %result = not file structured error %if p_flags & partition structured = 0
      ! Should really go via the cache here <<<<<<<<<
      i = read index block(pn, ID, h)
      %result = i %if i < 0
      %result = no such file error %if h_ID # ID & file ID part
      %result = no authority error %c
         %unless file access authority OK(h, access, read access, flags)
      fh = h
      %result = 0
%end

%externalintegerfn fsys obtain attributes(%record(fsys access fm)%name access,
                                          %integer ID, flags,
                                          %record(attributes list fm)%name a)
   %record(open file table fm)%name o
   %record(file header fm)%name h
   %record(partition fm)%name p
   %integer i, status, pn, privileged, group pos = 1
   %switch r(first attribute - 1 : last attribute)
      ID = ID & file ID mask
      ! Find the partition record
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %result = not file structured error %if p_flags & partition structured = 0
      semaphore wait(tables_open file table semaphore)
      i = get open file slot
      %result = i %if i < 0
      o == tables_open file table(i)
      ! Note that we specify control access mode here even though we later
      ! check for read access to the file.  This allows the protection
      ! mechanism to work sensibly while at the same time not unnecessarily
      ! blocking shared access.  We specify that any other concurrent users
      ! can have anything but control access in order to maintain a consistent
      ! view of the file's attributes.
      o_mode = control access;  o_compatible = \control access;  o_ID = ID
      status = get header(o)
      %result = status %if status < 0
      h == o_fhce_h
      %if h_ID # ID & file ID part %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no such file error
      %finish
      %unless file access authority OK(h, access, read access, flags) %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no authority error
      %finish
      %if access == nil %then privileged = -1 %c
                        %else privileged = access_privileges & admin privilege
   
      ! Now scan the list, filling in the various attribute requests
      %while a ## nil %cycle
         -> r(a_code) %if first attribute <= a_code <= last attribute
r(*):    a_status = attribute unavailable
         -> next

r(file ID attribute):
         a_numeric = h_ID
         -> OK next

r(file owner attribute):
         a_numeric = h_owner
         -> OK next

r(file supervisor attribute):
         a_numeric = h_supervisor
         -> OK next

r(owner access attribute):
         a_numeric = h_owner access
         -> OK next

r(local access attribute):
         a_numeric = h_local access
         -> OK next

r(world access attribute):
         a_numeric = h_world access
         -> OK next

r(group access attribute):
         group pos = group pos + 1
         %if group pos >= h_extent limit %or h_access(group pos)_ID = 0 %start
            group pos = infinity;  ! Abort any other pending requests
            a_status = attribute unavailable
            -> next
         %finish
         a_numeric2 = h_access(group pos)_ID
         a_numeric = h_access(group pos)_access
         -> OK next

r(defined groups attribute):
         a_status = attribute unavailable
         -> next

r(file creator attribute):
         a_numeric = h_creator
         -> OK next

r(static ID attribute):
         a_numeric = h_static ID
         -> OK next

r(audit ID attribute):
         a_numeric = h_audit ID
         -> OK next

r(date created attribute):
         a_numeric = h_created
         -> OK next

r(date modified attribute):
         a_numeric = h_modified
         -> OK next

r(date accessed attribute):
         a_numeric = h_accessed
         -> OK next

r(creation name attribute):
         a_textual = h_creation name
         -> OK next

r(file size attribute):
         a_numeric = 512 * h_blocks used + h_bytes in last block - 512
         -> OK next

r(file extents attribute):
         a_numeric = extent limit - h_extent limit + 1
         -> OK next

r(file flags attribute):
         a_numeric = h_flags
         -> OK next

OK next: a_status = attribute OK
next:    a == a_next
      %repeat

      forget header(o)
      signal semaphore(tables_open file table semaphore)
      %result = 0
%end

%externalintegerfn fsys modify attributes(%record(fsys access fm)%name access,
                                          %integer ID, flags,
                                          %record(attributes list fm)%name a)
   %record(open file table fm)%name o
   %record(file header fm)%name h
   %record(partition fm)%name p
   %integer i, status, pn, privileged, group pos = 1
   %switch r(first attribute - 1 : last attribute)
      ID = ID & file ID mask
      pn = ID >> partition shift
      %result = partition ID error %unless 0 < pn <= partitions
      p == tables_partition(pn)
      %result = partition ID error %if p_flags & partition valid = 0
      %result = not file structured error %if p_flags & partition structured = 0
      semaphore wait(tables_open file table semaphore)
      i = get open file slot
      %result = i %if i < 0
      o == tables_open file table(i)
      o_mode = control access;  o_compatible = control access;  o_ID = ID
      status = get header(o)
      %result = status %if status < 0
      h == o_fhce_h
      %if h_ID # ID & file ID part %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no such file error
      %finish
      %unless file access authority OK(h, access, control access, flags) %start
         forget header(o)
         signal semaphore(tables_open file table semaphore)
         %result = no authority error
      %finish
      %if access == nil %then privileged = -1 %c
                        %else privileged = access_privileges & admin privilege

      ! Now scan the attributes list, performing modifications as requested
      %while a ## nil %cycle
         -> r(a_code) %if first attribute <= a_code <= last attribute

r(file owner attribute):
         -> unavailable %if privileged = 0
         !! printstring("Set owner: ");  write(a_numeric, 0);  newline
         h_owner = a_numeric
         -> OK next

r(file supervisor attribute):
         -> unavailable %if privileged = 0
         !! printstring("Set supervisor: ");  write(a_numeric, 0);  newline
         h_supervisor = a_numeric
         -> OK next

r(owner access attribute):
         a_numeric = (a_numeric & (\ admin required)) ! %c
                     (h_owner access & admin required) %c
            %if access_privileges & admin privilege = 0
         !! printstring("Set owner access: ");  phex(a_numeric);  newline
         h_owner access = a_numeric
         -> OK next

r(local access attribute):
         a_numeric = (a_numeric & (\ admin required)) ! %c
                     (h_local access & admin required) %c
            %if access_privileges & admin privilege = 0
         !! printstring("Set local access: ");  phex(a_numeric);  newline
         h_local access = a_numeric
         -> OK next

r(world access attribute):
         a_numeric = (a_numeric & (\ admin required)) ! %c
                     (h_world access & admin required) %c
            %if access_privileges & admin privilege = 0
         !! printstring("Set world access: ");  phex(a_numeric);  newline
         h_world access = a_numeric
         -> OK next

r(group access attribute):
         !! printstring("Set group access: userID ");  write(a_numeric2, 0)
         !! printstring(", access ");  write(a_numeric, 0)
         !! printstring(", slot ");  write(group pos, 0);  newline
         %if group pos >= h_extent limit %start
            a_status = attribute list overflow
            -> next
         %finish
         h_access(group pos)_ID = a_numeric2
         h_access(group pos)_access = a_numeric
         group pos = group pos + 1
         h_access(group pos)_ID = 0 %if group pos < h_extent limit
         -> OK next

r(file flags attribute):
         !! printstring("Set flags: ");  phex(a_numeric);  newline
         h_flags = a_numeric
         -> OK next

! The following are either unimplemented as yet, or cannot meaningfully
! be modified by the user.
!r(file ID attribute):
!r(defined groups attribute):
!r(file creator attribute):
!r(static ID attribute):
!r(audit ID attribute):
!r(date created attribute):
!r(date modified attribute):
!r(date accessed attribute):
!r(creation name attribute):
!r(file size attribute):
!r(file extents attribute):

unavailable:
r(*):    a_status = attribute unavailable
         -> next

OK next: a_status = attribute OK
next:    a == a_next
      %repeat

      ! All done, mark the header as modified and write it out.
      h_modified = get datestamp
      ! Should we write it out here??
      status = write index block(pn, ID, h)
      o_fhce_dirty = 0
      forget header(o)
      signal semaphore(tables_open file table semaphore)
      %result = status
%end


! Partition module included here to force proper layering

%include "GDMR_H:Part"

%end %of %file