-- BTree.mesa		Last edit: KK		November 4, 1980  1:43 PM
-- Edited by Andrew Birrell 22-May-81 10:19:37

DIRECTORY
  BTreeDefs: FROM "BTreeDefs" USING [
    BTreeHandle, Call, Desc, KeyNotFound, TestKeys],
  BTree2Defs: FROM "BTree2Defs" USING [
    Delete, DeletePage, Entry, EntryR, GetAnother, Index, Initialize, Insert,
    Items, Lookup, Merger, Replace, VArray],
  BTreeSupportDefs: FROM "BTreeSupportDefs" USING [
    AllocateWords, FileHandle, FreeWords, PageHandle, PageSize, ReadPage,
    ReleasePage, UsePage, WritePage];

BTree: PROGRAM IMPORTS BTree2Defs, BTreeSupportDefs EXPORTS BTreeDefs =
  BEGIN

  TwoKeysNonLeafSplit: SIGNAL RETURNS [Page] = CODE;
  EntryTooSmall: SIGNAL = CODE;
  Malformed: SIGNAL = CODE;

  Alarm: PROCEDURE = BEGIN AlarmCalled END;
  AlarmCalled: SIGNAL = CODE;

  Version: NN ← 1;  -- for bug checking.
  Juniper: BOOLEAN = FALSE;

  CallTree: TYPE = PROCEDURE [p: Page, i: BTree2Defs.Index]
    RETURNS [more: BOOLEAN];

  NN: TYPE = CARDINAL;

  Page: TYPE = POINTER TO BTreePageRecord;
  BTreePageRecord: TYPE = RECORD [
    b: Tree,
    pa: NN,
    ca: BTree2Defs.VArray,
    c: BTreeDefs.Desc,
    level: NN,
    dirty, deleted, rekey: BOOLEAN];  -- pa is the number of this page in the file (starts at 1).

  Tree: TYPE = POINTER TO BTreeRecord;
  BTreeRecord: TYPE = RECORD [
    version, rootPA, freePA, lastPA, pageS, depth, entries: NN,
    file: BTreeSupportDefs.FileHandle,
    self: BTreePageRecord,
    IsFirstGreaterOrEqual, AreTheyEqual: BTreeDefs.TestKeys,
    dirtyTree, sawUserUnwind: BOOLEAN];

  OldBTreePageRecord: TYPE = RECORD [
    b: Tree,
    pa: NN,
    ca: BTree2Defs.VArray,
    c: BTreeDefs.Desc,
    level: NN,
    nul1: Page,
    nul2: NN,
    dirty, deleted, rekey: BOOLEAN];
  OldBTreeRecord: TYPE = RECORD [
    version, nlu1, nlu2, nlu3, rootPA, freePA, lastPA, pageS, depth, entries: NN,
    file: BTreeSupportDefs.FileHandle,
    oldSelf: OldBTreePageRecord,
    IsFirstGreaterOrEqual, AreTheyEqual: BTreeDefs.TestKeys,
    nlu4, dirtyTree: BOOLEAN,
    nlu5: CARDINAL];

  registeryOfBTrees: pntrToBTreeReg ← NIL;
  pntrToBTreeReg: TYPE = POINTER TO BTreeReg;
  BTreeReg: TYPE = RECORD [next: pntrToBTreeReg, tree: Tree, valid: BOOLEAN];

  nullPA: NN = 177777B;

  CheckAmount: TYPE = {little, moderate, lots, dontAsk};
  checking: CheckAmount ← little;

  -- there should be a check about pagesize vs. max. item size;
  PageSize: CARDINAL = BTreeSupportDefs.PageSize[];

  InvalidTree: PUBLIC ERROR = CODE;

  CheckBTreeRegistered: PROCEDURE [b: Tree] RETURNS [inValidTree: BOOLEAN] =
    BEGIN
    FOR pntr: pntrToBTreeReg ← registeryOfBTrees, pntr.next DO
      IF pntr = NIL THEN Alarm[];
      IF pntr.tree = b THEN RETURN[NOT pntr.valid];
      ENDLOOP;
    END;

  RegisterBTree: PROCEDURE [b: Tree] =
    BEGIN
    oldPntr: POINTER TO pntrToBTreeReg ← @registeryOfBTrees;
    pntr: pntrToBTreeReg ← registeryOfBTrees;
    DO
      IF pntr = NIL THEN
        BEGIN
        pntr ← BTreeSupportDefs.AllocateWords[SIZE[BTreeReg]];
        pntr↑ ← [tree: b, next: NIL, valid: TRUE];
        oldPntr↑ ← pntr;
        RETURN;
        END;
      oldPntr ← @pntr.next;
      pntr ← pntr.next;
      ENDLOOP;
    END;

  RemoveRegistryOfBTree: PROCEDURE [b: Tree] =
    BEGIN
    oldPntr: POINTER TO pntrToBTreeReg ← @registeryOfBTrees;
    pntr: pntrToBTreeReg ← registeryOfBTrees;
    DO
      IF pntr = NIL THEN Alarm[];
      IF pntr.tree = b THEN
        BEGIN oldPntr↑ ← pntr.next; BTreeSupportDefs.FreeWords[pntr]; RETURN; END;
      oldPntr ← @pntr.next;
      pntr ← pntr.next;
      ENDLOOP;
    END;

  MarkBTreeInvalidInRegistry: PROCEDURE [b: Tree] =
    BEGIN
    pntr: pntrToBTreeReg ← registeryOfBTrees;
    DO
      IF pntr = NIL THEN Alarm[];
      IF pntr.tree = b THEN BEGIN pntr.valid ← FALSE; RETURN; END;
      pntr ← pntr.next;
      ENDLOOP;
    END;

  -- Conventions: Unwinds out of CreateAndInitializeBTree and ReleaseBTree have freed Tree and removed the registry.  Other Unwinds expect someone else to shut down the tree (ReleaseBTree is not the thing to be called to do that; call ShutDownBTree instead).

  CreateAndInitializeBTree: PUBLIC PROCEDURE [
    fileH: BTreeSupportDefs.FileHandle,
    initializeFile, useDefaultOrderingRoutines: BOOLEAN,
    isFirstGreaterOrEqual, areTheyEqual: BTreeDefs.TestKeys]
    RETURNS [bh: BTreeDefs.BTreeHandle] =
    BEGIN
    b: Tree ← NIL;
    BEGIN
    ENABLE
      UNWIND =>
        IF b # NIL THEN
          BEGIN RemoveRegistryOfBTree[b]; BTreeSupportDefs.FreeWords[b]; END;
    b ← BTreeSupportDefs.AllocateWords[SIZE[BTreeRecord]];
    RegisterBTree[b];
    bh ← LOOPHOLE[b];
    IF initializeFile THEN
      BEGIN
      b↑ ← [
        version: Version, rootPA: nullPA, freePA: 0, lastPA: 1, pageS: PageSize,
        depth: 177777B, entries: 0, file: fileH,
        self: BTreePageRecord[
        b: b, pa: 1, ca:, c:, level: 1, dirty: TRUE, deleted: FALSE,
        rekey: FALSE], IsFirstGreaterOrEqual:, AreTheyEqual:, dirtyTree: TRUE,
        sawUserUnwind: FALSE];
      PushBTreeToDisk[bh];  -- just to keep WritePage happy about order of writes.
      BuildARoot[b, NIL];
      END
    ELSE
      BEGIN
      oldB: POINTER TO OldBTreeRecord ← LOOPHOLE[BTreeSupportDefs.ReadPage[
        fileH, 1 - 1]];
      IF oldB.version # Version THEN Malformed;
      IF oldB.pageS # PageSize THEN Malformed;
      b↑ ← [
        version: oldB.version, rootPA: oldB.rootPA, freePA: oldB.freePA,
        lastPA: oldB.lastPA, pageS: PageSize, depth: oldB.depth,
        entries: oldB.entries, file: fileH,
        self: [
        b: b, pa: oldB.oldSelf.pa, ca: oldB.oldSelf.ca, c: oldB.oldSelf.c,
        level: oldB.oldSelf.level, dirty: FALSE, deleted: FALSE, rekey: FALSE],
        IsFirstGreaterOrEqual:, AreTheyEqual:, dirtyTree: FALSE,
        sawUserUnwind: FALSE];
      BTreeSupportDefs.ReleasePage[LOOPHOLE[oldB, BTreeSupportDefs.PageHandle]];
      END;
    b.IsFirstGreaterOrEqual ←
      (IF useDefaultOrderingRoutines THEN MyIsFirstGreaterOrEqual
       ELSE isFirstGreaterOrEqual);
    b.AreTheyEqual ←
      (IF useDefaultOrderingRoutines THEN MyAreTheyEqual ELSE areTheyEqual);
    IF b.version # Version THEN Alarm[];
    END;
    END;

  ReleaseBTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle]
    RETURNS [fileH: BTreeSupportDefs.FileHandle] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    PushBTreeToDisk[
      bh !
      UNWIND =>
        BEGIN RemoveRegistryOfBTree[b]; BTreeSupportDefs.FreeWords[b]; END];
    fileH ← b.file;
    RemoveRegistryOfBTree[b];
    BTreeSupportDefs.FreeWords[b];
    RETURN[fileH];
    END;

  ShutDownBTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle]
    RETURNS [fileH: BTreeSupportDefs.FileHandle] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF NOT CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    RemoveRegistryOfBTree[b];
    BTreeSupportDefs.FreeWords[b];
    RETURN[b.file];
    END;

  PushBTreeToDisk: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    IF b.dirtyTree THEN
      BEGIN
      oldB: POINTER TO OldBTreeRecord ← LOOPHOLE[BTreeSupportDefs.UsePage[
        b.file, 0]];
      oldB↑ ← [
        version: b.version, nlu1:, nlu2:, nlu3:, rootPA: b.rootPA,
        freePA: b.freePA, lastPA: b.lastPA, pageS: b.pageS, depth: b.depth,
        entries: b.entries, file:,
        oldSelf: [
        b:, pa: b.self.pa, ca: b.self.ca, c: b.self.c, level: b.self.level, nul1:,
        nul2:, dirty:, deleted:, rekey:], IsFirstGreaterOrEqual:, AreTheyEqual:,
        nlu4:, dirtyTree:, nlu5:];
      BTreeSupportDefs.WritePage[
        b.file, 0, LOOPHOLE[oldB, BTreeSupportDefs.PageHandle] !
        UNWIND =>
          BEGIN
          BTreeSupportDefs.ReleasePage[
            LOOPHOLE[oldB, BTreeSupportDefs.PageHandle]];
          MarkBTreeInvalidInRegistry[b];
          END];
      b.dirtyTree ← FALSE;
      END;
    IF b.version # Version THEN Alarm[];
    END;

  PruneBTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle]
    RETURNS [storageFreed: BOOLEAN] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    RETURN[FALSE];
    END;

  AskNumberOfEntriesInTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle]
    RETURNS [nEntries: CARDINAL] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    IF ((b.entries = 0) OR (checking >= lots)) THEN CheckTree[bh];
    RETURN[b.entries];
    END;

  AskDepthOfTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle]
    RETURNS [nLevels: CARDINAL] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    RETURN[b.depth];
    END;

  Insert: PUBLIC PROCEDURE [
    bh: BTreeDefs.BTreeHandle, key: BTreeDefs.Desc, value: BTreeDefs.Desc] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    eR: BTree2Defs.EntryR ← [key, value];
    InsertC: CallTree =
      BEGIN
      IF b.AreTheyEqual[key, LookupP[p, i].k] THEN ReplaceP[p, i, @eR]
      ELSE BEGIN InsertP[p, i, @eR]; b.entries ← b.entries + 1; END;
      b.dirtyTree ← TRUE;
      RETURN[more: FALSE];
      END;
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    IF LENGTH[key] = 0 THEN ERROR;
    StartEnumerate[bh, key, InsertC];
    IF b.version # Version THEN Alarm[];
    END;

  Lookup: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle, key, value: BTreeDefs.Desc]
    RETURNS [lengthValue: CARDINAL] =
    BEGIN
    bcheck: Tree = LOOPHOLE[bh];
    LookupC: CallTree =
      BEGIN
      b: Tree = LOOPHOLE[bh];
      eR: BTree2Defs.EntryR ← LookupP[p, i];
      lengthValue ← LENGTH[eR.v];
      IF b.AreTheyEqual[key, eR.k] THEN Copy[from: eR.v, to: value]
      ELSE lengthValue ← BTreeDefs.KeyNotFound;
      RETURN[more: FALSE];
      END;
    IF CheckBTreeRegistered[bcheck].inValidTree THEN ERROR InvalidTree;
    IF bcheck.version # Version THEN Alarm[];
    StartEnumerate[bh, key, LookupC];
    IF bcheck.version # Version THEN Alarm[];
    END;

  Next: PROCEDURE [bh: BTreeDefs.BTreeHandle, e: BTree2Defs.Entry] =
    BEGIN
    seen: CARDINAL ← 0;
    bcheck: Tree = LOOPHOLE[bh];
    LookupC: CallTree =
      BEGIN
      b: Tree = LOOPHOLE[bh];
      eR: BTree2Defs.EntryR;
      IF (seen ← seen + 1) = 1 THEN RETURN[more: TRUE];
      eR ← LookupP[p, i];
      IF ((LENGTH[eR.v] > LENGTH[e.v]) OR (LENGTH[eR.k] > LENGTH[e.k])) THEN
        SIGNAL EntryTooSmall;
      Copy[from: eR.v, to: e.v];
      Copy[from: eR.k, to: e.k];
      e.k ← DESCRIPTOR[BASE[e.k], LENGTH[eR.k]];
      e.v ← DESCRIPTOR[BASE[e.v], LENGTH[eR.v]];
      RETURN[more: FALSE];
      END;
    IF CheckBTreeRegistered[bcheck].inValidTree THEN ERROR InvalidTree;
    IF bcheck.version # Version THEN Alarm[];
    StartEnumerate[bh, e.k, LookupC];
    IF bcheck.version # Version THEN Alarm[];
    END;

  Delete: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle, key: BTreeDefs.Desc] =
    BEGIN
    bcheck: Tree = LOOPHOLE[bh];
    DeleteC: CallTree =
      BEGIN
      b: Tree = LOOPHOLE[bh];
      IF b.AreTheyEqual[key, LookupP[p, i].k] THEN
        BEGIN
        DeleteP[p, i];
        IF i = 0 THEN p.rekey ← TRUE;
        b.entries ← b.entries - 1;
        b.dirtyTree ← TRUE;
        END;
      RETURN[more: FALSE];
      END;
    IF CheckBTreeRegistered[bcheck].inValidTree THEN ERROR InvalidTree;
    IF bcheck.version # Version THEN Alarm[];
    IF LENGTH[key] # 0 THEN StartEnumerate[bh, key, DeleteC];
    IF bcheck.version # Version THEN Alarm[];
    END;

  EnumerateFrom: PUBLIC PROCEDURE [
    bh: BTreeDefs.BTreeHandle, key: BTreeDefs.Desc, c: BTreeDefs.Call] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    seen: CARDINAL ← 0;
    EnumC: CallTree =
      BEGIN
      eR: BTree2Defs.EntryR ← LookupP[p, i];
      dirty: BOOLEAN;
      seen ← seen + 1;
      IF ((seen = 1) AND (~b.AreTheyEqual[key, eR.k])) THEN RETURN[more: TRUE];
      [more, dirty] ← c[
        eR.k, eR.v ! UNWIND => IF (NOT Juniper) THEN b.sawUserUnwind ← TRUE];
      IF dirty THEN
        BEGIN
        p.dirty ← TRUE;
        IF i = 0 THEN p.rekey ← TRUE;
        b.dirtyTree ← TRUE;
        END;
      RETURN[more];
      END;
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    IF b.version # Version THEN Alarm[];
    StartEnumerate[bh, key, EnumC];
    IF b.version # Version THEN Alarm[];
    END;

  StartEnumerate: PROCEDURE [
    bh: BTreeDefs.BTreeHandle, key: BTreeDefs.Desc, c: CallTree] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    BEGIN
    ENABLE
      UNWIND =>
        IF NOT b.sawUserUnwind THEN MarkBTreeInvalidInRegistry[b]
        ELSE b.sawUserUnwind ← FALSE;
    this: Page ← SwapInPage[b, b.rootPA, b.depth];
    brother: Page ← NIL;
    checkT: BOOLEAN = ((checking >= dontAsk) AND (LENGTH[key] > 0));
    GetPageForSplit: PROCEDURE RETURNS [Page] =
      BEGIN RETURN[brother ← SwapInPage[b, nullPA, this.level]]; END;
    IF checkT THEN CheckTree[bh];
    BEGIN
    ENABLE
      UNWIND =>
        BEGIN
        FreePageDueToUnwind[this];
        IF brother # NIL THEN FreePageDueToUnwind[brother];
        END;
    [] ← EnumerateFromTree[
      this, key, c ! BTree2Defs.GetAnother => RESUME [GetPageForSplit[].ca];
      TwoKeysNonLeafSplit => RESUME [GetPageForSplit[]];
      BTree2Defs.Merger => RESUME [NIL, TRUE]];
    END;
    IF brother # NIL THEN  -- add a new level.
      BEGIN
      brother.dirty ← TRUE;
      BuildARoot[b, brother ! UNWIND => FreePageDueToUnwind[this]];
      END;
    IF ((ItemsP[this] = 1) AND (b.depth # 0)) THEN  -- remove a level.
      BEGIN
      b.rootPA ← LookupPA[this, 0];
      this.deleted ← TRUE;
      b.depth ← b.depth - 1;
      b.dirtyTree ← TRUE;
      END;
    SwapOutPage[this];
    IF b.version # Version THEN Alarm[];
    IF checkT THEN CheckTree[bh];
    END;
    END;

  EnumerateFromTree: PROCEDURE [this: Page, key: BTreeDefs.Desc, c: CallTree]
    RETURNS [go: BOOLEAN] =
    BEGIN
    index: BTree2Defs.Index;
    son, sonssib, right: Page;
    onRight, reallySplit: BOOLEAN;
    end: CARDINAL ← ItemsP[this];
    low: NN = IF this.level > 0 THEN this.level - 1 ELSE 0;
    b: Tree = this.b;
    delta: NN;
    GetPageForMerge: PROCEDURE RETURNS [Page] =
      BEGIN
      onRight ← (end > index + 1);  -- get the page to the right of the son unless the son is already our rightmost descendent.
      delta ← IF onRight THEN 1 ELSE -1;
      IF ((index = 0) AND (NOT onRight)) THEN RETURN[NIL];
      sonssib ← SwapInPage[b, LookupPA[this, index + delta], low];
      (right ← IF onRight THEN sonssib ELSE son).rekey ← TRUE;
      RETURN[sonssib];
      END;
    GetPageForSplit: PROCEDURE RETURNS [Page] =
      BEGIN reallySplit ← TRUE; RETURN[sonssib ← SwapInPage[b, nullPA, low]]; END;
    IF b.version # Version THEN Alarm[];
    FOR index ← FindIndexOnPage[this, key], index + 1 UNTIL index >= end DO
      IF this.level = 0 THEN [go] ← c[this, index]
      ELSE
        BEGIN
        sonssib ← NIL;
        reallySplit ← FALSE;
        delta ← 0;
        son ← SwapInPage[b, LookupPA[this, index], low];
        BEGIN
        ENABLE
          UNWIND =>
            BEGIN
            FreePageDueToUnwind[son];
            IF sonssib # NIL THEN FreePageDueToUnwind[sonssib];
            END;
        [go] ← EnumerateFromTree[
          son, key, c ! BTree2Defs.GetAnother => RESUME [GetPageForSplit[].ca];
          BTree2Defs.Merger =>
            BEGIN
            tempPage: Page ← GetPageForMerge[];
            RESUME [(IF tempPage = NIL THEN NIL ELSE tempPage.ca), onRight];
            END;
          BTree2Defs.DeletePage => BEGIN right.deleted ← TRUE; RESUME ; END;
          TwoKeysNonLeafSplit => RESUME [GetPageForSplit[]]];
        IF sonssib # NIL THEN
          BEGIN
          -- if we have two keys to twitch, we must avoid causing two inter-page actions at the next higher level, as the routine is not expecting more than one.  Therefore the first key twitch can cause a split, and if so the second is not allowed to merge or balance.  Also the first cannot merge or balance as the second may want to split.
          twoKeysToEnter: BOOLEAN ←
            ((son.deleted OR son.rekey) AND (sonssib.deleted OR sonssib.rekey));
          split: Page ← NIL;
          sonssib.dirty ← TRUE;
          ChangeKeys[
            this, index + delta, sonssib, (NOT reallySplit) !
            BTree2Defs.GetAnother =>
              IF twoKeysToEnter THEN
                BEGIN split ← SIGNAL TwoKeysNonLeafSplit; RESUME [split.ca]; END;
            BTree2Defs.Merger => IF twoKeysToEnter THEN RESUME [NIL, TRUE]];
          IF split # NIL THEN
            BEGIN
            t: INTEGER ← index - ItemsP[this];
            IF t >= 0 THEN BEGIN index ← t; this ← split; END;
            END;
          ChangeKeys[
            this, index, son, TRUE !
            BTree2Defs.Merger =>
              IF ((twoKeysToEnter) AND (split # NIL)) THEN RESUME [NIL, TRUE]];
          END
        ELSE IF son.rekey THEN ChangeKeys[this, index, son, TRUE];
        END;
        SwapOutPage[sonssib ! UNWIND => FreePageDueToUnwind[son]; ];
        SwapOutPage[son];
        END;
      IF NOT go THEN EXIT;
      ENDLOOP;
    IF b.version # Version THEN Alarm[];
    END;

  ChangeKeys: PROCEDURE [
    this: Page, i: BTree2Defs.Index, son: Page, replace: BOOLEAN] =
    BEGIN
    eR: BTree2Defs.EntryR;
    this.dirty ← TRUE;
    IF ((i = 0) AND (son.deleted OR son.rekey)) THEN this.rekey ← TRUE;
    IF son.deleted THEN DeleteP[this, i]
    ELSE
      IF son.rekey THEN
        BEGIN
        son.rekey ← FALSE;
        eR ← LookupP[son, 0];
        eR.v ← DESCRIPTOR[@son.pa, 1];
        IF replace THEN BTree2Defs.Replace[this.ca, i, @eR]
        ELSE InsertP[this, i, @eR];
        END;
    END;

  FindIndexOnPage: PROCEDURE [p: Page, key: BTreeDefs.Desc]
    RETURNS [m: BTree2Defs.Index] =
    BEGIN
    GreaterOrEqual: BTreeDefs.TestKeys ← p.b.IsFirstGreaterOrEqual;
    numItemsOnPage: BTree2Defs.Index ← ItemsP[p];
    h: BTree2Defs.Index ← m ← 128;
    t: BOOLEAN;
    DO
      t ←
        IF (m >= numItemsOnPage) THEN FALSE
        ELSE GreaterOrEqual[key, LookupP[p, m].k];
      h ← h / 2;
      IF h = 0 THEN EXIT ELSE m ← IF t THEN m + h ELSE m - h;
      ENDLOOP;
    IF NOT t THEN m ← m - 1;
    END;

  -- Does it matter that for two empty args this returns TRUE?
  MyIsFirstGreaterOrEqual: BTreeDefs.TestKeys =
    BEGIN
    i: CARDINAL;
    t: CARDINAL = MIN[LENGTH[b], LENGTH[a]];
    g: INTEGER ← 0;
    FOR i IN [0..t) UNTIL ((g ← a[i] - b[i]) # 0) DO ENDLOOP;
    RETURN[((g > 0) OR ((g = 0) AND (LENGTH[a] >= LENGTH[b])))];
    END;

  MyAreTheyEqual: BTreeDefs.TestKeys =
    BEGIN
    i: CARDINAL;
    t: CARDINAL = LENGTH[a];
    IF LENGTH[b] # t THEN RETURN[FALSE];
    FOR i IN [0..t) DO IF a[i] # b[i] THEN RETURN[FALSE]; ENDLOOP;
    RETURN[TRUE];
    END;

  NullProc: PUBLIC BTreeDefs.TestKeys =
    BEGIN
    Alarm[];
    RETURN[TRUE];  -- keep compiler happy.
    END;

  Copy: PROCEDURE [from: BTreeDefs.Desc, to: BTreeDefs.Desc] =
    BEGIN
    i, l: CARDINAL;
    l ← MIN[LENGTH[from], LENGTH[to]];
    FOR i IN [0..l) DO to[i] ← from[i]; ENDLOOP;
    END;

  SwapInPage: PROCEDURE [b: Tree, p: NN, l: CARDINAL] RETURNS [bp: Page] =
    BEGIN
    place: BTreeSupportDefs.PageHandle ← [NIL];
    new: BOOLEAN ← (p = nullPA);
    reuse: BOOLEAN ← (new AND (b.freePA # 0));
    IF new THEN
      BEGIN
      p ← IF reuse THEN b.freePA ELSE b.lastPA ← b.lastPA + 1;
      b.dirtyTree ← TRUE;
      END;
    place ←
      (IF ((NOT new) OR reuse) THEN BTreeSupportDefs.ReadPage
       ELSE BTreeSupportDefs.UsePage)[b.file, p - 1];
    bp ← BTreeSupportDefs.AllocateWords[SIZE[BTreePageRecord]];
    bp.pa ← p;
    bp.b ← b;
    bp.ca ← @bp.c;
    bp.dirty ← FALSE;
    bp.c ← DESCRIPTOR[place, b.pageS];
    bp.level ← l;
    bp.rekey ← new;
    bp.deleted ← FALSE;
    IF reuse THEN b.freePA ← bp.ca[0];
    IF new THEN BEGIN bp.dirty ← FALSE; BTree2Defs.Initialize[bp.ca]; END;
    IF checking >= moderate THEN Check[bp];
    END;

  SwapOutPage: PROCEDURE [p: Page] =
    BEGIN
    b: Tree;
    temp: BTreeSupportDefs.PageHandle;
    IF p = NIL THEN RETURN;
    IF checking >= moderate THEN Check[p];
    b ← p.b;
    temp ← LOOPHOLE[BASE[p.c]];
    IF p.deleted THEN
      BEGIN
      p.ca[0] ← b.freePA;
      b.freePA ← p.pa;
      b.dirtyTree ← p.dirty ← TRUE;
      END;
    IF p.dirty THEN
      BTreeSupportDefs.WritePage[
        p.b.file, p.pa - 1, temp !
        UNWIND =>
          BEGIN
          BTreeSupportDefs.ReleasePage[temp];
          BTreeSupportDefs.FreeWords[p];
          END]
    ELSE BTreeSupportDefs.ReleasePage[temp];
    BTreeSupportDefs.FreeWords[p];
    END;

  FreePageDueToUnwind: PROCEDURE [p: Page] =
    BEGIN
    temp: BTreeSupportDefs.PageHandle ← LOOPHOLE[BASE[p.c]];  --this is the only way 
    BTreeSupportDefs.ReleasePage[temp];  -- the compiler will accept this.
    BTreeSupportDefs.FreeWords[p];
    END;

  BuildARoot: PROCEDURE [b: Tree, brother: Page] =
    BEGIN
    eR: BTree2Defs.EntryR;
    root: Page ← SwapInPage[
      b, nullPA, b.depth ← b.depth + 1 !
      UNWIND => IF brother # NIL THEN FreePageDueToUnwind[brother]];
    IF brother # NIL THEN
      BEGIN
      eR ← LookupP[brother, 0];
      eR.v ← DESCRIPTOR[@brother.pa, 1];
      InsertP[root, 177777B, @eR];
      SwapOutPage[brother ! UNWIND => FreePageDueToUnwind[root]];
      END;
    eR ← [DESCRIPTOR[NIL, 0], DESCRIPTOR[@b.rootPA, 1]];
    InsertP[root, 177777B, @eR];
    b.rootPA ← root.pa;
    b.dirtyTree ← TRUE;
    SwapOutPage[root];
    END;

  LookupPA: PROCEDURE [p: Page, i: BTree2Defs.Index] RETURNS [NN] =
    BEGIN RETURN[LookupP[p, i].v[0]]; END;

  InsertP: PROCEDURE [p: Page, i: BTree2Defs.Index, e: BTree2Defs.Entry] =
    BEGIN p.dirty ← TRUE; BTree2Defs.Insert[p.ca, i, e]; END;

  ReplaceP: PROCEDURE [p: Page, i: BTree2Defs.Index, e: BTree2Defs.Entry] =
    BEGIN p.dirty ← TRUE; BTree2Defs.Replace[p.ca, i, e]; END;

  LookupP: PROCEDURE [p: Page, i: BTree2Defs.Index] RETURNS [BTree2Defs.EntryR] =
    BEGIN RETURN[BTree2Defs.Lookup[p.ca, i]]; END;

  DeleteP: PROCEDURE [p: Page, i: BTree2Defs.Index] =
    BEGIN p.dirty ← TRUE; BTree2Defs.Delete[p.ca, i]; END;

  ItemsP: PROCEDURE [p: Page] RETURNS [CARDINAL] =
    BEGIN RETURN[BTree2Defs.Items[p.ca]]; END;

  Check: PROCEDURE [p: Page] =
    BEGIN
    b: Tree = p.b;
    i: NN;
    n: NN = ItemsP[p];
    e: BTree2Defs.EntryR;
    thisIsPageOne: BOOLEAN = (p = @b.self);
    IF b.version # Version THEN Alarm[];
    SELECT thisIsPageOne FROM
      TRUE => IF p.pa # 1 THEN Malformed;
      ENDCASE => IF p.pa NOT IN [2..b.lastPA] THEN Malformed;
    IF ((p.ca # @p.c) OR (LENGTH[p.c] # b.pageS)) THEN Malformed;
    IF ((p.level > b.depth) AND (NOT p.deleted)) THEN Malformed;
    IF
      ((b.rootPA NOT IN [2..b.lastPA])
        AND ~(b.rootPA = nullPA AND p.level = b.depth)) THEN Malformed;
    IF ((b.freePA > b.lastPA) OR (b.freePA = 1)) THEN Malformed;
    IF n >= 2 THEN
      IF b.IsFirstGreaterOrEqual[LookupP[p, 0].k, LookupP[p, n - 1].k] THEN
        Malformed;  -- Spot check
    IF n >= 4 THEN
      IF b.AreTheyEqual[LookupP[p, n / 2].k, LookupP[p, n / 2 - 1].k] THEN
        Malformed;  -- Spot check
    IF p.level > 0 THEN
      FOR i IN [0..n) DO
        e ← LookupP[p, i];
        IF ((LENGTH[e.v] # 1) OR (e.v[0] NOT IN [2..b.lastPA])) THEN Malformed;
        IF ((LENGTH[e.k] = 0) AND (i > 0)) THEN Malformed;
        ENDLOOP;
    END;

  CheckTree: PUBLIC PROCEDURE [bh: BTreeDefs.BTreeHandle] =
    BEGIN
    b: Tree = LOOPHOLE[bh];
    seen: CARDINAL ← 0;
    was: CheckAmount = checking;
    previous: ARRAY [0..32) OF UNSPECIFIED;
    d: BTreeDefs.Desc ← DESCRIPTOR[NIL, 0];
    CheckC: CallTree =
      BEGIN
      k: BTreeDefs.Desc ← LookupP[p, i].k;
      SELECT LENGTH[k] FROM
        > LENGTH[previous] => Malformed;
        > 0 =>
          BEGIN
          seen ← seen + 1;
          IF b.IsFirstGreaterOrEqual[d, k] THEN Malformed;
          END;
        ENDCASE;
      d ← DESCRIPTOR[@previous, LENGTH[k]];
      FOR i IN [0..LENGTH[k]) DO d[i] ← k[i]; ENDLOOP;
      RETURN[more: TRUE];
      END;
    IF CheckBTreeRegistered[b].inValidTree THEN ERROR InvalidTree;
    checking ← moderate;
    StartEnumerate[bh, d, CheckC];
    IF seen # b.entries THEN Malformed;
    checking ← was;
    END;


  END.

Edit Log

RTE: March 14, 1980 5:47 PM: KK: edited in Will's second fix for the split page - key problem.
Comment: March 28, 1980  7:13 PM: KK: changed the format of this program so that I could read it.
RTE: April 15, 1980  3:04 PM: KK: fixes in ChangeKeys and EnumFromTree for "two operations at once" bugs and delete not propagating the key bug.
RTE: May 1, 1980  5:12 PM: KK: insert didn't call replace for identical keys.
Comment: May 9, 1980  2:54 PM: KK: began changes to reflect changes to interface and removing caching.
RTE: September 8, 1980  1:14 PM: KK:  Mike Schroeder's fix: UNWIND in Enumerate.
RTE: September 25, 1980  4:20 PM: KK:  Unwind catches for transaction reset signals.  Also take out the two bV and bB things.
Comment: October 17, 1980  11:51 AM: KK:  added checks on version to catch bugs. 
Comment: October 21, 1980  7:02 PM: KK:  added registry of btrees.
RTE: October 27, 1980  12:40 PM: KK:  bug fix plus cleanup to above.
RTE: November 4, 1980  3:54 PM: KK: changed alarms to InvalidTree errors.  Also userUnwind fix.