! B-tree test program

%option "-nonstandard-low"

%systemroutinespec phex(%integer i)
%systemroutinespec phex2(%integer i)

! The following two must be the same as in TREE.CORE
%constinteger free size = 256 - 8
%recordformat header fm((%short checksum, 
                         %short root, used, flags, free count,
                         %shortarray free(1 : free size),
                         %short should have, seed) %c
                        %or %bytearray b(0 : 511))

%constinteger block slots = 253
%recordformat block fm(%short checksum,
                       %short flags,
                       %byte pointer limit, text limit,
                       %shortarray x(1 : block slots))
%constinteger leaf = 1;  ! Hence no child-pointers

%ownrecord(header fm) header

%externalintegerfnspec compare(%string(*)%name a, b, %integer case)

%externalroutinespec L open file(%record(*)%name access,
                                 %string(255) filename,
                                 %integer mode, compatible, partition,
                                 %integername token, size, flags)
%externalroutinespec L close file(%record(*)%name access,
                                  %integer token, flags)
%externalroutinespec L read block(%record(*)%name access,
                                  %integer token, block,
                                  %integername bytes,
                                  %record(*)%name buffer)


%owninteger token = 0

! Diagnostic stuff

%routine dump(%integer bytes, %bytename buffer)
   %integer i, j, k
      newline
      i = 0
      %while i < bytes %cycle
         %for j = 0, 1, 15 %cycle
            %if i + j >= bytes %then space %and space %c
                               %else phex2(byteinteger(addr(buffer) + j))
            space %if j & 3 = 3
         %repeat
         printstring(" [")
         write(i, -3)
         printstring("]  |")
         %for j = 0, 1, 15 %cycle
            %if j + i < bytes %start
               k = byteinteger(addr(buffer) + j) & 127
               %if k = 0 %start
                  k = '.'
               %else %unless ' ' <= k <= '~'
                  k = '_'
               %finish
               printsymbol(k)
            %else
               space
            %finish
         %repeat
         printsymbol('|')
         newline
         i = i + 16;  buffer == buffer [16]
      %repeat
      newline
%end

%routine put filtered(%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

%owninteger have
%ownstring(255) previous key

%routine print tree(%integer root, indent)
   %record(block fm) b
   %shortname p
   %integer i, bytes
   %string(*)%name k
      %unless 0 < root <= header_used %start
         printstring("Invalid block address ")
         write(root, 0);  newline
         %signal 13, root
      %finish
      L read block(nil, token, root, bytes, b)
      !! spaces(indent)
      !! printstring("Pointer limit = ");  write(b_pointer limit, 0)
      !! printstring(", text limit = ");  write(b_text limit, 0)
      !! newline
      %signal 13, b_pointer limit, b_text limit %c
          %unless 0 < b_pointer limit < b_text limit
      indent = indent + 3
      %if b_flags & leaf = 0 %start
         print tree(b_x(1), indent)
         i = b_pointer limit - 1
         p == b_x(2)
      %else
         i = b_pointer limit
         p == b_x(1)
      %finish
      %while i > 0 %cycle
         write(root, indent);  printstring(": ")
         phex(integer(addr(p) + 2));  spaces(2)
         k == string(addr(b_x(p)));  put filtered(k);  newline
         p == p [3]
         %unless compare(previous key, k, 0) < 0 %start
            printstring("*** Sort order error ***");  newline
         %finish
         previous key = k
         i = i - 3
         have = have + 1
         %if b_flags & leaf = 0 %start
            print tree(p, indent)
            p == p [1];  i = i - 1
         %finish
      %repeat
%end

%routine analyse one(%integer n, %record(block fm)%name b)
   %shortname p
   %integer i
      printstring("Block ");  write(n, 0);  newline
      printstring("   Pointer limit = ");  write(b_pointer limit, 0)
      printstring(", text limit = ");  write(b_text limit, 0)
      newline
      %return %unless 0 < b_pointer limit < b_text limit
      %if b_flags & leaf = 0 %start
         printstring("   -> ");  write(b_x(1), 0)
         newline
         i = b_pointer limit - 1
         p == b_x(2)
      %else
         i = b_pointer limit
         p == b_x(1)
      %finish
      %while i > 0 %cycle
         phex(integer(addr(p) + 2));  spaces(3)
         %unless b_text limit <= p <= block slots %start
            printstring("Dud text pointer ");  write(p, 0)
            p == p [3]
         %else
            put filtered(string(addr(b_x(p))));  p == p [3]
         %finish
         newline
         i = i - 3
         %if b_flags & leaf = 0 %start
            printstring("   -> ");  write(p, 0)
            newline
            p == p [1];  i = i - 1
         %finish
      %repeat
%end


! Test program

%begin
   %record(block fm) b
   %string(255) file
   %integer command, size, flags, n, bytes
      %on 3, 4, 9 %start
         printstring("%signal ");  write(event_event, 0)
         space;  write(event_sub, 0)
         space;  write(event_extra, 0)
         space;  printstring(event_message);  newline
         -> done %if token > 0
         %stop
      %finish
      open input(0, ":T");  select input(0)
      open output(0, ":T");  select output(0)
      prompt("File: ");  read(file)
      L open file(nil, file, 16_4001, -1, -1, token, size, flags)
      L read block(nil, token, 0, bytes, header)
      printstring("Got header, root at ");  write(header_root, 0)
      newline
top:  %cycle
         prompt("Command: ")
         read symbol(command) %until command > ' '
         %if command = 'p' %start
            have = 0;  previous key = ""
            print tree(header_root, 0) %if header_root # 0
         %else %if command = 's'
            prompt("N ");  read(n)
            L read block(nil, token, n, bytes, b)
            dump(512, byteinteger(addr(b)))
         %else %if command = 'x'
            prompt("N ");  read(n)
            L read block(nil, token, n, bytes, b)
            analyse one(n, b)
         %else %if command = 'e'
            %exit
         %finish
      %repeat
done: L close file(nil, token, 0)
%end %of %program