<> <> <> DIRECTORY BcdDefs: TYPE USING [Base, BcdBase, FTIndex, FTRecord, VersionStamp, FTNull], Basics: TYPE USING [bitsPerWord, LongMult, LowHalf], IO: TYPE USING [int, Put, PutChar, PutRope, STREAM], ListerUtil: TYPE USING [PutVersionId], PrincOps: TYPE USING [wordsPerPage], RCMap: TYPE USING [Base, FieldDescriptor, Index, Object, RCField], Rope: TYPE USING [ROPE], RTBcd: TYPE USING [ RefLitList, RTBase, StampIndex, StampList, RefLitItem, TypeItem, TypeList, UTInfo, VersionID, AnyStamp], TypeStrings: TYPE USING [Code, TypeString], UnsafeStorage: TYPE USING [GetSystemUZone]; RTList: PROGRAM IMPORTS IO, UnsafeStorage, Basics, ListerUtil EXPORTS ListerUtil = { out: IO.STREAM _ NIL; PutChar: PROC [c: CHAR] ~ INLINE {IO.PutChar[out, c]}; PutDecimal: PROC [i: INTEGER] ~ INLINE {IO.Put[out, IO.int[i]]}; PutRope: PROC [s: Rope.ROPE] ~ INLINE {IO.PutRope[out, s]}; PrintRTBcd: PUBLIC PROC [ dest: IO.STREAM, bcd: BcdDefs.BcdBase, sorted: BOOL] ~ { rtHeader: RTBcd.RTBase ~ IF bcd.extended AND bcd.rtPages.pages # 0 THEN LOOPHOLE[bcd + bcd.rtPages.relPageBase*PrincOps.wordsPerPage] ELSE NIL; out _ dest; IF rtHeader = NIL THEN PutRope["No RT pages\n"] ELSE IF rtHeader.versionIdent # RTBcd.VersionID THEN PutRope["Invalid RT version stamp\n"] ELSE { PrintHeader[rtHeader]; PrintTypes[rtHeader, bcd, sorted]; PrintStamps[rtHeader]; PrintRCMap[rtHeader]; PrintRefLits[rtHeader, sorted]}; out _ NIL}; PrintHeader: PROC [rtHeader: RTBcd.RTBase] ~ { PutRope["Types: "]; PutDecimal[rtHeader[rtHeader.typeTable].length]; PutRope[", Ref Literals: "]; PutDecimal[rtHeader[rtHeader.refLitTable].length]; PutRope[", "]; PutDecimal[rtHeader.rcMapLength]; PutRope[" Words of RC Map"]; PutRope[", "]; PutDecimal[rtHeader.litLength]; PutRope[" Words of Literals\n\n"]}; PrintTypes: PROC [rtHeader: RTBcd.RTBase, bcd: BcdDefs.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 PutRope[" ???"]}; PrintType: PROC [i: NAT] RETURNS [success: BOOL] ~ { Tab[2]; PrintIndex[i]; PutRope[" sei: "]; PutIndex[typeList[i].sei]; PutRope[", segment: "]; PrintIndex[typeList[i].table]; PutRope[", rcMap: "]; PrintIndex[typeList[i].rcMap]; PutRope[", UTF: [stamp: "]; IF typeList[i].ut.version = RTBcd.AnyStamp THEN PutRope["(any)"] ELSE PrintIndex[typeList[i].ut.version]; PutRope[", sei: "]; PutIndex[typeList[i].ut.sei]; PutChar[']]; IF typeList[i].canonical THEN PutRope[", canonical"] ELSE IF typeList[i].ut.version # RTBcd.AnyStamp THEN { fti: BcdDefs.FTIndex ~ VersionToFile[typeList[i].ut.version]; IF fti # BcdDefs.FTNull THEN { PutRope[" (file: "]; PrintIndex[fti]; PutChar[')]}}; Tab[4]; PrintIndex[typeList[i].ct.index]; RETURN [PrintTypeString[typeList[i].ct.index]]}; PutRope["Types"]; PrintIndex[rtHeader.typeTable]; IF sorted THEN PutRope[" (ordered)"]; PutRope[":\n"]; IF sorted THEN { typeTree: LONG POINTER TO Nodes _ (UnsafeStorage.GetSystemUZone[]).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]; (UnsafeStorage.GetSystemUZone[]).FREE[@typeTree]} ELSE FOR i: NAT IN [0 .. typeList.length) DO IF ~PrintType[i] THEN EXIT; ENDLOOP; PutRope["\n\n"]}; PrintStamps: PROC [rtHeader: RTBcd.RTBase] ~ { stampList: LONG POINTER TO RTBcd.StampList ~ @rtHeader[rtHeader.stampTable]; PutRope["Version Stamps"]; PrintIndex[rtHeader.stampTable]; PutRope[":\n"]; FOR i: NAT IN [1 .. stampList.limit) DO Tab[2]; PrintIndex[i]; PutChar[' ]; ListerUtil.PutVersionId[out, stampList[i]]; ENDLOOP; PutRope["\n\n"]}; PrintRCMap: PROC [rtHeader: RTBcd.RTBase] ~ { rcmb: RCMap.Base ~ LOOPHOLE[@rtHeader[rtHeader.rcMapBase]]; next: RCMap.Index; PutRope["RC Maps"]; PrintIndex[CARDINAL[LOOPHOLE[rtHeader.rcMapBase, LONG CARDINAL]]]; PutRope[":\n"]; 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 => { PutRope["null"]; next _ rcmi + RCMap.Object.null.SIZE}; ref => { PutRope["ref"]; next _ rcmi + RCMap.Object.ref.SIZE}; controlLink => { PutRope["controlLink"]; next _ rcmi + RCMap.Object.controlLink.SIZE}; oneRef => { PutRope["oneRef[offset: "]; PutDecimal[m.offset]; PutChar[']]; next _ rcmi + RCMap.Object.oneRef.SIZE}; simple => { PutRope["simple[length: "]; PutDecimal[m.length]; PutRope[", offsets: ["]; FOR i: NAT IN [0 .. m.length) DO IF m.refs[i] THEN { PutDecimal[i]; IF i + 1 # m.length THEN PutRope[", "]}; ENDLOOP; PutRope["]]"]; next _ rcmi + RCMap.Object.simple.SIZE}; nonVariant => { PutRope["nonVariant[nComponents: "]; PutDecimal[m.nComponents]; PutRope[", components: ["]; 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 PutRope[", "]; ENDLOOP; PutRope["]]"]; next _ rcmi + (RCMap.Object.nonVariant.SIZE + m.nComponents*RCMap.RCField.SIZE)}; variant => { PutRope["variant[fdTag: "]; PrintFD[m.fdTag]; PutRope[", nVariants: "]; PutDecimal[m.nVariants]; PutRope[", variants: ["]; FOR i: NAT IN [0..m.nVariants) DO PrintIndex[m.variants[i]]; IF i+1 # m.nVariants THEN PutRope[", "]; ENDLOOP; PutRope["]]"]; next _ rcmi + (RCMap.Object.variant.SIZE + m.nVariants*RCMap.Index.SIZE)}; array => { PutRope["array[wordsPerElement: "]; PutDecimal[m.wordsPerElement]; PutRope[", nElements: "]; PutDecimal[m.nElements]; PutRope[", rcmi: "]; PrintIndex[m.rcmi]; PutChar[']]; next _ rcmi + RCMap.Object.array.SIZE}; sequence => { PutRope["sequence[wordsPerElement: "]; PutDecimal[m.wordsPerElement]; PutRope[", fdLength: "]; PrintFD[m.fdLength]; PutRope[", dataOffset: "]; PutDecimal[m.dataOffset]; PutRope[", rcmi: "]; PrintIndex[m.rcmi]; PutChar[']]; next _ rcmi + RCMap.Object.sequence.SIZE}; ENDCASE => {PrintGarbage[]; EXIT}; ENDLOOP; PutRope["\n\n"]}; PrintField: PROC [f: RCMap.RCField] ~ { PutRope["[offset: "]; PutDecimal[f.wordOffset]; PutRope[", rcmi: "]; PrintIndex[f.rcmi]; PutChar[']]}; PrintFD: PROC [fd: RCMap.FieldDescriptor] ~ { PutChar['(]; PutDecimal[fd.wordOffset]; IF fd.bitFirst # 0 OR fd.bitCount # Basics.bitsPerWord THEN { PutChar[':]; PutDecimal[fd.bitFirst]; PutRope[".."]; 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]; PutRope[" type: "]; PrintIndex[litList[i].referentType]; PutRope[", "]; RETURN [PutLitString[litList[i].offset, litList[i].length]]}; PutRope["Atoms and REF Literals"]; PrintIndex[rtHeader.refLitTable]; IF sorted THEN PutRope[" (ordered)"]; PutRope[":\n"]; IF sorted THEN { litTree: LONG POINTER TO Nodes _ (UnsafeStorage.GetSystemUZone[]).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]; (UnsafeStorage.GetSystemUZone[]).FREE[@litTree]} ELSE FOR i: NAT IN [0 .. litList.length) DO IF ~PrintRefLit[i] THEN EXIT; ENDLOOP; PutRope["\n\n"]}; 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] ~ { PutRope["["]; PutDecimal[index]; PutChar[']]}; PrintText: PROC [t: LONG POINTER TO TEXT] ~ { IF t = NIL THEN PutRope["(nil)"] ELSE FOR i: NAT IN [0 .. t.length) DO PutChar[t[i]] ENDLOOP}; PrintGarbage: PROC ~ INLINE { PutRope["? Looks like garbage ...\n"]}; Tab: PROC [n: CARDINAL] ~ { PutChar['\n]; THROUGH [1..n/8] DO PutChar['\t] ENDLOOP; THROUGH [1..n MOD 8] DO PutChar[' ] ENDLOOP}; <> 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 [Basics.LowHalf[Basics.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]}; }.