! Data record manipulation module.  Data entries grow from the front, each
! with a length word first and the data following immediately after.

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

%option "-nonstandard-low"

%constinteger data block slots = 254
%recordformat data block fm((%short checksum, entries,
                            %shortarray x(1 : data block slots)) %c
                        %or %bytearray z(0 : 511))

%constinteger data header slots = 126
%recordformat data header slot fm(%short block, %byte free slots, released slots)
%recordformat data header fm((%short checksum, chain, used,
                              %record(data header slot fm)%array %c
                                s(1 : data header slots)) %c
                         %or %bytearray z(0 : 511))

%constinteger too many blocks    error = -550
%constinteger data size          error = -551
%constinteger data block corrupt error = -552
%constinteger data site          error = -553
%constinteger deleted data       error = -554


! Data copying

%routine move data(%integer bytes, %record(*)%name from, to)
   D0 = D0 - 1
L: *move.b (A0)+, (A1)+
   *dbra D0, L
%end


! Return the value of the data at the indicated location.  **exported**

%externalintegerfn B tree data value(%integer access token, site,
                                     %integername size, %record(*)%name target)
   %record(data block fm) buffer
   %integer status, block, slot, pos, n
   %shortname x
      !! printstring("Data value for ");  phex(site);  newline
      block = site >> 8;  slot = site & 255
      status = read block(access token, block, buffer)
      %result = status %if status < 0
      %result = data site error %unless 0 < slot <= buffer_entries
      pos = 1
      %for n = 1, 1, buffer_entries %cycle
         x == buffer_x(pos)
         %result = data block corrupt error %if x < 0
         !! printstring("Slot ");  write(n, 0)
         !! printstring(" size ");  write(x, 0);  newline
         %if n = slot %start
            ! Found our data
            %result = deleted data error %if x = 0
            move data(x, record(addr(buffer_x(pos + 1))), target)
            size = x
            %result = 0
         %finish
         pos = pos + (x + 3) // 2
         %result = data block corrupt error %if pos > data block slots
      %repeat
      %result = -9999;  ! Placate compiler
%end


! Replace the data at the indicated location.  **exported**

%externalintegerfn B tree data replace(%integer access token, site,
                                       %record(*)%name source)
   ! Use the size as indicated in the database
   %record(data block fm) buffer
   %integer status, block, slot, pos, n
   %shortname x
      !! printstring("Data replace for ");  phex(site);  newline
      block = site >> 8;  slot = site & 255
      status = read block(access token, block, buffer)
      %result = status %if status < 0
      %result = data site error %unless 0 < slot <= buffer_entries
      pos = 1
      %for n = 1, 1, buffer_entries %cycle
         x == buffer_x(pos)
         %result = data block corrupt error %if x < 0
         !! printstring("Slot ");  write(n, 0)
         !! printstring(" size ");  write(x, 0);  newline
         %if n = slot %start
            ! Found our data
            %result = deleted data error %if x = 0
            move data(x, source, record(addr(buffer_x(pos + 1))))
            %result = write block(access token, block, buffer)
         %finish
         pos = pos + (x + 3) // 2
         %result = data block corrupt error %if pos > data block slots
      %repeat
      %result = -9998;  ! Placate compiler
%end


! Find a home for the data and copy in.  **exported**

