-- DebuggerMXCode.mesa DIRECTORY Atom, RefTab, Rope, Scheme, SchemePrivate; DebuggerMXCode: CEDAR PROGRAM IMPORTS Atom, RefTab, Scheme = BEGIN OPEN Scheme; SymbolFromRope: PROC [rope: Rope.ROPE] RETURNS [Symbol] ~ {RETURN[Atom.MakeAtom[rope]]}; RopeFromSymbol: PROC [Symbol] RETURNS [Rope.ROPE] ~ Atom.GetPName; TheActivation: PROC [a: Any] RETURNS [SchemePrivate.Activation] = { WITH a SELECT FROM a: SchemePrivate.Activation => RETURN [a]; ENDCASE => Complain[a, "not a SchemePrivate.Activation"]; }; TheSymbol: PROC [a: Any] RETURNS [Scheme.Symbol] = { WITH a SELECT FROM a: Scheme.Symbol => RETURN [a]; ENDCASE => Complain[a, "not a Scheme.Symbol"]; }; TheEnvironment: PROC [a: Any] RETURNS [Scheme.Environment] = { WITH a SELECT FROM a: Scheme.Environment => RETURN [a]; ENDCASE => Complain[a, "not a Scheme.Environment"]; }; DebuggerPrim: PROC [SELF: Primitive, ARG1,ARG2,ARG3: Any, REST: ProperList] RETURNS [result: Any ← unspecified] = { POP: PROC RETURNS [a: Any ← undefined] = { IF REST#NIL THEN {a ← REST.car; REST ← NARROW[REST.cdr]}}; DATA: Pair ~ NARROW[SELF.data]; env: Environment ~ NARROW[DATA.cdr]; SELECT NAT[NARROW[DATA.car, REF INT]↑] FROM 10 => { frame: Any ← ARG1; result ← TheActivation[frame].env; }; 9 => { frame: Any ← ARG1; result ← TheActivation[frame].code.name; }; 8 => { frame: Any ← ARG1; a: SchemePrivate.Activation ~ TheActivation[frame].link; result ← IF a = NIL THEN false ELSE a; }; 7 => { value: Any ← ARG1; env: Environment ~ TheEnvironment[value]; IF env.names = NIL THEN { Inner: RefTab.EachPairAction = { result ← Cons[Cons[key, Cdr[val]], result] }; result ← NIL; [] ← RefTab.Pairs[x: NARROW[env[0]], action: Inner]; } ELSE { names: SimpleVector ← env.names; result ← NIL; FOR i: INT IN [0..names.length) DO result ← Cons[Cons[names[i], env[i]], result]; ENDLOOP; }; }; 6 => { env: Any ← ARG1; symbol: Any ← ARG2; result ← true; [] ← LookupVariableValue[TheSymbol[symbol], TheEnvironment[env] ! Complain => { result ← false; CONTINUE; }]; }; 5 => { env: Any ← ARG1; symbol: Any ← ARG2; value: Any ← ARG3; DefineVariable[TheSymbol[symbol], value, TheEnvironment[env]]; result ← symbol; }; 4 => { env: Any ← ARG1; symbol: Any ← ARG2; value: Any ← ARG3; IF SetVariableValue[TheSymbol[symbol], value, TheEnvironment[env]] THEN result ← unspecified ELSE Complain[symbol, "undefined variable cannot be set"]; }; 3 => { env: Any ← ARG1; symbol: Any ← ARG2; result ← LookupVariableValue[symbol, TheEnvironment[env]]; }; 2 => { value: Any ← ARG1; result ← IF ISTYPE[value, Environment] THEN true ELSE false; }; 1 => { env: Any ← ARG1; result ← TheEnvironment[env].parent; IF result = NIL THEN result ← false; }; 0 => { id: Any ← ARG1; parent: Any ← ARG2; parentEnv: Environment ~ IF parent = undefined THEN NIL ELSE TheEnvironment[parent]; env: Environment ~ NEW[EnvironmentRep[2]]; IF parentEnv # NIL AND parentEnv.names = NIL THEN Complain[parent, "not a top-level environment"]; env.parent ← parentEnv; env[1] ← id; env.names ← NIL; env[0] ← RefTab.Create[]; env.mark ← 100; result ← env; }; ENDCASE => ERROR }; DebuggerInit: PROC [env: Environment] = { DefinePrimitive[name: "frame-environment", nArgs: 1, proc: DebuggerPrim, doc: "(frame) Return the environment for this frame.", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[10], env]]; DefinePrimitive[name: "frame-name", nArgs: 1, proc: DebuggerPrim, doc: "(frame) Return the name of the active procedure for this frame.", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[9], env]]; DefinePrimitive[name: "frame-link", nArgs: 1, proc: DebuggerPrim, doc: "(frame) Return the frame for the caller of this frame.", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[8], env]]; DefinePrimitive[name: "%environment->alist", nArgs: 1, proc: DebuggerPrim, doc: "(value) PRIVATE: Used in definition of walk-environment", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[7], env]]; DefinePrimitive[name: "environment-bound?", nArgs: 2, proc: DebuggerPrim, doc: "(env symbol) Bind SYMBOL to VALUE in ENV", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[6], env]]; DefinePrimitive[name: "environment-define!", nArgs: 3, proc: DebuggerPrim, doc: "(env symbol value) Bind SYMBOL to VALUE in ENV", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[5], env]]; DefinePrimitive[name: "environment-set!", nArgs: 3, proc: DebuggerPrim, doc: "(env symbol value) Set the value of SYMBOL in ENV to VALUE", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[4], env]]; DefinePrimitive[name: "environment-ref", nArgs: 2, proc: DebuggerPrim, doc: "(env symbol) Return the value of SYMBOL in ENV", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[3], env]]; DefinePrimitive[name: "environment?", nArgs: 1, proc: DebuggerPrim, doc: "(value) Is VALUE an environment?", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[2], env]]; DefinePrimitive[name: "environment-parent", nArgs: 1, proc: DebuggerPrim, doc: "(env) Return the parent of the given environment", env: env, optional: 0, dotted: FALSE, data: Cons[MakeFixnum[1], env]]; DefinePrimitive[name: "make-environment", nArgs: 2, proc: DebuggerPrim, doc: "(id [ parent ]) Construct a new top-level environment", env: env, optional: 1, dotted: FALSE, data: Cons[MakeFixnum[0], env]]; }; RegisterInit[DebuggerInit]; END.