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