<<>>
    <<SchemeSupportImpl.mesa>>
        <<Copyright Ó 1987, 1988, 1989, 1991 by Xerox Corporation.  All rights reserved.>>
        <<Formerly part of SchemeEvalImpl.mesa>>
        <<Michael Plass, March 6, 1989 2:52:52 pm PST>>
        <<Last changed by Pavel on March 15, 1989 12:42:54 pm PST>>

    DIRECTORY
        Atom USING [GetPName, GetProp, MakeAtom, PutProp, PutPropOnList],
        BasicTime USING [GMT, Now],
        ProcessProps USING [AddPropList, GetProp],
        RefTab USING [Create, Fetch, Ref, Store],
        Rope USING [FromRefText, Replace, ROPE, Size],
        Scheme,
        SchemeRegistry USING [],
        SymTab USING [Create, EachPairAction, Fetch, Pairs, Ref, Store];

    SchemeSupportImpl: CEDAR MONITOR
    IMPORTS Atom, BasicTime, ProcessProps, RefTab, Rope, Scheme, SymTab
    EXPORTS Scheme, SchemeRegistry
    ~ BEGIN OPEN Scheme;

        ROPE: TYPE ~ Rope.ROPE;

        ICar: PROC [any: Any] RETURNS [Any] ~ INLINE {
            RETURN [WITH any SELECT FROM pair: Pair => pair.car ENDCASE => Car[any]]
            };

        ICdr: PROC [any: Any] RETURNS [Any] ~ INLINE {
            RETURN [WITH any SELECT FROM pair: Pair => pair.cdr ENDCASE => Cdr[any]]
            };

        SymbolFromRope: PUBLIC PROC [rope: ROPE] RETURNS [Symbol] ~ {RETURN[Atom.MakeAtom[rope]]};
        RopeFromSymbol: PUBLIC PROC [symbol: Symbol] RETURNS [ROPE] ~ {RETURN[Atom.GetPName[symbol]]};

        Complain: PUBLIC ERROR [object: Any, msg: ROPE] ~ CODE;
        GetUserEnvironment: PUBLIC SIGNAL RETURNS [env: Environment] ~ CODE;

        SpecialsRep: TYPE ~ RECORD [false, true, endOfFile, unspecified, undefined: Any, emptyString: String];
        GetSpecials: PROC RETURNS [REF SpecialsRep] ~ {
            WITH Atom.GetProp[atom: $SchemeSpecialValues, prop: $SchemeSpecialValues] SELECT FROM
                s: REF SpecialsRep => RETURN [s];
                ENDCASE => {
                    s: REF SpecialsRep ~ NEW[SpecialsRep Ź [
                        false: NEW[BOOL Ź FALSE],
                        true: NEW[BOOL Ź TRUE],
                        endOfFile: NEW[{eof} Ź eof],
                        unspecified: NEW[{unspecified} Ź unspecified],
                        undefined: NEW[{undefined} Ź undefined],
                        emptyString: NEW[StringRep Ź [base: NIL]]
                        ]];
                    Atom.PutProp[atom: $SchemeSpecialValues, prop: $SchemeSpecialValues, val: s];
                    RETURN [s]
                    };
            };

        specials: REF SpecialsRep ~ GetSpecials[];

        false: PUBLIC Any ~ specials.false;
        true: PUBLIC Any ~ specials.true;
        endOfFile: PUBLIC Any ~ specials.endOfFile;
        unspecified: PUBLIC Any ~ specials.unspecified;
        undefined: PUBLIC Any ~ specials.undefined;
        emptyString: PUBLIC String ~ specials.emptyString;

        StringFromRope: PUBLIC PROC [rope: ROPE] RETURNS [String] ~ {
            RETURN [IF Rope.Size[rope] = 0 THEN emptyString ELSE NEW[StringRep Ź [base: rope]]]
            };

        RopeFromString: PUBLIC PROC [string: String] RETURNS [ROPE] ~ {
            IF string.buffer = NIL OR string.buffer.length = 0 THEN NULL ELSE {
                string.base Ź Rope.Replace[base: string.base, start: string.where, len: string.buffer.length, with: 
                Rope.FromRefText[string.buffer]];
                string.buffer.length Ź 0;
                };
            RETURN [string.base]
            };

        Car: PUBLIC PROC [any: Any] RETURNS [Any] ~ {
            WITH any SELECT FROM
                pair: Pair => RETURN [pair.car];
                <<r: ReversedArgList => RETURN [r.car];>>
                list: LIST OF REF ANY => RETURN [list.first];
                ENDCASE => Complain[any, "not a pair"];
            };

        Cdr: PUBLIC PROC [any: Any] RETURNS [Any] ~ {
            WITH any SELECT FROM
                pair: Pair => RETURN [pair.cdr];
                <<r: ReversedArgList => RETURN [r.cdr];>>
                list: LIST OF REF ANY => RETURN [list.rest];
                ENDCASE => Complain[any, "not a pair"];
            };

        Cons: PUBLIC PROC [a, b: Any] RETURNS [Pair] ~ { RETURN [NEW[PairRep Ź [a, b]]] };

        ListLength: PUBLIC PROC [a: Any] RETURNS [n: INT Ź 0] ~ {
            DO WITH a SELECT FROM
                p: Pair => { n Ź n + 1; a Ź p.cdr };
                lora: LIST OF REF ANY => { n Ź n + 1; a Ź lora.rest };
                ENDCASE => IF a = NIL THEN EXIT ELSE { Complain[a, "not a proper list"] }
                ENDLOOP;
            };

        Reverse: PUBLIC PROC [a: Any] RETURNS [Any] ~ {
            r: Any Ź NIL;
            FOR each: Any Ź a, ICdr[each] UNTIL each = NIL DO
                r Ź Cons[ICar[each], r];
                ENDLOOP;
            RETURN [r]
            };

        VectorFromList: PUBLIC PROC [a: Any] RETURNS [Any] ~ {
            len: NAT ~ ListLength[a];
            v: SimpleVector ~ NEW[SimpleVectorRep[len]];
            FOR i: NAT IN [0..len) DO v[i] Ź ICar[a]; a Ź ICdr[a] ENDLOOP;
            RETURN [v]
            };

        VectorLength: PUBLIC PROC [a: Any] RETURNS [INT] ~ {
            WITH a SELECT FROM
                v: SimpleVector => RETURN [v.length];
                v: Vector => RETURN [v.length];
                ENDCASE => Complain[a, "not a vector"];
            };

        VectorRef: PUBLIC PROC [a: Any, i: INT] RETURNS [Any] ~ {
            WITH a SELECT FROM
                v: SimpleVector => { IF i IN [0..v.length) THEN RETURN [v[i]] };
                v: Vector => { IF i IN [0..v.length) THEN RETURN [v.ref[v, i]] };
                ENDCASE => Complain[a, "not a vector"];
            Complain[MakeFixnum[i], "index out of bounds"];
            };

        VectorSet: PUBLIC PROC [a: Any, i: INT, value: Any] ~ {
            WITH a SELECT FROM
                v: SimpleVector => { IF i IN [0..v.length) THEN {v[i] Ź value; RETURN} };
                v: Vector => { IF i IN [0..v.length) THEN {v.set[v, i, value]; RETURN} };
                ENDCASE => Complain[a, "not a vector"];
            Complain[MakeFixnum[i], "index out of bounds"];
            };

        LookupVariableValue: PUBLIC PROC [variable: Any, env: Environment] RETURNS [Any] ~ {
            FOR e: Environment Ź env, e.parent WHILE e # NIL DO
                IF e.names = NIL
                    THEN {
                        WITH e[0] SELECT FROM
                            tab: RefTab.Ref => {
                                WITH RefTab.Fetch[tab, variable].val SELECT FROM
                                    pair: Pair => {
                                        IF pair.cdr = undefined
                                            THEN Complain[variable, "undefined variable"]
                                            ELSE RETURN [pair.cdr];
                                        };
                                    ENDCASE => NULL;
                                };
                            ENDCASE => ERROR;
                        }
                    ELSE {
                        FOR i: NAT DECREASING IN [0..e.names.length) DO
                            IF variable = e.names[i] THEN RETURN [e[i]];
                            ENDLOOP;
                        };
                ENDLOOP;
            Complain[variable, "undefined variable"];
            };

        SetVariableValue: PUBLIC PROC [variable: Any, value: Any, env: Environment] RETURNS [BOOL] ~ {
            FOR e: Environment Ź env, e.parent WHILE e # NIL DO
                IF e.names = NIL
                    THEN {
                        WITH e[0] SELECT FROM
                            tab: RefTab.Ref => {
                                WITH RefTab.Fetch[tab, variable].val SELECT FROM
                                    pair: Pair => { pair.cdr Ź value; RETURN [TRUE] }
                                    ENDCASE => NULL;
                                };
                            ENDCASE => ERROR;
                        }
                    ELSE {
                        FOR i: NAT DECREASING IN [0..e.names.length) DO
                            IF variable = e.names[i] THEN { e[i] Ź value; RETURN [TRUE] };
                            ENDLOOP;
                        };
                ENDLOOP;
            RETURN [FALSE];
            };

        DefineVariable: PUBLIC PROC [variable: Any, value: Any, env: Environment] ~ {
            WITH env[0] SELECT FROM
                x: RefTab.Ref => {
                    WITH RefTab.Fetch[x, variable].val SELECT FROM
                        binding: Pair => { binding.cdr Ź value }
                        ENDCASE => { [] Ź RefTab.Store[x: x, key: variable, val: Cons[variable, value]] };
                    };
                ENDCASE => Complain[variable, "defines must be at top level"];
            };

        ExportVariable: PUBLIC PROC [fromEnv, toEnv: Environment, fromName, toName: Symbol] ~ {
            fromTab, toTab: RefTab.Ref;
            found: BOOL;
            binding: Any;
            IF fromEnv.names # NIL OR toEnv.names # NIL THEN 
                Complain[$exportVariable, "Not Implemented: export to/from a non-top-level environment"];
            fromTab Ź NARROW[fromEnv[0]];
            toTab Ź NARROW[toEnv[0]];
            [found, binding] Ź RefTab.Fetch[fromTab, fromName];
            IF NOT found THEN Complain[fromName, "attempt to export an undefined variable"];
            [] Ź RefTab.Store[toTab, toName, binding];
            };

        DefinePrimitive: PUBLIC PROC [name: ROPE, nArgs: NAT, dotted: BOOL, proc: PROC [Primitive, Any, Any, Any, ProperList] RETURNS 
        [Any], doc: Rope.ROPE, env: Environment, data: REF Ź NIL, optional: NAT Ź 0] ~ {
            symbol: Symbol ~ SymbolFromRope[name];
            DefineVariable[variable: symbol, value: NEW[PrimitiveRep Ź [minArgs: nArgs - optional, maxArgs: nArgs, dotted: dotted, proc: proc, 
            doc: doc, data: data, symbol: symbol]], env: env];
            };
