<> <> <> <> DIRECTORY AMBridge USING [ContextPC, FHFromTV, GetWorld, GFHFromTV, IsRemote, OctalRead, RemoteFHFromTV, RemoteGFHFromTV, SetTVFromLI, TVToCardinal, TVToCharacter, TVToInteger, TVToLC, TVToLI, TVToReal, TVToWordSequence, WordSequence, TVForSignal, TVForPointerReferent], AMTypes USING [Apply, Argument, Class, Coerce, Copy, Domain, EnclosingBody, Error, First, GlobalParent, Globals, GroundStar, Index, IndexToName, IndexToTV, IndexToType, IsAtom, IsComputed, IsNil, IsOverlaid, IsRefAny, IsRope, Last, Length, Locals, NComponents, Next, Procedure,Range, Referent, Result, Signal, Tag, TVSize, TVToName, TVToType, TVType, TypeClass, UnderClass, UnderType, Variant, TV, Size], BackStop USING [Call], Convert USING [RopeFromChar], IO USING [STREAM, Put, PutF, PutRope, card, real, PutChar, int, PutR], PrintTV USING [TVPrintProc, PrintType, GetTVPrintProc, GetClassPrintProc], Rope USING [Concat, Fetch, Map, ROPE, Size, Cat, IsEmpty], RuntimeError USING [UNCAUGHT, SendMsgSignal], SafeStorage USING [nullType, Type, EquivalentTypes], <> WorldVM USING [Address, AddressFault, LocalWorld, Long, Read, World] ; PrintTVImpl: CEDAR MONITOR IMPORTS AMBridge, AMTypes, BackStop, Convert, IO, PrintTV, Rope, RuntimeError, SafeStorage, WorldVM EXPORTS PrintTV = BEGIN OPEN PrintTV, Rope, AMBridge, AMTypes, SafeStorage, WorldVM; <> CR: CHAR = '\n; STREAM: TYPE = IO.STREAM; 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]; Pair: TYPE = MACHINE DEPENDENT RECORD [lo, hi: CARDINAL]; <> EnsureInit: ENTRY PROC = { ENABLE UNWIND => NULL; IF needInit THEN { UnderBoolean _ UnderType[UnderBoolean]; UnderString _ UnderType[UnderString]; UnderLongString _ UnderType[UnderLongString]; UnderRefText _ UnderType[UnderRefText]; UnderPtrText _ UnderType[UnderPtrText]; needInit _ FALSE; }; }; Print: PUBLIC PROC [tv: TV, put: STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = { PutCardRope: PROC [oct: LONG CARDINAL, tail: ROPE] = { PrintOctal[put, oct]; put.PutRope[tail]; }; PutCharLit: PROC [c: CHAR] = {put.PutRope[Convert.RopeFromChar[c]]}; <> <> <> <> < 377B THEN put.PutChar['!]>> <<}; >> PutWords: PROC [tv: TV, prefix: ROPE _ NIL, postfix: ROPE _ NIL] = TRUSTED { <> ENABLE {RuntimeError.UNCAUGHT => GOTO err}; size: INT _ 0; IF prefix # NIL AND prefix.Size[] > 0 THEN put.PutRope[prefix]; size _ TVSize[tv]; SELECT size FROM 0 => put.PutRope["[]"]; 1 => PrintOctal[put, TVToCardinal[tv]]; 2 => PrintOctal[put, TVToLC[tv]]; ENDCASE => { sep: ROPE _ NIL; put.PutChar['[]; FOR i: INT IN [0..size) DO IF i > width THEN {put.PutRope[", ..."]; EXIT}; put.PutRope[sep]; sep _ ", "; PrintOctal[put, LOOPHOLE[AMBridge.OctalRead[tv, i], CARDINAL]] ENDLOOP; put.PutChar[']]; }; IF postfix # NIL AND postfix.Size[] > 0 THEN put.PutRope[postfix] EXITS err => PutErr["??"] }; PutEscape: PROC [c: CHAR] RETURNS [quit: BOOL _ FALSE] = {put.PutRope[Convert.RopeFromChar[c, FALSE]]}; <> <= 177C THEN {>> <> <> <<'\n => put.PutChar['n];>> <<'\t => put.PutChar['t];>> < {>> <> <> <> <<}>> <> <> <<}; >> PutRopeConst: PROC [r: ROPE, max: INT] = { size: INT _ r.Size[]; max _ max + 16; -- allow for a reasonable minimum length put.PutChar['\"]; [] _ Rope.Map[base: r, start: 0, len: max, action: PutEscape]; IF size > max THEN put.PutRope["..."]; put.PutChar['"] }; QPutName: PROC [name: ROPE] = { IF name.Size[] = 0 THEN put.PutRope["??"] ELSE put.PutRope[name] }; PutStringConst: PROC [s: LONG STRING] = TRUSTED { len: CARDINAL _ s.length; charsToPrint: CARDINAL _ len; max: CARDINAL _ width * depth; IF max < charsToPrint THEN charsToPrint _ max; IF max < 8 THEN max _ max + 16; put.PutChar['"]; FOR i: CARDINAL IN [0..charsToPrint) DO [] _ PutEscape[s[i]]; ENDLOOP; IF len > charsToPrint THEN put.PutRope["..."]; put.PutChar['"]; }; PutErr: PROC [r1,r2: ROPE _ NIL] = {put.PutRope[Rope.Cat["--{", r1, r2, "}--"]]}; 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 {put.PutRope["[...]"]; RETURN}; sep _ BackStop.Call[innerSize]; IF sep # NIL THEN {PutErr["can't examine, ", sep]; RETURN}; put.PutChar['[]; <> <<{ ENABLE UNWIND => StructuredStreams.End[put];>> 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 {put.PutRope["--Overlaid--"]; RETURN}; IF IsComputed[iunder] THEN {put.PutRope["--Computed--"]; RETURN}; variantTV _ Variant[inner]; QPutName[TVToName[Tag[inner]]]; PutRecord[variantTV, i, depth - 1]; RETURN}; PutTV[inner, depth - 1]; }; msg: ROPE _ NIL; IF i > start THEN { put.PutRope[", "]; <> }; IF i > width THEN {put.PutRope["..."]; EXIT}; name _ IndexToName[type, i]; IF name.Size[] > 0 THEN put.PutRope[Rope.Cat[name, ": "]]; msg _ BackStop.Call[innerIndexToTV]; IF msg # NIL THEN {PutErr["Can't get element: ", msg]; LOOP}; msg _ BackStop.Call[innerPut]; IF msg # NIL THEN {PutErr["Can't print element: ", msg]; LOOP}; ENDLOOP; <<}; -- end ENABLE UNWIND => StructuredStreams.End[put];>> <> put.PutChar[']] }; PutTVAsType: PROC [tv: TV] = TRUSTED { type: Type _ TVToType[tv]; PrintTV.PrintType[type, put]; }; PutTypeOfTV: PROC [tv: TV, class: Class] = { inner: PROC = { SELECT class FROM globalFrame => put.PutRope["--GlobalFrame--"]; localFrame => put.PutRope["--LocalFrame--"] ENDCASE => { type: Type _ TVType[tv]; PrintTV.PrintType[type, put]; }; }; msg: ROPE _ BackStop.Call[inner]; IF msg # NIL THEN PutErr[msg]; }; PutTV: PROC [tv: TV, depth: INT, verbose: BOOL _ FALSE] = TRUSTED { deep: BOOL _ TRUE; msg1, msg2: ROPE _ NIL; IF tv = NIL THEN {put.PutRope["NIL"]; RETURN}; IF depth <= 0 THEN {put.PutRope["&"]; RETURN}; <> IF NOT HandledByPrintProc[tv: tv, type: TVType[tv]] THEN { inner: PROC = TRUSTED { PutTVNoCatch[tv, depth, verbose]; }; msg: ROPE _ BackStop.Call[inner]; IF msg # NIL THEN PutErr[msg]; }; }; HandledByPrintProc: PROC [tv: TV, type: Type] RETURNS[handled: BOOL _ FALSE] = TRUSTED { proc: TVPrintProc; data: REF; [proc, data] _ GetTVPrintProc[type]; IF proc = NIL THEN [proc, data] _ GetClassPrintProc[UnderClass[type]]; IF proc # NIL THEN handled _ NOT proc[tv, data, put, depth, width]; }; PutTVNoCatch: PROC [tv: TV, depth: INT, verbose: 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; put.PutRope["("]; -- used to be LIST[ <> <<{ ENABLE UNWIND => StructuredStreams.End[put];>> WHILE node # NIL DO elem: TV _ IndexToTV[node, 2]; IF node = NIL THEN EXIT; put.PutRope[sep]; sep _ ", "; <> IF (count _ count + 1) > width THEN {put.PutRope["..."]; EXIT}; PutTV[IndexToTV[node, 1], depth]; node _ Referent[IndexToTV[node, 2]]; ENDLOOP; <<}; -- end ENABLE UNWIND => StructuredStreams.End[put];>> <> put.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 EquivalentTypes[ Range[IndexToType[underType, 2]], underType] THEN RETURN [TRUE]; EXITS nope => {}; }; RETURN [FALSE]; }; IF type = nullType THEN type _ TVType[tv]; [under, class] _ UnderTypeAndClass[type]; SELECT class FROM definition => ERROR; record => PutRecord[tv, 1, depth]; structure => {IF isAList[under] THEN {putList[tv]; RETURN}; PutRecord[tv, 1, depth]}; union => PutWords[tv, "UNION#"]; -- shouldn't really happen array, sequence => { indexType: Type _ AMTypes.Domain[type]; index: TV _ AMTypes.First[indexType]; max: 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; }; <> put.PutRope["("]; put.Put[IO.int[max]]; put.PutRope[")["]; <> IF depth <= 1 THEN {put.PutRope["...]"]; RETURN}; <> <<{ ENABLE UNWIND => StructuredStreams.End[put];>> <> FOR i: INT IN [0..width] WHILE index # NIL AND i < max DO ENABLE AMTypes.Error => GOTO urp; elem: TV _ NIL; msg: ROPE _ NIL; IF i > 0 THEN { put.PutRope[", "]; <> }; IF i = width THEN {put.PutRope["..."]; EXIT}; elem _ AMTypes.Apply[tv, index]; PutTV[elem, depth - 1]; index _ AMTypes.Next[index]; ENDLOOP; put.PutChar[']]; EXITS urp => {PutErr["Can't fetch element"]; put.PutChar[']]}; <<}; -- end ENABLE UNWIND => StructuredStreams.End[put];>> <> }; enumerated => { name: ROPE _ NIL; wrap: BOOL _ verbose AND under # UnderBoolean AND under # type; IF wrap THEN { PutTypeOfTV[tv, class]; put.PutChar['[]}; name _ TVToName[tv ! AMTypes.Error => CONTINUE]; IF name = NIL THEN PutWords[tv, NIL, "?"] ELSE QPutName[name]; IF wrap THEN put.PutChar[']]; }; subrange => { ground: Type = GroundStar[under]; wide: 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 { put.PutRope["NIL"]; RETURN}; valid _ LocalValidate[tv, class]; IF depth <= 2 OR NOT valid THEN { PutCardRope[TVToLC[tv], IF valid THEN "^" ELSE "^??"]; RETURN}; putList[Referent[tv]]; }; atom => { IF IsNil[tv] THEN put.PutRope["NIL"] ELSE {put.PutChar['$]; put.PutRope[TVToName[tv]]}; }; rope => { IF IsNil[tv] THEN put.PutRope["NIL"] ELSE PutRopeConst[TVToName[tv], width * depth]; }; ref => { referentTV: TV _ NIL; referentType: Type; bits: LONG CARDINAL = TVToLC[tv]; msg: ROPE _ NIL; useReferent: BOOL _ depth > 2; inner: PROC = TRUSTED {referentTV _ Referent[tv]}; IF IsNil[tv] THEN {put.PutRope["NIL"]; RETURN}; IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "^??"]; RETURN}; IF AMTypes.IsRefAny[type] THEN { IF AMTypes.IsAtom[tv] THEN { put.PutChar['$]; put.PutRope[TVToName[tv]]; RETURN}; IF AMTypes.IsRope[tv] THEN { PutRopeConst[TVToName[tv], width * depth]; RETURN}; }; IF useReferent THEN msg _ BackStop.Call[inner]; IF msg # NIL OR NOT useReferent THEN { <> PutCardRope[bits, "^"]; IF msg # NIL THEN PutErr[msg]; RETURN}; <> referentType _ TVType[referentTV]; IF HandledByPrintProc[tv: referentTV, type: referentType] THEN RETURN; IF isAList[underType: referentType] THEN { putList[referentTV]; RETURN}; put.PutChar['^]; -- used to be @ PutTV[referentTV, depth - 1]; }; pointer => { bits: CARDINAL _ TVToCardinal[tv]; short: POINTER _ LOOPHOLE[bits]; lp: LONG POINTER _ short; IF bits = 0 THEN {put.PutRope["NIL"]; RETURN}; IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "@??"]; RETURN}; IF under = UnderString THEN { PutStringConst[LOOPHOLE[short, STRING]]; RETURN}; PutCardRope[bits, "@"]; }; longPointer, basePointer => { bits: LONG CARDINAL _ TVToLC[tv]; IF IsNil[tv] THEN {put.PutRope["NIL"]; RETURN}; IF NOT LocalValidate[tv] THEN {PutCardRope[bits, "@??"]; RETURN}; IF under = UnderLongString OR under = UnderPtrText THEN IF NOT isRemote THEN { PutStringConst[LOOPHOLE[bits, LONG STRING]]; RETURN}; PutCardRope[bits, "@"]; }; relativePointer => { IF IsNil[tv] THEN {put.PutRope["NIL"]; RETURN}; put.Put[IO.int[TVToLC[tv]]]; put.PutRope["^R"]; }; descriptor, longDescriptor => { ws: AMBridge.WordSequence = AMBridge.TVToWordSequence[tv]; base: LONG CARDINAL _ 0; len: CARDINAL _ 0; put.PutRope["DESCRIPTOR["]; SELECT class FROM descriptor => { shortDesc: LONG POINTER TO DESCRIPTOR FOR ARRAY OF WORD = LOOPHOLE[@ws[0]]; base _ LOOPHOLE[BASE[shortDesc^], CARDINAL]; len _ LENGTH[shortDesc^]; }; longDescriptor => { longDesc: LONG POINTER TO LONG DESCRIPTOR FOR ARRAY OF WORD = LOOPHOLE[@ws[0]]; base _ LOOPHOLE[BASE[longDesc^]]; len _ LENGTH[longDesc^]; }; ENDCASE => ERROR; IF base = 0 THEN put.PutRope["NIL, "] ELSE PutCardRope[base, "@, "]; put.Put[IO.int[len]]; put.PutRope["]"]; }; port => PutWords[tv, "PORT#"]; process => PutWords[tv, "PROCESS#"]; type => <> <> PutTVAsType[tv]; nil => put.PutRope["NIL"]; any => PutWords[tv, "ANY??"]; globalFrame => { name: ROPE _ TVToName[tv]; put.PutRope["{globalFrame: "]; QPutName[name]; IF verbose THEN { gf: CARDINAL _ IF isRemote THEN AMBridge.RemoteGFHFromTV[tv].gfh ELSE LOOPHOLE[GFHFromTV[tv], CARDINAL]; put.PutRope[" (GF#"]; PutCardRope[gf, ")\n"]; PrintVariables[tv, put]; }; put.PutChar['}]; }; localFrame => { proc: 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; put.PutRope[TVToName[gf]]; put.PutRope[".??"]; EXITS oops => {put.PutRope["??"]; RETURN}} ELSE PutTV[proc, depth]; IF verbose THEN { put.PutRope["(lf: "]; PutCardRope[lf, ", pc: "]; PutCardRope[pc, ")"]; IF depth > 1 THEN { put.PutRope["\nArguments:\n"]; PrintArguments[tv: tv, put: put, breakBetweenItems: TRUE]; put.PutRope["\nVariables:\n"]; PrintVariables[tv: tv, put: put, breakBetweenItems: TRUE]; }; put.PutRope["\n"]; }; }; program, procedure, signal, error => { kind: ROPE _ NIL; name: ROPE _ NIL; useGlobalName: BOOL _ TRUE; IF IsNil[tv] THEN {put.PutRope["NIL"]; RETURN}; name _ TVToName[tv ! AMTypes.Error => CONTINUE]; SELECT class FROM program => {kind _ "PROGRAM#"; useGlobalName _ FALSE}; procedure => kind _ NIL; signal, error => { kind _ IF class = signal THEN "SIGNAL " ELSE "ERROR "; IF AllCaps[name] THEN useGlobalName _ FALSE; } ENDCASE => ERROR; put.PutRope[kind]; IF useGlobalName THEN { ENABLE AMTypes.Error => GO TO oops; gn: ROPE _ NIL; gp: TV _ GlobalParent[tv]; IF gp # NIL THEN gn _ TVToName[gp]; QPutName[gn]; put.PutChar['.]; EXITS oops => put.PutRope["??."]; }; QPutName[name]; }; unspecified, cardinal => { lc: LONG CARDINAL = TVToCardinal[tv]; PrintOctal[put, lc]; put.PutRope[Rope.Cat[" (", IO.PutR[IO.card[lc]], ")"]]; }; integer => put.Put[IO.int[TVToInteger[tv]]]; character => PutCharLit[TVToCharacter[tv]]; longInteger => put.Put[IO.int[TVToLI[tv]]]; longCardinal => { lc: LONG CARDINAL = TVToLC[tv]; PrintOctal[put, lc]; put.PutRope[Rope.Cat[" (", IO.PutR[IO.card[lc]], ")"]]; }; real => put.Put[IO.real[TVToReal[tv]]]; ENDCASE => ERROR }; -- end PutTVNoCatch <<>> <<>> <> IF needInit THEN EnsureInit[]; PutTV[tv, depth, verbose] }; -- end Print AllCaps: PROC [name: ROPE] RETURNS [BOOL] = { FOR i: INT IN [0..name.Size[]) DO IF name.Fetch[i] IN ['a..'z] THEN RETURN [FALSE]; ENDLOOP; RETURN [TRUE]; }; PrintArguments: PUBLIC PROC [tv: TV, put: STREAM, depth: INT _ 4, width: INT _ 32, breakBetweenItems: 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 { put.PutRope["-- not a local frame! --"]; RETURN}; ptv _ Procedure[tv ! Error => CONTINUE]; IF ptv = NIL THEN ptv _ Signal[tv ! Error => CONTINUE]; IF ptv = NIL THEN RETURN; [type, class] _ UnderTypeAndClass[TVType[ptv]]; IF type = nullType THEN RETURN; [type, class] _ UnderTypeAndClass[Domain[type]]; IF type = nullType THEN RETURN; n _ NComponents[type]; IF n = 0 THEN RETURN; put.PutRope[" "]; FOR i IN [1..n] DO name: ROPE _ IndexToName[type, i]; each: ROPE _ NIL; IF i > 1 THEN put.PutRope[sep]; IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]]; each _ BackStop.Call[inner1]; IF each # NIL THEN put.PutRope[Rope.Cat["--{", each, "}--"]]; ENDLOOP; }; msg: ROPE _ BackStop.Call[inner]; IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]]; }; PrintResults: PUBLIC PROC [tv: TV, put: STREAM, depth: INT _ 4, width: INT _ 32, breakBetweenItems: 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 { put.PutRope["-- not a local frame! --"]; RETURN}; ptv _ Procedure[tv ! AMTypes.Error => CONTINUE]; IF ptv = NIL THEN ptv _ Signal[tv ! AMTypes.Error => CONTINUE]; IF ptv = NIL THEN RETURN; [type, class] _ UnderTypeAndClass[TVType[ptv]]; IF type = nullType THEN RETURN; [type, class] _ UnderTypeAndClass[Range[type]]; IF type = nullType THEN RETURN; n _ NComponents[type]; IF n = 0 THEN RETURN; put.PutRope[" "]; FOR i IN [1..n] DO name: ROPE _ IndexToName[type, i]; each: ROPE _ NIL; IF i > 1 THEN put.PutRope[sep]; IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]]; each _ BackStop.Call[inner1]; IF each # NIL THEN put.PutRope[Rope.Cat["--{", each, "}--"]]; ENDLOOP; }; msg: ROPE _ BackStop.Call[inner]; IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]]; }; PrintVariables: PUBLIC PROC [tv: TV, put: STREAM, depth: INT _ 4, width: INT _ 32, all, breakBetweenItems: 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 put.PutRope[indent]; IF name.Size[] # 0 THEN put.PutRope[Rope.Cat[name, ": "]]; Print[IndexToTV[tv1, i], put, depth, width] }; IF i > 1 THEN put.PutRope[sep]; msg _ BackStop.Call[inner2]; IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]]; ENDLOOP; IF local THEN tv _ EnclosingBody[tv] ELSE tv _ NIL; IF breakBetweenItems THEN indent _ Rope.Concat[indent, " "]; }; inner: PROC = TRUSTED { [type, class] _ UnderTypeAndClass[TVType[tv]]; SELECT class FROM globalFrame => global _ TRUE; localFrame => local _ TRUE; ENDCASE =>{put.PutRope["--{not a frame}--"]; RETURN}; WHILE tv # NIL DO IF nvars # 0 THEN put.PutRope[sep]; msg _ BackStop.Call[inner1]; IF msg # NIL THEN { put.PutRope[Rope.Cat["--{", msg, "}--"]]; EXIT}; IF NOT all THEN EXIT; ENDLOOP; }; msg: ROPE; msg _ BackStop.Call[inner]; IF msg # NIL THEN put.PutRope[Rope.Cat["--{", msg, "}--"]]; }; PrintSignal: PUBLIC PROC [signalTV, argsTV: TV, put: STREAM, depth: INT _ 4, width: INT _ 32, verbose: BOOL _ FALSE] = TRUSTED { msg, signal: UNSPECIFIED; r: ROPE; PutSignal1: PROC = TRUSTED { OPEN AMTypes, IO; signalType: Type; argsType: Type; ptr: LONG POINTER; argsSize: NAT; signalTV _ AMBridge.TVForSignal[LOOPHOLE[signal, ERROR ANY RETURNS ANY]]; signalType _ TVType[signalTV]; argsType _ Domain[signalType]; argsSize _ IF argsType = SafeStorage.nullType THEN 0 ELSE AMTypes.Size[argsType]; IF argsSize > 1 THEN ptr _ LOOPHOLE[msg, POINTER] ELSE ptr _ @msg; IF argsSize # 0 THEN argsTV _ AMBridge.TVForPointerReferent[ptr, argsType] ELSE RETURN; }; -- of PutSignal1 <> IF signalTV = NIL THEN { [msg, signal] _ SIGNAL RuntimeError.SendMsgSignal[]; SELECT signal FROM -- some common signals which have to be handled specially -1 => {put.PutRope ["ERROR"]; RETURN}; ABORTED => {put.PutRope["ABORTED"]; RETURN}; -- says andrew ENDCASE; r _ BackStop.Call[PutSignal1]; IF ~Rope.IsEmpty[r] THEN {put.PutRope[r]; RETURN}; }; Print[tv: signalTV, put: put, depth: depth, width: width, verbose: verbose]; IF argsTV # NIL THEN Print[tv: argsTV, put: put, depth: depth, width: width, verbose: verbose]; }; -- PrintSignal <> <<[world: World, addr: Address, type: Type, put: STREAM, depth: INT _ 4, width: INT _ 32]>> <<= TRUSTED {>> <> <> <> <> <> <> <> <> <> <<[[world, world.CurrentIncarnation[], addr], type];>> <> <<};>> <> <> <> <> <<};>> <<};>> <<};>> <<>> <> <<[ref: REF READONLY ANY, put: STREAM, depth: INT _ 4, width: INT _ 32] = TRUSTED {>> <> <> <> <> <> <> <> <> <> <> <> <> <> <<};>> <<};>> <<>> PrintOctal: PROC [put: STREAM, n: LONG CARDINAL] = { put.PutF["%b", IO.card[n]]; }; <> 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]; }; END.