-- file:  MBImpl.mesa
-- last modified by McCreight, August 18, 1981  5:10 PM
-- written by McCreight, August 4, 1981  2:44 PM

DIRECTORY
  InlineDefs: FROM "InlineDefs",
  MB: FROM "MB",
  StreamDefs: FROM "StreamDefs",
  StringDefs: FROM "StringDefs";


MBImpl: PROGRAM IMPORTS InlineDefs,StringDefs EXPORTS MB = PUBLIC

  BEGIN OPEN MB;

  IllegalMBFormat: SIGNAL = CODE;

  curMB: MBHandle _ NIL;
  curMem: MBMemoryPtr _ NIL;  -- always in curMB
  curWord: MBWordPtr _ NIL;  -- always in curMem

  ReadMB: PROCEDURE [
    s: StreamDefs.StreamHandle -- a word stream -- , z: UNCOUNTED ZONE]
    RETURNS [mb: MBHandle] =
    BEGIN
    FakeItem: TYPE = ARRAY [0..99] OF WORD;
    fakeItem: FakeItem;
    item: LONG POINTER TO MBItem _ LONG[LOOPHOLE[@fakeItem]];
    curLC: CARDINAL;  -- in curMem

    GetNextItem: PROCEDURE =
      BEGIN  -- fakeItem and item must lie in the same storage
      i: CARDINAL;
      fakeItem[0] _ s.get[s];
      SELECT item.itemType FROM
        end => RETURN;
        dataWord =>
          FOR i IN [1..1 + (curMem.width + 15)/16] DO
            fakeItem[i] _ s.get[s] ENDLOOP;
        setLC => FOR i IN [1..2] DO fakeItem[i] _ s.get[s] ENDLOOP;
        fixup => FOR i IN [1..4] DO fakeItem[i] _ s.get[s] ENDLOOP;
        memName, addrSym =>
          BEGIN
          FOR i IN [1..2] DO fakeItem[i] _ s.get[s] ENDLOOP;
          FOR i IN [3..99] DO
            c: PACKED ARRAY [0..1] OF CHARACTER;
            fakeItem[i] _ s.get[s];
            c _ LOOPHOLE[fakeItem[i], PACKED ARRAY [0..1] OF CHARACTER];
            IF c[0] = 0C OR c[1] = 0C THEN EXIT;
            ENDLOOP;
          END;
        extRef =>
          BEGIN
          FOR i IN [1..3] DO fakeItem[i] _ s.get[s] ENDLOOP;
          FOR i IN [4..99] DO
            c: PACKED ARRAY [0..1] OF CHARACTER;
            fakeItem[i] _ s.get[s];
            c _ LOOPHOLE[fakeItem[i], PACKED ARRAY [0..1] OF CHARACTER];
            IF c[0] = 0C OR c[1] = 0C THEN EXIT;
            ENDLOOP;
          END;
        ENDCASE;
      END;

    FindMem: PROCEDURE [memNo: CARDINAL] RETURNS [m: MBMemoryPtr] = {
      FOR m _ mb, m.nextMem UNTIL m = NIL OR m.memNo = memNo DO ENDLOOP};

    mb _ NIL;
    s.reset[s];
    DO
      GetNextItem[];
      WITH ditem: item SELECT FROM
        end => EXIT;
        dataWord =>
          BEGIN
          w: MBWordPtr _ FindWord[curMem, curLC];
          FOR i: CARDINAL IN [0..curMem.width) DO
            w.value[i] _ ditem.bits[i] ENDLOOP;
          curLC _ curLC + 1;
          END;
        setLC => BEGIN curMem _ FindMem[ditem.memNo]; curLC _ ditem.location; END;
        fixup =>
          BEGIN
          w: MBWordPtr _ FindWord[FindMem[ditem.memNo], ditem.location];
          FOR i: CARDINAL IN [ditem.firstBit..ditem.lastBit] DO
            w.value[i] _ ditem.bits[i - ditem.firstBit] ENDLOOP;
          END;
        memName =>
          BEGIN
          nameLen: CARDINAL;
          mb _ z.NEW[
            MBMemory _ [
            zone: z, nextMem: mb, name: NIL, memNo: ditem.memNo, length: 0,
            width: ditem.width, words: NIL, symbols: NIL]];
          FOR nameLen _ 0, nameLen + 1 WHILE ditem.name[nameLen] # 0C DO ENDLOOP;
          mb.name _ z.NEW[StringBody [nameLen]];
          FOR i: CARDINAL IN [0..nameLen) DO mb.name[i] _ ditem.name[i] ENDLOOP;
          mb.name.length _ nameLen;
          END;
        addrSym =>
          BEGIN
          nameLen: CARDINAL;
          m: MBMemoryPtr _ FindMem[ditem.memNo];
          m.symbols _ z.NEW[
            MBSym _ [nextSym: m.symbols, location: ditem.location, name: NIL]];
          FOR nameLen _ 0, nameLen + 1 WHILE ditem.name[nameLen] # 0C DO ENDLOOP;
          m.symbols.name _ z.NEW[StringBody [nameLen]];
          FOR i: CARDINAL IN [0..nameLen) DO
            m.symbols.name[i] _ ditem.name[i] ENDLOOP;
          m.symbols.name.length _ nameLen;
          END;
        ENDCASE => SIGNAL IllegalMBFormat;
      ENDLOOP;
    END;  -- of ReadMB

  FreeMBMemory: PROCEDURE [memP: LONG POINTER TO MBMemoryPtr] =
    BEGIN
    IF curMB = memP^ THEN curMB _ NIL;
    IF memP^ # NIL THEN
      BEGIN
      m: MBMemoryPtr _ memP^;
      z: UNCOUNTED ZONE _ m.zone;
      z.FREE[@m.name];
      FreeMBMemoryWords[m];
      FreeMBMemorySymbols[m];
      memP^ _ m.nextMem;
      z.FREE[@m];
      END;
    END;

  FreeMBMemoryWords: PROCEDURE [mem: MBMemoryPtr] =
    BEGIN
    WHILE mem.words # NIL DO
      w: MBWordPtr _ mem.words;
      mem.words _ w.nextWord;
      mem.zone.FREE[@w];
      ENDLOOP;
    END;

  FreeMBMemorySymbols: PROCEDURE [mem: MBMemoryPtr] =
    BEGIN
    WHILE mem.symbols # NIL DO
      s: MBSymPtr _ mem.symbols;
      mem.symbols _ s.nextSym;
      mem.zone.FREE[@s.name];
      mem.zone.FREE[@s];
      ENDLOOP;
    END;

  FreeMB: PROCEDURE [mb: MBHandle] = {
    WHILE mb # NIL DO FreeMBMemory[@mb] ENDLOOP};

  FindWord: PROCEDURE [m: MBMemoryPtr, location: LONG CARDINAL]
    RETURNS [w: MBWordPtr] =
    BEGIN  -- words appear in address order
    lastw: MBWordPtr _ NIL;
    w _
      IF m = curMem AND curWord # NIL AND curWord.location <= location THEN
      curWord ELSE m.words;
    WHILE w # NIL AND w.location < location DO lastw _ w; w _ w.nextWord ENDLOOP;
    IF w = NIL OR location < w.location THEN
      BEGIN  -- insert a new word
      w _ m.zone.NEW[
        MBWord [m.width] _ [nextWord: w, location: location, value: NULL]];
      FOR i: CARDINAL IN [0..m.width) DO w.value[i] _ FALSE ENDLOOP;
      IF lastw = NIL THEN m.words _ w ELSE lastw.nextWord _ w;
      END;
    IF m = curMem THEN curWord _ w;
    END;  -- of FindWord

  FindMBMemory: PROCEDURE [mb: MBHandle, memName: STRING] RETURNS [MBMemoryPtr] =
    BEGIN
    FOR mem: MBMemoryPtr _ mb, mem.nextMem WHILE mem # NIL DO
      IF EquivalentLongStrings[mem.name, memName] THEN RETURN[mem]; ENDLOOP;
    RETURN[NIL];
    END;

  AnalyzeMemory: PROCEDURE [mem: MBMemoryPtr]
    RETURNS [decodeWidth, wordCount, wordWidth: CARDINAL] =
    BEGIN
    maxAddress: LONG CARDINAL _ 0;
    wordWidth _ mem.width;
    decodeWidth _ 0;
    wordCount _ 0;
    FOR w: MBWordPtr _ mem.words, w.nextWord WHILE w # NIL DO
      WHILE w.location > maxAddress DO
        maxAddress _ 2*maxAddress+1; decodeWidth _ decodeWidth + 1; ENDLOOP;
      wordCount _ wordCount + 1;
      ENDLOOP;
    END;  -- of AnalyzeMemory

  SuppressDefaultWords: PROCEDURE [mem: MBMemoryPtr, default: BOOLEAN] =
    BEGIN
    pWord: LONG POINTER TO MBWordPtr _ @mem.words;
    FOR w: MBWordPtr _ pWord^, pWord^ WHILE w # NIL DO
      FOR i: CARDINAL IN [0..mem.width) DO
        IF w.value[i] # default THEN GOTO notDefault;
        REPEAT
          notDefault => pWord _ @w.nextWord;
          FINISHED => {t: MBWordPtr _ w; pWord^ _ w.nextWord; mem.zone.FREE[@t]};
        ENDLOOP;
      ENDLOOP;
    END;

  ReCast: PROCEDURE [mem: MBMemoryPtr, newWordWidth: CARDINAL] =
    BEGIN
    -- steals low-order address bits to widen the word by a power of 2.
    -- puts all original bit 0's together, then all bit 1's, then bit 2's, etc.
    newMem: MBMemory _ mem^;
    factor: CARDINAL;
    FOR factor _ 1, 2*factor WHILE factor*mem.width<newWordWidth DO
      ENDLOOP;
    newMem.width _ factor*mem.width;
    newMem.words _ NIL;
    curMem _ NIL;
    FOR w: MBWordPtr _ mem.words, w.nextWord WHILE w#NIL DO
      newW: MBWordPtr _ FindWord[@newMem, w.location/factor];
      FOR i: CARDINAL IN [0..mem.width) DO
        newW.value[InlineDefs.LowHalf[factor*i+(w.location MOD factor)]] _ w.value[i];
        ENDLOOP;
      ENDLOOP;
    FreeMBMemoryWords[mem];
    FreeMBMemorySymbols[@newMem];
    mem^ _ newMem;
    END;

  PermuteAddress: PROCEDURE [mem: MBMemoryPtr, p: PermutationPtr] =
    BEGIN
    newMem: MBMemory _ mem^;
    newMem.words _ NIL;
    curMem _ NIL;
    FOR w: MBWordPtr _ mem.words, w.nextWord WHILE w#NIL DO
      loc: LONG CARDINAL _ 0;
      newW: MBWordPtr;
      FOR i: CARDINAL DECREASING IN [0..p.length) DO
        WITH p.seq[i] SELECT FROM
          constantFalse => loc _ 2*loc+(IF invert THEN 1 ELSE 0);
          addrBit => loc _ 2*loc+(IF InlineDefs.BITXOR[invert, w.value[index]] THEN 1 ELSE 0);
          ENDCASE;
        ENDLOOP;
      newW _ FindWord[@newMem, loc];
      FOR i: CARDINAL IN [0..mem.width) DO
        newW.value[i] _ w.value[i];
        ENDLOOP;
      ENDLOOP;
    FreeMBMemoryWords[mem];
    FreeMBMemorySymbols[@newMem];
    mem^ _ newMem;
    END;

  PermuteData: PROCEDURE [mem: MBMemoryPtr, p: PermutationPtr] =
    BEGIN
    newMem: MBMemory _ mem^;
    newMem.width _ p.length;
    newMem.words _ NIL;
    curMem _ NIL;
    FOR w: MBWordPtr _ mem.words, w.nextWord WHILE w#NIL DO
      newW: MBWordPtr _ FindWord[@newMem, w.location];
      FOR i: CARDINAL IN [0..p.length) DO
        WITH p.seq[i] SELECT FROM
          constantFalse => newW.value[i] _ invert;
          addrBit => newW.value[i] _ InlineDefs.BITXOR[invert, w.value[index]];
          ENDCASE;
        ENDLOOP;
      ENDLOOP;
    FreeMBMemoryWords[mem];
    mem^ _ newMem;
    END;

  FindMBBit: PROCEDURE [
    mb: MBHandle, memName: STRING, word: LONG CARDINAL, bit: CARDINAL]
    RETURNS [BOOLEAN] =
    BEGIN
    lastWord: MBWordPtr;
    IF curMB # mb OR curMem = NIL
      OR NOT EquivalentLongStrings[memName, curMem.name] THEN
      BEGIN
      curMB _ mb;
      curMem _ mb;
      curWord _ NIL;
      FOR curMem _ mb, curMem.nextMem UNTIL curMem = NIL
        OR EquivalentLongStrings[memName, curMem.name] DO ENDLOOP;
      END;
    IF curWord = NIL OR word < curWord.location THEN curWord _ curMem.words;
    lastWord _ curWord;
    WHILE curWord # NIL AND curWord.location < word DO
      lastWord _ curWord; curWord _ curWord.nextWord; ENDLOOP;
    IF word = curWord.location THEN RETURN[curWord.value[bit]]
    ELSE {curWord _ lastWord -- for next search -- ; RETURN[FALSE]};
    END;  -- of FindMBBit

  EquivalentLongStrings: PROCEDURE [a, b: LONG STRING] RETURNS [BOOLEAN] =
    BEGIN
    IF a.length # b.length THEN RETURN[FALSE];
    FOR i: CARDINAL IN [0..a.length) DO
      IF StringDefs.UpperCase[a[i]] # StringDefs.UpperCase[b[i]] THEN
        RETURN[FALSE];
      ENDLOOP;
    RETURN[TRUE];
    END;

  END. -- of MBImpl