DIRECTORY
ConvertUnsafe USING [SubString],
IO,
MobListerUtils USING [PrintName, PrintSei],
OSMiscOps USING [bytesPerUnit],
Rope USING [ROPE],
SortedSymbolLister USING [],
StructuredStreams USING [Begin, Bp, Create, End],
SymbolOps USING [DecodeCard, DecodeType, FindExtension, FirstCtxSe, LinkMode, NextSe, NormalType, RecField, SubStringForName, ToType, TypeLink, UnderType, XferMode],
Symbols USING [Base, BitAddress, BodyRecord, BTIndex, codeANY, codeCHAR, CSEIndex, CSENull, CTXIndex, CTXNull, ExtensionType, FirstStandardCtx, HTIndex, HTNull, ISEIndex, ISENull, LastStandardCtx, lZ, RecordSEIndex, SEIndex, SENull, SERecord, TransferMode, typeANY, typeTYPE],
SymbolSegment USING [Base, STHeader],
SymbolTable USING [SymbolTableBaseRep],
SymbolTablePrivate USING [SymbolTableBase, SymbolTableBaseRep],
Tree USING [Base, Index, Link, Node, Null, Scan],
TreeOps USING [GetTag],
UnparserBuffer USING [Handle, Init, NewInittedHandle];
SortedSymbolListerImpl:
PROGRAM
IMPORTS IO, MobListerUtils, StructuredStreams, UnparserBuffer, SymbolOps, TreeOps
EXPORTS SortedSymbolLister, SymbolTable =
BEGIN OPEN Symbols;
bitsPerByte: CARD = 8;
bitsPerUnit: CARD = OSMiscOps.bytesPerUnit*bitsPerByte;
STREAM: TYPE = IO.STREAM;
SymbolTableBase: TYPE = REF SymbolTableBaseRep;
SymbolTableBaseRep: PUBLIC TYPE = SymbolTablePrivate.SymbolTableBaseRep;
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¬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
];
PrintInterface:
PUBLIC PROC[st:
STREAM, stb: SymbolTableBase] = {
sei: ISEIndex;
stHandle: LONG POINTER TO SymbolSegment.STHeader = stb.stHandle;
st.PutRope[" -- Item # -- Item Name\n"];
FOR sei ¬ SymbolOps.FirstCtxSe[stb, stHandle.outerCtx], SymbolOps.NextSe[stb, sei]
UNTIL sei = ISENull
DO
SELECT SymbolOps.LinkMode[stb, sei]
FROM
val => {
PutValue[st, stb, sei];
st.PutRope[ModePrintName[SymbolOps.XferMode[stb, stb.seb[sei].idType]]];
st.PutRope["\n"];
};
ref => {
PutValue[st, stb, sei];
st.PutRope["EXPORTED Variable"];
st.PutRope["\n"];
};
manifest => NULL; -- constant
ENDCASE;
ENDLOOP;
};
PutValue:
PROCEDURE [st:
STREAM, stb: SymbolTableBase, sei: Symbols.ISEIndex] = {
idValue: CARD ¬ SymbolOps.DecodeCard[stb.seb[sei].idValue];
st.PutRope[" -- "];
IF stb.seb[sei].extended THEN st.PutRope["(INLINE?) "];
PutUnsigned[st, idValue];
st.PutRope[" -- "];
MobListerUtils.PrintSei[sei: sei, stream: st, stb: stb];
st.PutRope[": "];
};
ModePrintName:
ARRAY Symbols.TransferMode
OF Rope.
ROPE =
["PROCEDURE", "PORT", "SIGNAL", "ERROR", "PROCESS", "PROGRAM", "OTHER", "NONE"];
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 ¬ SymbolOps.FirstCtxSe[stb, stHandle.directoryCtx], SymbolOps.NextSe[stb, sei]
UNTIL sei = ISENull
DO
mySei ¬ sei;
ENDLOOP;
MobListerUtils.PrintSei[mySei, ros, stb];
ros.PutRope["--"];
modname ¬ ros.RopeFromROS[FALSE];
upb ¬ UnparserBuffer.NewInittedHandle[[output: [stream[ros]]]];
strc ¬ StructuredStreams.Create[upb];
FOR sei ¬ SymbolOps.FirstCtxSe[stb, stHandle.outerCtx], SymbolOps.NextSe[stb, sei]
UNTIL sei = ISENull
DO
ros.Reset[];
upb.Init[];
DoControl[strc, $begin];
PrintSym[strc, stb, sei, modname, TRUE]; strc.PutChar[';];
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 ¬ SymbolOps.SubStringForName[stb, 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] = {
MobListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
typeSei: SEIndex;
vf: ValFormat;
hti: HTIndex;
check for weird 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 ¬ SymbolOps.DecodeType[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 SymbolOps.XferMode[stb, 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, SymbolOps.FindExtension[stb, sei].tree, vf]
ELSE PrintTypedVal[st, stb, SymbolOps.DecodeCard[stb.seb[sei].idValue], vf]}
};
DoControl[st, $end]};
PrintTypedVal:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, val:
LONG
UNSPECIFIED, vf: ValFormat] =
{
PutCharConst: PROC[val: CARDINAL] = {st.PutF1["%bC", [cardinal[val]]]};
loophole: BOOL ¬ FALSE;
val ¬ val + vf.bias;
WITH vf
SELECT
FROM
signed => PutSigned[st, LOOPHOLE[val, INT]];
unsigned => PutUnsigned[st, LOOPHOLE[val, CARD]];
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, LOOPHOLE[val, CARD]];
st.Put1[[character[']]]]};
};
GetBitSpec:
PROC[stb: SymbolTableBase, isei: ISEIndex]
RETURNS[
ROPE] = {
a: Symbols.BitAddress;
s: CARDINAL;
ros: IO.STREAM ¬ IO.ROS[];
[offset: a, size: s] ¬ SymbolOps.RecField[stb, isei];
ros.PutF1[" (%d", [cardinal[a.bd/bitsPerUnit]]];
IF s # 0 THEN ros.PutF[":%d..%d",
[cardinal[a.bd MOD bitsPerUnit]],
[cardinal[(a.bd+s-1) MOD bitsPerUnit]]];
ros.PutRope["): "];
RETURN[ros.RopeFromROS[]]};
PrintFieldCtx:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, ctx: CTXIndex, md:
BOOL, defaultPublic:
BOOL] = {
PutChar:
PROC[val:
CHAR] = {
st.Put1[[character[val]]]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
isei: ISEIndex ¬ SymbolOps.FirstCtxSe[stb, ctx];
bitspec: ROPE ¬ ": ";
first: BOOL ¬ TRUE;
IF isei # ISENull AND stb.seb[isei].idCtx # ctx THEN isei ¬ SymbolOps.NextSe[stb, isei];
IF isei = ISENull THEN { PutRope["NULL"]; RETURN };
PutChar['[];
FOR isei ¬ isei, SymbolOps.NextSe[stb, 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:
LONG
UNSPECIFIED] = {
lc: LONG CARDINAL ¬ LOOPHOLE[value];
PutUnsigned[st, lc]};
NoSub:
PROC[ptr:
BOOL] = { };
EnumeratedSEIndex:
TYPE =
Symbols.Base RELATIVE LONG POINTER TO SERecord.cons.enumerated;
PutEnum:
PROC[st:
IO.
STREAM, stb: SymbolTableBase, val:
LONG
UNSPECIFIED, esei: EnumeratedSEIndex] = {
sei: ISEIndex;
FOR sei ¬ SymbolOps.FirstCtxSe[stb, stb.seb[esei].valueCtx], SymbolOps.NextSe[stb, sei]
WHILE sei # ISENull DO
IF SymbolOps.DecodeCard[stb.seb[sei].idValue] = val
THEN {MobListerUtils.PrintSei[sei, st, stb]; RETURN};
ENDLOOP;
st.PutRope["LOOPHOLE ["];
PrintValue[st, val];
st.Put1[[character[']]]]};
GetValFormat:
PROC[stb: SymbolTableBase, tsei: SEIndex]
RETURNS[vf: ValFormat] = {
WITH t~~stb.seb[tsei]
SELECT
FROM
id => RETURN[GetValFormat[stb, SymbolOps.UnderType[stb, tsei]]];
cons =>
WITH t
SELECT
FROM
basic =>
SELECT code
FROM
codeANY => vf ¬ [,unsigned[]];
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};
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.PutF1["%bB", [integer[val]]]
ELSE st.PutF1["%d", [integer[val]]]};
PutUnsigned:
PROC[st:
IO.
STREAM, val:
LONG
CARDINAL] = {
IF val > octalThreshold THEN st.PutF1["%bB", [cardinal[val]]]
ELSE st.PutF1["%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.Put1[[character[val]]]};
PutRope:
PROC[val:
ROPE] = {
st.PutRope[val]};
PrintSei:
PROC[val: ISEIndex] = {
MobListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PrintHti:
PROC[val: HTIndex] = {
MobListerUtils.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 = SymbolOps.DecodeType[t.idInfo];
IF stb.seb[l1].seTag = id THEN GO TO noAdj;
UNTIL (tseiNext ¬ SymbolOps.TypeLink[stb, 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.FirstStandardCtx..Symbols.LastStandardCtx]
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 ¬ SymbolOps.UnderType[stb, 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 ¬ SymbolOps.FirstCtxSe[stb, valueCtx], SymbolOps.NextSe[stb, 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 ¬ SymbolOps.DecodeCard[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 + BodyRecord.Callable.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 ¬ SymbolOps.FirstCtxSe[stb, caseCtx], SymbolOps.NextSe[stb, isei]
UNTIL isei = ISENull
DO
DoControl[st, $tbrk];
DoControl[st, $begin];
PrintSei[isei];
PutRope[" => "];
varRec ¬ LOOPHOLE[SymbolOps.UnderType[stb, SymbolOps.DecodeType[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/bitsPerUnit];
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 LONG POINTER 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 ¬ SymbolOps.FirstCtxSe[stb, ctx];
IF first = ISENull THEN RETURN[FALSE, SENull];
element ¬ seb[first].idType;
rest ¬ SymbolOps.NextSe[stb, first];
IF rest = ISENull THEN RETURN[FALSE, SENull];
restp ¬ SymbolOps.UnderType[stb, seb[rest].idType];
WITH seb[restp]
SELECT
FROM
ref => RETURN[refType = rft, element];
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",
"OTHER", "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] ¬ SymbolOps.FindExtension[stb, sei];
IF extType # default THEN RETURN;
st.PutRope[" ← "];
WITH tree
SELECT TreeOps.GetTag[tree]
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 TreeOps.GetTag[root]
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[
CARD] = {
WITH t~~tree
SELECT TreeOps.GetTag[tree]
FROM
literal =>
WITH lr~~stb.ltb[t.index]
SELECT
FROM
short => RETURN[SymbolOps.DecodeCard[lr.value]];
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] = {
MobListerUtils.PrintSei[sei: val, stream: st, stb: stb]};
PrintHti:
PROC[val: HTIndex] = {
MobListerUtils.PrintName[name: val, stream: st, stb: stb]};
IF tree = Tree.Null THEN RETURN;
WITH t~~tree
SELECT TreeOps.GetTag[tree]
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[CARDINAL[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 TreeOps.GetTag[s1] = 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 TreeOps.GetTag[ptr]
FROM
symbol =>
type ¬ SymbolOps.NormalType[stb, SymbolOps.UnderType[stb,
stb.seb[p.index].idType]];
subtree => type ¬ LOOPHOLE[SymbolOps.ToType[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];
string => PutRope["(STRING)"];
literal => {
WITH stb.ltb[t.index]
SELECT
FROM
short => PrintTypedVal [st, stb, SymbolOps.DecodeCard[value], vf];
long =>
SELECT bits
FROM
2*bitsPerUnit => {
loophole: BOOL ¬ FALSE;
SELECT vf.tag
FROM
signed => {
li: INT = LOOPHOLE [@value, LUP]^;
li: INT = LOOPHOLE[value[0]];
SELECT li
FROM
INT.FIRST => PutRope["FIRST[INT]"];
INT.LAST => PutRope["LAST[INT]"];
ENDCASE => PutSigned[st, li];
};
unsigned => {
lu: LONG CARDINAL = LOOPHOLE [@value, LUP]^;
lu: LONG CARDINAL = LOOPHOLE [value[0]];
SELECT lu
FROM
LAST[LONG CARDINAL] => PutRope["LAST[LONG CARDINAL]"];
ENDCASE => PutUnsigned[st, lu];
};
real => st.Put1[[real[LOOPHOLE [value[0]]]]];
transfer, ref =>
IF
LOOPHOLE[value[0],
LONG
UNSPECIFIED] = 0
THEN PutRope["NIL"]
ELSE loophole ¬ TRUE;
ENDCASE => loophole ¬ TRUE;
IF loophole
THEN {
PutRope["LOOPHOLE ["];
PutUnsigned [st, LOOPHOLE [value[0]]];
PutChar [']]};
};
ENDCASE => PutRope["--constant--"];
ENDCASE; --shouldn't happen!
};
ENDCASE; --shouldn't happen!
};