[Indigo]<Cedar>IO>PrintTVImpl.mesa!6

PrintTVImpl.mesa

Russ Atkinson, June 22, 1983 6:53 pm

Warren Teitelman, February 5, 1983 3:50 pm

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, 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],

BBSafety USING [Mother],

Convert USING [MapValue, ValueToRope],

PrintTV USING [Interceptor, PrintType, PutClosure, PutProc],

Rope USING [Concat, Fetch, Map, ROPE, Size],

RTBasic USING [nullType, TV, Type, TypedVariable],

RTTypesBasic USING [GetCanonicalType, EquivalentTypes],

WorldVM USING

[Address, AddressFault, CurrentIncarnation, LocalWorld, Long, Read, World]

;

PrintTVImpl: CEDAR MONITOR

IMPORTS

AMBridge, AMEvents, AMTypes, BBSafety, Convert, PrintTV, Rope, RTTypesBasic, WorldVM

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

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;

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;

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 => {

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 => {

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];

nil =>

PutRope["NIL"];

any =>

PutWords[tv, "ANY??"];

globalFrame => {

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;

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;

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

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;

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

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;

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 {

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 {

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];

};

Safety and mother

Mother: PUBLIC PROC [inner: PROC] RETURNS [ROPE] = TRUSTED {

RETURN [BBSafety.Mother[inner]]};

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;

[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.

September 1, 1982 10:57 am fixed bug in PrintType so that LONG STRING would print correctly.

September 14, 1982 2:23 pm converted all 3.4 comments to real code, took out 3.3 stuff

September 17, 1982 11:04 am fixed printing of tv for tv, local frame. took out workarounds for IsAtom and IsRope.

September 21, 1982 11:06 pm fixed rope printing to distinguish between NIL and ""

October 6, 1982 8:14 pm (RRA) fixed PrintVariables[... all: TRUE ...] & descriptor printing

Edited on December 8, 1982 10:15 pm, by Teitelman

fixed PrintVariables to indent according to nesting (reverse of copilot - outer blocks are indented)

changes to: PrintVariables, inner2 (local of inner1, local of PrintVariables), inner1 (local of PrintVariables)

Edited on December 9, 1982 12:09 am, by Teitelman

fixed catch phrase in HandledByPrintProc to specifically catch AMEvents.Debugging, Debugged so as not to turn off printProcs simply because you plant a breakpoint in them.

changes to: DIRECTORY, IMPORTS, HandledByPrintProc (local of Print)

Edited on January 6, 1983 7:13 pm, by Teitelman

fixed print for tv of type atom where the value is NIL.

changes to: PutTVNoCatch (local of Print)

Edited on January 26, 1983 9:00 pm, by Teitelman

changed TVToLC[tv] = 0 to IsNil[tv]

Edited on March 15, 1983 6:41 pm, by Atkinson

fixed up printing of arrays&sequences

Edited on May 18, 1983 7:27 pm, by Atkinson

made PrintVariables, PrintArguments, and PrintResults more uniform

made printing of proc names for local frames better (using StaticParent)

Edited on May 27, 1983 11:49 am, by Atkinson

fixed bug in descriptor printing (found by Rovner)

Edited on May 27, 1983 11:49 am, by Atkinson

removed use of StaticParent, added use of BBSafetyImpl.Mother (& fixed imports)