
    <<InterpreterImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<Russ Atkinson, February 20, 1985 8:34:16 pm PST>>
        <<Paul Rovner, November 1, 1983 9:44 pm>>

    DIRECTORY
        AMBridge USING [IsRemote, Loophole, SetTVFromLC, SetTVFromLI, TVForReadOnlyReferent, TVToCardinal, TVToInteger, TVToLC, TVToLI, 
        TVToRef],
        AMModel USING [Context, RootContext],
        AMTypes USING [GetEmptyTV, Class, Coerce, Error, GroundStar, IndexToTV, NComponents, New, TV, Range, TVSize, TVType, TypeClass, 
        UnderType],
        BackStop USING [Call],
        CBinary USING [MesaTab],
        Interpreter USING [AbortClosure, AbortProc],
        InterpreterOps USING [EvalHead, EvalHeadRep, HelpFatal, Eval, AbortClosure, HelpDefaultClosure, HelpFatalClosure, HelpIdClosure, 
        HelpSelectorClosure, HelpWrongTypeClosure, Tree],
        InterpreterPrivate USING [],
        IO USING [ROS, RopeFromROS, PutRope, STREAM],
        PPP1 USING [Parse],
        PPTree USING [Node, NodeName, Null],
        PPTreeOps USING [Initialize, Finalize, PopTree],
        PrincOps USING [GlobalFrameHandle],
        PrincOpsUtils USING [Codebase],
        PrintTV USING [Print],
        Rope USING [Cat, ROPE],
        SafeStorage USING [Type, EquivalentTypes, GetReferentType],
        SymTab USING [Create, Ref],
        WorldVM USING [LocalWorld, World];

    InterpreterImpl: CEDAR MONITOR
        IMPORTS AMBridge, AMModel, AMTypes, BackStop, CBinary, PPP1, PPTreeOps, PrincOpsUtils, InterpreterOps, IO, PrintTV, Rope, 
        SafeStorage, SymTab, WorldVM
        EXPORTS Interpreter, InterpreterOps, InterpreterPrivate
        = BEGIN OPEN Interpreter, InterpreterOps, SafeStorage;

    <<Useful types>>
        Context: TYPE = AMModel.Context;
        ROPE: TYPE = Rope.ROPE;
        STREAM: TYPE = IO.STREAM;
        TV: TYPE = AMTypes.TV;
        World: TYPE = WorldVM.World;

    FatalInterpreterError: ERROR[msg: ROPE] = CODE;

    EvaluateToRope: PUBLIC PROC
        [rope: ROPE,
         context: Context _ NIL,  -- NIL means use AMModel.RootContext[LocalWorld[]]
         symTab: SymTab.Ref _ NIL,  -- look here first for name to TV lookup
         abort: AbortClosure _ [NIL, NIL]  -- default is to never abort
        ]
        RETURNS[result: ROPE _ NIL, errorRope: ROPE _ NIL, noResult: BOOL _ FALSE] = TRUSTED {
        tv: TV _ NIL;
        [tv, errorRope, noResult] _ Evaluate[rope, context, symTab, abort
            ! ANY => {errorRope _ "EvaluateToRope: unknown failure"; CONTINUE}];
        IF noResult OR errorRope # NIL THEN RETURN
            ELSE {
                printErr: BOOL _ FALSE;
                inner: SAFE PROC = TRUSTED {
                    s: IO.STREAM _ IO.ROS[];
                    PrintTV.Print[tv, s];
                    result _ IO.RopeFromROS[s];
                    };
                errorRope _ BackStop.Call[inner ! ANY => {printErr _ TRUE; CONTINUE}];
                IF printErr THEN errorRope _ "EvaluateToRope: unknown failure";
                };
        };

    Evaluate: PUBLIC PROC
        [rope: ROPE,
         context: Context _ NIL,  -- NIL means use AMModel.RootContext[LocalWorld[]]
         symTab: SymTab.Ref _ NIL,  -- look here first for name to TV lookup
         abort: AbortClosure _ [NIL, NIL]  -- default is to never abort
        ]
        RETURNS[result: TV _ NIL, errorRope: ROPE _ NIL, noResult: BOOL _ FALSE] = TRUSTED {
        inner: SAFE PROC = TRUSTED{
            result
                _ InterpreterOps.Eval
                    [tree: ParseExpr[expr: Rope.Cat["& _ ", rope], errout: errorStream],
                     head: NewEvalHead
                            [context: context,
                              specials: symTab,
                              helpFatalClosure: [myHelpFatal, errorStream],
                              abortClosure: abort]
                    ! FatalInterpreterError => {errorStream.PutRope[msg]; CONTINUE}];
            };
        errorStream: IO.STREAM _ IO.ROS[];

        IF context = NIL THEN context _ AMModel.RootContext[WorldVM.LocalWorld[]];
        IF symTab = NIL THEN symTab _ SymTab.Create[];
        errorStream.PutRope[BackStop.Call[inner]];
        errorRope _ IO.RopeFromROS[errorStream];
        noResult _ (result = AMTypes.GetEmptyTV[]);
        };

    NewEvalHead: PUBLIC PROC
        [context: AMModel.Context,
            <<context # NIL.>>
            <<AMModel.ContextClass[context]>>
                <<= one of: world, prog(global frame), interface(ir), proc(local frame)>>
         specials: SymTab.Ref,  -- non-NIL
         abortClosure: AbortClosure _ [NIL, NIL],
         helpFatalClosure: HelpFatalClosure _ [NIL, NIL],
         helpWrongTypeClosure: HelpWrongTypeClosure _ [NIL, NIL],
         helpIdClosure: HelpIdClosure _ [NIL, NIL],
         helpSelectorClosure: HelpSelectorClosure _ [NIL, NIL],
         helpDefaultClosure: HelpDefaultClosure _ [NIL, NIL]
        ]
        RETURNS [EvalHead] = {
        RETURN [
            NEW [
                EvalHeadRep_ [
                    context: context,
                    specials: specials,
                    abortClosure: abortClosure,
                    helpFatalClosure: helpFatalClosure,
                    helpWrongTypeClosure: helpWrongTypeClosure,
                    helpIdClosure: helpIdClosure,
                    helpSelectorClosure: helpSelectorClosure,
                    helpDefaultClosure: helpDefaultClosure]]];
        }; 

    myHelpFatal: InterpreterOps.HelpFatal = TRUSTED {
        <<PROC [data: REF, head: EvalHead, parent: Tree, msg: ROPE];>>
        ERROR FatalInterpreterError[msg];
        };

    ParseExpr: PUBLIC PROC [expr: Rope.ROPE, errout: IO.STREAM _ NIL] RETURNS [Tree] = {
        RETURN[
            GetFirstAssign[
                ParseStream[source: Rope.Cat["Expr: PROGRAM = {", expr, "\n}."], errPut: errout]
                ]]; 
        };

    ParseStream: PROC [source: Rope.ROPE, errPut: IO.STREAM] RETURNS [root: Tree] = TRUSTED {
        complete: BOOL;
            nErrors: CARDINAL;
            PPTreeOps.Initialize[];
            [complete, , nErrors]
                _ PPP1.Parse[source, LOOPHOLE[PrincOpsUtils.Codebase[LOOPHOLE[CBinary.MesaTab, PrincOps.GlobalFrameHandle]]], errPut ];
            root _ IF complete AND nErrors = 0 THEN PPTreeOps.PopTree[] ELSE PPTree.Null;
            PPTreeOps.Finalize[];
        };

    GetFirstAssign: PROC [tree: Tree] RETURNS [Tree] = {
        <<returns first assignment in the tree>>
        <<(where "first" is first in the preorder traversal)>>
        WITH tree SELECT FROM 
            node: REF PPTree.Node =>  {
                kind: PPTree.NodeName _ node.name; 
                nsons: CARDINAL = node.sonLimit - 1; 
                IF kind = assign THEN RETURN [node]; 
                FOR i: CARDINAL IN [1..nsons] DO 
                    nt: Tree _ GetFirstAssign[node[i]];
                    IF nt # NIL THEN RETURN [nt]
                    ENDLOOP}
            ENDCASE; 
        RETURN [NIL]
        }; 

    CoerceTV: PUBLIC PROC [arg: TV, fullType: Type] RETURNS [rtn: TV] = TRUSTED {
        OPEN AMBridge, AMTypes;
        givenType: Type _ AMTypes.UnderType[TVType[arg]];
        givenClass: Class _ AMTypes.TypeClass[givenType];
        targetType: Type _ AMTypes.UnderType[fullType];
        targetClass: Class _ AMTypes.TypeClass[targetType];
        isRemote: BOOL _ AMBridge.IsRemote[arg];

        IF givenType = targetType THEN RETURN[arg];

        {ENABLE 
            AMTypes.Error => 
                SELECT reason FROM
                    incompatibleTypes, typeFault => GOTO badType;
                    ENDCASE => REJECT;

            <<if types are equivalent, then just LOOPHOLE; if target is UNSPECIFIED, any 1-word match will do; if targetClass = givenClass, we 
            have two special cases>>
        IF EquivalentTypes[targetType, givenType]
            OR (targetClass = unspecified AND TVSize[arg] = 1)
            OR (targetClass = givenClass AND (targetClass = atom OR targetClass = rope))
            THEN GOTO loophole;

            <<strip off useless layers of record>>
        WHILE givenClass = record OR givenClass = structure DO
            n: NAT _ AMTypes.NComponents[givenType];
            IF n # 1 THEN EXIT;
            arg _ AMTypes.IndexToTV[arg, 1];
            givenType _ AMTypes.UnderType[TVType[arg]];
            givenClass _ AMTypes.TypeClass[givenType];
            IF givenType = targetType THEN RETURN [arg];
            IF EquivalentTypes[targetType, givenType]
                OR (targetClass = givenClass AND (targetClass = atom OR targetClass = rope))
                THEN GOTO loophole;
            ENDLOOP;
            <<>>
        <<NIL is handled specially>>
        SELECT givenClass FROM
            list, procedure, signal, error, program, port, ref, pointer, longPointer, rope, atom, unspecified, countedZone, uncountedZone, 
            process, nil, descriptor, longDescriptor, basePointer, relativePointer =>
                IF givenClass = nil OR AMBridge.TVToLC[arg] = 0 THEN
                    SELECT targetClass FROM
                        list, procedure, signal, error, program, port, ref, pointer, longPointer, rope, atom, unspecified, countedZone, uncountedZone, 
                        process, nil, descriptor, longDescriptor, basePointer, relativePointer => RETURN[AMTypes.New[fullType]];
                        ENDCASE => GOTO badType;
            ENDCASE;

        rtn _ AMTypes.New[fullType];
        <<generate the default return>>

        <<KLUDGE for conversion from REF opaque to REF concrete>>
        IF targetClass = ref AND givenClass = ref AND NOT isRemote THEN {
            ref: REF _ AMBridge.TVToRef[arg];
            concrete: Type _ GetReferentType[ref];
            desiredConcrete: Type _ Range[targetType];
            IF EquivalentTypes[concrete, desiredConcrete] THEN GOTO loophole;
            };

        SELECT targetClass FROM
            longInteger, longCardinal, real, cardinal, character => {
                <<these are cases not handled properly by AMTypes.Coerce>>
                int: LONG INTEGER _ 0;
                lc: LONG CARDINAL _ 0;
                givenType _ AMTypes.GroundStar[givenType];
                givenClass _ AMTypes.TypeClass[givenType];
                IF givenClass = targetClass THEN RETURN [arg];
                SELECT givenClass FROM 
                    cardinal, character => int _ AMBridge.TVToCardinal[arg];
                    integer => int _ AMBridge.TVToInteger[arg];
                    longInteger, longCardinal => int _ AMBridge.TVToLI[arg];
                    list, procedure, signal, error, ref, pointer, longPointer, unspecified, countedZone, uncountedZone => {
                        IF targetClass # longCardinal THEN GOTO badType;
                        int _ LOOPHOLE[AMBridge.TVToLC[arg]];
                        };
                    ENDCASE => GOTO badType;
                lc _ LOOPHOLE[int, LONG CARDINAL];
                SELECT targetClass FROM
                    real => RETURN[TVForReadOnlyReferent[NEW[REAL _ int]]];
                    cardinal => {
                        IF lc > LAST[CARDINAL] THEN GOTO badType;
                        AMBridge.SetTVFromLC[rtn, lc];
                        };
                    character => {
                        IF lc > LOOPHOLE[LAST[CHAR], CARDINAL] THEN GOTO badType;
                        AMBridge.SetTVFromLC[rtn, lc];
                        };
                    longCardinal =>
                        AMBridge.SetTVFromLC[rtn, lc];
                    integer => {
                        IF int < FIRST[INTEGER] OR int > LAST[INTEGER] THEN GOTO badType;
                        AMBridge.SetTVFromLI[rtn, int];
                        };
                    ENDCASE => SetTVFromLI[rtn, int];
                RETURN; 
                };
            ENDCASE;
            rtn _ AMTypes.Coerce[arg, fullType];
            EXITS
                loophole => RETURN [AMBridge.Loophole[arg, fullType]];
                badType => ERROR AMTypes.Error[incompatibleTypes, NIL, givenType, fullType];
            }};    

    END.