<<Registration Support >>
    Initializer: TYPE ~ RECORD [initProc: PROC [Environment]];
    initHead: LIST OF Initializer ~ LIST[[NIL]];
    lastInit: LIST OF Initializer Ź initHead;
    versionRef: REF Ź Cons[$VERSION, NEW[BasicTime.GMT Ź BasicTime.Now[]]];

    NewEnvironmentStructure: PUBLIC PROC RETURNS [userEnv: Environment] ~ {
        NewEnvironment: PROC [parent: Environment, id: Rope.ROPE]
        RETURNS [env: Environment] ~ {
            env Ź NEW[EnvironmentRep[2]];
            env.parent Ź parent;
            env.names Ź NIL;
            env.mark Ź 100;
            env.values[0] Ź RefTab.Create[];
            env.values[1] Ź StringFromRope[id];
            };
        userEnv Ź NewEnvironment[NIL, "user"];

        DefineVariable[
            variable: SymbolFromRope["user"],
            value: userEnv,
            env: userEnv];

        InitializeEnvironmentStructure[userEnv];
        };

    InitializeEnvironmentStructure: PUBLIC PROC [userEnv: Environment] ~ {
        ENABLE
            GetUserEnvironment => RESUME[userEnv];
        IF RefTab.Fetch[x: NARROW[userEnv.values[0]], key: $VERSION].val # versionRef THEN {
            FOR each: LIST OF Initializer Ź initHead.rest, each.rest UNTIL each = NIL DO
                each.first.initProc[userEnv];
                ENDLOOP;
            [] Ź RefTab.Store[x: NARROW[userEnv.values[0]], key: $VERSION, val: versionRef];
            };
        };

    namedInitializers: SymTab.Ref -- OF LIST OF Initializer -- ~ SymTab.Create[case: FALSE];

    CallNamedInitializers: PUBLIC PROC [name: ROPE, env: Environment] RETURNS [nInit: INT Ź 0] ~ {
        <<Call all the initializers associated with a given name.>>
        WITH SymTab.Fetch[x: namedInitializers, key: name].val SELECT FROM
            initializers: LIST OF Initializer => {
                FOR tail: LIST OF Initializer Ź initializers, tail.rest UNTIL tail = NIL DO
                    tail.first.initProc[env];
                    nInit Ź nInit + 1;
                    ENDLOOP;
                };
            ENDCASE => NULL;
        };

    InitializationCell: TYPE ~ REF InitializationCellRep;
    InitializationCellRep: TYPE ~ RECORD [
        head: LIST OF Initializer,
        last: LIST OF Initializer
        ];

    CollectInitializers: PUBLIC PROC [name: ROPE, proc: PROC] ~ {
        <<All calls to RegisterInit while proc has control will be collected into a named table of Initializers.  Normally proc will cause 
        a Cedar module (or perhaps several) to be loaded and run.>>
        cell: InitializationCell Ź NEW[InitializationCellRep];
        cell.last Ź cell.head Ź LIST[[NIL]];
        ProcessProps.AddPropList[propList: Atom.PutPropOnList[propList: NIL, prop: $SchemeInitializers, val: cell], inner: proc];
        IF cell.head.rest # NIL THEN {
            <<If nothing was registered, NOP since the installation probably went awry.>>
            [] Ź SymTab.Store[x: namedInitializers, key: name, val: cell.head.rest];
            };
        };

    RegisterInit: PUBLIC ENTRY PROC [initProc: PROC [Environment]] ~ {
        <<Cedar programs call this to make themselves known to Scheme>>
        WITH ProcessProps.GetProp[$SchemeInitializers] SELECT FROM
            cell: InitializationCell => {
                <<This is under control of CollectInitializers>>
                cell.last Ź cell.last.rest Ź LIST[[initProc]];
                };
            ENDCASE => {
                <<This is free-floating; add to the global list.>>
                lastInit Ź lastInit.rest Ź LIST[[initProc]];
                versionRef Ź Cons[$VERSION, NEW[BasicTime.GMT Ź BasicTime.Now[]]];
                };
        };

    InitializerIsDefined: PUBLIC PROC [name: ROPE] RETURNS [BOOL] ~ {
        RETURN[SymTab.Fetch[namedInitializers, name].found]
        };

    ListNamedInitializers: PUBLIC PROC RETURNS [list: ProperList Ź NIL] ~ {
        EachPair: SymTab.EachPairAction = {
            <<[key: ROPE, val: SymTab.Val] RETURNS [quit: BOOL _ FALSE]>>
            list Ź Cons[StringFromRope[key], list];
            };
        [] Ź SymTab.Pairs[x: namedInitializers, action: EachPair]
        };

    END.