SortedSymbolListerImpl:
PROGRAM
IMPORTS
IO, ListerUtils, StructuredStreams, UnparserBuffer
EXPORTS SortedSymbolLister =
BEGIN OPEN Symbols;
CR: CHAR = '\n;
SP: CHAR = ' ;
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, FALSE, 2];
tbrk => StructuredStreams.Bp[st, TRUE, 2];
ENDCASE => ERROR;
};
alwaysMD: BOOL ← FALSE;
VfTag: TYPE = {signed, unsigned, char, enum, array, transfer, ref, real, other};
ValFormat:
TYPE =
RECORD [
bias: INTEGER ← 0,
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] =
BEGIN
ros: IO.STREAM ← IO.ROS[];
upb: UnparserBuffer.Handle;
strc: IO.STREAM;
modname: ROPE;
mySei, sei: ISEIndex;
stHandle: LONG POINTER TO SymbolSegment.STHeader = stb.stHandle;
IO.PutRope[ros, ": --"]; -- set up modname
FOR sei ← stb.FirstCtxSe[stHandle.directoryCtx], stb.NextSe[sei]
UNTIL sei = ISENull
DO
mySei ← sei;
ENDLOOP;
ListerUtils.PrintSei[mySei, ros, stb];
IO.PutRope[ros, "--"];
modname ← IO.RopeFromROS[ros, FALSE];
upb ← UnparserBuffer.NewHandle[[stream[ros]]];
strc ← StructuredStreams.Create[upb];
FOR sei ← stb.FirstCtxSe[stHandle.outerCtx], stb.NextSe[sei]
UNTIL sei = ISENull
DO
IO.Reset[ros];
UnparserBuffer.Init[upb];
DoControl[strc, begin];
PrintSym[strc, stb, sei, modname, TRUE]; IO.Put[strc, [character[';]]];
DoControl[strc, end];
rList ← CONS [IO.RopeFromROS[ros, FALSE], rList];
ENDLOOP;
RETURN [rList];
END;
FirstChar:
PROC [stb: SymbolTableBase, hti: HTIndex]
RETURNS [
CHAR] = {
ss: ConvertUnsafe.SubString;
IF hti = HTNull THEN RETURN [0C];
ss ← stb.SubStringForName[hti];
IF ss.length = 0 THEN RETURN [0C];
RETURN[ss.base[ss.offset]]};
PrintSym:
PROC [st:
IO.
STREAM, stb: SymbolTableBase, sei: ISEIndex, colonstring:
ROPE, defaultPublic:
BOOL] =
BEGIN
PrintSei:
PROC [val: ISEIndex] = {
ListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PutRope:
PROC[val:
ROPE] = {
IO.PutRope[st, val]};
typeSei: SEIndex;
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
BEGIN PrintSei[sei]; PutRope[colonstring]; END;
IF stb.seb[sei].public # defaultPublic
THEN
BEGIN
defaultPublic ← stb.seb[sei].public;
PutRope[IF defaultPublic THEN "PUBLIC " ELSE "PRIVATE "];
END;
IF stb.seb[sei].idType = typeTYPE
THEN
BEGIN
vf: ValFormat;
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];
END
ELSE
BEGIN
vf: ValFormat;
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
BEGIN
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];
END;
END;
DoControl[st, end];
END;
PrintTypedVal:
PROC [st:
IO.
STREAM, stb: SymbolTableBase, val:
UNSPECIFIED, vf: ValFormat] =
BEGIN
PutCharConst: PROC [val: CARDINAL] = {IO.PutF[st, "%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 IO.PutRope[st, "NIL"] ELSE loophole ← TRUE;
ENDCASE => loophole ← TRUE;
IF loophole
THEN
{IO.PutRope[st, "LOOPHOLE ["];
PutUnsigned[st, LONG[LOOPHOLE[val, CARDINAL]]];
IO.Put[st, [character[']]]]};
END;
GetBitSpec:
PROC [stb: SymbolTableBase, isei: ISEIndex]
RETURNS [
ROPE] =
BEGIN
a: Symbols.BitAddress;
s: CARDINAL;
ros: IO.STREAM ← IO.ROS[];
[offset: a, size: s] ← stb.RecField[isei];
IO.PutF[ros, " (%d", [cardinal[a.wd]]];
IF s # 0 THEN IO.PutF[ros, ":%d..%d", [cardinal[a.bd]], [cardinal[a.bd+s-1]]];
IO.PutRope[ros, "): "];
RETURN [IO.RopeFromROS[ros]];
END;
PrintFieldCtx:
PROC [st:
IO.
STREAM, stb: SymbolTableBase, ctx: CTXIndex, md:
BOOL, defaultPublic:
BOOL] =
BEGIN
PutChar:
PROC [val:
CHAR] = {
IO.Put[st, [character[val]]]};
PutRope:
PROC[val:
ROPE] = {
IO.PutRope[st, 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 BEGIN PutRope["NULL"]; RETURN END;
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[']];
END;
PrintValue:
PROC [st:
IO.
STREAM, value:
UNSPECIFIED] =
BEGIN
lc: LONG CARDINAL ← LOOPHOLE[value, CARDINAL];
PutUnsigned[st, lc];
END;
NoSub:
PROC [ptr:
BOOL] =
BEGIN
RETURN
END;
EnumeratedSEIndex:
TYPE =
Symbols.Base RELATIVE POINTER [0..Limit) TO enumerated cons SERecord;
PutEnum:
PROC [st:
IO.
STREAM, stb: SymbolTableBase, val:
UNSPECIFIED, esei: EnumeratedSEIndex] =
BEGIN
sei: ISEIndex;
FOR sei ← stb.FirstCtxSe[stb.seb[esei].valueCtx], stb.NextSe[sei]
WHILE sei # ISENull DO
IF stb.seb[sei].idValue = val THEN BEGIN ListerUtils.PrintSei[sei, st, stb]; RETURN; END;
ENDLOOP;
IO.PutRope[st, "LOOPHOLE ["];
PrintValue[st, val];
IO.Put[st, [character[']]]];
END;
GetValFormat:
PROC [stb: SymbolTableBase, tsei: SEIndex]
RETURNS [vf: ValFormat] =
BEGIN
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 IO.PutF[st, "%bB", [integer[val]]]
ELSE IO.PutF[st, "%d", [integer[val]]]};
PutUnsigned:
PROC [st:
IO.
STREAM, val:
LONG
CARDINAL] = {
IF val > octalThreshold THEN IO.PutF[st, "%bB", [cardinal[val]]]
ELSE IO.PutF[st, "%d", [cardinal[val]]]};
PrintType:
PROC [st:
IO.
STREAM, stb: SymbolTableBase, tsei: SEIndex, dosub:
PROC [ptr:
BOOL], defaultPublic:
BOOL]
RETURNS [vf: ValFormat] =
BEGIN OPEN Symbols;
PutChar:
PROC [val:
CHAR] = {
IO.Put[st, [character[val]]]};
PutRope:
PROC[val:
ROPE] = {
IO.PutRope[st, 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 =>
BEGIN
printBase: BOOL ← TRUE;
multiSubrange: BOOL ← FALSE;
bsei: SEIndex ← tsei;
csei: CSEIndex;
print adjectives, if any
tseiNext: SEIndex;
BEGIN
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 => BEGIN PrintSei[LOOPHOLE[tsei]]; PutChar[SP]; END;
ENDCASE;
tsei ← tseiNext;
ENDLOOP;
END;
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 =>
BEGIN
hti: HTIndex = stb.mdb [c.module].moduleId;
PrintHti [hti]; --interface name
PutChar ['.]; -- dot qualification
END;
simple => PutCurrentModuleDot[];
finally print that last ID
DO
csei ← stb.UnderType[bsei];
WITH stb.seb[csei]
SELECT
FROM
basic =>
BEGIN
SELECT code
FROM
codeINT => printBase ← multiSubrange;
ENDCASE;
EXIT;
END;
subrange => {bsei ← rangeType; multiSubrange ← TRUE};
enumerated => {printBase ← TRUE; EXIT};
ENDCASE => EXIT;
ENDLOOP;
IF printBase OR dosub = NoSub THEN PrintSei[LOOPHOLE[tsei]];
dosub[FALSE];
END;
cons =>
WITH t
SELECT
FROM
basic => won't see one, see the id first.
enumerated =>
BEGIN
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['}];
END;
record =>
BEGIN
IF stb.ctxb[fieldCtx].level # lZ
THEN
BEGIN
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 =>
BEGIN
IF entry.localCtx = fctx
THEN
BEGIN PrintSei[entry.id]; PutChar[']]; EXIT END;
bti ←
bti +
(
WITH entry
SELECT
FROM
Inner => SIZE[Inner Callable BodyRecord],
ENDCASE => SIZE[Outer Callable BodyRecord]);
END;
ENDCASE => bti ← bti + SIZE[Other BodyRecord];
ENDLOOP;
END
ELSE
BEGIN
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];
END;
END;
ref =>
BEGIN
referent: SEIndex ← refType;
IF var
THEN
IF readOnly THEN PutRope["READONLY "]
ELSE PutRope["VAR "]
ELSE
BEGIN
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 "];
};
END;
DoControl[st, brk];
[] ← PrintType[st, stb, referent, NoSub, defaultPublic];
EXITS noprint => NULL;
END;
array =>
BEGIN
IF packed THEN PutRope["PACKED "];
PutRope["ARRAY "];
[] ← PrintType[st, stb, indexType, NoSub, defaultPublic];
PutRope[" OF "];
DoControl[st, brk];
[] ← PrintType[st, stb, componentType, NoSub, defaultPublic];
END;
arraydesc =>
BEGIN
PutRope["DESCRIPTOR FOR "];
IF readOnly THEN PutRope["READONLY "];
DoControl[st, brk];
[] ← PrintType[st, stb, describedType, NoSub, defaultPublic];
END;
transfer =>
BEGIN
PutModeName[st, mode];
IF typeIn # CSENull
THEN
BEGIN PutChar[' ];
WITH tt: stb.seb[typeIn]
SELECT
FROM
record => PrintFieldCtx[st, stb, tt.fieldCtx, FALSE, defaultPublic];
any => PutRope["ANY"];
ENDCASE => ERROR;
END;
IF typeOut # CSENull
THEN
BEGIN
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;
END;
END;
union =>
BEGIN
tagType: SEIndex;
PutRope["SELECT "];
IF ~controlled
THEN
IF overlaid THEN PutRope["OVERLAID "]
ELSE PutRope["COMPUTED "]
ELSE
BEGIN
PrintSei[tagSei];
IF machineDep OR alwaysMD THEN PutRope[GetBitSpec[stb, tagSei]]
ELSE PutRope[": "];
END;
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 "];
BEGIN
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"];
END;
END;
relative =>
BEGIN
IF baseType # SENull THEN [] ← PrintType[st, stb, baseType, NoSub, defaultPublic];
PutRope[" RELATIVE "];
[] ← PrintType[st, stb, offsetType, dosub, defaultPublic];
END;
sequence =>
BEGIN
tagType: SEIndex;
pubTag: BOOL ← stb.seb[tagSei].public;
IF packed THEN PutRope["PACKED "];
PutRope["SEQUENCE "];
IF ~controlled THEN PutRope["COMPUTED "]
ELSE
BEGIN
PrintSei[tagSei];
IF machineDep THEN PutRope[GetBitSpec[stb, tagSei]]
ELSE PutRope[": "];
END;
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];
END;
subrange =>
BEGIN
org: INTEGER ← origin;
size: CARDINAL ← range;
mt: BOOL ← empty;
doit:
PROC [ptr:
BOOL] =
BEGIN
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[']]};
END;
[] ← PrintType[st, stb, rangeType, doit, defaultPublic];
vf.bias ← org;
END;
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 =>
BEGIN
IF NOT IsVarOrRef [rangeType, stb] THEN PutRope["LONG "];
[] ← PrintType[st, stb, rangeType, NoSub, defaultPublic];
END;
real => PutRope["REAL"];
ENDCASE => PutRope["xxxx"];
ENDCASE;
END;
IsVarOrRef:
PROC [tsei: Symbols.SEIndex, stb: SymbolTableBase]
RETURNS [
BOOL] =
BEGIN
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];
END;
RefIndex: TYPE = Symbols.Base RELATIVE POINTER [0..Limit) TO ref cons SERecord;
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] =
BEGIN
ModePrintName:
ARRAY TransferMode
OF
ROPE =
["PROC", "PORT", "SIGNAL", "ERROR", "PROCESS", "PROGRAM",
"NONE"];
IO.PutRope[st, ModePrintName[n]]
END;
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] =
BEGIN
extType: ExtensionType;
tree: Tree.Link;
[extType, tree] ← stb.FindExtension[sei];
IF extType # default THEN RETURN;
IO.PutRope[st, " ← "];
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];
IO.PutChar[st, '|];
PrintTreeLink[st, stb, stb.tb[index].son[2], vf];
RETURN};
ENDCASE ;
PrintTreeLink [st, stb, tree, vf];
END;
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] =
BEGIN
PutChar:
PROC [val:
CHAR] = {
IO.PutChar[st, val]};
PutRope:
PROC[val:
ROPE] = {
IO.PutRope[st, 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 =>
BEGIN
node: NodePointer = @stb.tb[t.index];
SELECT node.name
FROM
all =>
BEGIN
PutRope["ALL["];
WITH v: vf
SELECT
FROM
array => PrintTreeLink[st, stb, node.son [1], GetValFormat[stb, v.componentType]];
ENDCASE;
PutChar[']];
END;
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 =>
BEGIN
PrintTreeLink[st, stb, node.son[1], [,other[]]];
PutChar ['.]; --dot
PrintTreeLink[st, stb, node.son[2], [,other[]]];
END;
first, last, size =>
BEGIN
PutRope[
SELECT node.name
FROM
first => "FIRST[",
last => "LAST[",
ENDCASE => "SIZE["];
PrintTreeLink[st, stb, node.son[1], vf];
PutChar [']];
END;
lengthen =>
BEGIN
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 [']]};
END;
construct =>
BEGIN
s1: Tree.Link = node.son[1];
PutChar['[];
IF node.nSons = 2 THEN PrintTreeLink [st, stb, node.son[2], vf];
PutChar[']];
END;
union =>
BEGIN
PrintTreeLink [st, stb, node.son[1], vf];
PutChar ['[];
PrintTreeLink [st, stb, node.son[2], vf];
PutChar [']];
END;
list =>
BEGIN
first: BOOL ← TRUE;
PrintOne: Tree.Scan = {
IF first THEN first ← FALSE ELSE PutRope[", "];
PrintTreeLink [st, stb, t, [,other[]]]};
ScanList[stb.tb, tree, PrintOne];
END;
longTC =>
BEGIN
PutRope["LONG "];
PrintTreeLink [st, stb, node.son[1], vf];
END;
callx => {
PrintTreeLink [st, stb, node.son[1], vf];
PutChar ['[];
PrintTreeLink [st, stb, node.son[2], vf];
PutChar [']];
};
uparrow =>
BEGIN
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['^];
END;
ENDCASE => PutRope["xxxx"];
END;
hash => PrintHti [t.index];
symbol => PrintSei [t.index];
literal =>
BEGIN
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 =>
BEGIN
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 => IO.Put[st, [real[LOOPHOLE [@value, LUP]^]]];
transfer, ref =>
IF
LOOPHOLE[@value,
LUP]^ = 0
THEN PutRope["NIL"]
ELSE loophole ← TRUE;
ENDCASE => loophole ← TRUE;
IF loophole
THEN
BEGIN
PutRope["LOOPHOLE ["];
PutUnsigned [st, LOOPHOLE [@value, LUP]^];
PutChar [']];
END;
END;
ENDCASE => PutRope["--constant--"];
ENDCASE; --shouldn't happen!
ENDCASE --string-- => PutRope["(STRING)"];
END;
ENDCASE; --shouldn't happen!
END;