-- RTList.mesa
-- last edited by Satterthwaite on October 25, 1982 4:00 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.extended AND 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]};
}.