PrintTVImpl.mesa
Russ Atkinson, June 22, 1983 6:53 pm
Warren Teitelman, February 5, 1983 3:50 pm
Paul Rovner, November 17, 1983 3:57 pm
DIRECTORY
AMBridge USING
[ContextPC, FHFromTV, GetWorld, GFHFromTV, IsRemote, OctalRead, RemoteFHFromTV, RemoteGFHFromTV, SetTVFromLI, TVToCardinal, TVToCharacter, TVToInteger, TVToLC, TVToLI, TVToReal, TVToWordSequence, WordSequence, TVForSignal, TVForPointerReferent],
AMTypes USING
[Apply, Argument, Class, Coerce, Copy, Domain, EnclosingBody, Error, First, GlobalParent, Globals, GroundStar, Index, IndexToName, IndexToTV, IndexToType, IsAtom, IsComputed, IsNil, IsOverlaid, IsRefAny, IsRope, Last, Length, Locals, NComponents, Next, Procedure,Range, Referent, Result, Signal, Tag, TVSize, TVToName, TVToType, TVType, TypeClass, UnderClass, UnderType, Variant, TV, Size],
BackStop USING [Call],
Convert USING [RopeFromChar],
IO USING [STREAM, Put, PutF, PutRope, card, real, PutChar, int, PutR],
PrintTV USING [TVPrintProc, PrintType, GetTVPrintProc, GetClassPrintProc],
Rope USING [Concat, Fetch, Map, ROPE, Size, Cat, IsEmpty],
RuntimeError USING [UNCAUGHT, SendMsgSignal],
SafeStorage USING [nullType, Type, EquivalentTypes],
StructuredStreams USING [Begin, End, Bp],
WorldVM USING
[Address, AddressFault, LocalWorld, Long, Read, World]
;
PrintTVImpl: CEDAR MONITOR
IMPORTS
AMBridge, AMTypes, BackStop, Convert, IO, PrintTV, Rope, RuntimeError, SafeStorage, WorldVM
EXPORTS PrintTV
= BEGIN OPEN PrintTV, Rope, AMBridge, AMTypes, SafeStorage, WorldVM;
miscellaneous types and constants
CR: CHAR = '\n;
STREAM: TYPE = IO.STREAM;
needInit: BOOLTRUE;
UnderBoolean: Type ← CODE[BOOL];
UnderString: Type ← CODE[STRING];
UnderLongString: Type ← CODE[LONG STRING];
UnderRefText: Type ← CODE[REF TEXT];
UnderPtrText: Type ← CODE[LONG POINTER TO TEXT];
Pair: TYPE = MACHINE DEPENDENT RECORD [lo, hi: CARDINAL];
procedures
EnsureInit: ENTRY PROC = {
ENABLE UNWIND => NULL;
IF needInit THEN {
UnderBoolean ← UnderType[UnderBoolean];
UnderString ← UnderType[UnderString];
UnderLongString ← UnderType[UnderLongString];
UnderRefText ← UnderType[UnderRefText];
UnderPtrText ← UnderType[UnderPtrText];
needInit ← FALSE;
};
};
Print: PUBLIC PROC
[tv: TV, put: STREAM, depth: INT ← 4, width: INT ← 32, verbose: BOOLFALSE] = {
PutCardRope: PROC [oct: LONG CARDINAL, tail: ROPE] = {
PrintOctal[put, oct];
put.PutRope[tail];
};
PutCharLit: PROC [c: CHAR] = {put.PutRope[Convert.RopeFromChar[c]]};
IF c IN [40B..176B] THEN {
ch: CHARLOOPHOLE[c];
put.PutChar[''];
IF ch = '\\ THEN put.PutChar[ch];
put.PutChar[ch];
RETURN};
put.PutF["%b", IO.card[LOOPHOLE[c, CARDINAL]]];
put.PutChar['C];
IF c > 377B THEN put.PutChar['!]
};
PutWords: PROC [tv: TV, prefix: ROPENIL, postfix: ROPENIL] = TRUSTED {
this routine must be relatively indestructible!!!
ENABLE {RuntimeError.UNCAUGHT => GOTO err};
size: INT ← 0;
IF prefix # NIL AND prefix.Size[] > 0 THEN put.PutRope[prefix];
size ← TVSize[tv];
SELECT size FROM
0 => put.PutRope["[]"];
1 => PrintOctal[put, TVToCardinal[tv]];
2 => PrintOctal[put, TVToLC[tv]];
ENDCASE => {
sep: ROPENIL;
put.PutChar['[];
FOR i: INT IN [0..size) DO
IF i > width THEN {put.PutRope[", ..."]; EXIT};
put.PutRope[sep];
sep ← ", ";
PrintOctal[put, LOOPHOLE[AMBridge.OctalRead[tv, i], CARDINAL]]
ENDLOOP;
put.PutChar[']];
};
IF postfix # NIL AND postfix.Size[] > 0 THEN put.PutRope[postfix]
EXITS
err => PutErr["??"]
};
PutEscape: PROC [c: CHAR] RETURNS [quit: BOOLFALSE] =
{put.PutRope[Convert.RopeFromChar[c, FALSE]]};
IF c = '\\ OR c = '" THEN put.PutChar['\\];
IF c < 40C OR c >= 177C THEN {
put.PutChar['\\];
SELECT c FROM
'\n => put.PutChar['n];
'\t => put.PutChar['t];
ENDCASE => {
put.PutChar['0 + (c - 0C) / 64];
put.PutChar['0 + (c - 0C) MOD 64 / 8];
put.PutChar['0 + (c - 0C) MOD 8]}
}
ELSE put.PutChar[c];
RETURN [FALSE]
};
PutRopeConst: PROC [r: ROPE, max: INT] = {
size: INT ← r.Size[];
max ← max + 16; -- allow for a reasonable minimum length
put.PutChar['\"];
[] ← Rope.Map[base: r, start: 0, len: max, action: PutEscape];
IF size > max THEN put.PutRope["..."];
put.PutChar['"]
};
QPutName: PROC [name: ROPE] = {
IF name.Size[] = 0 THEN put.PutRope["??"] ELSE put.PutRope[name]
};
PutStringConst: PROC [s: LONG STRING] = TRUSTED {
len: CARDINAL ← s.length;
charsToPrint: CARDINAL ← len;
max: CARDINAL ← width * depth;
IF max < charsToPrint THEN charsToPrint ← max;
IF max < 8 THEN max ← max + 16;
put.PutChar['"];
FOR i: CARDINAL IN [0..charsToPrint) DO
[] ← PutEscape[s[i]];
ENDLOOP;
IF len > charsToPrint THEN put.PutRope["..."];
put.PutChar['"];
};
PutErr: PROC [r1,r2: ROPENIL] = {put.PutRope[Rope.Cat["--{", r1, r2, "}--"]]};
PutRecord: PROC [tv: TV, start: NAT ← 0, depth: INT ← 0] = {
size: Index;
sep: ROPENIL;
type: Type;
innerSize: PROC = {type ← TVType[tv]; size ← NComponents[type]};
IF depth <= 1 THEN {put.PutRope["[...]"]; RETURN};
sep ← BackStop.Call[innerSize];
IF sep # NIL THEN {PutErr["can't examine, ", sep]; RETURN};
put.PutChar['[];
StructuredStreams.Begin[put];
{ ENABLE UNWIND => StructuredStreams.End[put];
FOR i: Index IN [start..size] DO
name: ROPE;
inner: TVNIL;
quitFlag: BOOLFALSE;
innerIndexToTV: PROC = {inner ← IndexToTV[tv, i]};
innerPut: PROC = {
itype: Type ← TVType[inner];
iunder: Type;
iclass: Class;
[iunder, iclass] ← UnderTypeAndClass[itype];
IF i = size AND iclass = union THEN {
variantTV: TV;
IF IsOverlaid[iunder] THEN {put.PutRope["--Overlaid--"]; RETURN};
IF IsComputed[iunder] THEN {put.PutRope["--Computed--"]; RETURN};
variantTV ← Variant[inner];
QPutName[TVToName[Tag[inner]]];
PutRecord[variantTV, i, depth - 1];
RETURN};
PutTV[inner, depth - 1];
};
msg: ROPENIL;
IF i > start THEN {
put.PutRope[", "];
StructuredStreams.Bp[put, FALSE, 0];
};
IF i > width THEN {put.PutRope["..."]; EXIT};
name ← IndexToName[type, i];
IF name.Size[] > 0 THEN put.PutRope[Rope.Cat[name, ": "]];
msg ← BackStop.Call[innerIndexToTV];
IF msg # NIL THEN {PutErr["Can't get element: ", msg]; LOOP};
msg ← BackStop.Call[innerPut];
IF msg # NIL THEN {PutErr["Can't print element: ", msg]; LOOP};
ENDLOOP;
}; -- end ENABLE UNWIND => StructuredStreams.End[put];
StructuredStreams.End[put];
put.PutChar[']]
};
PutTVAsType: PROC [tv: TV] = TRUSTED {
type: Type ← TVToType[tv];
PrintTV.PrintType[type, put];
};
PutTypeOfTV: PROC [tv: TV, class: Class] = {
inner: PROC = {
SELECT class FROM
globalFrame => put.PutRope["--GlobalFrame--"];
localFrame => put.PutRope["--LocalFrame--"]
ENDCASE => {
type: Type ← TVType[tv];
PrintTV.PrintType[type, put];
};
};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL THEN PutErr[msg];
};
PutTV: PROC [tv: TV, depth: INT, verbose: BOOLFALSE] = TRUSTED {
deep: BOOLTRUE;
msg1, msg2: ROPENIL;
IF tv = NIL THEN {put.PutRope["NIL"]; RETURN};
IF depth <= 0 THEN {put.PutRope["&"]; RETURN};
try to get user print proc
IF NOT HandledByPrintProc[tv: tv, type: TVType[tv]] THEN {
inner: PROC = TRUSTED {
PutTVNoCatch[tv, depth, verbose];
};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL THEN PutErr[msg];
};
};
HandledByPrintProc:
PROC [tv: TV, type: Type] RETURNS[handled: BOOLFALSE] = TRUSTED {
proc: TVPrintProc;
data: REF;
[proc, data] ← GetTVPrintProc[type];
IF proc = NIL THEN [proc, data] ← GetClassPrintProc[UnderClass[type]];
IF proc # NIL THEN handled ← NOT proc[tv, data, put, depth, width];
};
PutTVNoCatch: PROC
[tv: TV, depth: INT, verbose: BOOLFALSE, type: Type ← nullType]
= TRUSTED {
fooey: BOOLFALSE;
under: Type;
class: Class;
isRemote: BOOL ← AMBridge.IsRemote[tv];
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: ROPENIL;
count: INT ← 0;
put.PutRope["("]; -- used to be LIST[
StructuredStreams.Begin[put];
{ ENABLE UNWIND => StructuredStreams.End[put];
WHILE node # NIL DO
elem: TV ← IndexToTV[node, 2];
IF node = NIL THEN EXIT;
put.PutRope[sep];
sep ← ", ";
StructuredStreams.Bp[put, FALSE, 0];
IF (count ← count + 1) > width THEN {put.PutRope["..."]; EXIT};
PutTV[IndexToTV[node, 1], depth];
node ← Referent[IndexToTV[node, 2]];
ENDLOOP;
}; -- end ENABLE UNWIND => StructuredStreams.End[put];
StructuredStreams.End[put];
put.PutChar[')];
}; -- used to be ] when ( was LIST
isAList: PROC [underType: Type] RETURNS [result: BOOLFALSE] = CHECKED {
copied from ListImpl (in order to avoid dependency on List so Russ can use PrintTVImpl stand alone.
IF TypeClass[underType] = structure AND NComponents[underType] = 2 THEN {
ENABLE AMTypes.Error => GO TO nope;
checks whether the rest field points to an object whose type is the same as the referrent of ref. Note that it is nnecessary to check to see whether TypeClass[IndexToType[underType, 2]] = list since this is a stronger test, i.e. that it is equivalent to the type of the first list node. The catch phrase is to handle REF ANY, for which Range causes a typefault.
IF EquivalentTypes[
Range[IndexToType[underType, 2]],
underType]
THEN RETURN [TRUE];
EXITS nope => {};
};
RETURN [FALSE];
};
IF type = nullType THEN type ← TVType[tv];
[under, class] ← UnderTypeAndClass[type];
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];
max: INTLAST[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
put.PutRope["("];
put.Put[IO.int[max]];
put.PutRope[")["];
Next test to see if we have anything to print
IF depth <= 1 THEN {put.PutRope["...]"]; RETURN};
StructuredStreams.Begin[put];
{ ENABLE UNWIND => StructuredStreams.End[put];
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 => GOTO urp;
elem: TVNIL;
msg: ROPENIL;
IF i > 0 THEN {
put.PutRope[", "];
StructuredStreams.Bp[put, FALSE, 0];
};
IF i = width THEN {put.PutRope["..."]; EXIT};
elem ← AMTypes.Apply[tv, index];
PutTV[elem, depth - 1];
index ← AMTypes.Next[index];
ENDLOOP;
put.PutChar[']];
EXITS
urp => {PutErr["Can't fetch element"]; put.PutChar[']]};
}; -- end ENABLE UNWIND => StructuredStreams.End[put];
StructuredStreams.End[put];
};
enumerated => {
name: ROPENIL;
wrap: BOOL ← verbose AND under # UnderBoolean AND under # type;
IF wrap THEN {
PutTypeOfTV[tv, class];
put.PutChar['[]};
name ← TVToName[tv ! AMTypes.Error => CONTINUE];
IF name = NIL
THEN PutWords[tv, NIL, "?"]
ELSE QPutName[name];
IF wrap THEN put.PutChar[']];
};
subrange => {
ground: Type = GroundStar[under];
wide: TVNIL;
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: BOOLFALSE;
IF IsNil[tv] THEN {
put.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 put.PutRope["NIL"]
ELSE {put.PutChar['$]; put.PutRope[TVToName[tv]]};
};
rope => {
IF IsNil[tv] THEN put.PutRope["NIL"]
ELSE PutRopeConst[TVToName[tv], width * depth];
};
ref => {
referentTV: TVNIL;
referentType: Type;
bits: LONG CARDINAL = TVToLC[tv];
msg: ROPENIL;
useReferent: BOOL ← depth > 2;
inner: PROC = TRUSTED {referentTV ← Referent[tv]};
IF IsNil[tv] THEN {put.PutRope["NIL"]; RETURN};
IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "^??"]; RETURN};
IF AMTypes.IsRefAny[type] THEN {
IF AMTypes.IsAtom[tv] THEN {
put.PutChar['$];
put.PutRope[TVToName[tv]];
RETURN};
IF AMTypes.IsRope[tv] THEN {
PutRopeConst[TVToName[tv], width * depth];
RETURN};
};
IF useReferent THEN msg ← BackStop.Call[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]
THEN RETURN;
IF isAList[underType: referentType] THEN {
putList[referentTV];
RETURN};
put.PutChar['^]; -- used to be @
PutTV[referentTV, depth - 1];
};
pointer => {
bits: CARDINAL ← TVToCardinal[tv];
short: POINTERLOOPHOLE[bits];
lp: LONG POINTER ← short;
IF bits = 0 THEN {put.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 {put.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 {put.PutRope["NIL"]; RETURN};
put.Put[IO.int[TVToLC[tv]]];
put.PutRope["^R"];
};
descriptor, longDescriptor => {
ws: AMBridge.WordSequence = AMBridge.TVToWordSequence[tv];
base: LONG CARDINAL ← 0;
len: CARDINAL ← 0;
put.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 put.PutRope["NIL, "] ELSE PutCardRope[base, "@, "];
put.Put[IO.int[len]];
put.PutRope["]"];
};
port =>
PutWords[tv, "PORT#"];
process =>
PutWords[tv, "PROCESS#"];
type =>
this handles object of type TYPE.
Objects of type Type are also printed this way via a printproc.
PutTVAsType[tv];
nil =>
put.PutRope["NIL"];
any =>
PutWords[tv, "ANY??"];
globalFrame => {
name: ROPE ← TVToName[tv];
put.PutRope["{globalFrame: "];
QPutName[name];
IF verbose THEN {
gf: CARDINAL
IF isRemote
THEN AMBridge.RemoteGFHFromTV[tv].gfh
ELSE LOOPHOLE[GFHFromTV[tv], CARDINAL];
put.PutRope[" (GF#"];
PutCardRope[gf, ")\n"];
PrintVariables[tv, put];
};
put.PutChar['}];
};
localFrame => {
proc: TVNIL;
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;
put.PutRope[TVToName[gf]];
put.PutRope[".??"];
EXITS oops => {put.PutRope["??"]; RETURN}}
ELSE PutTV[proc, depth];
IF verbose THEN {
put.PutRope["(lf: "];
PutCardRope[lf, ", pc: "];
PutCardRope[pc, ")"];
IF depth > 1 THEN {
put.PutRope["\nArguments:\n"];
PrintArguments[tv: tv, put: put, breakBetweenItems: TRUE];
put.PutRope["\nVariables:\n"];
PrintVariables[tv: tv, put: put, breakBetweenItems: TRUE];
};
put.PutRope["\n"];
};
};
program, procedure, signal, error => {
kind: ROPENIL;
name: ROPENIL;
useGlobalName: BOOLTRUE;
IF IsNil[tv] THEN {put.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;
put.PutRope[kind];
IF useGlobalName THEN {
ENABLE AMTypes.Error => GO TO oops;
gn: ROPENIL;
gp: TV ← GlobalParent[tv];
IF gp # NIL THEN gn ← TVToName[gp];
QPutName[gn];
put.PutChar['.];
EXITS oops => put.PutRope["??."];
};
QPutName[name];
};
unspecified, cardinal => {
lc: LONG CARDINAL = TVToCardinal[tv];
PrintOctal[put, lc];
put.PutRope[Rope.Cat[" (", IO.PutR[IO.card[lc]], ")"]];
};
integer =>
put.Put[IO.int[TVToInteger[tv]]];
character =>
PutCharLit[TVToCharacter[tv]];
longInteger =>
put.Put[IO.int[TVToLI[tv]]];
longCardinal => {
lc: LONG CARDINAL = TVToLC[tv];
PrintOctal[put, lc];
put.PutRope[Rope.Cat[" (", IO.PutR[IO.card[lc]], ")"]];
};
real => put.Put[IO.real[TVToReal[tv]]];
ENDCASE => ERROR
}; -- end PutTVNoCatch
START Print HERE
IF needInit THEN EnsureInit[];
PutTV[tv, depth, verbose]
}; -- end Print
AllCaps: PROC [name: ROPE] RETURNS [BOOL] = {
FOR i: INT IN [0..name.Size[]) DO
IF name.Fetch[i] IN ['a..'z] THEN RETURN [FALSE];
ENDLOOP;
RETURN [TRUE];
};
PrintArguments: PUBLIC PROC
[tv: TV, put: STREAM, depth: INT ← 4, width: INT ← 32, breakBetweenItems: BOOLFALSE] = {
print the arguments to the given local frame
the depth and width args apply to the individual printing
an error msg is printed if this is not a local frame
type: Type;
class: Class;
n: NAT ← 0;
i: NAT ← 0;
inner1: PROC = {
Print[Argument[tv, i], put, depth, width, FALSE];
};
inner: PROC = {
ptv: TVNIL;
sep: ROPEIF breakBetweenItems THEN "\n " ELSE ", ";
[type, class] ← UnderTypeAndClass[TVType[tv]];
IF class # localFrame THEN {
put.PutRope["-- not a local frame! --"];
RETURN};
ptv ← Procedure[tv ! Error => CONTINUE];
IF ptv = NIL THEN
ptv ← Signal[tv ! Error => CONTINUE];
IF ptv = NIL THEN RETURN;
[type, class] ← UnderTypeAndClass[TVType[ptv]];
IF type = nullType THEN RETURN;
[type, class] ← UnderTypeAndClass[Domain[type]];
IF type = nullType THEN RETURN;
n ← NComponents[type];
IF n = 0 THEN RETURN;
put.PutRope[" "];
FOR i IN [1..n] DO
name: ROPE ← IndexToName[type, i];
each: ROPENIL;
IF i > 1 THEN put.PutRope[sep];
IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]];
each ← BackStop.Call[inner1];
IF each # NIL THEN
put.PutRope[Rope.Cat["--{", each, "}--"]];
ENDLOOP;
};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
PrintResults: PUBLIC PROC
[tv: TV, put: STREAM, depth: INT ← 4, width: INT ← 32, breakBetweenItems: BOOLFALSE] = {
print the results for the given local frame
the depth and width args apply to the individual printing
an error msg is printed if this is not a local frame
type: Type;
class: Class;
n: NAT ← 0;
i: NAT ← 0;
inner1: PROC = {
Print[Result[tv, i], put, depth, width, FALSE];
};
inner: PROC = {
ptv: TVNIL;
sep: ROPEIF breakBetweenItems THEN "\n " ELSE ", ";
[type, class] ← UnderTypeAndClass[TVType[tv]];
IF class # localFrame THEN {
put.PutRope["-- not a local frame! --"]; RETURN};
ptv ← Procedure[tv ! AMTypes.Error => CONTINUE];
IF ptv = NIL THEN
ptv ← Signal[tv ! AMTypes.Error => CONTINUE];
IF ptv = NIL THEN RETURN;
[type, class] ← UnderTypeAndClass[TVType[ptv]];
IF type = nullType THEN RETURN;
[type, class] ← UnderTypeAndClass[Range[type]];
IF type = nullType THEN RETURN;
n ← NComponents[type];
IF n = 0 THEN RETURN;
put.PutRope[" "];
FOR i IN [1..n] DO
name: ROPE ← IndexToName[type, i];
each: ROPENIL;
IF i > 1 THEN put.PutRope[sep];
IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]];
each ← BackStop.Call[inner1];
IF each # NIL THEN put.PutRope[Rope.Cat["--{", each, "}--"]];
ENDLOOP;
};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
PrintVariables: PUBLIC PROC
[tv: TV, put: STREAM, depth: INT ← 4, width: INT ← 32, all, breakBetweenItems: BOOLTRUE] = TRUSTED {
print the results for the given local frame
the depth and width args apply to the individual printing
an error msg is printed if this is not a local frame
if all = TRUE, then all variables in the frame are printed
type: Type;
local, global: BOOLFALSE;
class: Class;
n: NAT ← 0;
i: NAT ← 0;
indent: ROPE ← " ";
sep: ROPEIF breakBetweenItems THEN "\n" ELSE ", ";
nvars: NAT ← 0;
inner1: PROC = TRUSTED {
tv1: TVIF local THEN Locals[tv] ELSE Globals[tv];
type1: Type ← TVType[tv1];
nvars ← IF tv1 = NIL THEN 0 ELSE NComponents[type1];
FOR i: INT IN [1..nvars] DO
inner2: PROC = TRUSTED {
name: ROPE ← IndexToName[type1, i];
IF breakBetweenItems THEN put.PutRope[indent];
IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]];
Print[IndexToTV[tv1, i], put, depth, width]
};
IF i > 1 THEN put.PutRope[sep];
msg ← BackStop.Call[inner2];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
ENDLOOP;
IF local
THEN tv ← EnclosingBody[tv]
ELSE tv ← NIL;
IF breakBetweenItems THEN indent ← Rope.Concat[indent, " "];
};
inner: PROC = TRUSTED {
[type, class] ← UnderTypeAndClass[TVType[tv]];
SELECT class FROM
globalFrame => global ← TRUE;
localFrame => local ← TRUE;
ENDCASE =>{put.PutRope["--{not a frame}--"]; RETURN};
WHILE tv # NIL DO
IF nvars # 0 THEN put.PutRope[sep];
msg ← BackStop.Call[inner1];
IF msg # NIL THEN {
put.PutRope[Rope.Cat["--{", msg, "}--"]];
EXIT};
IF NOT all THEN EXIT;
ENDLOOP;
};
msg: ROPE;
msg ← BackStop.Call[inner];
IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
PrintSignal: PUBLIC PROC [signalTV, argsTV: TV, put: STREAM, depth: INT ← 4, width: INT ← 32, verbose: BOOLFALSE] = TRUSTED {
msg, signal: UNSPECIFIED;
r: ROPE;
PutSignal1: PROC = TRUSTED {
OPEN AMTypes, IO;
signalType: Type;
argsType: Type;
ptr: LONG POINTER;
argsSize: NAT;
signalTV ← AMBridge.TVForSignal[LOOPHOLE[signal, ERROR ANY RETURNS ANY]];
signalType ← TVType[signalTV];
argsType ← Domain[signalType];
argsSize ← IF argsType = SafeStorage.nullType THEN 0 ELSE AMTypes.Size[argsType];
IF argsSize > 1 THEN ptr ← LOOPHOLE[msg, POINTER] ELSE ptr ← @msg;
IF argsSize # 0 THEN argsTV ← AMBridge.TVForPointerReferent[ptr, argsType]
ELSE RETURN;
}; -- of PutSignal1
START PrintSignal HERE
IF signalTV = NIL THEN {
[msg, signal] ← SIGNAL RuntimeError.SendMsgSignal[];
SELECT signal FROM -- some common signals which have to be handled specially
-1 => {put.PutRope ["ERROR"]; RETURN};
ABORTED => {put.PutRope["ABORTED"]; RETURN}; -- says andrew
ENDCASE;
r ← BackStop.Call[PutSignal1];
IF ~Rope.IsEmpty[r] THEN {put.PutRope[r]; RETURN};
};
Print[tv: signalTV, put: put, depth: depth, width: width, verbose: verbose];
IF argsTV # NIL
THEN Print[tv: argsTV, put: put, depth: depth, width: width, verbose: verbose];
}; -- PrintSignal
PrintPointer: PUBLIC PROC
[world: World, addr: Address, type: Type, put: STREAM, depth: INT ← 4, width: INT ← 32]
= TRUSTED {
print the given long pointer as a pointer to the given type; an error msg is printed if there are any errors
IF addr = 0
THEN put.PutRope["NIL"]
ELSE {
inner: PROC = TRUSTED {
tv: TVNIL;
IF world = WorldVM.LocalWorld[]
THEN tv ← TVForPointerReferent[LOOPHOLE[addr, LONG POINTER], type]
ELSE tv ← AMBridge.TVForRemotePointerReferent
[[world, world.CurrentIncarnation[], addr], type];
Print[tv, put, depth, width, FALSE];
};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL THEN {
PrintOctal[put, addr];
put.PutRope[Rope.Cat["??", "--{", msg, "}--"]];
};
};
};
PrintRef: PROC
[ref: REF READONLY ANY, put: STREAM, depth: INT ← 4, width: INT ← 32] = TRUSTED {
print the contents of the given ref; an error msg is printed if there are any errors
IF ref = NIL
THEN put.PutRope["NIL"]
ELSE {
tv: TVNIL;
inner: PROC = TRUSTED {
should be a benign loophole. n.b., if instead REF READONLY ANY is used, then won't get printprocs because the types will be different.
Print[
TVForReferent[NEW[REFLOOPHOLE[ref, REF]]],
put, depth, width, FALSE];};
msg: ROPE ← BackStop.Call[inner];
IF msg # NIL
THEN put.PutRope[Rope.Cat["--{", msg, "}--"]];
};
};
PrintOctal: PROC [put: STREAM, n: LONG CARDINAL] = {
put.PutF["%b", IO.card[n]];
};
miscellaneous utility routines
UnderTypeAndClass: PROC [type: Type] RETURNS [under: Type, class: Class] = {
under ← type;
WHILE (class ← TypeClass[under]) = definition DO
under ← UnderType[under];
ENDLOOP;
};
AddrForFrameTV: PROC [frame: TV] RETURNS [world: World, addr: Address] = TRUSTED {
class: Class ← TypeClass[UnderType[TVType[frame]]];
world ← WorldVM.LocalWorld[];
addr ← 0;
SELECT class FROM
localFrame, globalFrame => {};
ENDCASE => RETURN;
IF AMBridge.IsRemote[frame]
THEN {
card: CARDINAL ← 0;
world ← AMBridge.GetWorld[frame];
IF class = localFrame
THEN card ← LOOPHOLE[AMBridge.RemoteFHFromTV[frame].fh, CARDINAL]
ELSE card ← LOOPHOLE[AMBridge.RemoteGFHFromTV[frame].gfh, CARDINAL];
addr ← WorldVM.Long[world, card];
}
ELSE {
local
sp: POINTER
IF class = localFrame
THEN LOOPHOLE[FHFromTV[frame], POINTER]
ELSE LOOPHOLE[GFHFromTV[frame], POINTER];
lp: LONG POINTER ← sp;
addr ← LOOPHOLE[lp, LONG CARDINAL];
};
};
LocalValidate: PROC [tv: TV, class: Class ← definition] RETURNS [BOOL] = TRUSTED {
will only work for pointers right now...
ref-checking will have to wait (sigh)
isRemote: BOOL ← AMBridge.IsRemote[tv];
validateRef: BOOLFALSE;
world: World ←
IF isRemote THEN AMBridge.GetWorld[tv] ELSE WorldVM.LocalWorld[];
bits: Address ← 0;
IF class = definition THEN
class ← TypeClass[UnderType[TVType[tv]]];
SELECT class FROM
definition => RETURN [FALSE]; -- huh?
atom, rope, list, ref, countedZone => {
ref-class stuff
validateRef ← TRUE;
bits ← TVToLC[tv];
};
longPointer, uncountedZone, basePointer => {
ptr-class stuff
bits ← TVToLC[tv];
};
pointer => {
lengthen this first
bits ← WorldVM.Long[world, TVToCardinal[tv]];
};
globalFrame, localFrame =>
[world, bits] ← AddrForFrameTV[tv];
ENDCASE => RETURN [TRUE];
IF bits = 0 THEN RETURN [FALSE];
address validation first
[] ← WorldVM.Read[world, bits ! WorldVM.AddressFault => GO TO bad];
ref validation next (someday)
RETURN [TRUE];
EXITS
bad => RETURN [FALSE];
};
END.