! B-tree system-dependent module (internal filesystem version).
! Interim version to facilitate conversion to transactions using shadowing.
! Note that the tree and data modules are not affected by whether or not
! this layer implements transactions, as they just read and write logical
! blocks using the routines provided here...

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

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

%constinteger initial size = 4

%constinteger data header site = 1

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

!! %include "GDMR_H:Dump.Inc"

%include "Moose:Mouse.Inc"
%systemroutinespec phex(%integer i)

!>>>>>

%recordformat used fm(%integer n, %integerarray x(1 : 128))

%routine add used(%integer what, %record(used fm)%name u)
   u_n = u_n + 1
   u_x(u_n) = what
%end

!<<<<<

! Old-style (unmapped) header, contains root block pointer, free list, and some
! stuff used during testing.

{C}%constinteger old free size = 256 - 8
{C}%recordformat old header fm((%short checksum, 
{C}                             %short root, used, flags, free count,
{C}                             %shortarray free(1 : old free size),
{C}                             %short should have, seed) %c
{C}                            %or %bytearray b(0 : 511))


! A two-level indirectory is used to convert from logical page number to
! physical page number.  The following two records describe the upper and
! lower levels of the map respectively.  To save space, the tree root block
! is kept in the master page.
!
! The update strategy for the database is that when a page (data, tree or
! map) is written for the first time a new physical page is allocated for it
! and the map is updated accordingly.  The database is commited iff the master
! page has been written out successfully to the alternate site, the newer of the
! two pages being used when the database is first opened.

%constinteger map limit = 255 - 1 - 1 - 2
%recordformat master fm(%short checksum,
                        %shortarray map(0 : map limit),
                        %short tree root,
                        %integer epoch)

%constinteger page map limit = 254
%recordformat page map fm(%short checksum,
                          %shortarray page(0 : page map limit))


! The following record holds the state of the open database.  If the old header
! field is non-nil then the database is assumed to be an old-style one with
! no indirectory map.  Otherwise (for databases with maps) the active master
! page and the most recent lower-level map page are cached, together with a
! used and a modified bitmap giving the status of the physical pages in the
! database: allocations of physical pages take place via the used map, while
! the modified map determines whether a new site is required or not (on first
! write to a page).

%constinteger bitmap size = 64  { * 8 to get blocks }
%recordformat tree access fm(%record(*)%name access,
                             %integer file token,
                             %record(old header fm)%name old header,
                             %record(master fm)%name master,
                             %integer master site,
                             %integer master page changed,
                             %record(page map fm)%name page map,
                             %integer last page map site,
                             %integer page map changed,
                             %bytearray physical used(0 : bitmap size),
                             %bytearray logical used(0 : bitmap size),
                             %bytearray modified(0 : bitmap size))
                             

! Error codes

%constinteger checksum error = -500


! Checksum stuff

%predicate check checksum(%record(*)%name b)
   %short c
   %shortname p
   %integer i
      c = 0;  p == shortinteger(addr(b))
      %for i = 1, 1, 256 %cycle
         c <- c + p;  p == p [1]
      %repeat
      %false %if c # 0
      %true
%end

%routine set checksum(%record(*)%name b)
   %short c
   %shortname p
   %integer i
      c = 0;  p == shortinteger(addr(b) + 2)
      %for i = 2, 1, 256 %cycle
         c <- c + p;  p == p [1]
      %repeat
      shortinteger(addr(b)) = -c
%end


! I/O stuff proper

%routine zap block(%record(*)%name block)
   D0 = 127
L: *clr.l (A0)+
   *dbra D0, L
%end

%integerfn read physical block(%integer access token, block,
                               %record(*)%name buffer)
   %record(tree access fm)%name a
   %integer bytes, status
      a == record(access token)
      status = fsys read file block(a_access, a_file token,
                                    block, bytes, buffer)
      %result = status %if status # 0
      %result = 0 %if check checksum(buffer)
      %result = checksum error
%end

%integerfn write physical block(%integer access token, block,
                                %record(*)%name buffer)
   %record(tree access fm)%name a
      a == record(access token)
      set checksum(buffer)
      %result = fsys write file block(a_access, a_file token,
                                      block, 512, buffer)
%end

%integerfn write unreadable(%record(tree access fm)%name ta,
                            %integer block)
   %recordformat block fm(%integerarray x(0 : 127))
   %record(block fm) b
   %integer i, status
      !! printstring("Write unreadable: block ");  write(block, 0);  newline
      b_x(i) = 16_ABABABAB %for i = 0, 1, 127
      status = fsys write file block(ta_access, ta_file token,
                                     block, 512, b)
      %if status # 0 %start
         printstring("Write unreadable: ");  write(status, 0)
         newline
         %result = -1
      %finish
      %result = 0
