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};
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 [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]};
}.