
    <<AMHacks.Mesa>>
        <<Last Edited by: Spreitzer, May 10, 1986 0:42:55 am PDT>>

    DIRECTORY AMBridge, AMTypes, BBUrpEval, EvalQuote, InterpreterOps, InterpreterPrivate, List, PPTree, PPTreeOps, ProcessProps, Rope, 
    SymTab;

    AMHacks: CEDAR PROGRAM
        IMPORTS AMBridge, AMTypes, BBUrpEval, EvalQuote, InterpreterOps, InterpreterPrivate, List, PPTreeOps, ProcessProps, SymTab =

    BEGIN

    ROPE: TYPE = Rope.ROPE;
    Type: TYPE = AMTypes.Type;
    TV: TYPE = AMTypes.TV;
    Tree: TYPE = InterpreterOps.Tree;
    EvalHead: TYPE = InterpreterOps.EvalHead;
    nullType: Type = AMTypes.nullType;
    empty: TV _ AMTypes.GetEmptyTV[];

    Reflect: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- 
    EvalQuote.EvalQuoteProc -- =
        BEGIN
        TRUSTED {return _ AMBridge.TVForReferent[NEW[Reflection _ latest _ [head, tree, target]]]};
        END;

    Reflection: TYPE = RECORD [head: EvalHead, tree: Tree, target: Type];

    latest: Reflection;

    ReturnEmpty: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- 
    EvalQuote.EvalQuoteProc -- =
        BEGIN
        latest _ [head, tree, target];
        return _ empty;
        END;

    Up: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc -- =
        BEGIN
        args: Tree _ PPTreeOps.NthSon[tree, 2];
        arg: TV _ InterpreterOps.Eval[tree: args, head: head];
        TRUSTED {return _ AMBridge.TVForReferent[NEW [TV _ arg]]};
        END;

    tvType: Type = CODE[TV];

    Down: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc 
    -- =
        BEGIN
        args: Tree _ PPTreeOps.NthSon[tree, 2];
        arg: TV _ InterpreterOps.Eval[tree: args, head: head, target: tvType];
        DO
            SELECT AMTypes.TypeClass[AMTypes.UnderType[AMTypes.TVType[arg]]] FROM
                ref => {
                    ra: REF ANY;
                    TRUSTED {ra _ AMBridge.TVToRef[arg]};
                    WITH ra SELECT FROM
                        tv: TV => RETURN [tv];
                        ENDCASE;
                    };
                ENDCASE;
            arg _ BBUrpEval.UrpWrongType[head, args, arg, tvType, "Down takes a TV"];
            args _ NIL;
            ENDLOOP;
        END;

    TypeOf: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc 
    -- =
        BEGIN
        args: Tree _ PPTreeOps.NthSon[tree, 2];
        arg: TV _ InterpreterOps.Eval[tree: args, head: head];
        type: Type _ AMTypes.TVType[arg];
        TRUSTED {return _ AMBridge.TVForType[type]};
        END;

    EnType: PROC [head: EvalHead, tree: Tree, target: Type _ nullType, data: REF _ NIL] RETURNS [return: TV] -- EvalQuote.EvalQuoteProc 
    -- =
        BEGIN
        args: Tree _ PPTreeOps.NthSon[tree, 2];
        arg: TV _ InterpreterOps.Eval[tree: args, head: head, target: underType];
        type: Type _ ForceType[arg, head, tree];
        TRUSTED {return _ AMBridge.TVForType[type]};
        END;

    UndefineEQ: PROC [name: ROPE, table: SymTab.Ref _ NIL] =
        BEGIN
        IF table = NIL THEN table _ NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]], EvalHead].specials;
        EvalQuote.Register[name, NIL, table];
        END;

    Undefine: PROC [name: ROPE, table: SymTab.Ref _ NIL] RETURNS [wasDefined: BOOL] =
        BEGIN
        IF table = NIL THEN table _ NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]], EvalHead].specials;
        wasDefined _ table.Delete[name];
        END;

    underType: Type _ AMTypes.UnderType[CODE[Type]];
    ropeType: Type _ AMTypes.UnderType[CODE[ROPE]];

    ForceType: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [Type] = TRUSTED {
        rtn: TV _ tv;
        DO
            <<Try to get the right stuff.>>
            ut: Type = AMTypes.UnderType[AMTypes.TVType[rtn]];
            IF ut = underType THEN RETURN [AMTypes.TVToType[rtn]];
            IF AMTypes.TypeClass[ut] = type THEN RETURN [AMTypes.TVToType[rtn]];
            rtn _ BBUrpEval.UrpWrongType[head, parent, rtn, underType, "not Type"]
            ENDLOOP
        }; 

    Start: PROC = {
        EvalQuote.Register["&reflect", Reflect, NIL];
        EvalQuote.Register["&returnEmpty", ReturnEmpty, NIL];
        EvalQuote.Register["&up", Up, NIL];
        EvalQuote.Register["&down", Down, NIL];
        EvalQuote.Register["&typeOf", TypeOf, NIL];
        EvalQuote.Register["&unCODE", EnType, NIL];
        TRUSTED {
            InterpreterOps.RegisterTV["&undefineEQ", AMBridge.TVForProc[UndefineEQ], "Undoes an EvalQuote registration", 
            InterpreterPrivate.GetGlobalSymTab[]];
            InterpreterOps.RegisterTV["&undefine", AMBridge.TVForProc[Undefine], "Removes something from the specials table", 
            InterpreterPrivate.GetGlobalSymTab[]];
            };
        };

    Start[];

    END.