DIRECTORY
AMBridge
USING
[ContextPC, FHFromTV, GetWorld, GFHFromTV, IsRemote, OctalRead, RemoteFHFromTV, RemoteGFHFromTV, SetTVFromLI, TVForPointerReferent, TVForReferent, TVForRemotePointerReferent, TVToCardinal, TVToInteger, TVToLC, TVToLI, TVToReal, TVToWordSequence, WordSequence],
AMEvents USING [Debugging, Debugged],
AMTypes
USING
[Apply, Argument, Class, Coerce, Copy, Domain, EnclosingBody, Error, ErrorReason, First, GlobalParent, Globals, GroundStar, Index, IndexToName, IndexToTV, IndexToType, IsAtom, IsComputed, IsNil, IsOverlaid, IsRefAny, IsRope, Last, Length, Locals, NComponents, Next, Procedure,Range, Referent, Result, Signal, StaticParent, Tag, TVSize, TVToName, TVToType, TVType, TypeClass, UnderClass, UnderType, Variant],
CIFS USING [Error],
Convert USING [MapValue, ValueToRope],
PageFault USING [AddressFault],
PrintTV USING [Interceptor, PrintType, PutClosure, PutProc],
Rope USING [Cat, Concat, Fetch, Map, ROPE, Size],
RTBasic USING [nullType, TV, Type, TypedVariable],
RTTypesBasic USING [GetCanonicalType, EquivalentTypes, InvalidType],
Runtime
USING
[BoundsFault, CallDebugger, ControlFault, DivideCheck, PointerFault, StartFault, StackError, UnboundProcedure, ZeroDivisor],
Space
USING [InsufficientSpace], WorldVM
USING
[Address, AddressFault, BadWorld, CurrentIncarnation, LocalWorld, Long, Read, World],
WriteFault USING [WriteProtectFault]
IMPORTS
AMBridge, AMEvents, AMTypes, CIFS, Convert, PageFault, PrintTV, Rope, RTTypesBasic, Runtime, Space, WorldVM, WriteFault
EXPORTS PrintTV
= BEGIN OPEN PrintTV, Rope, RTBasic, AMBridge, AMTypes, WorldVM;
miscellaneous types and constants
CR: CHAR = '\n;
needInit: BOOL ← TRUE;
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];
TypeOfTV1: Type = CODE[TV];
TypeOfTV2: Type = CODE[RTBasic.TypedVariable];
Pair: TYPE = MACHINE DEPENDENT RECORD [lo, hi: CARDINAL];
procedures
EnsureInit:
ENTRY
PROC = {
ENABLE UNWIND => NULL;
IF needInit
THEN {
ENABLE {ABORTED => GO TO abort; ANY => GO TO notNow};
UnderBoolean ← UnderType[UnderBoolean];
UnderString ← UnderType[UnderString];
UnderLongString ← UnderType[UnderLongString];
UnderRefText ← UnderType[UnderRefText];
UnderPtrText ← UnderType[UnderPtrText];
needInit ← FALSE;
EXITS
notNow => {};
abort => RETURN WITH ERROR ABORTED;
};
};
Print:
PUBLIC
PROC
[tv: TV, put: PutClosure, depth: INT ← 4, width: INT ← 32, verbose: BOOL ← FALSE] = {
putproc: PutProc = put.proc;
putdata: REF = put.data;
PutChar:
PROC [c:
CHAR] = {
putproc[putdata, c]
};
PutCard:
PROC [oct:
LONG
CARDINAL, tail:
CHAR ← 'B] = {
Convert.MapValue[PutChar, [unsigned[oct, 8]]];
IF oct > 7 AND tail # 0C THEN PutChar[tail]
};
PutCardRope:
PROC [oct:
LONG
CARDINAL, tail:
ROPE ←
NIL] = {
Convert.MapValue[PutChar, [unsigned[oct, 8]]];
IF oct > 7 THEN PutChar['B];
PutRope[tail];
};
PutCardInt:
PROC [oct:
LONG
CARDINAL, tail:
CHAR ← 'B] = {
Convert.MapValue[PutChar, [unsigned[oct, 8]]];
IF oct > 7
THEN {
IF tail # 0C THEN PutChar[tail];
PutChar[' ];
PutChar['(];
Convert.MapValue[PutChar, [unsigned[oct, 10]]];
PutChar[')]};
};
PutInt:
PROC [dec:
INT] = {
Convert.MapValue[PutChar, [signed[dec, 10]]]
};
PutCharB:
PROC [c:
CHAR]
RETURNS [
BOOL] = {
PutChar[c]; RETURN [FALSE]
};
PutCharLit:
PROC [c:
CARDINAL] = {
IF c
IN [40B..176B]
THEN {
ch: CHAR ← LOOPHOLE[c];
PutChar[''];
IF ch = '\\ THEN PutChar[ch];
PutChar[ch];
RETURN};
PutCard[LONG[LOOPHOLE[c, CARDINAL]], 'C];
IF c > 377B THEN PutChar['!]
};
PutWords:
PROC [tv:
TV, prefix:
ROPE ←
NIL, postfix:
ROPE ←
NIL] =
TRUSTED {
this routine must be relatively indestructible!!!
ENABLE {ABORTED => GO TO abort; ANY => GO TO err};
size: INT ← 0;
IF prefix # NIL AND prefix.Size[] > 0 THEN PutRope[prefix];
size ← TVSize[tv];
SELECT size
FROM
0 => PutRope["[]"];
1 => PutCard[TVToCardinal[tv]];
2 => PutCard[TVToLC[tv]];
ENDCASE => {
sep: ROPE ← NIL;
PutChar['[];
FOR i:
CARDINAL
IN [0..size)
DO
IF i > width THEN {PutRope[", ..."]; EXIT};
PutRope[sep];
sep ← ", ";
PutCard[LOOPHOLE[AMBridge.OctalRead[tv, i], CARDINAL]]
ENDLOOP;
PutChar[']];
};
IF postfix # NIL AND postfix.Size[] > 0 THEN PutRope[postfix]
EXITS
abort => ERROR ABORTED;
err => PutErr["??"]
};
PutRope:
PROC [r:
ROPE] = {
[] ← Rope.Map[base: r, action: PutCharB]
};
PutEscape:
PROC [c:
CHAR]
RETURNS [
BOOL] = {
IF c = '\\ OR c = '" THEN PutChar['\\];
IF c < 40C
OR c >= 177C
THEN {
PutChar['\\];
SELECT c
FROM
'\n => PutChar['n];
'\t => PutChar['t];
ENDCASE => {
PutChar['0 + (c - 0C) / 64];
PutChar['0 + (c - 0C) MOD 64 / 8];
PutChar['0 + (c - 0C) MOD 8]}
}
ELSE PutChar[c];
RETURN [FALSE]
};
PutRopeConst:
PROC [r:
ROPE, max:
INT] = {
size: INT ← r.Size[];
max ← max + 16; -- allow for a reasonable minimum length
PutChar['\"];
[] ← Rope.Map[base: r, start: 0, len: max, action: PutEscape];
IF size > max THEN PutRope["..."];
PutChar['"]
};
QPutName:
PROC [name:
ROPE] = {
IF name.Size[] = 0 THEN PutRope["??"] ELSE PutRope[name]
};
PutSelector:
PROC [name:
ROPE, tail:
ROPE] = {
IF name.Size[] > 0
THEN {
PutRope[name];
PutRope[tail]}
};
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;
PutChar['"];
FOR i:
CARDINAL
IN [0..charsToPrint)
DO
[] ← PutEscape[s[i]];
ENDLOOP;
IF len > charsToPrint THEN PutRope["..."];
PutChar['"];
};
PutErr:
PROC [r1,r2:
ROPE ←
NIL] = {
PutRope["--{"];
PutRope[r1];
IF r2 # NIL THEN PutRope[r2];
PutRope["}--"]
};
PutRecord:
PROC [tv:
TV, start:
NAT ← 0, depth:
INT ← 0] = {
size: Index;
sep: ROPE ← NIL;
type: Type;
innerSize:
PROC = {
type ← TVType[tv];
size ← NComponents[type]};
IF depth <= 1 THEN {PutRope["[...]"]; RETURN};
sep ← Mother[innerSize];
IF sep # NIL THEN {PutErr["can't examine, ", sep]; RETURN};
PutChar['[];
IF depth = 1 THEN {PutRope["...]"]; RETURN};
FOR i: Index
IN [start..size]
DO
name: ROPE;
inner: TV ← NIL;
quitFlag: BOOL ← FALSE;
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 {PutRope["--Overlaid--"]; RETURN};
IF IsComputed[iunder] THEN {PutRope["--Computed--"]; RETURN};
variantTV ← Variant[inner];
QPutName[TVToName[Tag[inner]]];
PutRecord[variantTV, i, depth - 1];
RETURN};
PutTV[inner, depth - 1];
};
msg: ROPE ← NIL;
IF i > width THEN {PutRope[", ..."]; EXIT};
name ← IndexToName[type, i];
PutRope[sep];
sep ← ", ";
PutSelector[name, ": "];
msg ← Mother[innerIndexToTV];
IF msg # NIL THEN {PutErr["Can't get element: ", msg]; LOOP};
msg ← Mother[innerPut];
IF msg # NIL THEN {PutErr["Can't print element: ", msg]; LOOP};
ENDLOOP;
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 => PutRope["--GlobalFrame--"];
localFrame => PutRope["--LocalFrame--"]
ENDCASE => {
type: Type ← TVType[tv];
PrintTV.PrintType[type, put];
};
};
msg: ROPE ← Mother[inner];
IF msg # NIL THEN PutErr[msg];
};
PutTV:
PROC [tv:
TV, depth:
INT, verbose:
BOOL ←
FALSE] =
TRUSTED {
deep: BOOL ← TRUE;
msg1, msg2: ROPE ← NIL;
IF tv = NIL THEN {PutRope["NIL"]; RETURN};
IF depth <= 0 THEN {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 ← Mother[inner];
IF msg # NIL THEN PutErr[msg];
};
};
HandledByPrintProc:
PROC [tv:
TV, type: Type, refTV:
TV ←
NIL]
RETURNS[handled:
BOOL ←
FALSE] =
TRUSTED {
proc: Interceptor ← NIL;
data: REF ← NIL;
isRemote: BOOL = AMBridge.IsRemote[tv];
deReferenced: BOOL = refTV # NIL;
enabled, canHandleRemote: BOOL ← FALSE;
[proc, data, enabled, canHandleRemote] ← GetInterceptor[type, deReferenced];
IF proc #
NIL
AND enabled
AND (canHandleRemote
OR ~isRemote)
THEN {
ENABLE {
ABORTED => GO TO abort;
UNWIND, AMEvents.Debugging, AMEvents.Debugged => NULL;
ANY =>
{SetEnabled[type: type, deReferenced: deReferenced, enabled: FALSE];
REJECT};
};
useOld: BOOL ← proc[IF deReferenced THEN refTV ELSE tv, data, put, depth, width];
RETURN[NOT useOld]
};
EXITS
abort => ERROR ABORTED
};
PutTVNoCatch:
PROC
[tv: TV, depth: INT, verbose: BOOL ← FALSE, type: Type ← nullType]
=
TRUSTED {{
fooey: BOOL ← FALSE;
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: 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
isAList:
PROC [underType: Type]
RETURNS [result:
BOOL ←
FALSE] =
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 RTTypesBasic.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];
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;
next: TV ← NIL;
proc ← Procedure[temp ! AMTypes.Error => CONTINUE];
IF proc # NIL THEN EXIT;
next ← EnclosingBody[temp];
IF next =
NIL
THEN {
next ← AMTypes.StaticParent[temp];
IF next =
NIL
OR UnderTypeAndClass[TVType[next]].class = globalFrame
THEN EXIT;
};
temp ← next;
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
}
};
IF needInit THEN EnsureInit[];
PutTV[tv, depth, verbose]
};
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: PutClosure, depth: INT ← 4, width: INT ← 32, breakBetweenItems: BOOL ← FALSE] = {
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: TV ← NIL;
sep: ROPE ← IF breakBetweenItems THEN "\n " ELSE ", ";
[type, class] ← UnderTypeAndClass[TVType[tv]];
IF class # localFrame
THEN {
PrintRope[put, "-- 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;
PrintRope[put, " "];
FOR i
IN [1..n]
DO
name: ROPE ← IndexToName[type, i];
each: ROPE ← NIL;
IF i > 1 THEN PrintRope[put, sep];
IF name.Size[] # 0 THEN PrintRopes[put, name, ": "];
each ← Mother[inner1];
IF each #
NIL
THEN
PrintRopes[put, "--{", each, "}--"];
ENDLOOP;
};
msg: ROPE ← Mother[inner];
IF msg # NIL THEN PrintRopes[put, "--{", msg, "}--"];
};
PrintResults:
PUBLIC
PROC
[tv: TV, put: PutClosure, depth: INT ← 4, width: INT ← 32, breakBetweenItems: BOOL ← FALSE] = {
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: TV ← NIL;
sep: ROPE ← IF breakBetweenItems THEN "\n " ELSE ", ";
[type, class] ← UnderTypeAndClass[TVType[tv]];
IF class # localFrame
THEN {
PrintRope[put, "-- 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;
PrintRope[put, " "];
FOR i
IN [1..n]
DO
name: ROPE ← IndexToName[type, i];
each: ROPE ← NIL;
IF i > 1 THEN PrintRope[put, sep];
IF name.Size[] # 0 THEN PrintRopes[put, name, ": "];
each ← Mother[inner1];
IF each # NIL THEN PrintRopes[put, "--{", each, "}--"];
ENDLOOP;
};
msg: ROPE ← Mother[inner];
IF msg # NIL THEN PrintRopes[put, "--{", msg, "}--"];
};
PrintVariables:
PUBLIC
PROC
[tv: TV, put: PutClosure, depth: INT ← 4, width: INT ← 32, all, breakBetweenItems: BOOL ← TRUE] = 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: BOOL ← FALSE;
class: Class;
n: NAT ← 0;
i: NAT ← 0;
indent: ROPE ← " ";
sep: ROPE ← IF breakBetweenItems THEN "\n" ELSE ", ";
nvars: NAT ← 0;
inner1:
PROC =
TRUSTED {
tv1: TV ← IF 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 PrintRope[put, indent];
IF name.Size[] # 0 THEN PrintRopes[put, name, ": "];
Print[IndexToTV[tv1, i], put, depth, width]
};
IF i > 1 THEN PrintRope[put, sep];
msg ← Mother[inner2];
IF msg # NIL THEN PrintRopes[put, "--{", 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 =>{PrintRope[put, "--{not a frame}--"]; RETURN};
WHILE tv #
NIL
DO
IF nvars # 0 THEN PrintRope[put, sep];
msg ← Mother[inner1];
IF msg #
NIL
THEN {
PrintRopes[put, "--{", msg, "}--"];
EXIT};
IF NOT all THEN EXIT;
ENDLOOP;
};
msg: ROPE;
msg ← Mother[inner];
IF msg # NIL THEN PrintRopes[put, "--{", msg, "}--"];
};
PrintPointer:
PUBLIC
PROC
[world: World, addr: Address, type: Type, put: PutClosure, 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 PrintRope[put, "NIL"]
ELSE {
inner:
PROC =
TRUSTED {
tv: TV ← NIL;
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 ← Mother[inner];
IF msg #
NIL
THEN {
PrintOctalErr[put, addr];
PrintRopes[put, "--{", msg, "}--"];
};
};
};
PrintRef:
PUBLIC
PROC
[ref: REF READONLY ANY, put: PutClosure, 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 PrintRope[put, "NIL"]
ELSE {
tv: TV ← NIL;
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[REF ← LOOPHOLE[ref, REF]]],
put, depth, width, FALSE];};
msg: ROPE ← Mother[inner];
IF msg #
NIL
THEN PrintRopes[put, "--{", msg, "}--"];
};
};
PrintRopes:
PROC [put: PutClosure, r1,r2,r3,r4:
ROPE ←
NIL] = {
IF r1 # NIL THEN PrintRope[put, r1];
IF r2 # NIL THEN PrintRope[put, r2];
IF r3 # NIL THEN PrintRope[put, r3];
IF r4 # NIL THEN PrintRope[put, r4];
};
PrintRope:
PROC [put: PutClosure, r:
ROPE ←
NIL] = {
putproc: PutProc ← put.proc;
putdata: REF ← put.data;
FOR i:
INT
IN [0..r.Size[])
DO
putproc[putdata, r.Fetch[i]];
ENDLOOP;
};
PrintOctalErr:
PROC [put: PutClosure, addr: Address] = {
put1: PROC [c: CHAR] = {put.proc[put.data, c]};
Convert.MapValue[put1, [unsigned[addr, 8]]];
PrintRope[put, "B^??"];
};
miscellaneous utility routines
IntToRope:
PROC [int:
INT]
RETURNS [
ROPE] = {
RETURN [Convert.ValueToRope[[signed[int]]]]};
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: BOOL ← FALSE;
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];
};
Print Interceptor stuff
interceptorList: InterceptorList ← NIL;
lastInterceptorList: InterceptorList ← NIL;
InterceptorList: TYPE = LIST OF InterceptorListRecord;
InterceptorListRecord:
TYPE =
RECORD [
type: Type, origType: Type, proc: Interceptor, data: REF, enabled: BOOL, deReferenced: BOOL, canHandleRemote: BOOL];
Intercept:
PUBLIC
ENTRY
PROC
[type: Type, proc: Interceptor ← NIL, data: REF ← NIL, canHandleRemote: BOOL ← FALSE] = {
... intercepts printing for the given type; proc will be called when PrintTV.Print tries to print the given type (proc = NIL removes the print proc for the type); data will be supplied when proc is called (faking a closure); type = 0 => ERROR InvalidInterceptor
ENABLE UNWIND => NULL;
DoIntercept[type: type, proc: proc, data: data, canHandleRemote: canHandleRemote];
SELECT TypeClass[UnderType[type]]
FROM
ref, list =>
if user defines a printproc for REF FOO, then a REF ANY that happens to be a REF FOO should also print using the same printProc. This requires associating the printproc with FOO, but marking it as being deReferenced.
DoIntercept[
type: Range[type],
proc: proc,
data: data,
canHandleRemote: canHandleRemote,
deReferenced: TRUE];
ENDCASE;
};
DoIntercept:
PROC
[type: Type, proc: Interceptor, data: REF, deReferenced, canHandleRemote: BOOL ← FALSE]
= {
intercepts printing for the given type; proc will be called when PrintTV.Print tries to print the given type (proc = NIL removes the print proc for the type); data will be supplied when proc is called (faking a closure); type = 0 => ERROR InvalidInterceptor
ENABLE UNWIND => NULL;
lag, new: InterceptorList ← NIL;
canonType: Type ← type;
IF type = LOOPHOLE[0, Type] THEN RETURN WITH ERROR InvalidInterceptor;
SELECT TypeClass[type]
FROM
globalFrame, localFrame => NULL; -- cant call GetCanonicalType or causes an address fault.
ENDCASE => canonType ← RTTypesBasic.GetCanonicalType[type];
new ←
LIST[[type: canonType, origType: type, proc: proc, data: data,
enabled: TRUE, deReferenced: deReferenced, canHandleRemote: canHandleRemote]];
IF interceptorList = NIL THEN {interceptorList ← new; RETURN};
FOR x: InterceptorList ← interceptorList, x.rest
WHILE x #
NIL
DO
IF
LOOPHOLE[x.first.type,
CARDINAL] >=
LOOPHOLE[canonType,
CARDINAL]
THEN EXIT;
lag ← x;
ENDLOOP;
IF lag =
NIL
THEN {
new.rest ← interceptorList;
interceptorList ← new}
ELSE {
splice it in
new.rest ← lag.rest;
lag.rest ← new};
WHILE new.rest #
NIL
AND new.rest.first.type = canonType
AND new.rest.first.deReferenced = deReferenced
DO
-- remove any old definitions.
new.rest ← new.rest.rest;
ENDLOOP;
lastInterceptorList ← new;
};
Interceptor: TYPE = PROC
[tv: TV, data: REF, put: PutClosure, depth: NAT, width: NAT]
RETURNS [useOld: BOOLEAN];
the type of user's print proc
tv: TV is the thing to print
data: REF is the user's data given to Intercept
put: is the output routine for characters
interceptsEnabled:
BOOL ←
TRUE;
-- for debugging
GetInterceptor:
PUBLIC
ENTRY
PROC
[type: Type, deReferenced: BOOL]
RETURNS [proc: Interceptor, data: REF, enabled, canHandleRemote: BOOL] = {
ENABLE UNWIND => NULL;
under: Type;
class: Class;
[proc, data, enabled, canHandleRemote] ← DoGetInterceptor[type, deReferenced];
IF proc # NIL AND enabled THEN RETURN;
[under, class] ← UnderTypeAndClass
[type ! ABORTED => GO TO abort; ANY => GO TO nope];
[proc, data, enabled, canHandleRemote] ← DoGetInterceptor[under, deReferenced];
EXITS
abort => RETURN WITH ERROR ABORTED;
nope => {};
};
DoGetInterceptor:
PROC
[type: Type, deReferenced: BOOL]
RETURNS [proc: Interceptor, data: REF, enabled, canHandleRemote: BOOL] = {
proc # NIL => print proc provided
enabled => print proc is enabled
x: InterceptorList ← lastInterceptorList;
IF
NOT interceptsEnabled
THEN
RETURN [
NIL,
NIL,
FALSE,
FALSE];
SELECT TypeClass[type]
FROM
globalFrame, localFrame =>
NULL; -- cant call GetCanonicalType or causes an address fault.
ENDCASE => type ← RTTypesBasic.GetCanonicalType[type];
IF x #
NIL
AND x.first.type = type
AND x.first.deReferenced = deReferenced
THEN
RETURN [x.first.proc, x.first.data, x.first.enabled, x.first.canHandleRemote];
FOR x ← interceptorList, x.rest
UNTIL x =
NIL
DO
IF x.first.proc = NIL THEN LOOP;
IF x.first.type = type
AND x.first.deReferenced = deReferenced
THEN {
lastInterceptorList ← x;
RETURN [x.first.proc, x.first.data, x.first.enabled, x.first.canHandleRemote]};
IF
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[type,
CARDINAL]
THEN EXIT;
ENDLOOP;
RETURN [NIL, NIL, FALSE, FALSE];
};
SetEnabled:
PUBLIC
ENTRY
PROC
[type: Type, deReferenced: BOOL, enabled: BOOL ← TRUE] = {
sets the enabled flag for the type; no effect if no interceptor for that type
ENABLE UNWIND => NULL;
[] ← DoGetInterceptor[type, deReferenced];
IF lastInterceptorList # NIL THEN lastInterceptorList.first.enabled ← enabled;
};
NextInterceptor:
PUBLIC
ENTRY
PROC
[after: Type ← LOOPHOLE[0]]
RETURNS [type:Type, proc: Interceptor, data: REF, enabled: BOOL] = {
provides a stateless enumerator for print interceptors
ENABLE UNWIND => NULL;
x: InterceptorList ← lastInterceptorList;
IF x =
NIL
OR
LOOPHOLE[x.first.type,
CARDINAL] >
LOOPHOLE[after,
CARDINAL]
THEN x ← interceptorList;
FOR x ← x, x.rest
UNTIL x =
NIL
DO
IF x.first.proc = NIL THEN LOOP;
IF LOOPHOLE[x.first.type, CARDINAL] > LOOPHOLE[after, CARDINAL] THEN EXIT;
ENDLOOP;
IF x = NIL THEN RETURN [after, NIL, NIL, FALSE];
lastInterceptorList ← x;
RETURN [x.first.type, x.first.proc, x.first.data, x.first.enabled];
};
InvalidInterceptor:
PUBLIC
ERROR =
CODE;
error raised by Intercept if bad arguments are given
END.