! Directory package for new filestores.  This version has a translation cache.
!
! Uses B-tree package for key manipulation, and related data-storage
! mechanism for keeping large equivalence records.
!
! Strategy is that if the translation is a single file ID then it
! is inserted directly into the tree.  Otherwise, if it has several
! versions, or is a textual equivalent, then it is packaged up in a
! separate record as follows:
!     Each record starts with a tag field, indicating whether the translation
!     is a list of IDs, a local translation, or an external translation.
!     If it is a list of IDs, then there is a count field, followed by the
!     corresponding IDs.  If it is a textual translation, then the actual
!     text appears as a string immediately after the tag field.
!
! Paths can be either absolute (relative to the root) or start with a
! file ID.  Paths are presented as a list of components (already split).
!
! IDs which do not explicitly specify a partition are taken to be in the
! same partition as their parent.  The partition ID is taken as 4 bits of
! partition-within-drive + 2 bits of drive.  This is a NASTY HACK -- it's
! necessary to allow entire drives to be moved to another system which might
! well result in partition number clashes otherwise.  If the drive-ID isn't
! specified it too defaults to the parent's drive.  This has the unfortunate
! side-effect that we can't refer to files on drive 0 from directories on
! other drives except via the root (redirector).  We'll worry about this at
! some other time, though -- just make everything drive-relative for now...
! BEWARE: the constants are hard-coded in!!
!
! The top few bits of IDs are reserved for use by the directory structure.
! <non ID> and <directory> are defined at present

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

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

%constinteger NUL = 0

! +ve error codes indicate redirectors
%constinteger dud path              error = -201
%constinteger not a directory       error = -202
%constinteger dud component         error = -203
%constinteger non empty directory   error = -204
%constinteger no versions           error = -205
%constinteger version not found     error = -206
%constinteger too many versions     error = -207
%constinteger no privilege          error = -208
%constinteger dud redirect level    error = -209

%include "Moose:Mouse.Inc"

%include "GDMR_H:FSysAcc.Inc"
%include "GDMR_H:FSys.Inc"
%include "GDMR_H:Tree.Inc"

%externalroutinespec fsys initialise
%externalintegerfnspec fsys get full ID(%integer partial, %integername full)

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

%externalintegerfnspec global heap get(%integer amount)

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

%constinteger infinity = 16_7FFFFFFF

%constinteger world read access = 16_20000000

%constinteger directory          flag = 16_40000000
%constinteger non ID             flag = 16_80000000
%constinteger directory relative flag = non ID flag

%recordformat path fm(%record(path fm)%name next,
                      %integer version, %string(*)%name key,
                      %string(255) text)

!constinteger partition shift = 24
!constinteger partition mask  = 16_3F000000
!constinteger ID        mask  = 16_00FFFFFF

%constinteger max compound ID = 32;  ! Meantime
%recordformat compound fm(%short tag,
                          ((%short count,
                            %integerarray ID(1 : max compound ID)) %c
                       %or %string(255) text))
%constinteger compound ID           tag = 1
! Unfortunately we used '1' to indicate a compound ID, so we have to
! use redirect-levels of 2 or more.....

%constinteger ID escape character = 2


! Translation cache

%constinteger cache slot entries = 100
%constinteger cache slots = 64

%constinteger cache name limit = 23
%recordformat cache entry fm(%string(23) name, %integer ID)
%recordformat cache slot fm(%integer n, stamp,
                            %record(cache entry fm)%array e(1 : cache slot entries))
%recordformat cache fm(%record(semaphore fm) semaphore,
                       %integer hits, misses, new dirs, new entries,
                       %integerarray ID(1 : cache slots),
                       %record(cache slot fm)%array s(1 : cache slots))

%owninteger cache stamp = 0
%ownrecord(cache fm)%name cache == nil

%externalroutine directory initialise cache
   %integer x
      %if FS lookup("FS__DIRECTORY_CACHE", x) %start
         !! printstring("Directory cache already known at ")
         !! phex(x);  newline
         cache == record(x)
      %else
         x = global heap get(size of(cache))
         cache == record(x);  cache = 0
         setup semaphore(cache_semaphore)
         signal semaphore(cache_semaphore)
         FS insert("FS__DIRECTORY_CACHE", x)
         !! printstring("Directory cache created at ")
         !! phex(addr(x));  newline
      %finish
