putList:
PROC [node:
TV] =
CHECKED {
separate procedure because can be called from both ref, list, and structure case case. start with node, rather than element, because in case of structure, already at the node.
sep: ROPE ← NIL;
count: INT ← 0;
PutRope["("]; -- used to be LIST[
WHILE node #
NIL DO
elem: TV ← IndexToTV[node, 2];
IF node = NIL THEN EXIT;
PutRope[sep];
sep ← ", ";
IF (count ← count + 1) > width
THEN
{PutRope["..."]; EXIT};
PutTV[IndexToTV[node, 1], depth];
node ← Referent[IndexToTV[node, 2]];
ENDLOOP;
PutChar[')];
};
-- used to be ] when ( was LIST
SELECT class
FROM
definition => ERROR;
record => PutRecord[tv, 1, depth];
structure =>
{
IF isAList[under]
THEN
{putList[tv];
RETURN};
PutRecord[tv, 1, depth]};
union =>
PutWords[tv, "UNION#"]; -- shouldn't really happen
array, sequence => {
indexType: Type ← AMTypes.Domain[type];
index: TV ← AMTypes.First[indexType];
sep: ROPE ← NIL;
max: INT ← LAST[INT];
IF AMTypes.UnderClass[indexType] = integer
THEN {
Absolutely miserable kludge to get around indexing by INTEGER
index ← AMTypes.Copy[index];
AMBridge.SetTVFromLI[index, 0];
};
IF class = sequence
THEN
For sequences, the length is easy to find
max ← AMTypes.Length[tv]
ELSE {
For arrays, we have to do this the hard way (sigh)
low: INT ← AMBridge.TVToLI[index];
high: INT ← AMBridge.TVToLI[AMTypes.Last[indexType]];
max ← high-low+1;
};
First show the number of elements
PutRope["("];
PutInt[max];
PutRope[")["];
Next test to see if we have anything to print
IF depth <= 1 THEN {PutRope["...]"]; RETURN};
Now try to output the remainder of the elements
FOR i:
INT IN [0..width]
WHILE index #
NIL AND i < max
DO
ENABLE {AMTypes.Error => GO TO urp};
elem: TV ← NIL;
msg: ROPE ← NIL;
IF i = width THEN {PutRope[", ..."]; EXIT};
PutRope[sep];
sep ← ", ";
elem ← AMTypes.Apply[tv, index];
PutTV[elem, depth - 1];
index ← AMTypes.Next[index];
ENDLOOP;
PutChar[']];
EXITS
urp => {PutErr["Can't fetch element"]; PutChar[']]}};
enumerated => {
name: ROPE ← NIL;
wrap: BOOL ← verbose AND under # UnderBoolean AND under # type;
IF wrap
THEN {
PutTypeOfTV[tv, class];
PutChar['[]};
name ← TVToName[tv ! AMTypes.Error => CONTINUE];
IF name =
NIL
THEN PutWords[tv, NIL, "?"]
ELSE QPutName[name];
IF wrap THEN PutChar[']];
};
subrange => {
ground: Type = GroundStar[under];
wide: TV ← NIL;
wide ← Coerce[tv, ground ! AMTypes.Error => CONTINUE];
IF wide =
NIL
THEN PutWords[tv, "??"]
ELSE PutTV[wide, depth];
opaque =>
PutWords[tv, "OPAQUE#"];
countedZone =>
PutWords[tv, "ZONE#"];
uncountedZone =>
PutWords[tv, "UZONE#"];
list => {
count: INT ← 0;
valid: BOOL ← FALSE;
IF IsNil[tv]
THEN {
PutRope["NIL"]; RETURN};
valid ← LocalValidate[tv, class];
IF depth <= 2
OR NOT valid
THEN {
PutCardRope[TVToLC[tv], IF valid THEN "^" ELSE "^??"];
RETURN};
putList[Referent[tv]];
atom => {
IF IsNil[tv] THEN PutRope["NIL"]
ELSE {PutChar['$]; PutRope[TVToName[tv]]};
};
rope => {
IF IsNil[tv] THEN PutRope["NIL"]
ELSE PutRopeConst[TVToName[tv], width * depth];
};
ref => {
referentTV: TV ← NIL;
referentType: Type;
bits: LONG CARDINAL = TVToLC[tv];
rangeClass: Class;
msg: ROPE ← NIL;
useReferent: BOOL ← depth > 2;
inner:
PROC =
TRUSTED {
try to get the referent
[, rangeClass] ← UnderTypeAndClass[Range[under]];
IF useReferent THEN referentTV ← Referent[tv];
};
IF IsNil[tv] THEN {PutRope["NIL"]; RETURN};
IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "^??"]; RETURN};
IF AMTypes.IsRefAny[type]
THEN {
IF AMTypes.IsAtom[tv]
THEN {
PutChar['$];
PutRope[TVToName[tv]];
RETURN};
IF AMTypes.IsRope[tv]
THEN {
PutRopeConst[TVToName[tv], width * depth];
RETURN};
};
IF useReferent THEN msg ← Mother[inner];
IF msg #
NIL OR NOT useReferent
THEN {
use the octal
PutCardRope[bits, "^"];
IF msg # NIL THEN PutErr[msg];
RETURN};
try to get user print proc
referentType ← TVType[referentTV];
IF HandledByPrintProc[tv: referentTV, type: referentType, refTV: tv]
THEN RETURN; -- Note that in this case, if the print proc causes an error (has a bug in it), you won't get a chance to debug the printproc because Mother is above you on the stack.
IF isAList[underType: referentType]
THEN {
putList[referentTV];
RETURN};
PutChar['^]; -- used to be @
PutTV[referentTV, depth - 1];
pointer => {
bits: CARDINAL ← TVToCardinal[tv];
short: POINTER ← LOOPHOLE[bits];
lp: LONG POINTER ← short;
IF bits = 0 THEN {PutRope["NIL"]; RETURN};
IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "@??"]; RETURN};
IF under = UnderString
THEN {
PutStringConst[LOOPHOLE[short, STRING]];
RETURN};
PutCardRope[bits, "@"];
};
longPointer, basePointer => {
bits: LONG CARDINAL ← TVToLC[tv];
IF IsNil[tv] THEN {PutRope["NIL"]; RETURN};
IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "@??"]; RETURN};
IF under = UnderLongString
OR under = UnderPtrText
THEN
IF NOT isRemote
THEN {
PutStringConst[LOOPHOLE[bits, LONG STRING]];
RETURN};
PutCardRope[bits, "@"];
};
relativePointer => {
IF IsNil[tv] THEN {PutRope["NIL"]; RETURN};
PutInt[TVToLC[tv]];
PutRope["^R"];
};
descriptor, longDescriptor => {
ws: AMBridge.WordSequence = AMBridge.TVToWordSequence[tv];
base: LONG CARDINAL ← 0;
len: CARDINAL ← 0;
PutRope["DESCRIPTOR["];
SELECT class
FROM
descriptor => {
shortDesc:
LONG POINTER TO DESCRIPTOR FOR ARRAY OF WORD =
LOOPHOLE[@ws[0]];
base ← LOOPHOLE[BASE[shortDesc^], CARDINAL];
len ← LENGTH[shortDesc^];
};
longDescriptor => {
longDesc:
LONG POINTER TO LONG DESCRIPTOR FOR ARRAY OF WORD =
LOOPHOLE[@ws[0]];
base ← LOOPHOLE[BASE[longDesc^]];
len ← LENGTH[longDesc^];
};
ENDCASE => ERROR;
IF base = 0 THEN PutRope["NIL, "] ELSE PutCardRope[base, "@, "];
PutInt[len];
PutRope["]"];
};
port =>
PutWords[tv, "PORT#"];
process =>
PutWords[tv, "PROCESS#"];
type =>
this handles object of type TYPE.
Objects of type RTBasic.Type are also printed this way via a printproc.
PutTVAsType[tv];
any =>
PutWords[tv, "ANY??"];
globalFrame => {
name: ROPE ← TVToName[tv];
PutRope["{globalFrame: "];
QPutName[name];
IF verbose
THEN {
gf: CARDINAL ←
IF isRemote
THEN AMBridge.RemoteGFHFromTV[tv].gfh
ELSE LOOPHOLE[GFHFromTV[tv], CARDINAL];
PutRope[" (GF#"];
PutCardRope[gf, ")\n"];
PrintVariables[tv, put];
};
PutChar['}];
localFrame => {
proc: TV ← NIL;
pc: CARDINAL = AMBridge.ContextPC[tv];
lf:
CARDINAL =
IF isRemote
THEN AMBridge.RemoteFHFromTV[tv].fh
ELSE LOOPHOLE[FHFromTV[tv], CARDINAL];
temp: TV ← tv;
WHILE temp #
NIL DO
ENABLE AMTypes.Error => EXIT;
proc ← Procedure[temp ! AMTypes.Error => CONTINUE];
IF proc # NIL THEN EXIT;
temp ← EnclosingBody[temp];
ENDLOOP;
IF proc #
NIL THEN {
ENABLE AMTypes.Error => GO TO oops;
IF UnderTypeAndClass[TVType[proc]].class = nil THEN proc ← NIL;
EXITS oops => proc ← NIL;
};
IF proc =
NIL THEN {
ENABLE AMTypes.Error => GO TO oops;
gf: TV ← GlobalParent[tv];
IF gf = NIL THEN GO TO oops;
PutRope[TVToName[gf]];
PutRope[".??"];
EXITS oops => {PutRope["??"]; RETURN}}
ELSE PutTV[proc, depth];
IF verbose
THEN {
PutRope["(lf: "];
PutCardRope[lf, ", pc: "];
PutCardRope[pc, ")"];
IF depth > 1
THEN {
PutRope["\nArguments:\n"];
PrintArguments[tv: tv, put: put, breakBetweenItems: TRUE];
PutRope["\nVariables:\n"];
PrintVariables[tv: tv, put: put, breakBetweenItems: TRUE];
};
PutRope["\n"];
};
};
program, procedure, signal, error => {
kind: ROPE ← NIL;
name: ROPE ← NIL;
useGlobalName: BOOL ← TRUE;
IF IsNil[tv] THEN {PutRope["NIL"]; RETURN};
name ← TVToName[tv ! AMTypes.Error => CONTINUE];
SELECT class
FROM
program => {kind ← "PROGRAM#"; useGlobalName ← FALSE};
procedure => kind ← NIL;
signal, error => {
kind ← IF class = signal THEN "SIGNAL " ELSE "ERROR ";
IF AllCaps[name] THEN useGlobalName ← FALSE;
}
ENDCASE => ERROR;
PutRope[kind];
IF useGlobalName
THEN {
ENABLE AMTypes.Error => GO TO oops;
gn: ROPE ← NIL;
gp: TV ← GlobalParent[tv];
IF gp # NIL THEN gn ← TVToName[gp];
QPutName[gn];
PutChar['.];
EXITS oops => PutRope["??."];
};
QPutName[name];
};
unspecified, cardinal =>
PutCardInt[TVToCardinal[tv]];
integer =>
PutInt[TVToInteger[tv]];
character =>
PutCharLit[TVToCardinal[tv]];
longInteger =>
PutInt[TVToLI[tv]];
longCardinal =>
PutCardInt[TVToLC[tv]];
real => {
periodSeen: BOOL ← FALSE;
putChar1:
PROC[char:
CHAR] =
CHECKED {
IF char = '. THEN periodSeen ← TRUE;
PutChar[char]};
Convert.MapValue[put: putChar1, value: [real[TVToReal[tv]]]];
IF NOT periodSeen THEN PutRope[".0"]};
ENDCASE => ERROR
}