! New super improved directory file manipulation, GDMR, Sept/Oct 1988

! The basic strategy is that entries are stored sorted in a sequence of logical
! blocks: searching is by binary split inter-block, with linear search used
! intra-block; insertion is done by splitting blocks when they get full, and
! shuffling the map entries to give the appearance of everything else having
! moved as required; blocks are only merged when entries are deleted (this
! version doesn't attempt to rotate, though it will do multi-merges).
!
! To do: merge adjacent blocks on deletion.

!**Temporary** error codes
%constinteger dud op             error = -97
%constinteger not implemented    error = -98
%constinteger bugcheck           error = -99
%constinteger not found          error = -209
%constinteger type mismatch      error = -210
%constinteger no versions        error = -211
%constinteger version not found  error = -212

! Root block format.  The <chain> field is for future expansion (but is unlikely
! to be required, as 127 directory blocks will point to a lot of files!).  Each
! <p> entry contains the "physical" block number of the corresponding logical
! block.  Note that we don't have an "epoch" field in the root, though we do
! have two alternately-used roots, as the necessary information is in the file's
! header to avoid one unnecessary block-read when searching the directory.
! <limit> is for use in automatic version-limiting (not in yet).
%constinteger logical limit = 127
%recordformat D root entry fm(%short p, u)
%recordformat D root fm(%short chain, limit,
                        %record(D root entry fm)%array p(1 : logical limit))

! Data block format.  The <last entry> field points to the key for the final
! entry -- this allows searches to be speeded up by making it easy to eliminate
! blocks early.
%recordformat D data fm(%byte last entry, spare,
                        %shortarray x(1 : 255))

! Tokens, bitmaps, etc.  These are kept in a record claimed from the heap rather
! than being %own as the module must be concurrently callable.  The root and one
! data block are cached for speed.  <find position> is set to point to the key
! on a successful search; it is ASSUMED that the calling sequence will be such
! that this will be valid when required.  Two bitmaps are used: one indicates
! which physical blocks are mapped by the current root; the other which PHYSICAL
! blocks have been remapped this time around (to avoid multiple allocations when
! several inserts or deletes are performed).
%recordformat D IO fm(%record(*)%name access,
                      %integer token 1, token 2, {two required for IO_F}
                      %integer flags, mode, root block, logical blocks,
                      %record(D root fm) root,
                      %record(D data fm) data,
                      %integer data block, status, find position,
                      %bytearray map, new(0 : 15))

%include "GDMR_H:IO_F.Inc"
%systemroutinespec phex(%integer x)
%systemroutinespec phex2(%integer x)

%include "GDMR_H:Dump.Inc"


! Bitmap manipulation: all pretty straightforward.  Note that as we never free
! blocks (they might be in use by the other root, and we need to be able to
! ditch the one we're working on and back out) we don't need a bit-clear.

%routine D set bit(%integer n, %bytename m)
   %integer b, o
      b = n >> 3;  o = n & 7
      m [b] = m [b] ! (1 << o)
%end

%predicate D test bit(%integer n, %bytename m)
   %integer b, o
      b = n >> 3;  o = n & 7
      %true %if m [b] & (1 << o) # 0
      %false
%end


! File I/O.  At the moment we're testing with the user-level interface.

%integerfn D open(%string(255) file, %integer mode, %integername token)
   %string(255) T
   %record(D IO fm)%name D
   %integer status, n, m, c, other, size
      D == new(D);  D = 0;  D_map(0) = 3;  ! Zap, claim root blocks
      D_mode = mode
      ! Select appropriate access/sharing modes and open the file.
      %if mode = 0 %start
         m = read file mode;  c = read file mode
      %else
         m = read file mode ! modify file mode;  c = 0
      %finish
      status = F open file(nil, file, m, {c} read file mode ! modify file mode,
                           0, D_token 1,  D_token 2, size, D_flags, T)
      -> error %if status # 0
      {} printstring(file);  printstring(" opened as ")
      {} phex(D_token 1);  space;  phex(D_token 2)
      {} printstring(" size ");  write(size, 0);  newline
      ! Extract root flags from header info and choose root.
      D_flags = D_flags & 16_C000
      %if D_flags = 16_8000 %start
         {} printstring("Root is 0");  newline
         D_root block = 0;  other = 1
      %else %if D_flags = 16_4000
         {} printstring("Root is 1");  newline
         D_root block = 1;  other = 0
      %else
         {} printstring("No root?");  newline
         status = -1;  T = "No root??"
         -> error
      %finish
      status = F read block(nil, D_token 1, D_token 2, D_root block << 9,
                            n, byteinteger(addr(D_root)), T)
      -> error %if status # 0
      {} printstring("Got root");  newline
      ! Build "in-use" bitmap.
      %for m = 1, 1, logical limit %cycle
         %if D_root_p(m)_p # 0 %start
            D_logical blocks = m
            D set bit(D_root_p(m)_p, D_map(0))
         %else
            %exit;  ! Assume there are no logical holes.
         %finish
      %repeat
      {} printstring("Map:")
      {} space %and phex2(D_map(m)) %for m = 0, 1, 15;  newline
      {} write(D_logical blocks, 0);  printstring(" logical in use")
      {} newline
      ! All OK, return a pointer to the <D IO> record
      token = addr(D)
      %result = 0

error:! Some kind of an error.  Dump everything and return status.
      dispose(D)
      {} printstring("Open error: ");  printstring(T);  newline
      %result = status
%end

%integerfn D close(%integer token, how)
   %record(D IO fm)%name D
   %string(255) T
   %integer status, x
      D == record(token)
      %if D_mode = 0 %or how # 0 %start
         ! Read-only or abandon
         {} printstring("R/O or A");  newline
         status = F close file(nil, D_token 1, D_token 2, 0, T)
         dispose(D)
         %result = status
      %finish
      ! Commit-write: flush the root.  Note that we don't have to flush the
      ! data block as it is ASSUMED that this will have been done when it was
      ! modified.
      D_root block = D_root block !! 1;  ! Switch roots
      status = F write block(nil, D_token 1, D_token 2, D_root block << 9,
                             512, byteinteger(addr(D_root)), T)
      %if status # 0 %start
         ! Error, preserve root
         {} printstring("Failed to write root");  newline
         x = F close file(nil, D_token 1, D_token 2, 0, T)
      %else
         ! OK, so switch roots
         {} printstring("Root out OK, close & switch");  newline
         status = F close file(nil, D_token 1, D_token 2, D_flags !! 16_C000, T)
      %finish
      dispose(D)
      %result = status
%end

%integerfn D create(%string(255) file)
   ! Create an new file by writing two blocks of zeros into the roots.  In fact
   ! we really only need to zap one of these, but it doesn't cost us much to do
   ! both and is safer.  The non-test version will have to worry about inserting
   ! directory entries here....
   %ownbytearray zero(0 : 511) = 0(*)
   %string(255) T
   %integer status, T1, T2, s, f
      {} printstring("Create ");  printstring(file);  newline
      status = F open file(nil, file, read file mode ! modify file mode, 0,
                           create flag, T1, T2, s, f, T)
      {} printstring("Open status ");  write(status, 0)
      {} space;  printstring(T);  newline
      %result = status %if status # 0
      status = F write block(nil, T1, T2, 0, 512, zero(0), T)
      {} printstring("Write 0 status ");  write(status, 0);  newline
      status = F write block(nil, T1, T2, 512, 512, zero(0), T)
      {} printstring("Write 1 status ");  write(status, 0);  newline
      %result = F close file(nil, T1, T2, 16_8000, T)
%end

%integerfn D get block(%integer token, block)
   %record(D IO fm)%name D
   %string(255) T
   %integer p, n
      D == record(token)
      %result = bugcheck error %unless 0 < block <= D_logical blocks
      %result = 0 %if block = D_data block %and D_status = 0
      p = D_root_p(block)_p
      {} printstring("Get logical ");  write(block, 0)
      {} printstring(" -> physical ");  write(p, 0);  newline
      D_status = F read block(nil, D_token 1, D_token 2, p << 9, n,
                              byteinteger(addr(D_data)), T)
      D_data block = block
      %result = D_status
%end

%integerfn D put block(%integer token, block, %record(*)%name X)
   %record(D IO fm)%name D
   %string(255) T
   %integer p
      D == record(token)
      %result = bugcheck error %unless 0 < block <= D_logical blocks
      %result = dud op error %if D_mode = 0;  ! Read-only
      p = D_root_p(block)_p
      {} printstring("Put logical ");  write(block, 0)
      {} printstring(" -> physical ");  write(p, 0);  newline
      D_status = F write block(nil, D_token 1, D_token 2, p << 9, 512,
                               byteinteger(addr(X)), T)
      %result = D_status
%end


! Diagnostic routines: hexdump (physical) blocks and dump logical contents.
! Don't use the pre-packaged <get> routine, as it will zap the cache.

%routine D dump(%integer token)
   %record(D IO fm)%name D
   %bytearray x(0 : 511)
   %string(255) T
   %integer status, i, p, n
      D == record(token)
      %for i = 1, 1, logical limit %cycle
         p = D_root_p(i)_p
         %if p # 0 %start
            status = F read block(nil, D_token 1, D_token 2, p << 9,
                                  n, x(0), T)
            printstring("Logical ");  write(i, 0)
            printstring(" -> physical ");  write(p, 0)
            printstring(", ");  write(D_root_p(i)_u, 0)
            printstring(" used:")
            %if status = 0 %start
               newline
               dump2(512, x(0))
            %else
               printstring(" status ")
               write(status, 0);  newline
            %finish
         %finish
      %repeat
%end

%routine D print(%integer token)
   %record(D IO fm)%name D
   %record(D data fm) X
   %string(255) T
   %integer status, i, p, n, pos
      D == record(token)
      %for i = 1, 1, logical limit %cycle
         p = D_root_p(i)_p
         %if p # 0 %start
            status = F read block(nil, D_token 1, D_token 2, p << 9,
                                  n, byteinteger(addr(X)), T)
            printstring("Logical ");  write(i, 0)
            printstring(" -> physical ");  write(p, 0)
            printstring(", ");  write(D_root_p(i)_u, 0)
            printstring(" used:")
            %if status = 0 %start
               newline
               pos = 1
               %while pos <= X_last entry %cycle
                  spaces(36 - length(string(addr(X_x(pos)))))
                  printstring(string(addr(X_x(pos))))
                  pos = pos + length(string(addr(X_x(pos)))) // 2 + 1
                  n = X_x(pos);  pos = pos + 1
                  %if n > 0 %start
                     %cycle
                        spaces(2);  phex(integer(addr(X_x(pos))))
                        spaces(2);  write(integer(addr(x_x(pos))), 0);  newline
                        n = n - 1;  pos = pos + 2
                        %exit %if n = 0
                        spaces(36)
                     %repeat
                  %else
                     spaces(2);  printstring(string(addr(X_x(pos))));  newline
                     pos = pos + length(string(addr(X_x(pos)))) // 2 + 1
                  %finish
               %repeat                  
               pos = pos - 1
               %unless pos = D_root_p(i)_u %start
                  printstring("""used"" wrong: is ")
                  write(D_root_p(i)_u, 0)
                  printstring(", should be ")
                  write(pos, 0);  newline
               %finish
            %else
               printstring(" status ")
               write(status, 0);  newline
            %finish
         %finish
      %repeat
%end


! Case-independent string comparison.  Result is:
!     < 0 if a < b
!     = 0 if a = b
!     > 0 if a > b

%integerfn D compare(%string(*)%name a, b)
   %integer l, m, p, q, d
   %bytename aa, bb
      l = length(a);  m = length(b)
      aa == charno(a, 1);  bb == charno(b, 1)
      %while l > 0 %and m > 0 %cycle
         ! Test unstandardised first, and only convert if the characters
         ! are different.  This should save us a little time.
         %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
            d = p - q
            %result = d %if d # 0
         %finish
         l = l - 1;  m = m - 1
         aa == aa [1];  bb == bb [1]
      %repeat
      ! All the common characters are identical, so the only question is
      ! whether or not the strings are the same length.
      %result = length(a) - length(b)
%end


! Block searching.  This comes in two parts: one to search a particular
! (supplied) block, and the other to search the entire file.

%predicate D search block(%string(*)%name key, %record(D data fm)%name B,
                        %integername position, comparison)
   ! Scan the block provided looking for the key.  If it's there return %true
   ! and the position; if it's not then return %false and a +- comparison.
   ! Check the first and last entries before any others, as this will help
   ! eliminate the block if it doesn't contain the key.
   %integer limit, c, kl
   %shortname k, d
      ! First key first
      !! printstring("Compare (first): ");  printstring(key)
      !! space;  printstring(string(addr(B_x(1))));  newline
      c = D compare(key, string(addr(B_x(1))))
      %if c = 0 %start
         ! We've found it
         position = 1
         %true
      %else %if c < 0
         ! In a previous block
         position = 0;  comparison = -1
         %false
      %finish
      ! Else, may be in this block, so try the last key.  Note that if there's
      ! only one entry in the block then we don't need to repeat the comparison,
      ! though we do need to check "its" result.
      limit = B_last entry
      %if limit # 1 %start
         !! printstring("Compare (last): ");  printstring(key)
         !! space;  printstring(string(addr(B_x(limit))));  newline
         c = D compare(key, string(addr(B_x(limit))))
      %finish
      %if c = 0 %start
         ! We've found it
         position = limit
         %true
      %else %if c > 0
         ! In a subsequent block
         position = 0;  comparison = 1
         %false
      %finish
      ! Else, must be in this block if anywhere, so go looking
      position = 1;  k == B_x(1)
      %cycle
         kl = length(string(addr(k))) // 2 + 1;  ! Current key length
         d == B_x(position + kl);  ! Offset to data part
         ! Move to the new position
         %if d >= 0 %start
            ! Integer data: starts with a count of the
            ! number of following %integers.
            position = position + kl + 2 * d + 1
            !! printstring("Numeric: skipped ");  write(kl, 0)
            !! printstring(" + ");  write(d, 0)
            !! printstring(" to ");  write(position, 0);  newline
         %else
            ! Textual data
            position = position + kl + length(string(addr(d) + 2)) // 2 + 1 + 1
            !! printstring("Numeric: skipped to ");  write(position, 0);  newline
         %finish
         %if position >= limit %start
            ! Not found -- dropped off the end.  We leave the position
            ! pointer pointing at the key for the last entry: we already know
            ! that it must be lexically after what we're searching for, and if
            ! we're going to do an insertion of the key then this is the right
            ! place to do it.
            comparison = 0;  ! This block, if any
            %false
         %finish
         k == B_x(position)
         !! printstring("Compare at ");  write(position, 0)
         !! printstring(": ");  printstring(key)
         !! space;  printstring(string(addr(k)));  newline
         c = D compare(key, string(addr(k)))
         %if c = 0 %start
            ! Found it
            %true
         %else %if c < 0
            ! Not found: search key is before comparison key.  Note that the
            ! position pointer is at the correct place for any subsequent
            ! insert operations.
            comparison = 0;  ! This block if any
            %false
         %finish
         ! Else round for the next entry
      %repeat
%end

%integerfn D search(%integer token, %string(*)%name key)
   %string(255) T
   %record(D IO fm)%name D
   %integer status, p, l, u, m, bytes, position, comparison
      D == record(token)
      !! printstring("Search ");  printstring(key)
      !! printstring(", limit ");  write(D_logical blocks, 0);  newline
      %result = not found error %if D_logical blocks = 0
      ! Binary search inter-block.
      l = 1;  u = D_logical blocks
      %while l <= u %cycle
         m = (l + u) // 2
         !! printstring("Search logical ");  write(m, 0)
         !! printstring(", l ");  write(l, 0)
         !! printstring(", u ");  write(u, 0);  newline
         status = D get block(token, m)
         %result = status %if status # 0
         %if D search block(key, D_data, D_find position, comparison) %start
            ! Found it
            %result = 0
         %else
            ! Not found in this block.  Might it be elsewhere
            %if comparison = 0 %start
               ! Should have been in this block.
               %result = not found error
            %else %if comparison < 0
               ! Try a previous block
               u = m - 1
            %else {comparison > 0}
               ! Try a subsequent block
               l = m + 1
            %finish
         %finish
      %repeat
      ! No more candidata blocks to search
      %result = not found error
%end

%integerfn D query(%integer token, %string(*)%name key, %integer version,
                   %integername type, I value, %string(*)%name T value)
   %record(D IO fm)%name D
   %integer status, kl, pos
      %result = dud op error %if version > 0
      status = D search(token, key)
      %result = status %if status # 0
      D == record(token)
      kl = length(string(addr(D_data_x(D_find position)))) // 2 + 1
      pos = D_find position + kl
      type = D_data_x(pos)
      %if type >= 0 %start
         ! Numeric
         version = 1 - version
         %result = version not found error %unless type >= version
         I value = integer(addr(D_data_x(pos + version << 1 - 1)))
      %else
         ! Textual
         %result = version not found error %unless version = 0
         T value = string(addr(D_data_x(pos + 1)))
      %finish
      %result = 0
%end


! Useful block-space utilities

!%integerfn D used(%record(D data fm)%name B)
!   ! Calculate the total amount of space used in this block.  Assumes only
!   ! %integer data at present.
!   %integer n
!      n = B_last entry + length(string(addr(B_x(B_last entry)))) // 2 + 1
!      %result = n + 2 * B_x(n)
!%end
!
!%integerfn D entry used(%record(D data fm)%name B, %integer pos)
!   ! Calculate the total amount of space used by this entry.  Assumes only
!   ! %integer data at present.
!   %integer n
!      n = length(string(addr(B_x(pos)))) // 2 + 1
!      %result = n + 1 + 2 * B_x(pos + n)
!%end


! Scan the bitmap looking for a free physical block.  We ASSUME that the
! blocks we allocate will be written in the order we allocate them, so we
! don't have to pre-zap them to keep the file system happy (unlike the B-tree
! allocator).

%integerfn D new physical(%bytename map)
   %integer bit, byte, m
   %bytename x
      ! Scan bytewise.  It's a bit of a balance whether we look at
      ! fewer larger chunks or more smaller ones.
      %for byte = 0, 1, 15 %cycle
         x == map [byte]
         %if x # 255 %start
            %for bit = 0, 1, 7 %cycle
               m = 1 << bit
               %if x & m = 0 %start
                  ! Found one free
                  x = x ! m
                  %result = byte << 3 + bit
               %finish
            %repeat
         %finish
      %repeat
      %signal 13;  ! Most unlikely...
%end


! Data insertion.

%integerfn D add(%integer token, type, %string(*)%name key,
                 %integer I value, %string(*)%name T value)
   %record(D IO fm)%name D
   %record(D data fm) B
   %integer status, kl, vl, used, i, p, insert pos, amount
      D == record(token)
      %result = dud op error %if D_mode = 0 %or key = ""
      kl = length(key) // 2 + 1
      ! Special case -- the directory is empty
      %if D_logical blocks = 0 %start
         B = 0;  B_last entry = 1
         string(addr(B_x(1))) = key
         %if type >= 0 %start
            ! Numeric
            B_x(kl + 1) = 1
            integer(addr(B_x(kl + 2))) = I value
            vl = 2
         %else
            ! Textual
            B_x(kl + 1) = type
            string(addr(B_x(kl + 2))) = T value
            vl = length(T value) // 2 + 1
         %finish
         D_logical blocks = 1
         D_root_p(1)_p = 2
         D_root_p(1)_u = kl + vl + 1 {for type}
         D_map(0) = 7;  ! Claim block
         D_new(0) = 7;  ! Note updated this time
         %result = D put block(token, 1, B)
      %finish
      ! First, see if the entry is there already
      status = D search(token, key)
      %if status = 0 %start
         ! Found it.  We can only insert the new entry if both it and the
         ! already-existing entries are numeric-valued.
         {} printstring("Found it at ");  write(D_find position, 0)
         {} printstring(" in ");  write(D_data block, 0);  newline
         insert pos = D_find position + kl
         %if type < 0 %start
            ! Inserting textual.  Must be an error of some kind....
            %if D_data_x(insert pos) >= 0 %then %result = type mismatch error %c
                                          %else %result = no versions error
         %finish
         ! Inserting a numeric.  Only allowed if existing numerics.
         %result = type mismatch error %if D_data_x(insert pos) < 0
         used = D_root_p(D_data block)_u
         {} write(used, 0);  printstring(" used");  newline
         -> split %if used > 253;  ! No room in this block
         ! OK to insert, so shuffle up
         {} printstring("Shuffle: ");  write(used, 0)
         {} space;  write(insert pos + 1, 0);  newline
         D_data_x(i + 2) = D_data_x(i) %for i = used, -1, insert pos + 1
         integer(addr(D_data_x(insert pos + 1))) = I value
         D_data_x(insert pos) = D_data_x(insert pos) + 1
         D_data_last entry = D_data_last entry + 2 %c
            %if D_find position # D_data_last entry;  ! Final entry has moved
         amount = 2
      %else
         ! Not found.  Was it because we couldn't read the block or
         ! because it wasn't there?
         %result = D_status %if D_status # 0;  ! Failed to read block
         ! Is there room to insert?
         used = D_root_p(D_data block)_u
         %if type >= 0 %then amount = kl + 3 %c
                       %else amount = kl + length(T value) // 2 + 1 + 1
         {} printstring("Used: ");  write(used, 0)
         {} printstring(", amount: ");  write(amount, 0);  newline
         -> split %if used + amount > 255;  ! No room in this block
         ! We've to insert in this block.  We've a pointer to approximately
         ! the correct place: if the pointer is zero then we have to insert at
         ! one or other end; while if the pointer is non-zero we'll have to
         ! shuffle.
         {} printstring("Find position is ");  write(D_find position, 0);  newline
         %if D_find position # 0 %c
         %or D compare(key, string(addr(D_data_x(1)))) < 0 %start
            ! Not at the end of this block
            {} printstring("Insert at beginning/middle");  newline
            %if D_find position = 0 %then insert pos = 1 {beginning} %c
                                    %else insert pos = D_find position {middle}
            ! Shuffle the later keys/data
            D_data_x(i + amount) = D_data_x(i) %for i = used, -1, insert pos
            D_data_last entry = D_data_last entry + amount
         %else
            ! Insert at the end, so use the appropriate pointers
            {} printstring("Insert at end");  newline
            insert pos = used + 1
            D_data_last entry = insert pos
         %finish
         ! Insert the key and data at the indicated position
         {} printstring("Insert at ");  write(insert pos, 0);  newline
         string(addr(D_data_x(insert pos))) = key
         %if type >= 0 %start
            D_data_x(insert pos + kl) = 1
            integer(addr(D_data_x(insert pos + kl + 1))) = I value
         %else
            D_data_x(insert pos + kl) = type
            string(addr(D_data_x(insert pos + kl + 1))) = T value
         %finish
      %finish
      ! Finally, remap the block if necessary and write it out
      %if D test bit(D_root_p(D_data block)_p, D_new(0)) %start
         ! Already allocated this time round
         p = D_root_p(D_data block)_p
      %else
         ! Must allocate a new one
         p = D new physical(D_map(0))
         D_root_p(D_data block)_p = p
         {} printstring("New physical: ");  write(p, 0);  newline
         D set bit(p, D_new(0))
      %finish
      D_root_p(D_data block)_u = used + amount
      D_status = D put block(token, D_data block, D_data)
      %result = D_status

split:
      %result = not implemented error
%end


%integerfn D delete(%integer token, %string(*)%name key, %integer version)
   %record(D IO fm)%name D
   %integer status, kl, amount, i, previous, pos, p
   %shortname type, k
      D == record(token)
      %result = dud op error %if D_mode = 0 %or key = "" %or version > 0
      %result = not found error %if D_logical blocks = 0;  ! Empty
      status = D search(token, key)
      %result = status %if status # 0
      ! We have a pointer to the located key.  We now have to decide what type
      ! it is, and whether the requested version exists.
      kl = length(key) // 2 + 1
      type == D_data_x(D_find position + kl)
      {} printstring("Found at ");  write(D_find position, 0)
      {} printstring(", type ");  write(type, 0);  newline
      %if type >= 0 %start
         ! Numeric, so there may be several versions.  If there is only
         ! the one then we have to delete the entire entry.  If there are
         ! several then we only delete the one requested (which implicitly
         ! renumbers all the older versions).
         version = 1 - version
         %result = version not found error %if version > type
         %if type = 1 %start
            ! Only one version exists
            amount = kl + 3 {type + one datum}
            -> delete entire entry
         %finish
         ! Calculate position: offset in data part is 2 * (version - 1) + 1
         pos = D_find position + kl + version << 1 - 1
         D_root_p(D_data block)_u = D_root_p(D_data block)_u - 2
         D_data_x(i) = D_data_x(i + 2) %for i = pos, 1, D_root_p(D_data block)_u
         D_data_last entry = D_data_last entry - 2 %c
            %if D_find position # D_data_last entry
         type = type - 1
         amount = 2
         -> write block
      %finish
      ! Must have been textual, so we delete the entire entry (assuming
      ! we've been asked for version 0).  Calculate how much to zap and
      ! fall through.....
      %result = version not found error %if version # 0
      amount = %c
         kl + length(string(addr(D_data_x(D_find position + kl + 1)))) // 2 + 1 + 1

delete entire entry:
      ! If the entry isn't the last one in the block then we have to shuffle
      ! down the later ones and recalculate the pointers.  If it is the last
      ! then we don't need to shuffle but we do need to search for the
      ! previous key.  If there is only one entry then we can dump the
      ! entire block.  Note that this version doesn't attempt to merge
      ! adjacent blocks for optimal space utilisation.
      {} printstring("Delete entire entry at ");  write(D_find position, 0);  newline
      -> delete entire block %if D_data_last entry = 1;  ! Only one entry
      D_root_p(D_data block)_u = D_root_p(D_data block)_u - amount
      %if D_find position = D_data_last entry %start
         ! Delete final entry.  We don't have to shuffle, but we do have to
         ! search for the previous key.  We know that there must be at least
         ! one previous key, as otherwise we would be deleting the entire block.
         i = 1;  k == D_data_x(1)
         %cycle
            previous = i
            kl = length(string(addr(k))) // 2 + 1;  ! Current key length
            type == D_data_x(i + kl)
            ! Move to the new position
            %if type >= 0 %start
               ! Integer data: starts with a count of the
               ! number of following %integers.
               i = i + kl + 2 * type + 1
            %else
               ! Textual data
               i = i + kl + length(string(addr(type) + 2)) // 2 + 1 + 1
            %finish
            %exit %if i >= D_data_last entry;  ! The end
            k == D_data_x(i)
            ! Round for the next entry
         %repeat
         D_data_last entry = previous
      %else
         ! At the beginning/in the middle.  Shuffle, and recalculate pointers.
         ! Note: _u has already been adjusted.
         D_data_x(i) = D_data_x(i + amount) %c
            %for i = D_find position, 1, D_root_p(D_data block)_u
         D_data_last entry = D_data_last entry - amount
      %finish

write block:
      {} D_data_x(i) <- 16_DEAD %c
      {}    %for i = D_root_p(D_data block)_u + 1, 1, %c
      {}             D_root_p(D_data block)_u + amount
      %if D test bit(D_root_p(D_data block)_p, D_new(0)) %start
         ! Already allocated this time round
         p = D_root_p(D_data block)_p
      %else
         ! Must allocate a new one
         p = D new physical(D_map(0))
         D_root_p(D_data block)_p = p
         {} printstring("New physical: ");  write(p, 0);  newline
         D set bit(p, D_new(0))
      %finish
      D_status = D put block(token, D_data block, D_data)
      %result = D_status

delete entire block:
      ! If we delete the one entry asked there'll be nothing left.  In that
      ! case we logically delete the block by shuffling up the map entries.
      {} printstring("Delete entire block");  newline
      D_root_p(i) = D_root_p(i + 1) %for i = D_data block, 1, D_logical blocks - 1
      D_root_p(D_logical blocks) = 0
      D_logical blocks = D_logical blocks - 1
      D_data block = -1;  D_status = bugcheck error;  ! Just in case....
      %result = 0
%end


! Test stuff

%systemintegerfnspec real time
%systemintegerfnspec CPU time

%integerfn random
   %owninteger seed, first time = 0
      seed = real time !! CPU time %and first time = 1 %if first time = 0
      seed <- seed * 1103515245 + 12345
      %result = seed
%end

%string(15)%fn xtos(%integer x)
   %integer ch, i
   %string(15) s = ""
      %for i = 28, -4, 0 %cycle
         ch = (x >> i) & 15
         %if ch <= 9 %then ch = ch + '0' %c
                     %else ch = ch - 10 + 'A'
         s = s . to string(ch)
      %repeat
      %result = s
%end

%begin
   %integer op, T = 0, x, m, v
   %string(255) name, value
      %on 9 %start;  -> close;  %finish
      %cycle
         prompt("Op: ");  read symbol(op) %until op > ' '
         %if op = 'n' %or op = 'N' %start
            prompt("Name:    ");  read(name)
            x = D create(name)
            printstring("Create status ");  write(x, 0)
            newline
         %else %if op = 'o' %or op = 'O'
            prompt("Name:    ");  read(name)
            prompt("Mode:    ");  read(m)
            x = D open(name, m, T)
            printstring("Open status ");  write(x, 0)
            newline
         %else %if op = 'c' %or op = 'C'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               x = D close(T, 0)
               printstring("Close status ");  write(x, 0)
               newline
               T = 0
            %finish
         %else %if op = 'f' %or op = 'F'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               prompt("Key:     ");  read(name)
               prompt("Version: ");  read(x)
               x = D query(T, name, x, m, v, value)
               printstring("Find status ");  write(x, 0)
               newline
               %if x = 0 %start
                  printstring("Type ");  write(m, 0)
                  printstring(", value ")
                  %if m >= 0 %then write(v, 0) %c
                             %else printstring(value)
                  newline
               %finish
            %finish
         %else %if op = 'i' %or op = 'I'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               prompt("Key:     ");  read(name)
               prompt("Value:   ");  read(x)
               x = D add (T, 0, name, x, nil)
               printstring("Insert status ");  write(x, 0)
               newline
            %finish
         %else %if op = 't' %or op = 'T'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               prompt("Key:     ");  read(name)
               prompt("Value:   ");  read(value)
               x = D add(T, -1, name, 0, value)
               printstring("Insert status ");  write(x, 0)
               newline
            %finish
         %else %if op = 'r' %or op = 'R'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               name = xtos(random) . xtos(random) . xtos(random) . xtos(random)
               x = random
               {} printstring("Adding ");  printstring(name)
               {} printstring(", value ");  phex(x);  newline
               x = D add(T, 0, name, x, nil)
               printstring("Insert status ");  write(x, 0)
               newline
            %finish
         %else %if op = 'z' %or op = 'Z'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               prompt("Key:     ");  read(name)
               prompt("Version: ");  read(x)
               x = D delete(T, name, x)
               printstring("Delete status ");  write(x, 0)
               newline
            %finish
         %else %if op = 'x' %or op = 'X'
            %exit
         %else %if op = 'd' %or op = 'D'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               D dump(T)
            %finish
         %else %if op = 'p' %or op = 'P'
            %if T = 0 %start
               printstring("Not open");  newline
            %else
               D print(T)
            %finish
         %finish
      %repeat
close:
      %if T # 0 %start
         x = D close(T, -1)
         printstring("Close status ");  write(x, 0)
         newline
      %finish
%end %of %program