%end

%integerfn find cache slot(%integer ID)
   %constinteger directory cache loop = cache slots - 1
   %record(cache slot fm)%name s
   %integer x, i, oldest = infinity
   %label IDL, found it
      ! First off, search the cache for the header.  This loop is based on the
      ! one used by the partition cache manager.  We assume the semaphore has
      ! been claimed elsewhere.
      x = addr(cache_ID(1))
      D1 = ID                 { The directory ID we're looking for
      *move.l x, A0           { The address of the first ID
      *move.l #directory 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
      %result = -1            { Not there

found it:
      *move.l A0, x
      %result = (x - addr(cache_ID(1))) >> 2
%end

%predicate same(%string(*)%name a, b)
   %integer l, m, p, q, d
   %bytename aa, bb
      l = length(a);  m = length(b)
      %false %if l # m
      aa == charno(a, 1);  bb == charno(b, 1)
      %while l > 0 %and m > 0 %cycle
         %if aa # bb %start
            ! Standardise case for comparison
            %if 'A' <= aa <= 'Z' %then p = aa - 'A' + 'a' %else p = aa
            %if 'A' <= bb <= 'Z' %then q = bb - 'A' + 'a' %else q = bb
            %false %if p # q
         %finish
         l = l - 1;  m = m - 1
         aa == aa [1];  bb == bb [1]
      %repeat
      %true
%end

%integerfn cache find(%integer directory ID, %string(*)%name name)
   %record(cache slot fm)%name s
   %record(cache entry fm)%name e
   %integer slot, i, x
      directory initialise cache %if cache == nil
      !! printstring("Cache find """);  printstring(name)
      !! printstring(""" in ");  phex(directory ID);  newline
      %result = -1 %unless 0 < length(name) <= cache name limit
      semaphore wait(cache_semaphore)
      slot = find cache slot(directory ID)
      %if slot < 0 %start
         ! Directory isn't there
         cache_misses = cache_misses + 1
         signal semaphore(cache_semaphore)
         !! printstring("Directory isn't in cache");  newline
         %result = -1
      %finish
      s == cache_s(slot)
      %for i = 1, 1, s_n %cycle
         e == s_e(i)
         %if same(name, e_name) %start
            !! printstring("Found it -> ");  phex(e_ID);  newline
            x = e_ID
            cache stamp = cache stamp + 1
            s_stamp = cache stamp
            cache_hits = cache_hits + 1
            signal semaphore(cache_semaphore)
            %result = x
         %finish
      %repeat
      !! printstring("Not there");  newline
      cache_misses = cache_misses + 1
      signal semaphore(cache_semaphore)
      %result = -1
%end

%routine cache insert(%integer directory ID,
                      %string(*)%name name, %integer value)
   %record(cache slot fm)%name s
   %record(cache entry fm)%name e
   %integer slot, i, x, oldest = infinity
      directory initialise cache %if cache == nil
      !! printstring("Cache insert """);  printstring(name)
      !! printstring(""" in ");  phex(directory ID)
      !! printstring(" as ");  phex(value);  newline
      %return %unless 0 < length(name) <= cache name limit
      semaphore wait(cache_semaphore)
      slot = find cache slot(directory ID)
      %if slot < 0 %start
         ! Directory isn't there
         !! printstring("Directory isn't in cache");  newline
         %for i = 1, 1, cache slots %cycle
            s == cache_s(i)
            slot = i %and oldest = s_stamp %if s_stamp < oldest
         %repeat
         cache_ID(slot) = directory ID
         cache_s(slot)_n = 0
         cache_new dirs = cache_new dirs + 1
      %finish
      s == cache_s(slot)
      %for i = 1, 1, s_n %cycle
         e == s_e(i)
         %if same(name, e_name) %start
            !! printstring("Found it");  newline
            e_ID = value
            cache stamp = cache stamp + 1
            s_stamp = cache stamp
            cache_hits = cache_hits + 1
            signal semaphore(cache_semaphore)
            %return
         %finish
      %repeat
      !! printstring("Not there");  newline
      cache_new entries = cache_new entries + 1
      %if s_n = cache slot entries %start
         !! printstring("Full");  newline
         signal semaphore(cache_semaphore)
         %return
      %finish
      s_n = s_n + 1
      e == s_e(s_n)
      e_name = name;  e_ID = value
      signal semaphore(cache_semaphore)
%end

%routine cache delete(%integer directory ID, %string(*)%name name)
   %record(cache slot fm)%name s
   %record(cache entry fm)%name e
   %integer slot, i, x
      directory initialise cache %if cache == nil
      !! printstring("Cache delete """);  printstring(name)
      !! printstring(""" in ");  phex(directory ID);  newline
      %return %unless 0 < length(name) <= cache name limit
      semaphore wait(cache_semaphore)
      slot = find cache slot(directory ID)
      %if slot < 0 %start
         ! Directory isn't there
         !! printstring("Directory isn't in cache");  newline
         cache_misses = cache_misses + 1
         signal semaphore(cache_semaphore)
         %return
      %finish
      s == cache_s(slot)
      %for i = 1, 1, s_n %cycle
         e == s_e(i)
         %if same(name, e_name) %start
            !! printstring("Found it");  newline
            %if i # s_n %start
               ! Not at the end, so we'll have to shuffle
               s_e(x - 1) = s_e(x) %for x = i + 1, 1, s_n
            %finish
            ! All done, forget the last slot and return
            s_n = s_n - 1
            cache_hits = cache_hits + 1
            signal semaphore(cache_semaphore)
            %return
         %finish
      %repeat
      !! printstring("Not there");  newline
      cache_misses = cache_misses + 1
      signal semaphore(cache_semaphore)
%end


! Root directory stuff

%owninteger root directory ID = -1
%constinteger root ID = 16_01000002;  ! No sequence

%routine get root ID
   %integer status, x, token, flags
      fsys initialise
      status = fsys get full ID(root ID, root directory ID)
      %if status # 0 %start
         printstring("Failed to find root directory's ID: ")
         write(status, 0);  newline
         prompt("Would you like to create a new one? ")
         read symbol(x) %until x # NL
         %stop %unless x = 'y' %or x = 'Y'
         status = B tree create(nil, 0, "Root", 1, 0, root directory ID)
         %if status # 0 %start
            printstring("Failed to create new root ");  write(status, 0)
            newline
            %stop
         %finish
         printstring("New root directory is ");  phex(root directory ID)
         newline
         ! Bump the refcount.  It's not actually IN any directories,
         ! but it'll stop it being deleted.
         status = fsys bump refcount(nil, root directory ID, 0, 1)
         %if status # 0 %start
            printstring("Failed to bump refcount for new root");  newline
         %finish
         ! Now insert $BootArea
         prompt("Would you like to insert $BootArea as 04000000? ")
         read symbol(x) %until x # NL
         %if x = 'y' %or x = 'Y' %start
            status = B tree open by ID(nil, 0, root directory ID, 1, token, flags)
            %if status # 0 %start
               printstring("Failed to open new root directory: ")
               write(status, 0);  newline
            %else
               status = B tree add entry(token, "$BootArea", 16_04000000)
               %if status # 0 %start
                  printstring("Failed to insert $BootArea: ")
                  write(status, 0);  newline
               %finish
               status = B tree close(token, status)
            %finish
         %finish
      %finish
      root directory ID = root directory ID ! directory flag
      !! printstring("Root directory is ");  phex(root directory ID)
      !! newline
%end


! Diagnostic string-putter

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

!! %routine print key list(%record(key list fm)%name list)
!!    %while list ## nil %cycle
!!       spaces(15 - length(list_key));   zput string(list_key)
!!       spaces(2);  phex(list_value);  newline
!!       list == list_next
!!    %repeat
!! %end


%predicate path component OK(%string(*)%name s)
   %integer i
      %false %if s = ""
      %for i = 1, 1, length(s) %cycle
         %false %unless ' ' < charno(s, i) <= '~'
      %repeat
      %true
%end

%externalintegerfn directory lookup one(%record(fsys access fm)%name access,
                                        %integer request flags,
                                        %integer directory ID,
                                        %string(*)%name key, %integer version,
                                        %integername resulting ID,
                                        %string(*)%name textual translation)
   %record(compound fm) c
   %integer token, status, size, x, flags, drive mask
      get root ID %if root directory ID < 0
      directory ID = root directory ID %if directory ID = 0
      !! printstring("Lookup one : component ");  zput string(key)
      !! printstring(" in ");  phex(directory ID);  newline
      %result = not a directory error %if directory ID & directory flag = 0
      %result = version not found error %if version > 0;  ! No absolute versions
      %if key = "" %start
         ! Null name -> directory self-reference
         resulting ID = directory ID
         %result = 0
      %else %if length(key) = 5 %and charno(key, 1) = ID escape character
         ! Absolute ID escape in path.  First character is escape, next
         ! four are (binary) ID.
         resulting ID = integer(addr(key) + 2)
         !! printstring("Absolute lookup: ");  phex(resulting ID);  newline
         %result = 0
      %finish
      %result = dud component error %unless path component OK(key)
      %if version = 0 %start
         ! Only the most recent is ever cached
         x = cache find(directory ID, key)
         %if x > 0 %start
            resulting ID = x
            flags = 0;  ! Zap world-read, so no cache insert
            -> done ID
         %finish
      %finish
      status = B tree open by ID(access, request flags, directory ID,
                                 0, token, flags)
      textual translation = key %and %result = status %if status # 0
      status = B tree find entry(token, key, resulting ID)
      %if status # 0 %start
         x = B tree close(token, 0)
         !! %if x # 0 %start
         !!    printstring("Lookup one: close status ")
         !!    write(x, 0);  newline
         !! %finish
         textual translation = key
         %result = status
      %finish
      %if resulting ID & non ID flag = 0 %start
         ! Simple ID
         x = B tree close(token, 0)
         !! %if x # 0 %start
         !!    printstring("Lookup one: close status ")
         !!    write(x, 0);  newline
         !! %finish
         %result = version not found error %unless version = 0
done ID: %if resulting ID & 16_3F000000 = 0 %start
            ! Drive and partition defaulted
            resulting ID = resulting ID ! (directory ID & 16_3F000000)
         %else %if resulting ID & 16_30000000 = 0
            ! Drive only defaulted
            resulting ID = resulting ID ! (directory ID & 16_30000000)
         %finish
         textual translation = ""
         !! printstring("Result is ");  phex(resulting ID);  newline
         ! Should we insert it in the cache?  Only the latest version of world-
         ! readable files are inserted.  Note that when we reach here either
         ! (a) version = 0 and the ID was non-compound, or (b) version has been
         ! converted to be the compound slot number (1, 2, 3, ...).  Note that
         ! the case where the caller is looking for version < 0 with a simple
         ! ID is an error and has already been bounced (just before the label
         ! above).
         cache insert(directory ID, key, resulting ID) %c
            %if version <= 1 %and flags & world read access # 0
         %result = 0
      %else
         ! Compound ID
         status = B tree data value(token, resulting ID & (\ non ID flag),
                                    size, c)
         x = B tree close(token, 0)
         !! %if x # 0 %start
         !!    printstring("Lookup one: close status ")
         !!    write(x, 0);  newline
         !! %finish
         %if status # 0 %start
            textual translation = key
            %result = status
         %finish
         %if c_tag = compound ID tag %start
            version = 1 - version
            %result = version not found error %unless 0 < version <= c_count
            resulting ID = c_ID(version)
            -> done ID
         %else
            ! Redirector
            !! printstring("Redirector");  newline
            textual translation = c_text
            %result = c_tag
         %finish
      %finish
%end

! Search for the specified path.  Halts search at last-but-one component.
! Returns: file ID (> 0) if a local filename; or component count + translation
! if non-local; or component count + offending component + error status.
! Always start looking in the file system root directory.

%externalrecord(path fm)%map directory penultimate %c
                                    (%record(fsys access fm)%name access,
                                     %integer request flags,
                                     %record(path fm)%name path, 
                                     %integername components translated,
                                     %integername resulting ID,
                                     %string(*)%name textual translation,
                                     %integername status)
   %integer ID, current directory ID
      status = dud path error %and %result == nil %if path == nil
      get root ID %if root directory ID < 0
      current directory ID = root directory ID
      ID = root directory ID
      components translated = 0
      %cycle
         %if path_next == nil %start
            ! Stop at the penultimate one
            !! printstring("Lookup terminating with ");  phex(ID);  newline
            resulting ID = ID
            textual translation = ""
            status = 0
            %result == path
         %finish
         current directory ID = ID
         !! printstring("Lookup: component ");  zput string(path_key)
         !! printstring(" in ");  phex(current directory ID);  newline
         status = directory lookup one(access, request flags, current directory ID,
                                       path_key, 0 {not until final},
                                       ID, textual translation)
         resulting ID = 0 %and %result == nil %if status < 0;  ! Not there
         %result == path %if status > 0;  ! Non-local
         components translated = components translated + 1
         path == path_next
      %repeat
%end

%externalintegerfn directory lookup(%record(fsys access fm)%name access,
                                    %integer request flags,
                                    %record(path fm)%name path,
                                    %integername components translated,
                                    %integername file ID, penultimate ID,
                                    %string(*)%name textual translation)
   %integer status
      !! printstring("Directory lookup");  newline
      path == directory penultimate(access, request flags, path,
                                    components translated,
                                    penultimate ID, textual translation, status)
      %result = status %if status # 0
      status = directory lookup one(access, request flags, penultimate ID,
                                    path_key, path_version,
                                    file ID, textual translation)
      components translated = components translated + 1 %if status = 0
      !! printstring("Returning file ");  phex(file ID)
      !! printstring(", penultimate ");  phex(penultimate ID)
      !! printstring(", status ");  write(status, 0);  newline
      %result = status
%end


%integerfn insert new compound ID(%integer token, previous ID, new ID,
                                  %integername resulting)
   %record(compound fm) c
   %integer status, size, i
      !! printstring("Insert new compound ID: ");  phex(new ID)
      !! printstring(", previous: ");  phex(previous ID);  newline
      %if previous ID & non ID flag = 0 %start
         ! Inserting new with previously simple
         !! printstring("New + previously simple: ")
         !! phex(previous ID);  newline
         %result = no versions error %c
            %if previous ID & (directory flag ! non ID flag) # 0 %c
            %or new ID & (directory flag ! non ID flag) # 0
         c = 0
         c_tag = compound ID tag
         c_count = 2
         c_ID(1) = new ID
         c_ID(2) = previous ID
         %result = B tree data insert(token, 12, c, resulting)
      %else
         ! Previously compound
         %result = no versions error %c
            %if new ID & (directory flag ! non ID flag) # 0;  ! Require simple
         previous ID = previous ID & (\ non ID flag)
         !! printstring("New + previous compound @ ")
         !! phex(previous ID);  newline
         status = B tree data value(token, previous ID, size, c)
         %result = status %if status # 0
         %result = no versions error %unless c_tag = compound ID tag
         %result = too many versions error %if c_count = max compound ID
         c_count = c_count + 1
         c_ID(i) = c_ID(i - 1) %for i = c_count, -1, 2
         c_ID(1) = new ID
         status = B tree data insert(token, 4 * (c_count + 1), c, resulting)
         %result = status %if status # 0
         %result = B tree data delete(token, previous ID)
      %finish
%end

%externalintegerfn directory insert ID(%record(fsys access fm)%name access,
                                       %integer request flags,
                                       %integer directory ID,
                                       %string(*)%name inserting key,
                                       %integer inserting ID)
   %integer status, ID, token, x, flags, resulting, bump ID
      %result = dud component error %if inserting ID & 16_0F000000 = 0
      %result = dud component error %unless path component OK(inserting key)
      %result = not a directory error %if directory ID & directory flag = 0
      inserting ID = inserting ID & (\ directory relative flag);  ! Obsolete
      bump ID = inserting ID
      %if inserting ID & 16_3F000000 = directory ID & 16_3F000000 %start
         ! Drive and partition same, so default them
         inserting ID = inserting ID & (16_00FFFFFF ! directory flag)
      %else %if inserting ID & 16_30000000 = directory ID & 16_30000000
         ! Drive only same -- default it
         inserting ID = inserting ID & (16_0FFFFFFF ! directory flag)
      %finish
      !! printstring("Inserting ");  phex(inserting ID)
      !! printstring(" into ");  phex(directory ID);  newline
      status = B tree open by ID(access, request flags, directory ID,
                                 1, token, flags)
      %result = status %if status # 0
      status = B tree find entry(token, inserting key, ID)
      %if status = 0 %start
         ! Entry is already there, so compound it.
         %if inserting ID & directory flag # 0 %start
            ! Not allowed to insert a directory as compound
            status = B tree close(token, -1)
            %result = no versions error
         %finish
         cache delete(directory ID, inserting key)
         status = insert new compound ID(token, ID, inserting ID, resulting)
         status = B tree modify entry(token, inserting key,
                                      resulting ! non ID flag) %if status = 0
      %else
         ! Not there, so insert a new simple ID
         status = B tree add entry(token, inserting key, inserting ID)
      %finish
      x = B tree close(token, status)
      !! %if x # 0 %start
      !!    printstring("Insert ID: close status ")
      !!    write(x, 0);  newline
      !! %finish
      %result = status %if status # 0
      status = fsys bump refcount(access, bump ID, request flags, 1)
      %result = status %if status # 0
      cache insert(directory ID, inserting key, inserting ID) %c
         %if flags & world read access # 0
      %result = 0
%end

%externalintegerfn directory insert textual(%record(fsys access fm)%name access,
                                            %integer request flags,
                                            %integer directory ID,
                                            %string(*)%name inserting key,
                                            %integer inserting level,
                                            %string(*)%name inserting text)
   %integer status, ID, token, x, flags, resulting
   %record(compound fm) c
      %result = dud component error %unless path component OK(inserting key)
      %result = not a directory error %if directory ID & directory flag = 0
      %result = dud redirect level error %if inserting level < 2
      !! printstring("Inserting ");  printstring(inserting text)
      !! printstring(" into ");  phex(directory ID)
      !! printstring(" as ");  printstring(inserting key)
      !! printstring(", level ");  write(inserting level, 0);  newline
      status = B tree open by ID(access, request flags, directory ID,
                                 1, token, flags)
      %result = status %if status # 0
      status = B tree find entry(token, inserting key, ID)
      %if status = 0 %start
         ! Entry is already there & versions aren't allowed
         x = B tree close(token, -1)
         !! %if x # 0 %start
         !!    printstring("Insert textual: close status ")
         !!    write(x, 0);  newline
         !! %finish
         %result = no versions error
      %finish
      ! Not there, so insert a new textual translation
      c = 0
      c_tag = inserting level;  ! Assume correct
      c_text = inserting text
      status = B tree data insert(token, length(inserting text) + 3,
                                  c, resulting)
      %if status # 0 %start
         x = B tree close(token, -1)
         !! %if x # 0 %start
         !!    printstring("Insert textual: close status ")
         !!    write(x, 0);  newline
         !! %finish
         %result = status
      %finish
      !! printstring("Data inserted as ");  phex(resulting);  newline
      status = B tree add entry(token, inserting key, resulting ! non ID flag)
      x = B tree close(token, status)
      !! %if x # 0 %start
      !!    printstring("Insert textual: close status ")
      !!    write(x, 0);  newline
      !! %finish
      %result = status
%end

%externalintegerfn directory delete entry(%record(fsys access fm)%name access,
                                          %integer request flags,
                                          %integer directory ID,
                                          %string(255) key, %integer version)
   %integer status, token, flags, translated ID, bump status, x
   %integer size, site, new site, i
   %record(compound fm) c
      %result = dud component error %unless path component OK(key)
      %result = not a directory error %if directory ID & directory flag = 0
      !! printstring("Deleting ");  printstring(key)
      !! printstring(" from ");  phex(directory ID);  newline
      cache delete(directory ID, key)
      status = B tree open by ID(access, request flags, directory ID,
                                 1, token, flags)
      %result = status %if status # 0
      status = B tree find entry(token, key, translated ID)
      %if status = 0 %start
         %if translated ID & non ID flag = 0 %start
            ! Simple translation
            status = B tree delete entry(token, key)
         %else
            ! Translation is non-simple
            site = translated ID & (\ non ID flag)
            status = B tree data value(token, site, size, c)
            %if status # 0 %start
               x = B tree close(token, -1)
               !! %if x # 0 %start
               !!    printstring("Delete entry: close status ")
               !!    write(x, 0);  newline
               !! %finish
               %result = status
            %finish
            %if c_tag # compound ID tag %start
               ! Non-ID, so just zap the entry & translation
               status = B tree data delete(token, site)
               status = B tree delete entry(token, key)
               x = B tree close(token, status)
               !! %if x # 0 %start
               !!    printstring("Delete entry: close status ")
               !!    write(x, 0);  newline
               !! %finish
               %result = status
            %finish
            version = 1 - version
            %unless 0 < version <= c_count %start
               x = B tree close(token, -1)
               !! %if x # 0 %start
               !!    printstring("Delete entry: close status ")
               !!    write(x, 0);  newline
               !! %finish
               %result = version not found error
            %finish
            translated ID = c_ID(version)
            %if version < c_count %start
               ! Shuffle down
               c_ID(i) = c_ID(i + 1) %for i = version, 1, c_count - 1
            %finish
            c_count = c_count - 1
            %if c_count = 1 %start
               status = B tree modify entry(token, key, c_ID(1))
               %if status # 0 %start
                  x = B tree close(token, -1)
                  !! %if x # 0 %start
                  !!    printstring("Delete entry: close status ")
                  !!    write(x, 0);  newline
                  !! %finish
                  %result = status
               %finish
               status = B tree data delete(token, site)
            %else
               status = B tree data insert(token, 4 * (c_count + 1), c, new site)
               %if status # 0 %start
                  x = B tree close(token, -1)
                  !! %if x # 0 %start
                  !!    printstring("Delete entry: close status ")
                  !!    write(x, 0);  newline
                  !! %finish
                  %result = status
               %finish
               status = B tree modify entry(token, key,
                                            new site ! non ID flag)
               %if status # 0 %start
                  x = B tree close(token, -1)
                  !! %if x # 0 %start
                  !!    printstring("Delete entry: close status ")
                  !!    write(x, 0);  newline
                  !! %finish
                  %result = status
               %finish
               status = B tree data delete(token, site)
            %finish
         %finish
      %finish
      x = B tree close(token, status)
      !! %if x # 0 %start
      !!    printstring("Delete entry: close status ")
      !!    write(x, 0);  newline
      !! %finish
      %if translated ID & 16_3F000000 = 0 %start
         ! Drive and partition defaulted
         translated ID = translated ID ! (directory ID & 16_3F000000)
      %else %if translated ID & 16_30000000 = 0
         ! Drive only defaulted
         translated ID = translated ID ! (directory ID & 16_30000000)
      %finish
      bump status = fsys bump refcount(access, translated ID, request flags, -1)
      %result = bump status %if bump status # 0
      %result = status
%end


%externalintegerfn create directory(%record(fsys access fm)%name access,
                                    %integer request flags,
                                    %record(path fm)%name path,
                                    %integer desired partition,
                                    %integer no inherit,
                                    %integername components translated,
                                    %integername final directory ID,
                                    %string(*)%name textual translation)
   %record(path fm)%name final
   %integer status, ID, token, x, actual partition, flags, benefactor ID
      final == directory penultimate(access, request flags, path, components translated,
                                     final directory ID, textual translation,
                                     status)
      %result = status %if status # 0
      %result = not a directory error %if final directory ID & directory flag = 0
      %if desired partition > 0 %start
         %result = no privilege error %if access_privileges & admin privilege = 0
         actual partition = desired partition
      %else
         actual partition = (final directory ID & partition mask) >> partition shift
      %finish
      !! printstring("Creating directory ");  printstring(final_key)
      !! printstring(" in ");  phex(final directory ID)
      !! printstring(", partition ");  write(actual partition, 0);  newline
      ! Note that when we create the directory below we use its parent as
      ! its benefactor, so that directories inherit ownership, protection
      ! and so on from the directory they were created in.  This has the
      ! side effect of requiring modify access to the parent directory
      ! (because of FSys's version replacement check), but that's OK as we
      ! are going to be trying to modify the parent directory anyway...
      benefactor ID = final directory ID
      benefactor ID = 0 %if no inherit # 0
      status = B tree create(access, request flags, final_key, actual partition,
                             benefactor ID, ID)
      !! printstring("Create status ");  write(status, 0);  newline
      %result = status %if status # 0
      ID = ID ! directory flag
      ! Bump the refcount
      status = fsys bump refcount(access, ID, request flags, 1)
      !! printstring("Bump status ");  write(status, 0);  newline
      %if status # 0 %start
         ! For some reason we don't have access to our own newly-created
         ! directory, so we'll just (attempt to) delete it again.
         x = fsys delete file(nil, ID, 0)
         %result = status
      %finish
      ! Now insert in the final directory
      %if ID & 16_3F000000 = final directory ID & 16_3F000000 %start
         ! Drive and partition same, so default them
         ID = ID & (16_00FFFFFF ! directory flag)
      %else %if ID & 16_30000000 = final directory ID & 16_30000000
         ! Drive only same -- default it
         ID = ID & (16_0FFFFFFF ! directory flag)
      %finish
      status = B tree open by ID(access, request flags, final directory ID,
                                 1, token, flags)
      %result = status %if status # 0
      status = B tree find entry(token, final_key, x)
      %if status = 0 %start
         ! Directory already exists, so we'll have to delete the new one
         x = B tree close(token, -1)
         !! %if x # 0 %start
         !!    printstring("Create directory: close status ")
         !!    write(x, 0);  newline
         !! %finish
         x = fsys delete file(nil, ID, 0)
         %result = no versions error
      %finish
      status = B tree add entry(token, final_key, ID)
      x = B tree close(token, status)
      !! %if x # 0 %start
      !!    printstring("Create directory: close status ")
      !!    write(x, 0);  newline
      !! %finish
      %result = status
%end

%externalintegerfn directory check empty(%record(fsys access fm)%name access,
                                         %integer request flags,
                                         %integer directory ID)
   %integer token, flags, status, empty
      %result = not a directory error %if directory ID & directory flag = 0
      status = B tree open by ID(access, request flags, directory ID,
                                 0, token, flags)
      %result = status %if status # 0
      %if flags & multiple references # 0 %or B tree empty(token) %start
         ! Directories with multiple references to them are always
         ! assumed to be empty (so all but one can be deleted).
         empty = 0
      %else
         empty = non empty directory error
      %finish
      status = B tree close(token, 0)
      !! %if status # 0 %start
      !!    printstring("Check empty: close status ")
      !!    write(status, 0);  newline
      !! %finish
      %result = empty
%end


%externalrecord(*)%map directory contents(%record(fsys access fm)%name access,
                                          %integer request flags,
                                          %integer ID, %integername status, flags)
   %record(key list fm)%name key list, last == nil, current, next
   %integer token, x, i, size
   %record(compound fm) c
   %string(255) text
      %if root directory ID < 0 %start
         printstring("*** Calling ""directory contents"" before a lookup??")
         newline
         status = dud path error
         %result == nil
      %finish
      status = not a directory error %and %result == nil %c
         %if ID & directory flag = 0
      !! printstring("Get key list for ");  phex(ID);  newline
      status = B tree open by ID(access, request flags, ID, 0, token, flags)
      %result == nil %if status # 0
      key list == B tree key list(token, status)
      current == key list
      %while current ## nil %cycle
         %if current_value & non ID flag = 0 %start
            last == nil
         %else
            ! Compound with (maybe) versions)
            status = B tree data value(token, current_value & (\ non ID flag),
                                       size, c)
            %if status # 0 %start
               ! Error on lookup, so just assume it's simple
               last == nil
               status = 0;  !!!
               current_value = non ID flag
            %else %if c_tag = compound ID tag
               text = current_key
               next == current_next
               last == current
               current_value = c_ID(1)
               %for i = 2, 1, c_count %cycle
                  current == record(heap get(length(text) + 9 + 4))
                  current_value = c_ID(i)
                  current_key = text . to string(NUL) . itos(1 - i, 0)
                  current_next == next
                  last_next == current
                  last == current
               %repeat
            %finish
         %finish
         current == current_next
      %repeat
      x = B tree close(token, 0)
      !! %if x # 0 %start
      !!    printstring("Directory contents: close status ")
      !!    write(x, 0);  newline
      !! %finish
      !! print key list(key list)
      %result == key list
%end

%end %of %file