%end


! Map manipulation routines: read and write map pages, obtain and release
! logical and physical pages.

!! %routine show bitmap(%bytename map)
!!    %integer n, i
!!       %for n = 1, 1, 8 %cycle
!!          space
!!          %for i = 0, 1, 7 %cycle
!!             %if map & (1 << i) = 0 %then print symbol('0') %c
!!                                    %else print symbol('1')
!!          %repeat
!!          map == map [1]
!!       %repeat
!! %end

%integerfn translate for read(%record(tree access fm)%name ta,
                              %integer logical, %integername physical)
   ! Performs a map lookup to convert the logical block address to a
   ! physical address.  Returns zero physical address if the page is unmapped.
   %integer map page, map offset, status
      !! printstring("Translate for read: ");  write(logical, 0);  newline
      map page = logical // page map limit
      map offset = logical - map page * page map limit
      map page = ta_master_map(map page)
      %if ta_last page map site # map page %start
         %if ta_page map changed # 0 %start
            !! printstring("Previous map page at ")
            !! write(ta_last page map site, 0)
            !! printstring(" changed, flushing")
            !! newline
            status = write physical block(addr(ta), ta_last page map site,
                                          ta_page map)
            %result = status %if status # 0
         %finish
         ta_page map changed = 0
         %if map page = 0 %start
            !! printstring("New page, zapping");  newline
            zap block(ta_page map)
         %else
            ta_last page map site = -1
            !! printstring("Reading from ");  write(map page, 0)
            !! newline
            status = read physical block(addr(ta), map page, ta_page map)
            %result = status %if status # 0
         %finish
         ta_last page map site = map page
      %finish
      physical = ta_page map_page(map offset)
      !! printstring("-> ");  write(physical, 0);  newline
      %result = 0
%end

%integerfn new physical page(%record(tree access fm)%name ta)
   %integer bit, byte, mask, block, status
      !! printstring("Map:");  show bitmap(ta_physical used(0));  newline
      %for byte = 0, 1, bitmap size %cycle
         %if ta_physical used(byte) # 255 %start
            %for bit = 0, 1, 7 %cycle
               mask = 1 << bit
               %if ta_physical used(byte) & mask = 0 %start
                  ta_physical used(byte) = ta_physical used(byte) ! mask
                  block = byte << 3 + bit
                  !! printstring("New physical page ")
                  !! write(block, 0);  newline
                  status = write unreadable(ta, block)
                  %result = -1 %if status # 0
                  %result = block
               %finish
            %repeat
         %finish
      %repeat
      !! printstring("No new physical page");  newline
      %result = -1
%end

