<> <> <> 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; <> 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]; <> 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 { <> 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}; <> 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 { <> 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 { <> IF TypeClass[underType] = structure AND NComponents[underType] = 2 THEN { ENABLE AMTypes.Error => GO TO nope; <> 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 { <> index _ AMTypes.Copy[index]; AMBridge.SetTVFromLI[index, 0]; }; IF class = sequence THEN <> max _ AMTypes.Length[tv] ELSE { <> low: INT _ AMBridge.TVToLI[index]; high: INT _ AMBridge.TVToLI[AMTypes.Last[indexType]]; max _ high-low+1; }; <> PutRope["("]; PutInt[max]; PutRope[")["]; <> IF depth <= 1 THEN {PutRope["...]"]; RETURN}; <> 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 { <> [, 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 { <> PutCardRope[bits, "^"]; IF msg # NIL THEN PutErr[msg]; RETURN}; <> 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 => <> <> PutTVAsType[tv]; nil => PutRope["NIL"]; 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 } }; 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] = { <> <> <> 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] = { <> <> <> 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 { <> <> <> <> 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 { <> 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 { <> IF ref = NIL THEN PrintRope[put, "NIL"] ELSE { tv: TV _ NIL; inner: PROC = TRUSTED { <> 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^??"]; }; <> 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 { <> 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 { <> <> 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 => { <> validateRef _ TRUE; bits _ TVToLC[tv]; }; longPointer, uncountedZone, basePointer => { <> bits _ TVToLC[tv]; }; pointer => { <> bits _ WorldVM.Long[world, TVToCardinal[tv]]; }; globalFrame, localFrame => [world, bits] _ AddrForFrameTV[tv]; ENDCASE => RETURN [TRUE]; IF bits = 0 THEN RETURN [FALSE]; <

> [] _ WorldVM.Read[world, bits ! WorldVM.AddressFault => GO TO bad]; <> RETURN [TRUE]; EXITS bad => RETURN [FALSE]; }; <> Mother: PUBLIC PROC [inner: PROC] RETURNS [ROPE] = TRUSTED { RETURN [BBSafety.Mother[inner]]}; <> 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 => <> 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] = { < 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 { <> 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; }; <> <<[tv: TV, data: REF, put: PutClosure, depth: NAT, width: NAT]>> <> <> <> <> <> 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] = { < print proc provided>> < 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] = { <> 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] = { <> 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; <> 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 <> <> <> <<>> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <> <<>> <<>>