-- RTList.mesa  
-- last edited by Satterthwaite on August 1, 1983 1:51 pm

DIRECTORY
  BcdDefs: TYPE USING [Base, FTIndex, FTRecord, VersionStamp, FTNull],
  BcdOps: TYPE USING [BcdBase],
  CharIO: TYPE USING [PutChar, PutDecimal, PutString],
  Environment: TYPE USING [bitsPerWord, wordsPerPage],
  Heap: TYPE USING [systemZone],
  Inline: TYPE USING [LongMult, LowHalf],
  ListerUtil: TYPE USING [PutVersionId],
  RCMap: TYPE USING [Base, FieldDescriptor, Index, Object, RCField],
  RTBcd: TYPE USING [
    RefLitList, RTBase, StampIndex, StampList, RefLitItem, TypeItem, TypeList,
    UTInfo, VersionID, AnyStamp],
  Stream: TYPE USING [Handle],
  Strings: TYPE USING [String],
  TypeStrings: TYPE USING [Code, TypeString];

RTList: PROGRAM
    IMPORTS CharIO, Heap, Inline, ListerUtil
    EXPORTS ListerUtil = {
  
  out: Stream.Handle _ NIL;
  
  PutChar: PROC [c: CHAR] ~ INLINE {CharIO.PutChar[out, c]};
  PutDecimal: PROC [i: INTEGER] ~ INLINE {CharIO.PutDecimal[out, i]};
  PutString: PROC [s: Strings.String] ~ INLINE {CharIO.PutString[out, s]};
  
  PrintRTBcd: PUBLIC PROC [
      dest: Stream.Handle, bcd: BcdOps.BcdBase, sorted: BOOL] ~ {
    rtHeader: RTBcd.RTBase ~ IF bcd.rtPages.pages # 0
      THEN LOOPHOLE[bcd + bcd.rtPages.relPageBase*Environment.wordsPerPage]
      ELSE NIL;
    out _ dest;
    IF rtHeader = NIL THEN PutString["No RT pages\n"L]
    ELSE IF rtHeader.versionIdent # RTBcd.VersionID THEN
      PutString["Invalid RT version stamp\n"L]
    ELSE {
      PrintHeader[rtHeader];
      PrintTypes[rtHeader, bcd, sorted];
      PrintStamps[rtHeader];
      PrintRCMap[rtHeader];
      PrintRefLits[rtHeader, sorted]};
    out _ NIL};
    
  PrintHeader: PROC [rtHeader: RTBcd.RTBase] ~ {
    PutString["Types: "L]; PutDecimal[rtHeader[rtHeader.typeTable].length];
    PutString[", Ref Literals: "L]; PutDecimal[rtHeader[rtHeader.refLitTable].length];
    PutString[", "L];
    PutDecimal[rtHeader.rcMapLength]; PutString[" Words of RC Map"L];
    PutString[", "L];
    PutDecimal[rtHeader.litLength]; PutString[" Words of Literals\n\n"L]};
    
  PrintTypes: PROC [rtHeader: RTBcd.RTBase, bcd: BcdOps.BcdBase, sorted: BOOL] ~ {
    typeList: LONG POINTER TO RTBcd.TypeList ~ @rtHeader[rtHeader.typeTable];
    stampList: LONG POINTER TO RTBcd.StampList ~ @rtHeader[rtHeader.stampTable];
    textBase: LONG POINTER ~ @rtHeader[rtHeader.litBase];

    ftb: BcdDefs.Base ~ LOOPHOLE[bcd, BcdDefs.Base] + bcd.ftOffset;
    ftLimit: BcdDefs.FTIndex ~ bcd.ftLimit;
    
    VersionToFile: PROC [i: RTBcd.StampIndex] RETURNS [fti: BcdDefs.FTIndex] ~ {
      FOR fti _ BcdDefs.FTIndex.FIRST, fti + BcdDefs.FTRecord.SIZE UNTIL fti = ftLimit DO
        IF stampList[i] = ftb[fti].version THEN RETURN;
	ENDLOOP;
      RETURN [BcdDefs.FTNull]};
      
    PrintTypeString: PROC [offset: CARDINAL] RETURNS [valid: BOOL] ~ INLINE {
      text: TypeStrings.TypeString ~ textBase + offset;
      valid _ offset <= rtHeader.litLength
        AND offset+StringBody[text.length].SIZE <= rtHeader.litLength;
      PutChar[' ];
      IF ~valid THEN PrintGarbage[]
      ELSE
	IF PutType[text, 0] # text.length THEN PutString[" ???"L]};
      
    PrintType: PROC [i: NAT] RETURNS [success: BOOL] ~ {
      Tab[2];
      PrintIndex[i];
      PutString[" sei: "L];  PutIndex[typeList[i].sei];
      PutString[", segment: "L];  PrintIndex[typeList[i].table];
      PutString[", rcMap: "L];  PrintIndex[typeList[i].rcMap];
      PutString[", UTF: [stamp: "L];
	IF typeList[i].ut.version = RTBcd.AnyStamp THEN PutString["(any)"L]
	ELSE PrintIndex[typeList[i].ut.version];
	PutString[", sei: "L];
	PutIndex[typeList[i].ut.sei];
	PutChar[']];
      IF typeList[i].canonical THEN PutString[", canonical"L]
      ELSE IF typeList[i].ut.version # RTBcd.AnyStamp THEN {
	fti: BcdDefs.FTIndex ~ VersionToFile[typeList[i].ut.version];
	IF fti # BcdDefs.FTNull THEN {
	  PutString[" (file: "L]; PrintIndex[fti]; PutChar[')]}};
      Tab[4];
      PrintIndex[typeList[i].ct.index];
      RETURN [PrintTypeString[typeList[i].ct.index]]};

    PutString["Types"L];  PrintIndex[rtHeader.typeTable];
    IF sorted THEN PutString[" (ordered)"L];
    PutString[":\n"L];
    IF sorted THEN {
      typeTree: LONG POINTER TO Nodes _ (Heap.systemZone).NEW[Nodes[typeList.length]];
      
      EnterType: PROC [n: NAT] ~ {
	i: Branch _ 0;
	typeTree[n] _ [l~nullBranch, r~nullBranch];
	DO
	  SELECT CompareTypes[typeList[n], typeList[i]] FROM
	    $ls => {
	      IF typeTree[i].l = nullBranch THEN typeTree[i].l _ n;
	      i _ typeTree[i].l};
	    $gr => {
	      IF typeTree[i].r = nullBranch THEN typeTree[i].r _ n;
	      i _ typeTree[i].r};
	    ENDCASE => EXIT
	  ENDLOOP};
     
      PrintBranch: PROC [i: Branch] RETURNS [success: BOOL _ TRUE] ~ {
        UNTIL i = nullBranch OR ~success DO
	  success _ PrintBranch[typeTree[i].l] AND PrintType[i];
	  i _ typeTree[i].r;
	  ENDLOOP;
	RETURN}; 

      FOR n: NAT IN [0 .. typeList.length) DO EnterType[n] ENDLOOP;
      [] _ PrintBranch[IF typeList.length = 0 THEN nullBranch ELSE 0];
      (Heap.systemZone).FREE[@typeTree]}
    ELSE
      FOR i: NAT IN [0 .. typeList.length) DO
        IF ~PrintType[i] THEN EXIT;
        ENDLOOP;
    PutString["\n\n"L]};
    
    
  PrintStamps: PROC [rtHeader: RTBcd.RTBase] ~ {
    stampList: LONG POINTER TO RTBcd.StampList ~ @rtHeader[rtHeader.stampTable];
    PutString["Version Stamps"L];
    PrintIndex[rtHeader.stampTable];
    PutString[":\n"L];
    FOR i: NAT IN [1 .. stampList.limit) DO
      Tab[2];
      PrintIndex[i];
      PutChar[' ];
      ListerUtil.PutVersionId[out, stampList[i]];
      ENDLOOP;
    PutString["\n\n"L]};


  PrintRCMap: PROC [rtHeader: RTBcd.RTBase] ~ {
    rcmb: RCMap.Base ~ LOOPHOLE[@rtHeader[rtHeader.rcMapBase]];
    next: RCMap.Index;
    PutString["RC Maps"L];
    PrintIndex[CARDINAL[LOOPHOLE[rtHeader.rcMapBase, LONG CARDINAL]]];
    PutString[":\n"L];
    FOR rcmi: RCMap.Index _ RCMap.Index.FIRST, next
     WHILE LOOPHOLE[rcmi, CARDINAL] < rtHeader.rcMapLength DO
      Tab[2];
      PrintIndex[rcmi];
      PutChar[' ];
      WITH m~~rcmb[rcmi] SELECT FROM
        null => {
	  PutString["null"L];
	  next _ rcmi + RCMap.Object.null.SIZE};
        ref => {
	  PutString["ref"L];
	  next _ rcmi + RCMap.Object.ref.SIZE};
        controlLink => {
	  PutString["controlLink"L];
	  next _ rcmi + RCMap.Object.controlLink.SIZE};
        oneRef => {
	  PutString["oneRef[offset: "L];  PutDecimal[m.offset];  PutChar[']];
	  next _ rcmi + RCMap.Object.oneRef.SIZE};
        simple => {
	  PutString["simple[length: "L];  PutDecimal[m.length];
	  PutString[", offsets: ["L];
	  FOR i: NAT IN [0 .. m.length) DO
	    IF m.refs[i] THEN {
	      PutDecimal[i];
	      IF i + 1 # m.length THEN PutString[", "L]};
	    ENDLOOP;
	  PutString["]]"L];
	  next _ rcmi + RCMap.Object.simple.SIZE};
        nonVariant => {
	  PutString["nonVariant[nComponents: "L];  PutDecimal[m.nComponents];
	  PutString[", components: ["L];
	  FOR i: NAT IN [0..m.nComponents) DO
	    IF i MOD 3 = 0 THEN Tab[8];
	    PrintField[m.components[i]];
	    IF i+1 # m.nComponents THEN PutString[", "L];
	    ENDLOOP;
	  PutString["]]"L];
	  next _ rcmi + (RCMap.Object.nonVariant.SIZE + m.nComponents*RCMap.RCField.SIZE)};
        variant => {
	  PutString["variant[fdTag: "L];  PrintFD[m.fdTag];
	  PutString[", nVariants: "L];  PutDecimal[m.nVariants];
	  PutString[", variants: ["L];
	  FOR i: NAT IN [0..m.nVariants) DO
	    PrintIndex[m.variants[i]];
	    IF i+1 # m.nVariants THEN PutString[", "L];
	    ENDLOOP;
	  PutString["]]"L];
	  next _ rcmi + (RCMap.Object.variant.SIZE + m.nVariants*RCMap.Index.SIZE)};
        array => {
	  PutString["array[wordsPerElement: "L];  PutDecimal[m.wordsPerElement];
	  PutString[", nElements: "L];  PutDecimal[m.nElements];
	  PutString[", rcmi: "L];  PrintIndex[m.rcmi];  PutChar[']];
	  next _ rcmi + RCMap.Object.array.SIZE};
        sequence => {
	  PutString["sequence[wordsPerElement: "L];  PutDecimal[m.wordsPerElement];
	  PutString[", fdLength: "L];  PrintFD[m.fdLength];
	  PutString[", dataOffset: "L];  PutDecimal[m.dataOffset];
	  PutString[", rcmi: "L];  PrintIndex[m.rcmi];  PutChar[']];
	  next _ rcmi + RCMap.Object.sequence.SIZE};
	ENDCASE => {PrintGarbage[]; EXIT};
      ENDLOOP;
    PutString["\n\n"L]};
    
  PrintField: PROC [f: RCMap.RCField] ~ {
    PutString["[offset: "L];  PutDecimal[f.wordOffset];
    PutString[", rcmi: "L];  PrintIndex[f.rcmi];  PutChar[']]};
    
  PrintFD: PROC [fd: RCMap.FieldDescriptor] ~ {
    PutChar['(];  PutDecimal[fd.wordOffset];
    IF fd.bitFirst # 0 OR fd.bitCount # Environment.bitsPerWord THEN {
      PutChar[':];  PutDecimal[fd.bitFirst];
      PutString[".."L];  PutDecimal[fd.bitFirst + fd.bitCount - 1]};
    PutChar[')]};
    
        
  PrintRefLits: PROC [rtHeader: RTBcd.RTBase, sorted: BOOL] ~ {
    litList: LONG POINTER TO RTBcd.RefLitList ~ @rtHeader[rtHeader.refLitTable];
    textBase: LONG POINTER ~ @rtHeader[rtHeader.litBase];

    PutLitString: PROC [offset, length: CARDINAL] RETURNS [valid: BOOL] ~ INLINE {
      text: LONG POINTER TO TEXT ~ textBase + offset;
      valid _ offset + length <= rtHeader.litLength AND length = TEXT[text.length].SIZE;
      IF valid THEN PrintText[text] ELSE PrintGarbage[]};
      
    PrintRefLit: PROC [i: NAT] RETURNS [valid: BOOL] ~ {
      Tab[2];
      PrintIndex[i];
      PutString[" type: "L];
      PrintIndex[litList[i].referentType];
      PutString[",  "L];
      RETURN [PutLitString[litList[i].offset, litList[i].length]]};
    
    PutString["Atoms and REF Literals"L];  PrintIndex[rtHeader.refLitTable];
    IF sorted THEN PutString[" (ordered)"L];
    PutString[":\n"L];
    IF sorted THEN {
      litTree: LONG POINTER TO Nodes _ (Heap.systemZone).NEW[Nodes[litList.length]];
      
      EnterLit: PROC [n: NAT] ~ {
	i: Branch _ 0;
	litTree[n] _ [l~nullBranch, r~nullBranch];
	DO
	  SELECT CompareLits[litList[n], litList[i]] FROM
	    $ls => {
	      IF litTree[i].l = nullBranch THEN litTree[i].l _ n;
	      i _ litTree[i].l};
	    $gr => {
	      IF litTree[i].r = nullBranch THEN litTree[i].r _ n;
	      i _ litTree[i].r};
	    ENDCASE => EXIT
	  ENDLOOP};
     
      PrintBranch: PROC [i: Branch] RETURNS [success: BOOL _ TRUE] ~ {
        UNTIL i = nullBranch OR ~success DO
	  success _ PrintBranch[litTree[i].l] AND PrintRefLit[i];
	  i _ litTree[i].r;
	  ENDLOOP;
	RETURN}; 

      FOR n: NAT IN [0 .. litList.length) DO EnterLit[n] ENDLOOP;
      [] _ PrintBranch[IF litList.length = 0 THEN nullBranch ELSE 0];
      (Heap.systemZone).FREE[@litTree]}
    ELSE
      FOR i: NAT IN [0 .. litList.length) DO
        IF ~PrintRefLit[i] THEN EXIT;
        ENDLOOP;
    PutString["\n\n"L]};
    
    
  PutIndex: PROC [index: UNSPECIFIED] ~ INLINE {PutDecimal[LOOPHOLE[index]]};
    
  PutType: PROC [s: TypeStrings.TypeString, i: CARDINAL] RETURNS [CARDINAL] ~ {
    
    PutCode: PROC [c: TypeStrings.Code] ~ {
      SELECT c FROM
	$leftParen => PutChar['[];
	$definition => PutChar['&];
	$name => PutChar['.];
	$ref => PutChar['@];
	$list => PutChar['*];
	ENDCASE => {
	  repr: NAT = c.ORD;
	  offset: NAT = repr - 200b;
	  PutChar[VAL[IF offset < 'Z.ORD-'A.ORD+1
	    THEN 'A.ORD + offset
	    ELSE 'a.ORD + (offset - ('Z.ORD-'A.ORD+1))]]}};
      
    Skip: PROC [nBytes: CARDINAL] ~ {THROUGH [1..nBytes] DO i _ i+1 ENDLOOP};
      
    PutNum: PROC [nBytes: [1..2]] ~ {
      v: CARDINAL _ 0;
      THROUGH [1..nBytes] DO
        v _ 256*v + (s[i]-0c); i _ i+1;
	ENDLOOP;
      PutDecimal[v]};
      
    PutId: PROC ~ {
      n: NAT ~ s[i].ORD;
      PutChar[''];  i _ i + 1;
      THROUGH [1..n] DO
        PutChar[s[i]];  i _ i+1
	ENDLOOP;
      PutChar['']};
      
    PutPaint: PROC ~ {
      hex: STRING ~ "0123456789abcdef"L;
      PutChar['{];
      THROUGH [1..6] DO
        v: NAT ~ s[i] - 0c;
	PutChar[hex[v/16]]; PutChar[hex[v MOD 16]];
	i _ i + 1;
	ENDLOOP;
      PutNum[2];
      PutChar['}]};
      
    PutSubType: PROC ~ {
      c: TypeStrings.Code ~ LOOPHOLE[s[i]];
      PutCode[c];
      i _ i + 1;
      SELECT c FROM
        $definition => {PutNum[1]; PutSubType[]};
        $name => {PutNum[1]};
        $leftParen => {
	  WHILE LOOPHOLE[s[i], TypeStrings.Code] # $rightParen DO
	    PutId[]; PutSubType[];
	    ENDLOOP;
	  PutChar[']]; i _ i+1};

        $paint, $opaque, $union => {PutPaint[]};

        $subrange => {
	  PutSubType[];
	  Skip[2]; PutNum[2];
	  PutChar[',];
	  Skip[2]; PutNum[2]};

        $sequence => {PutId[]; PutSubType[]; PutSubType[]};

        $array, $relativeRef,
        $port, $program, $procedure, $safeProc, $signal => {
	  PutSubType[]; PutSubType[]};	-- binary

        $list, $ref, $var, $pointer, $longPointer, $descriptor, $longDescriptor,
	$process, $error,
	$readOnly, $packed, $ordered =>
	  PutSubType[];	-- unary

        ENDCASE => NULL};	-- nullary
      
    PutChar['(]; PutDecimal[s.length]; PutChar[')]; PutChar[' ];
    PutSubType[];
    RETURN [i]};
  

  PrintIndex: PROC [index: UNSPECIFIED] ~ {
    PutString["["L];  PutDecimal[index];  PutChar[']]};
    
  PrintText: PROC [t: LONG POINTER TO TEXT] ~ {
    IF t = NIL THEN PutString["(nil)"L]
    ELSE
      FOR i: NAT IN [0 .. t.length) DO PutChar[t[i]] ENDLOOP};
    
  PrintGarbage: PROC ~ INLINE {
    PutString["? Looks like garbage ...\n"L]};
    
  Tab: PROC [n: CARDINAL] ~ {
    PutChar['\n];
    THROUGH [1..n/8] DO PutChar['\t] ENDLOOP;
    THROUGH [1..n MOD 8] DO PutChar[' ] ENDLOOP};


 -- auxiliary types and predicates for sorting (from BcdLiteralsImpl)
 
  Relation: TYPE ~ {ls, gr, eq};
  Branch: TYPE ~ CARDINAL --[0..NAT.LAST+1]--;
  nullBranch: Branch ~ NAT.LAST+1;
  Nodes: TYPE ~ RECORD [SEQUENCE length: NAT OF RECORD [l, r: Branch]];
  
  Scramble: PROC [n: CARDINAL] RETURNS [WORD] ~ INLINE {  -- see Knuth, v 3, p. 509-511
    RETURN [Inline.LowHalf[Inline.LongMult[n, 44451]]]};
    
  CompareTypes: PROC [l, r: RTBcd.TypeItem] RETURNS [Relation] ~ {
    sl: WORD ~ Scramble[l.ct];
    sr: WORD ~ Scramble[r.ct];
    RETURN [
      SELECT sl FROM
	< sr => $ls,  > sr => $gr,
	ENDCASE => 
	  SELECT TRUE FROM
	    l.canonical AND ~r.canonical => $ls,
	    ~l.canonical AND r.canonical => $gr,
	    ENDCASE =>	-- l.canonical = r.canonical
	      IF l.canonical THEN $eq ELSE CompareUTFs[l.ut, r.ut]]};

  CompareUTFs: PROC [l, r: RTBcd.UTInfo] RETURNS [Relation] ~ {
    UTWords: TYPE ~ ARRAY [0 .. RTBcd.UTInfo.SIZE) OF WORD;
    FOR i: NAT IN [0 .. RTBcd.UTInfo.SIZE) DO
      SELECT LOOPHOLE[l, UTWords][i] FROM
        < LOOPHOLE[r, UTWords][i] => RETURN [$ls];
	> LOOPHOLE[r, UTWords][i] => RETURN [$gr];
	ENDCASE;
      ENDLOOP;
    RETURN [$eq]};

  CompareLits: PROC [l, r: RTBcd.RefLitItem] RETURNS [Relation] ~ {
    sl: WORD ~ Scramble[l.offset];
    sr: WORD ~ Scramble[r.offset];
    RETURN [SELECT sl FROM
      < sr => $ls,
      > sr => $gr,
      ENDCASE => SELECT l.length FROM
	= r.length =>
	  SELECT l.referentType - r.referentType FROM
	    = 0 => $eq, > 0 => $gr, ENDCASE => $ls,
	< r.length => $ls,
	ENDCASE => $gr]};

  }.