%integerfn translate for write(%record(tree access fm)%name ta,
                               %integer logical, %integername physical)
   ! Perform a map lookup.  Allocate a new physical page if this is the first
   ! time the logical page has been modified.
   %integer bit, byte, status, map page, map offset, new physical map page
      ! First pull in the map page and translate the current physical
      ! address.  We'll have to check whether or not it has been updated this
      ! time round.
      !! printstring("Translate for write: ");  write(logical, 0);  newline
      status = translate for read(ta, logical, physical)
      %result = status %if status # 0
      bit = physical & 7;  byte = physical >> 3
      %if byte > bitmap size %start
         printstring("Translate for write -- ""modified"" bitmap size error: ")
         write(byte, 0);  newline
      %finish
      %if (byte # 0 %or bit # 0) %and ta_modified(byte) & (1 << bit) # 0 %start
         ! Already updated
         !! printstring("Already updated to ");  write(physical, 0);  newline
         %result = 0
      %finish
      ! Since we know now that this is a first-time update for this
      ! logical page, we'll have to allocate a new physical page and update 
      ! the corresponding map page.
      physical = new physical page(ta)
      !! printstring("First update, mapping to ");  write(physical, 0);  newline
      %result = -1 %if physical <= 0
      map page = logical // page map limit
      map offset = logical - map page * page map limit
      ! The map page is in store.  Update it.  If necessary obtain a new
      ! physical page for it.
      ta_page map_page(map offset) = physical
      ta_page map changed = 1
      !! printstring("MM");  show bitmap(ta_modified(0));  newline
      bit = ta_last page map site & 7;  byte = ta_last page map site >> 3
      %if byte > bitmap size %start
         printstring("Translate for write -- ""modified"" bitmap size error: ")
         write(byte, 0);  newline
      %finish
      %if bit = 0 = byte %or ta_modified(byte) & (1 << bit) = 0 %start
         ! First modification for map page.  Get a new physical page.
         new physical map page = new physical page(ta)
         !! printstring("New map page: ");  write(new physical map page, 0)
         !! newline
         %result = -1 %if new physical map page < 0
         ta_master_map(map page) = new physical map page
         ta_last page map site = new physical map page 
         ta_master page changed = 1
         bit = new physical map page & 7;  byte = new physical map page >> 3
         %if byte > bitmap size %start
            printstring("Translate for write -- ""modified"" bitmap size error: ")
            write(byte, 0);  newline
         %finish
         ta_modified(byte) = ta_modified(byte) ! (1 << bit)
      %finish
      ! Now mark the new physical page as changed
      bit = physical & 7;  byte = physical >> 3
      %if byte > bitmap size %start
         printstring("Translate for write -- ""modified"" bitmap size error: ")
         write(byte, 0);  newline
      %finish
      ta_modified(byte) = ta_modified(byte) ! (1 << bit)
      %result = 0
%end

! Logical block I/O.  For unmapped trees these just call the corresponding
! physical I/O routines.  Mapped trees require an indirection.

%integerfn read block(%integer access token, block, %record(*)%name buffer)
   %record(tree access fm)%name ta
   %integer status, physical
      ta == record(access token)
{C}   %result = read physical block(access token, block, buffer) %c
{C}      %if ta_old header ## nil
      !! printstring("Read (mapped) block ");  write(block, 0);  newline
      status = translate for read(ta, block, physical)
      %result = status %if status # 0
      !! printstring("Translated to ");  write(physical, 0);  newline
      zap block(buffer) %and %result = 0 %if physical <= 0;  ! Unmapped
      %result = read physical block(access token, physical, buffer)
%end

%integerfn write block(%integer access token, block, %record(*)%name buffer)
   %record(tree access fm)%name ta
   %integer status, physical
      ta == record(access token)
{C}   %result = write physical block(access token, block, buffer) %c
{C}      %if ta_old header ## nil
      !! printstring("Write (mapped) block ");  write(block, 0);  newline
      status = translate for write(ta, block, physical)
      %result = status %if status # 0
      !! printstring("Translated to ");  write(physical, 0);  newline
      %result = write physical block(access token, physical, buffer)
%end


! Free block list management.  For non-mapped databases the free list is held
! in the header block, while the bitmap and map pages themselves are used for
! mapped databases.

%integerfn get new block(%integer access token)
   %record(tree access fm)%name ta
{C}%record(old header fm)%name old header
{C}%integer it, i
   %integer bit, byte, mask
      ta == record(access token)
{C}   %if ta_old header ## nil %start
{C}      old header == ta_old header
{C}      %if old header_free count = 0 %start
{C}         ! Nothing spare.  Should extend.
{C}         old header_used = 1 %if old header_used = 0;  ! Skip data header
{C}         old header_used = old header_used + 1
{C}         i = write block(access token, 0, old header)
{C}         %result = i %if i < 0
{C}         %result = old header_used
{C}      %else
{C}         it = old header_free(1);  ! Use the first
{C}         old header_free count = old header_free count - 1
{C}         %if old header_free count > 0 %start
{C}            ! More than one free.  Shuffle down the rest.
{C}            old header_free(i) = old header_free(i + 1) %c
{C}               %for i = 1, 1, old header_free count
{C}         %finish
{C}         i = write block(access token, 0, old header)
{C}         %result = i %if i < 0
{C}         %result = it
{C}      %finish
{C}   %finish
      %for byte = 0, 1, bitmap size %cycle
         %if ta_logical used(byte) # 255 %start
            %for bit = 0, 1, 7 %cycle
               mask = 1 << bit
               %if ta_logical used(byte) & mask = 0 %start
                  ta_logical used(byte) = ta_logical used(byte) ! mask
                  !! printstring("Logical block ")
                  !! write(byte << 3 + bit, 0)
                  !! printstring(" allocated");  newline
                  %result = byte << 3 + bit
               %finish
            %repeat
         %finish
      %repeat
      %result = -1
%end

%integerfn free block(%integer access token, which)
   %record(tree access fm)%name ta
{C}%record(old header fm)%name old header
{C}%integer i, pos
   %integer bit, byte
      ta == record(access token)
{C}   %if ta_old header ## nil %start
{C}      old header == ta_old header
{C}      %result = 0 %if old header_free count >= old free size;  ! Throw it away meantime
{C}      %if old header_free count = 0 %start
{C}         old header_free(1) = which
{C}         old header_free count = 1
{C}      %else
{C}         %for pos = 1, 1, old header_free count %cycle
{C}            %if old header_free(pos) > which %start
{C}               ! Found insertion position
{C}               old header_free(i + 1) = old header_free(i) %c
{C}                  %for i = old header_free count, -1, pos
{C}               old header_free(pos) = which
{C}               old header_free count = old header_free count + 1
{C}               -> write it
{C}            %finish
{C}         %repeat
{C}         ! Muat be last of all
{C}         old header_free count = old header_free count + 1
{C}         old header_free(old header_free count) = which
{C}      %finish
{C}write it:
{C}      %result = write block(access token, 0, old header)
{C}   %finish
      !! printstring("Freeing logical block ");  write(which, 0);  newline
      bit = which & 7;  byte = which >> 3
      %if byte > bitmap size %start
         printstring("Free block bitmap error: ");  write(byte, 0)
         newline
      %finish
      ta_logical used(byte) = ta_logical used(byte) & (\ (1 << bit))
      %result = 0
%end


! Tree root determination.  Rather than take up an entire block in a known
! location to store the pointer to the tree's root, we decide instead to keep
! it in the database indirectory master page.  (At least, we will do!)
! Non-mapped databases hold it in the tree header.

%integerfn find root(%integer access token)
   %record(tree access fm)%name ta
      ta == record(access token)
{C}   %result = ta_old header_root %if ta_old header ## nil
      %result = ta_master_tree root
%end

%integerfn set root(%integer access token, new root)
   %record(tree access fm)%name ta
{C}%record(old header fm)%name old header
      ta == record(access token)
{C}   %if ta_old header ## nil %start
{C}      old header == ta_old header
{C}      old header_root = new root
{C}      %result = write block(access token, 0, old header)
{C}   %finish
      ta_master_tree root = new root
      ta_master page changed = 1
      %result = 0
%end


! Bitmap construction

%routine bitmap set(%integer bit, %bytename map)
   %integer byte, offset
      byte = bit >> 3;  offset = bit & 7
      map [byte] = map [byte] ! (1 << offset)
%end

%integerfn build bitmaps(%record(tree access fm)%name ta)
   %integer status, map page, map offset, map physical, map logical
      ta_physical used(0) = 2_00000011;  ! Two master pages
      ta_logical used(0)  = 2_00000011;  ! Reserved + data header
      ta_modified(0)      = 2_00000011;  ! Two master pages (??)
      %for map page = 0, 1, map limit %cycle
         map physical = ta_master_map(map page)
         %if map physical # 0 %start
            ! Map page exists, so note it and scan it
            !! printstring("Note map page ");  write(map physical, 0)
            !! newline
            bitmap set(map physical, ta_physical used(0))
            status = read physical block(addr(ta), map physical, ta_page map)
            %result = status %if status # 0
            ta_last page map site = map physical
            %for map offset = 0, 1, page map limit %cycle
               map physical = ta_page map_page(map offset)
               %if map physical # 0 %start
                  ! Database page exists.  Note physical site, then
                  ! calculate and note logical address.
                  !! printstring("Note physical database page ")
                  !! write(map physical, 0);  newline
                  bitmap set(map physical, ta_physical used(0))
                  map logical = map page * page map limit + map offset
                  !! printstring("Note logical database page ")
                  !! write(map logical, 0);  newline
                  bitmap set(map logical, ta_logical used(0))
               %finish
            %repeat
         %finish
      %repeat
      !! printstring("PU");  show bitmap(ta_physical used(0));  newline
      !! printstring("LU");  show bitmap(ta_logical  used(0));  newline
      !! printstring("M ");  show bitmap(ta_modified     (0));  newline
      %result = 0
%end


! Tree module proper

%include "GDMR_H:Tree.Core"
%include "GDMR_H:Data.Core"


! open/close/create

%externalintegerfn B tree open by ID(%record(fsys access fm)%name access,
                                     %integer ID, mode,
                                     %integername token, flags)
   %record(used fm) used = 0
   %record(tree access fm)%name a == nil
   %record(master fm)%name other master
   %integer status, size, x, access mode, compatible mode
      !! printstring("Open ");  phex(ID);  newline
      %if mode = 0 %start
         access mode = read access
         compatible mode = read access
      %else
         access mode = read access ! modify access
         compatible mode = 0
      %finish
      a == new(a);  a = 0
      a_access == access
      status = fsys open file(access, ID, access mode, compatible mode,
                              a_file token, size, flags)
      dispose(a) %and %result = status %if status # 0
      a_master == new(a_master)
      status = read physical block(addr(a), 0, a_master)
      %if status # 0 %start
         x = fsys close file(nil, a_file token, 0)
         dispose(a_master)
         dispose(a)
         %result = status
      %finish
      !>>>>>
      %if a_master_epoch = 0 %start
         !! printstring("Unmapped tree ");  phex(ID);  newline
         a_old header == record(addr(a_master))
         a_master == nil
         generate tree block list(addr(a), a_old header_root, used)
         generate data block list(addr(a), used)
         !! printstring("Tree + data block list:")
         !! %if used_n > 0 %start
         !!    space %and write(used_x(x), 0) %for x = 1, 1, used_n
         !! %finish
         !! newline
      %else
         !! printstring("B-tree ");  phex(ID)
         !! printstring(": master 0 epoch ");  phex(a_master_epoch)
         !! newline
         other master == new(other master)
         status = read physical block(addr(a), 1, other master)
         %result = status %if status # 0
         !! spaces(17);  printstring("master 1 epoch ")
         !! phex(other master_epoch);  newline
         !! dump(512, byteinteger(addr(a_master)))
         !! dump(512, byteinteger(addr(other master)))
         %if other master_epoch > a_master_epoch %start
            dispose(a_master)
            a_master == other master
            a_master site = 0;  ! Always the *target* site
         %else
            dispose(other master)
            a_master site = 1;  ! Always the *target* site
         %finish
         a_old header == nil
         a_page map == new(a_page map);  a_page map = 0
         status = build bitmaps(a)
         %result = status %if status # 0
      %finish
      !<<<<<
      token = addr(a)
      !! printstring("Opened as ");  phex(token)
      !! printstring(", size is ");  write(size >> 9 + 1, 0);  newline
      %result = 0
%end


%externalintegerfn B tree close(%integer token, abandon)
   %record(tree access fm)%name a
   %integer status
      a == record(token)
{C}   %if a_old header ## nil %start
{C}      dispose(a_old header)
{C}   %else
         ! Write out the maps, then dispose them
         !! printstring("Closing: abandon ");  write(abandon, 0)
         !! printstring(", mpc ");  write(a_master page changed, 0)
         !! printstring(", ms ");  write(a_master site, 0)
         !! printstring(", pmc ");  write(a_page map changed, 0)
         !! printstring(", lpms ");  write(a_last page map site, 0)
         !! newline
         %if abandon = 0 %start
            %if a_master page changed # 0 %start
               %if a_page map changed # 0 %start
                  !! printstring("Writing last modified map to ")
                  !! write(a_last page map site, 0);  newline
                  status = write physical block(token, a_last page map site,
                                                a_page map)
                  %result = status %if status # 0
               %finish
               a_master_epoch = a_master_epoch + 1
               !! printstring("Writing master page to ")
               !! write(a_master site, 0);  newline
               status = write physical block(token, a_master site, a_master)
               %result = status %if status # 0
            %finish
         %finish
         dispose(a_page map)
         dispose(a_master)
{C}   %finish
      status = fsys close file(a_access, a_file token, auto truncate flag)
      !! %if status < 0 %start
      !!    printstring("Close tree failed: ");  write(status, 0)
      !!    newline
      !! %finish
      dispose(a)
      %result = 0
%end


%externalintegerfn B tree create(%record(fsys access fm)%name access,
                                 %string(31) name, %integer partition,
                                 %integer benefactor ID,
                                 %integername ID)
   %record(master fm) master
   %integer status, token, size, flags
      status = fsys create file(access, name, partition, benefactor ID,
                                initial size, ID)
      %result = status %if status # 0
      status = fsys open file(nil, ID, modify mode, 0, token, size, flags)
      %result = status %if status # 0
      ! Initialise the two master pages with epoch 1 & everything else
      ! zero -- this means that the database is implicitly zero.
      master = 0
      master_epoch = 1
      master_checksum = -1
      status = fsys write file block(access, token, 0, 512, master)
      %result = status %if status # 0
      status = fsys write file block(access, token, 1, 512, master)
      %result = status %if status # 0
      %result = fsys close file(access, token, 0)
%end

%end %of %file