%externalintegerfn B tree data insert(%integer access token, size,
                                      %record(*)%name source, %integername site)
   %record(data header fm) header
   %record(data header slot fm)%name s
   %record(data block fm) buffer
   %integer status, block, required, i, n, pos, total used
   %shortname x
      !! printstring("Data insert: size ");  write(size, 0)
      !! printstring(", source at ");  phex(addr(source))
      !! printstring(", site at ");  phex(addr(site))
      !! newline
      %result = data size error %if size <= 0
      required = (size + 1) // 2
      %result = data size error %unless required < data block slots
      status = read block(access token, data header site, header)
      %result = status %if status < 0
      %if header_used > 0 %start
         %for i = 1, 1, header_used %cycle
            s == header_s(i)
            !! printstring("Block ");  write(s_block, 0)
            !! printstring(", slots ");  write(s_free slots, 0)
            !! printstring(", released ");  write(s_released slots, 0)
            !! newline
            %if s_free slots > required %or %c
                  (s_free slots = required %and s_released slots # 0) %start
               !! printstring("Space in ");  write(s_block, 0);  newline
               total used = data block slots - s_free slots
               s_free slots = s_free slots - required
               %if s_released slots # 0 %start
                  s_released slots = s_released slots - 1
               %else
                  s_free slots = s_free slots - 1
               %finish
               status = write block(access token, data header site, header)
               %result = status %if status < 0
               block = s_block
               status = read block(access token, block, buffer)
               %result = status %if status < 0
               -> do insert
            %finish
         %repeat
      %finish

      ! Nothing found that's big enough.  We'll need to get another
      ! block to hold the new data.
      %result = too many blocks error %if header_used = data header slots
      block = get new block(access token)
      %result = block %if block < 0
      !! printstring("No space, using ");  write(block, 0);  newline
      header_used = header_used + 1
      s == header_s(header_used)
      s_block = block;  s_released slots = 0
      s_free slots = data block slots - required - 1
      status = write block(access token, data header site, header)
      %result = status %if status < 0
      buffer = 0;  pos = 1
      -> insert at end;  ! New, so must be empty

do insert:
      ! Now cycle through the block looking for a spare slot for the data
      pos = 1
      %for n = 1, 1, buffer_entries %cycle
         x == buffer_x(pos)
         %if x = 0 %start
            ! Found a null length (empty slot).  Shuffle up
            !! printstring("Empty slot at ");  write(pos, 0)
            !! printstring(" (");  write(n, 0);  print symbol(')')
            !! newline
            buffer_x(i + required) = buffer_x(i) %for i = total used, -1, pos + 1
            site = block << 8 ! n
            x = size
            move data(size, source, record(addr(x) + 2))
            %result = write block(access token, block, buffer)
         %else
            ! This one's used, so skip it
            %result = data block corrupt error %if x < 0
            pos = pos + (x + 3) // 2
            %result = data block corrupt error %if pos > data block slots
         %finish
      %repeat
      ! Nothing spare, so drop through to insert it at the end

insert at end:
      ! Nothing spare, so it must be at the end
      !! printstring("At end, pos ");  write(pos, 0);  newline
      buffer_entries = buffer_entries + 1
      !! printstring("Now have ");  write(buffer_entries, 0)
      !! printstring(" entries");  newline
      site = block << 8 ! buffer_entries
      buffer_x(pos) = size
      move data(size, source, record(addr(buffer_x(pos + 1))))
      %result = write block(access token, block, buffer)
%end


! Delete the data at the specified location.  **exported**

%externalintegerfn B tree data delete(%integer access token, site)
   %record(data header fm) header
   %record(data header slot fm)%name s
   %record(data block fm) buffer
   %integer status, i, required, header slot pos, pos, block, slot, null run
   %shortname x
      !! printstring("Data delete from ");  phex(site);  newline
      block = site >> 8;  slot = site & 255
      ! Find the pointer in the header
      status = read block(access token, data header site, header)
      %result = status %if status < 0
      %result = data site error %if header_used = 0
      %for i = 1, 1, header_used %cycle
         s == header_s(i)
         header slot pos = i %and -> found header slot %if s_block = block
      %repeat
      %result = data site error

found header slot:
      !! printstring("Found header slot at ");  write(header slot pos, 0)
      !! printstring(", ");  write(s_free slots, 0);  printstring(" free, ")
      !! write(s_released slots, 0);  printstring(" released");  newline
      status = read block(access token, block, buffer)
      %result = status %if status < 0
      %result = data site error %unless 0 < slot <= buffer_entries
      ! Find the data
      pos = 1;  null run = 0
      %for i = 1, 1, buffer_entries %cycle
         x == buffer_x(pos)
         %result = data block corrupt error %if x < 0
         !! printstring("Slot ");  write(i, 0)
         !! printstring(" size ");  write(x, 0);  newline
         %exit %if i = slot
         %if x = 0 %then null run = null run + 1 %else null run = 0
         pos = pos + (x + 3) // 2
         %result = data block corrupt error %if pos > data block slots
      %repeat
      ! Found the data.  <pos> & <x> point at the length
      !! printstring("Found data at ");  write(pos, 0)
      !! printstring(", ");  write(null run, 0);  printstring(" null")
      !! newline
      %result = deleted data error %if x = 0
      required = (x + 1) // 2
      %if slot < buffer_entries %start
         ! Not the last one, so we'll have to shuffle down.
         !! printstring("Not last, shuffling data");  newline
         x = 0
         buffer_x(i) = buffer_x(i + required) %c
            %for i = pos + 1, 1, data block slots - s_free slots - required
         s_free slots = s_free slots + required
         s_released slots = s_released slots + 1
         status = write block(access token, block, buffer)
         %result = status %if status < 0
      %else
         ! Last in the block, so forget it.
         !! printstring("Last, forgetting in data block");  newline
         buffer_entries = buffer_entries - 1 - null run
         %if buffer_entries = 0 %start
            ! Nothing left in the block, so we can free it up.
            !! printstring("Empty, free it up");  newline
            header_used = header_used - 1
            %if header slot pos <= header_used %start
               ! Not the last, so we'll have to shuffle
               header_s(i) = header_s(i + 1) %c
                  %for i = header slot pos, 1, header_used
            %finish
            status = free block(access token, block)
            %result = status %if status < 0
         %else
            ! Can't free it, so adjust the header
            s_free slots = s_free slots + required + 1 + null run
            s_released slots = s_released slots - null run
            status = write block(access token, block, buffer)
            %result = status %if status < 0
         %finish
      %finish
      !! printstring("Now have ");  write(s_free slots, 0);  printstring(" free, ")
      !! write(s_released slots, 0);  printstring(" released");  newline
      %result = write block(access token, data header site, header)
%end

%end %of %file