DIRECTORY
ConvertUnsafe: TYPE USING [SubString],
IO: TYPE USING [STREAM, Put, PutChar, PutF, PutRope, Reset, RopeFromROS, ROS],
ListerUtils: TYPE USING [PrintName, PrintSei],
Rope: TYPE USING [ROPE],
SortedSymbolLister: TYPE,
StructuredStreams: TYPE USING [Begin, Bp, Create, End],
Symbols: TYPE,
SymbolSegment: TYPE USING [STHeader],
SymbolTable: TYPE USING [Base],
Tree: TYPE USING [Index, Link, Node, Scan, Null],
UnparserBuffer: TYPE USING [Handle, Init, NewInittedHandle];
SortedSymbolListerImpl:
PROGRAM
IMPORTS IO, ListerUtils, StructuredStreams, UnparserBuffer EXPORTS SortedSymbolLister =
BEGIN OPEN Symbols;
wordlength: CARDINAL = 16;
SymbolTableBase: TYPE = SymbolTable.Base;
ROPE: TYPE = Rope.ROPE;
Control: TYPE = {begin, end, brk, tbrk};
DoControl:
PROC[st:
IO.
STREAM, cc: Control] = {
SELECT cc
FROM
$begin => StructuredStreams.Begin[st];
$end => StructuredStreams.End[st];
$brk => StructuredStreams.Bp[st, width, 2];
$tbrk => StructuredStreams.Bp[st, united, 2];
ENDCASE => ERROR;
};
alwaysMD: BOOL ← FALSE;
VfTag: TYPE = {signed, unsigned, char, enum, array, transfer, ref, real, other};
ValFormat:
TYPE =
RECORD[
bias: INTEGER𡤀,
var:
SELECT tag: VfTag
FROM
signed => [], --an INTEGER or subrange with base < 0
unsigned => [], -- a CARDINAL, WORD, UNSPECIFIED, or subrange w/ base >= 0
char => [], --a character
enum => [esei: EnumeratedSEIndex], --an enumerated type
array => [componentType: SEIndex],
transfer => [mode: TransferMode], --a PROC, SIGNAL, ERROR, PROGRAM, or PORT
ref => [], --a pointer
real => [],
other => [], --anything else (whether single word or multi-word)
ENDCASE
];
AddSymbols:
PUBLIC
PROC[rList:
LIST
OF
REF
ANY , stb: SymbolTableBase]
RETURNS[LIST OF REF ANY] = {
ros: IO.STREAM ← IO.ROS[];
upb: UnparserBuffer.Handle;
strc: IO.STREAM;
modname: ROPE;
mySei, sei: ISEIndex;
stHandle: LONG POINTER TO SymbolSegment.STHeader = stb.stHandle;
ros.PutRope[": --"]; -- set up modname
FOR sei ← stb.FirstCtxSe[stHandle.directoryCtx], stb.NextSe[sei]
UNTIL sei = ISENull
DO
mySei ← sei;
ENDLOOP;
ListerUtils.PrintSei[mySei, ros, stb];
ros.PutRope["--"];
modname ← ros.RopeFromROS[FALSE];
upb ← UnparserBuffer.NewInittedHandle[[output: [stream[ros]]]];
strc ← StructuredStreams.Create[upb];
FOR sei ← stb.FirstCtxSe[stHandle.outerCtx], stb.NextSe[sei]
UNTIL sei = ISENull
DO
ros.Reset[];
upb.Init[];
DoControl[strc, $begin];
PrintSym[strc, stb, sei, modname, TRUE]; strc.Put[[character[';]]];
DoControl[strc, $end];
rList ← CONS[ros.RopeFromROS[FALSE], rList];
ENDLOOP;
RETURN[rList]};
FirstChar:
PROC[stb: SymbolTableBase, hti: HTIndex]
RETURNS[
CHAR] = {
ss: ConvertUnsafe.SubString;
IF hti = HTNull THEN RETURN['\000];
ss ← stb.SubStringForName[hti];
RETURN[IF ss.length = 0 THEN '\000 ELSE ss.base[ss.offset]]};
PrintSym:
PROC[
st: IO.STREAM, stb: SymbolTableBase, sei: ISEIndex,
colonstring: ROPE, defaultPublic: BOOL] = {
PrintSei:
PROC[val: ISEIndex] = {
ListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
typeSei: SEIndex;
vf: ValFormat;
hti: HTIndex;
check for wierd inserted symbols
hti ← stb.seb[sei].hash;
IF FirstChar[stb, hti] = '& THEN RETURN;
DoControl[st, $begin];
IF hti # HTNull THEN {PrintSei[sei]; PutRope[colonstring]};
IF stb.seb[sei].public # defaultPublic
THEN {
defaultPublic ← stb.seb[sei].public;
PutRope[IF defaultPublic THEN "PUBLIC " ELSE "PRIVATE "]};
IF stb.seb[sei].idType = typeTYPE
THEN {
typeSei ← stb.seb[sei].idInfo;
PutRope["TYPE"];
WITH t~~stb.seb[typeSei]
SELECT
FROM
cons =>
WITH t
SELECT
FROM
opaque => NULL;
ENDCASE => PutRope[" = "];
ENDCASE => PutRope[" = "];
DoControl[st, $brk];
vf ← PrintType[st, stb, typeSei, NoSub, defaultPublic];
DoControl[st, $brk];
PrintDefaultValue [st, stb, sei, vf]}
ELSE {
typeSei ← stb.seb[sei].idType;
IF stb.seb[sei].immutable
AND NOT stb.seb[sei].constant
AND (
SELECT stb.XferMode [typeSei]
FROM
none, process =>
TRUE,
ENDCASE =>
FALSE)
it's not a proc, signal, error, program, or port
THEN PutRope["READONLY "];
vf ← PrintType[st, stb, typeSei, NoSub, defaultPublic];
IF stb.seb[sei].constant
AND vf.tag <= enum
THEN {
PutRope[" = "];
DoControl[st, $brk];
IF stb.seb[sei].extended THEN PrintTreeLink [st, stb, stb.FindExtension[sei].tree, vf]
ELSE PrintTypedVal[st, stb, stb.seb[sei].idValue, vf]}
};
DoControl[st, $end]};
PrintTypedVal:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, val:
UNSPECIFIED, vf: ValFormat] =
{
PutCharConst: PROC[val: CARDINAL] = {st.PutF["%bC", [cardinal[val]]]};
loophole: BOOL ← FALSE;
val ← val + vf.bias;
WITH vf
SELECT
FROM
signed => PutSigned[st, LONG[LOOPHOLE[val, INTEGER]]];
unsigned => PutUnsigned[st, LONG[LOOPHOLE[val, CARDINAL]]];
char => PutCharConst[val];
enum => PutEnum[st, stb, val, esei];
transfer, ref => IF val = 0 THEN st.PutRope["NIL"] ELSE loophole ← TRUE;
ENDCASE => loophole ← TRUE;
IF loophole
THEN {
st.PutRope["LOOPHOLE ["];
PutUnsigned[st, LONG[LOOPHOLE[val, CARDINAL]]];
st.Put[[character[']]]]};
};
GetBitSpec:
PROC[stb: SymbolTableBase, isei: ISEIndex]
RETURNS[
ROPE] = {
a: Symbols.BitAddress;
s: CARDINAL;
ros: IO.STREAM ← IO.ROS[];
[offset: a, size: s] ← stb.RecField[isei];
ros.PutF[" (%d", [cardinal[a.wd]]];
IF s # 0 THEN ros.PutF[":%d..%d", [cardinal[a.bd]], [cardinal[a.bd+s-1]]];
ros.PutRope["): "];
RETURN[ros.RopeFromROS[]]};
PrintFieldCtx:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, ctx: CTXIndex, md:
BOOL, defaultPublic:
BOOL] = {
PutChar:
PROC[val:
CHAR] = {
st.Put[[character[val]]]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
isei: ISEIndex ← stb.FirstCtxSe[ctx];
bitspec: ROPE ← ": ";
first: BOOL ← TRUE;
IF isei # ISENull AND stb.seb[isei].idCtx # ctx THEN isei ← stb.NextSe[isei];
IF isei = ISENull THEN { PutRope["NULL"]; RETURN };
PutChar['[];
FOR isei ← isei, stb.NextSe[isei]
UNTIL isei = ISENull
DO
IF first THEN first ← FALSE ELSE PutRope[", "];
DoControl[st, $brk];
IF md THEN bitspec ← GetBitSpec[stb, isei];
DoControl[st, $begin];
PrintSym[st, stb, isei, bitspec, defaultPublic];
PrintDefaultValue [st, stb, isei, GetValFormat[stb, stb.seb[isei].idType]];
DoControl[st, $end];
ENDLOOP;
PutChar[']]};
PrintValue:
PROC[st:
IO.
STREAM, value:
UNSPECIFIED] = {
lc: LONG CARDINAL ← LOOPHOLE[value, CARDINAL];
PutUnsigned[st, lc]};
NoSub:
PROC[ptr:
BOOL] = { };
EnumeratedSEIndex:
TYPE =
Symbols.Base RELATIVE POINTER [0..Limit) TO SERecord.cons.enumerated;
PutEnum:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, val:
UNSPECIFIED, esei: EnumeratedSEIndex] = {
sei: ISEIndex;
FOR sei ← stb.FirstCtxSe[stb.seb[esei].valueCtx], stb.NextSe[sei]
WHILE sei # ISENull
DO
IF stb.seb[sei].idValue = val THEN {ListerUtils.PrintSei[sei, st, stb]; RETURN};
ENDLOOP;
st.PutRope["LOOPHOLE ["];
PrintValue[st, val];
st.Put[[character[']]]]};
GetValFormat:
PROC[stb: SymbolTableBase, tsei: SEIndex]
RETURNS[vf: ValFormat] = {
WITH t~~stb.seb[tsei]
SELECT
FROM
id => RETURN[GetValFormat[stb, stb.UnderType[tsei]]];
cons =>
WITH t
SELECT
FROM
basic =>
SELECT code
FROM
codeANY => vf ← [,unsigned[]];
codeINT => vf ← [,signed[]];
codeCHAR => vf ← [,char[]];
ENDCASE;
enumerated => vf ← [,enum [LOOPHOLE [tsei]]];
array => vf ← [,array [componentType]];
transfer => vf ← [,transfer[mode]];
relative => vf ← GetValFormat[stb, offsetType];
subrange => {
vf ← GetValFormat [stb, rangeType];
IF vf.tag = signed AND origin >= 0 THEN vf ← [,unsigned[]];
vf.bias ← origin};
long => vf ← GetValFormat[stb, rangeType];
real => vf ← [,real[]];
ref => vf ← [,ref[]];
ENDCASE => vf ← [,other[]];
ENDCASE => vf ← [,other[]];
octalThreshold: NAT ← 1024;
PutSigned:
PROC[st:
IO.
STREAM, val:
INT] = {
IF val > octalThreshold THEN st.PutF["%bB", [integer[val]]]
ELSE st.PutF["%d", [integer[val]]]};
PutUnsigned:
PROC[st:
IO.
STREAM, val:
LONG
CARDINAL] = {
IF val > octalThreshold THEN st.PutF["%bB", [cardinal[val]]]
ELSE st.PutF["%d", [cardinal[val]]]};
PrintType:
PROC[
st: IO.STREAM, stb: SymbolTableBase, tsei: SEIndex,
dosub: PROC[ptr: BOOL], defaultPublic: BOOL]
RETURNS[vf: ValFormat] = {
PutChar:
PROC[val:
CHAR] = {
st.Put[[character[val]]]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
PrintSei:
PROC[val: ISEIndex] = {
ListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PrintHti:
PROC[val: HTIndex] = {
ListerUtils.PrintName[name: val, stream: st, stb: stb]};
vf ← GetValFormat[stb, tsei];
WITH t~~stb.seb[tsei]
SELECT
FROM
id => {
printBase: BOOL ← TRUE;
multiSubrange: BOOL ← FALSE;
bsei: SEIndex ← tsei;
csei: CSEIndex;
print adjectives, if any
tseiNext: SEIndex;
{
l1: SEIndex = t.idInfo;
IF stb.seb[l1].seTag = id THEN GO TO noAdj;
UNTIL (tseiNext ← stb.TypeLink[tsei]) = SENull
DO
WITH stb.seb[tsei]
SELECT
FROM
id => { PrintSei[LOOPHOLE[tsei]]; PutChar[' ]; };
ENDCASE;
tsei ← tseiNext;
ENDLOOP;
};
print module qualification of last ID in chain
IF t.idCtx
NOT
IN Symbols.StandardContext
THEN
WITH c~~stb.ctxb [t.idCtx]
SELECT
FROM
included => {
hti: HTIndex = stb.mdb [c.module].moduleId;
PrintHti [hti]; --interface name
PutChar ['.]}; -- dot qualification
simple => PutCurrentModuleDot[];
finally print that last ID
DO
csei ← stb.UnderType[bsei];
WITH stb.seb[csei]
SELECT
FROM
basic => {
SELECT code
FROM
codeINT => printBase ← multiSubrange;
ENDCASE;
EXIT};
subrange => {bsei ← rangeType; multiSubrange ← TRUE};
enumerated => {printBase ← TRUE; EXIT};
ENDCASE => EXIT;
ENDLOOP;
IF printBase OR dosub = NoSub THEN PrintSei[LOOPHOLE[tsei]];
dosub[FALSE]};
cons =>
WITH t
SELECT
FROM
basic => won't see one, see the id first.
enumerated => {
isei: ISEIndex;
v: CARDINAL ← 0;
sv: CARDINAL;
md: BOOL = machineDep;
first: BOOL ← TRUE;
IF md THEN PutRope["MACHINE DEPENDENT "];
PutChar['{];
FOR isei ← stb.FirstCtxSe[valueCtx], stb.NextSe[isei]
UNTIL isei = ISENull
DO
IF first THEN first ← FALSE ELSE PutRope[", "];
DoControl[st, $brk];
IF md
THEN {
hti: Symbols.HTIndex = stb.seb[isei].hash;
sv ← stb.seb[isei].idValue;
IF hti # HTNull THEN PrintSei[isei];
IF hti = HTNull
OR sv # v
THEN
{PutChar['(]; PutUnsigned[st, sv]; PutChar[')]};
v ← sv + 1}
ELSE PrintSei[isei];
ENDLOOP;
PutChar['}]};
record => {
IF stb.ctxb[fieldCtx].level # lZ
THEN {
fctx: CTXIndex = fieldCtx;
bti: BTIndex ← FIRST[BTIndex];
btlimit: BTIndex = bti + stb.stHandle.bodyBlock.size;
PutRope["FRAME ["];
UNTIL bti = btlimit
DO
WITH entry~~stb.bb[bti]
SELECT
FROM
Callable => {
IF entry.localCtx = fctx THEN {PrintSei[entry.id]; PutChar[']]; EXIT};
bti ←
bti +
(
WITH entry
SELECT
FROM
Inner => BodyRecord.Callable.Inner.SIZE,
ENDCASE => BodyRecord.Callable.Outer.SIZE);
};
ENDCASE => bti ← bti + BodyRecord.Other.SIZE;
ENDLOOP;
}
ELSE {
IF defaultPublic AND hints.privateFields THEN PutRope["PRIVATE "];
IF monitored THEN PutRope["MONITORED "];
IF machineDep THEN PutRope["MACHINE DEPENDENT "];
PutRope["RECORD"];
PrintFieldCtx[st, stb, fieldCtx, machineDep, defaultPublic AND ~hints.privateFields];
};
};
ref => {
referent: SEIndex = refType;
IF var THEN PutRope[IF readOnly THEN "READONLY " ELSE "VAR "]
ELSE {
IF ordered THEN PutRope["ORDERED "];
IF basing THEN PutRope["BASE "];
IF counted
THEN {
isList: BOOL;
element: SEIndex;
[isList, element] ← CheckForList[stb, LOOPHOLE[tsei]];
IF isList
THEN {
PutRope["LIST OF "];
[] ← PrintType[st, stb, element, NoSub, defaultPublic];
GO TO noprint}
ELSE PutRope["REF "];
WITH rt~~stb.seb[referent]
SELECT
FROM
cons =>
WITH rt
SELECT
FROM
any => {
PutRope["ANY"];
GO TO noprint};
ENDCASE;
ENDCASE;
}
ELSE {
PutRope["POINTER"];
IF dosub # NoSub
THEN {
PutChar[' ];
dosub[TRUE]};
WITH rt~~stb.seb[referent]
SELECT
FROM
cons =>
WITH rt
SELECT
FROM
basic =>
IF code = Symbols.codeANY
AND ~readOnly
THEN
GO TO noprint;
ENDCASE;
ENDCASE;
PutRope[" TO "];
IF readOnly THEN PutRope["READONLY "]};
};
DoControl[st, $brk];
[] ← PrintType[st, stb, referent, NoSub, defaultPublic];
EXITS noprint => NULL;
};
array => {
IF packed THEN PutRope["PACKED "];
PutRope["ARRAY "];
[] ← PrintType[st, stb, indexType, NoSub, defaultPublic];
PutRope[" OF "];
DoControl[st, $brk];
[] ← PrintType[st, stb, componentType, NoSub, defaultPublic]};
arraydesc => {
PutRope["DESCRIPTOR FOR "];
IF readOnly THEN PutRope["READONLY "];
DoControl[st, $brk];
[] ← PrintType[st, stb, describedType, NoSub, defaultPublic]};
transfer => {
PutModeName[st, mode];
IF typeIn # CSENull
THEN {
PutChar[' ];
WITH tt~~stb.seb[typeIn]
SELECT
FROM
record => PrintFieldCtx[st, stb, tt.fieldCtx, FALSE, defaultPublic];
any => PutRope["ANY"];
ENDCASE => ERROR;
};
IF typeOut # CSENull
THEN {
DoControl[st, $brk];
PutRope[" RETURNS "];
WITH tt~~stb.seb[typeOut]
SELECT
FROM
record => PrintFieldCtx[st, stb, tt.fieldCtx, FALSE, defaultPublic];
any => PutRope["ANY"];
ENDCASE => ERROR;
};
};
union => {
tagType: SEIndex;
PutRope["SELECT "];
IF ~controlled
THEN
PutRope[IF overlaid THEN "OVERLAID " ELSE "COMPUTED "]
ELSE {
PrintSei[tagSei];
PutRope[IF machineDep OR alwaysMD THEN GetBitSpec[stb, tagSei] ELSE ": "]};
tagType ← stb.seb[tagSei].idType;
IF stb.seb[tagSei].public # defaultPublic
THEN
PutRope[IF defaultPublic THEN "PRIVATE " ELSE "PUBLIC "];
WITH stb.seb[tagType]
SELECT
FROM
id => [] ← PrintType[st, stb, tagType, NoSub, defaultPublic];
cons => PutChar['*];
ENDCASE;
PutRope[" FROM "];
{
isei: ISEIndex;
varRec: RecordSEIndex;
FOR isei ← stb.FirstCtxSe[caseCtx], stb.NextSe[isei]
UNTIL isei = ISENull
DO
DoControl[st, $tbrk];
DoControl[st, $begin];
PrintSei[isei];
PutRope[" => "];
varRec ← LOOPHOLE[stb.UnderType[stb.seb[isei].idInfo]];
PrintFieldCtx[st, stb, stb.seb[varRec].fieldCtx, machineDep, defaultPublic];
PutRope[", "];
DoControl[st, $end];
ENDLOOP;
DoControl[st, $tbrk];
PutRope["ENDCASE"];
};
};
relative => {
IF baseType # SENull THEN [] ← PrintType[st, stb, baseType, NoSub, defaultPublic];
PutRope[" RELATIVE "];
[] ← PrintType[st, stb, offsetType, dosub, defaultPublic]};
sequence => {
tagType: SEIndex;
pubTag: BOOL ← stb.seb[tagSei].public;
IF packed THEN PutRope["PACKED "];
PutRope["SEQUENCE "];
IF ~controlled THEN PutRope["COMPUTED "]
ELSE {
PrintSei[tagSei];
PutRope[IF machineDep THEN GetBitSpec[stb, tagSei] ELSE ": "]};
tagType ← stb.seb[tagSei].idType;
IF pubTag # defaultPublic
THEN
PutRope[IF defaultPublic THEN "PRIVATE " ELSE "PUBLIC "];
[] ← PrintType[st, stb, tagType, NoSub, pubTag];
PutRope[" OF "];
[] ← PrintType[st, stb, componentType, NoSub, defaultPublic]};
subrange => {
org: INTEGER ← origin;
size: CARDINAL ← range;
mt: BOOL ← empty;
doit:
PROC[ptr:
BOOL] = {
vfSub: ValFormat ← IF ptr THEN [,unsigned[]] ELSE vf;
vfSub.bias ← 0;
PutChar['[];
PrintTypedVal[st, stb, org, vfSub];
PutRope[".."];
IF mt THEN {PrintTypedVal[st, stb, org, vfSub]; PutChar[')]}
ELSE {PrintTypedVal[st, stb, org + size, vfSub]; PutChar[']]}};
[] ← PrintType[st, stb, rangeType, doit, defaultPublic];
vf.bias ← org};
zone =>
SELECT
TRUE
FROM
counted => PutRope["ZONE"];
mds => PutRope["MDSZone"];
ENDCASE => PutRope["UNCOUNTED ZONE"];
opaque => {
IF lengthKnown
THEN {
PutChar['[];
PutUnsigned[st, length/wordlength];
PutChar[']]}
};
long => {
IF NOT IsVarOrRef [rangeType, stb] THEN PutRope["LONG "];
[] ← PrintType[st, stb, rangeType, NoSub, defaultPublic]};
real => PutRope["REAL"];
ENDCASE => PutRope["xxxx"];
ENDCASE;
};
IsVarOrRef:
PROC[tsei: Symbols.SEIndex, stb: SymbolTableBase]
RETURNS[
BOOL] = {
WITH t~~stb.seb[tsei]
SELECT
FROM
id => RETURN[FALSE];
cons =>
WITH t2~~t
SELECT
FROM
ref => RETURN[t2.var OR t2.counted]
ENDCASE => RETURN[FALSE];
ENDCASE => RETURN[FALSE];
};
RefIndex: TYPE = Symbols.Base RELATIVE POINTER [0..Limit) TO SERecord.cons.ref;
CheckForList:
PROC[stb: SymbolTableBase, rsei: RefIndex]
RETURNS[
BOOL, SEIndex] = {
rft: SEIndex ← stb.seb[rsei].refType;
seb: Symbols.Base = stb.seb;
WITH rt~~seb[rft]
SELECT
FROM
id => RETURN[FALSE, SENull];
cons =>
WITH rec~~rt
SELECT
FROM
record => {
ctx: CTXIndex = rec.fieldCtx;
first, rest: ISEIndex;
element: SEIndex;
restp: CSEIndex;
IF ctx = CTXNull THEN RETURN[FALSE, SENull];
first ← stb.FirstCtxSe[ctx];
IF first = ISENull THEN RETURN[FALSE, SENull];
element ← seb[first].idType;
rest ← stb.NextSe[first];
IF rest = ISENull THEN RETURN[FALSE, SENull];
restp ← stb.UnderType[seb[rest].idType];
WITH seb[restp]
SELECT
FROM
long => {
rgt: CSEIndex = stb.UnderType[rangeType];
WITH seb[rgt]
SELECT
FROM
ref => RETURN[refType = rft, element];
ENDCASE => RETURN[FALSE, SENull];
};
ENDCASE => RETURN[FALSE, SENull];
};
ENDCASE => RETURN[FALSE, SENull];
ENDCASE => RETURN[FALSE, SENull];
};
PutModeName:
PROC[st:
IO.
STREAM, n: TransferMode] = {
ModePrintName:
ARRAY TransferMode
OF
ROPE =
["PROC", "PORT", "SIGNAL", "ERROR", "PROCESS", "PROGRAM",
"NONE"];
st.PutRope[ModePrintName[n]]};
LUP: TYPE = LONG POINTER TO LONG UNSPECIFIED;
NodePointer: TYPE = LONG POINTER TO Tree.Node;
PrintDefaultValue:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, sei: ISEIndex, vf: ValFormat] = {
extType: ExtensionType;
tree: Tree.Link;
[extType, tree] ← stb.FindExtension[sei];
IF extType # default THEN RETURN;
st.PutRope[" ← "];
WITH tree
SELECT
FROM
subtree =>
IF stb.tb[index].name = list
AND stb.tb[index].nSons = 2
THEN {
PrintTreeLink[st, stb, stb.tb[index].son[1], vf];
st.PutChar['|];
PrintTreeLink[st, stb, stb.tb[index].son[2], vf];
RETURN};
ENDCASE ;
PrintTreeLink [st, stb, tree, vf]};
endIndex: Tree.Index = Tree.Index.LAST;
endMark: Tree.Link = [subtree[index: endIndex]];
ScanList:
PROC[tb: Symbols.Base, root: Tree.Link, action: Tree.Scan] = {
IF root # Tree.Null
THEN
WITH root
SELECT
FROM
subtree => {
node: Tree.Index = index;
i, n: CARDINAL;
t: Tree.Link;
IF tb[node].name # $list THEN action[root]
ELSE
IF (n ← tb[node].nSons) # 0
THEN
FOR i ← 1, i+1 WHILE i <= n DO action[tb[node].son[i]] ENDLOOP
ELSE
FOR i ← 1, i+1 UNTIL (t←tb[node].son[i]) = endMark DO action[t] ENDLOOP};
ENDCASE => action[root]};
LiteralValue:
PROC[stb: SymbolTableBase, tree: Tree.Link]
RETURNS[
CARDINAL] = {
WITH t~~tree
SELECT
FROM
literal =>
WITH lr~~t.index
SELECT
FROM
word =>
WITH stb.ltb[lr.lti]
SELECT
FROM
short => RETURN[value];
ENDCASE;
ENDCASE;
ENDCASE;
RETURN[0]};
PrintTreeLink:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, tree: Tree.Link, vf: ValFormat] = {
PutChar:
PROC[val:
CHAR] = {
st.PutChar[val]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
PrintSei:
PROC[val: ISEIndex] = {
ListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PrintHti:
PROC[val: HTIndex] = {
ListerUtils.PrintName[name: val, stream: st, stb: stb]};
IF tree = Tree.Null THEN RETURN;
WITH t~~tree
SELECT
FROM
subtree => {
node: NodePointer = @stb.tb[t.index];
SELECT node.name
FROM
all => {
PutRope["ALL["];
WITH v~~vf
SELECT
FROM
array => PrintTreeLink[st, stb, node.son [1], GetValFormat[stb, v.componentType]];
ENDCASE;
PutChar[']]};
atom => {
PutChar['$];
PrintTreeLink[st, stb, node.son [1], vf]};
clit => {
ch: CHAR ← VAL[LiteralValue[stb, node.son[1]]];
PutChar[''];
PutChar[ch]};
mwconst, cast, loophole => PrintTreeLink[st, stb, node.son [1], vf];
nil => PutRope["NIL"];
void => PutRope["TRASH"];
dot, cdot => {
PrintTreeLink[st, stb, node.son[1], [,other[]]];
PutChar ['.]; --dot
PrintTreeLink[st, stb, node.son[2], [,other[]]]};
first, last, size => {
PutRope[
SELECT node.name
FROM
first => "FIRST[",
last => "LAST[",
ENDCASE => "SIZE["];
PrintTreeLink[st, stb, node.son[1], vf];
PutChar [']]};
lengthen => {
s1: Tree.Link = node.son[1];
IF s1.tag = literal THEN PrintTreeLink[st, stb, s1, vf]
ELSE {
PutRope["LONG["];
PrintTreeLink[st, stb, s1, vf];
PutChar [']]};
};
construct => {
s1: Tree.Link = node.son[1];
PutChar['[];
IF node.nSons = 2 THEN PrintTreeLink [st, stb, node.son[2], vf];
PutChar[']]};
union => {
PrintTreeLink [st, stb, node.son[1], vf];
PutChar ['[];
PrintTreeLink [st, stb, node.son[2], vf];
PutChar [']]};
list => {
first: BOOL ← TRUE;
PrintOne: Tree.Scan = {
IF first THEN first ← FALSE ELSE PutRope[", "];
PrintTreeLink [st, stb, t, [,other[]]]};
ScanList[stb.tb, tree, PrintOne]};
longTC => {
PutRope["LONG "];
PrintTreeLink [st, stb, node.son[1], vf]};
callx => {
PrintTreeLink [st, stb, node.son[1], vf];
PutChar ['[];
PrintTreeLink [st, stb, node.son[2], vf];
PutChar [']]};
uparrow => {
ptr: Tree.Link = node.son[1];
type: Symbols.CSEIndex;
WITH p~~ptr
SELECT
FROM
symbol =>
type ← stb.NormalType [stb.UnderType[
stb.seb[p.index].idType]];
subtree => type ← stb.tb[p.index].info;
ENDCASE => type ← Symbols.typeANY;
PrintTreeLink[st, stb, node.son[1], [,other[]]];
WITH q~~stb.seb[type]
SELECT
FROM
ref => IF ~q.var THEN PutChar['^];
ENDCASE => PutChar['^];
};
ENDCASE => PutRope["xxxx"];
};
hash => PrintHti [t.index];
symbol => PrintSei [t.index];
literal => {
WITH lr~~t.index
SELECT
FROM
word =>
WITH stb.ltb[lr.lti]
SELECT
FROM
short => PrintTypedVal [st, stb, value, vf];
long =>
SELECT length
FROM
2 => {
loophole: BOOL ← FALSE;
SELECT vf.tag
FROM
signed => {
li: INT = LOOPHOLE [@value, LUP]^;
SELECT li
FROM
INT.FIRST => PutRope["FIRST[INT]"];
INT.LAST => PutRope["LAST[INT]"];
ENDCASE => PutSigned[st, li];
};
unsigned => {
lu: LONG CARDINAL = LOOPHOLE [@value, LUP]^;
SELECT lu
FROM
LAST[LONG CARDINAL] => PutRope["LAST[LONG CARDINAL]"];
ENDCASE => PutUnsigned[st, lu];
};
real => st.Put[[real[LOOPHOLE [@value, LUP]^]]];
transfer, ref =>
IF
LOOPHOLE[@value,
LUP]^ = 0
THEN PutRope["NIL"]
ELSE loophole ← TRUE;
ENDCASE => loophole ← TRUE;
IF loophole
THEN {
PutRope["LOOPHOLE ["];
PutUnsigned [st, LOOPHOLE [@value, LUP]^];
PutChar [']]};
};
ENDCASE => PutRope["--constant--"];
ENDCASE; --shouldn't happen!
ENDCASE --string-- => PutRope["(STRING)"];
};
ENDCASE; --shouldn't happen!
};