<<>>
    <<TJaMDictImpl.mesa>>
        <<Copyright Ó 1985, 1986, 1991, 1992, 1993 by Xerox Corporation.  All rights reserved.>>
        <<Michael Plass, September 24, 1991 12:03 pm PDT>>
        <<Doug Wyatt, October 19, 1993 12:56 pm PDT>>

    <<Administers JaM dictionaries.  A Dict is a set of <ATOM, REF> tuples.>>

    DIRECTORY
        Atom USING [GetPName, MakeAtom],
        RefTab USING [Create, Delete, EachPairAction, Fetch, GetSize, Pairs, Ref, Replace, Store],
        TJaM,
        TJaMPrivate;

    TJaMDictImpl: CEDAR PROGRAM
    IMPORTS Atom, RefTab, TJaM
    EXPORTS TJaM, TJaMPrivate
    ~ BEGIN OPEN TJaM, TJaMPrivate;

    RopeFromAtom: PUBLIC PROC [atom: ATOM] RETURNS [ROPE] ~ {
        RETURN[Atom.GetPName[atom]];
        };

    AtomFromRope: PUBLIC PROC [rope: ROPE] RETURNS [ATOM] ~ {
        RETURN[Atom.MakeAtom[rope]];
        };
        <<>>
    FrameImplRep: PUBLIC TYPE ~ TJaMPrivate.FrameImplRep;

    NewDict: PUBLIC PROC[mod: NAT Ź 17] RETURNS[Dict] ~ {
        refTab: RefTab.Ref ~ RefTab.Create[mod];
        RETURN[NEW[DictRep Ź [refTab: refTab, attach: NIL]]];
        };

    DictLength: PUBLIC PROC[dict: Dict] RETURNS[INT] ~ {
        RETURN[dict.refTab.GetSize[]];
        };

    TryToGet: PUBLIC PROC[dict: Dict, key: ATOM] RETURNS[found: BOOL, val: REF] ~ {
        [found, val] Ź dict.refTab.Fetch[key];
        };

    Get: PUBLIC PROC[dict: Dict, key: ATOM] RETURNS[val: REF] ~ {
        found: BOOL; [found, val] Ź TryToGet[dict, key];
        IF NOT found THEN ProduceError[undefinedKey];
        };

    Put: PUBLIC PROC[dict: Dict, key: ATOM, val: REF] ~ {
        [] Ź dict.refTab.Store[key, val];
        };

    Del: PUBLIC PROC[dict: Dict, key: ATOM] ~ {
        IF NOT dict.refTab.Delete[key] THEN ProduceError[undefinedKey];
        };

    ClrDict: PUBLIC PROC[dict: Dict] ~ {
        refTab: RefTab.Ref ~ dict.refTab;
        delete: RefTab.EachPairAction ~ { [] Ź refTab.Delete[key]; RETURN[quit: FALSE] };
        [] Ź refTab.Pairs[delete];
        };

    DictForAll: PUBLIC PROC[dict: Dict, action: TupleAction] RETURNS[BOOL] ~ {
        <<applies action to each tuple in dict>>
        pairAction: RefTab.EachPairAction ~ {
            WITH key SELECT FROM
                key: ATOM => RETURN[action[key, val]];
                ENDCASE => ERROR;
            };
        RETURN[dict.refTab.Pairs[pairAction]];
        };


    DictMap: PROC[dict: Dict, action: DictAction] RETURNS[BOOL] ~ {
    <<applies action to dict, then recursively maps its attachments in order>>
        IF action[dict] THEN RETURN[TRUE];
        FOR list: LIST OF Dict Ź dict.attach, list.rest UNTIL list=NIL DO
            IF DictMap[list.first, action] THEN RETURN[TRUE];
            ENDLOOP;
        RETURN[FALSE];
        };

    AttachDict: PUBLIC PROC[dict1, dict2: Dict] ~ {
        find1: DictAction ~ { RETURN[dict=dict1] };
        find2: DictAction ~ { RETURN[dict=dict2] };
        IF DictMap[dict2, find1] THEN ProduceError[attachmentCycle];
        IF DictMap[dict1, find2] THEN RETURN; -- already attached
        dict1.attach Ź CONS[dict2, dict1.attach];
        };

    DetachDict: PUBLIC PROC[dict1, dict2: Dict] ~ {
        list, prev: LIST OF Dict Ź NIL;
        FOR list Ź dict1.attach, list.rest UNTIL list=NIL DO
            IF list.first=dict2 THEN EXIT ELSE prev Ź list;
            ENDLOOP;
        IF list=NIL THEN ProduceError[notAttached]; -- didn't find it
        IF prev=NIL THEN dict1.attach Ź list.rest ELSE prev.rest Ź list.rest;
        };

    DetachAll: PUBLIC PROC[dict: Dict] ~ {
        dict.attach Ź NIL;
        };

    AttachedForAll: PUBLIC PROC[dict: Dict, action: DictAction] RETURNS[BOOL] ~ {
        FOR list: LIST OF Dict Ź dict.attach, list.rest UNTIL list=NIL DO
            IF action[list.first] THEN RETURN[TRUE];
            ENDLOOP;
        RETURN[FALSE];
        };


    NewDictStack: PUBLIC PROC[size: NAT] RETURNS[DictStack] ~ {
        stack: DictStack ~ NEW[DictStackRep[size]];
        stack.count Ź stack.max Ź 0;
        RETURN[stack];
        };

    DictTop: PUBLIC PROC[frame: Frame] RETURNS[Dict] ~ {
        impl: FrameImpl ~ frame.impl;
        stack: DictStack ~ impl.dictStack;
        IF NOT stack.count>0 THEN ProduceError[dictionaryUnderflow];
        RETURN[stack[stack.count-1]];
        };

    Begin: PUBLIC PROC[frame: Frame, dict: Dict] ~ {
        impl: FrameImpl ~ frame.impl;
        stack: DictStack ~ impl.dictStack;
        IF NOT stack.count<stack.size THEN ProduceError[dictionaryOverflow];
        stack[stack.count] Ź dict;
        stack.count Ź stack.count+1;
        IF stack.count>stack.max THEN stack.max Ź stack.count;
        };

    End: PUBLIC PROC[frame: Frame] ~ {
        impl: FrameImpl ~ frame.impl;
        stack: DictStack ~ impl.dictStack;
        IF NOT stack.count>0 THEN ProduceError[dictionaryUnderflow];
        stack.count Ź stack.count-1;
        stack[stack.count] Ź NIL;
        };

    DictStackForAll: PUBLIC PROC[frame: Frame, action: DictAction] RETURNS[BOOL] ~ {
        impl: FrameImpl ~ frame.impl;
        stack: DictStack ~ impl.dictStack;
        FOR i: NAT DECREASING IN[0..stack.count) DO
            dict: Dict ~ stack[i];
            IF action[dict] THEN RETURN[TRUE];
            ENDLOOP;
        RETURN[FALSE];
        };

    DictStackMap: PROC[frame: Frame, action: DictAction] RETURNS[BOOL] ~ {
        impl: FrameImpl ~ frame.impl;
        stack: DictStack ~ impl.dictStack;
        FOR i: NAT DECREASING IN[0..stack.count) DO
            IF DictMap[stack[i], action] THEN RETURN[TRUE];
            ENDLOOP;
        RETURN[FALSE];
        };


    Find: PROC[frame: Frame, key: ATOM] RETURNS [found: BOOL Ź TRUE, val: REF, where: Dict] ~ {
        find: DictAction ~ { [found, val] Ź (where Ź dict).refTab.Fetch[key]; RETURN[found] };
        IF NOT DictStackMap[frame, find] THEN RETURN[FALSE, NIL, NIL];
        };

    Where: PUBLIC PROC[frame: Frame, key: ATOM] RETURNS[found: BOOL, where: Dict] ~ {
        val: REF;
        [found: found, val: val, where: where] Ź Find[frame, key];
        IF found THEN CachePut[frame, key, val]; -- anticipate a Load
        };

    TryToLoad: PUBLIC PROC[frame: Frame, key: ATOM] RETURNS[found: BOOL, val: REF] ~ {
        [found, val] Ź CacheGet[frame, key];
        IF found THEN RETURN;
        [found: found, val: val] Ź Find[frame, key];
        IF NOT found THEN [found, val] Ź TryToGet[primitives, key];
        IF found THEN CachePut[frame, key, val];
        };

    Load: PUBLIC PROC[frame: Frame, key: ATOM] RETURNS[val: REF] ~ {
        found: BOOL; [found, val] Ź TryToLoad[frame, key];
        IF NOT found THEN ProduceError[undefinedKey];
        };

    Def: PUBLIC PROC[frame: Frame, key: ATOM, val: REF] ~ {
        dict: Dict ~ DictTop[frame];
        Put[dict, key, val];
        CachePut[frame, key, val];
        };

    Store: PUBLIC PROC[frame: Frame, key: ATOM, val: REF] ~ {
        store: DictAction ~ { RETURN[dict.refTab.Replace[key, val]] };
        IF DictStackMap[frame, store] THEN CachePut[frame, key, val]
        ELSE Def[frame, key, val];
        };

    <<>>
    CacheGet: PROC[frame: Frame, key: ATOM] RETURNS[found: BOOL, val: REF] ~ {
        RETURN[FALSE, NIL];
        };

    CachePut: PROC[frame: Frame, key: ATOM, val: REF] ~ {
        };

    CacheDel: PROC[frame: Frame, key: ATOM] ~ {
        };

    CacheClear: PROC[frame: Frame] ~ {
        };


    primitives: Dict ~ NewDict[97];

    RegisterPrimitive: PUBLIC PROC[name: ROPE, proc: CommandProc, data: REF Ź NIL] ~ {
        key: ATOM ~ AtomFromRope[name];
        cmd: Cmd ~ NEW[CmdRep Ź [proc: proc, data: data, name: key]];
        Put[primitives, key, cmd];
        };


    <<*** JaM INTRINSICS ***>>

    PopKey: PROC[frame: Frame] RETURNS[ATOM] ~ {
        x: REF ~ Pop[frame];
        WITH x SELECT FROM
            x: ATOM => RETURN[x];
            x: ROPE => RETURN[AtomFromRope[x]];
            ENDCASE => ProduceError[wrongType];
        RETURN[NIL];
        };

    ApplyDict: CommandProc ~ {
        length: INT ~ PopInt[frame];
        PushDict[frame, NewDict[length]];
        };

    ApplyGet: CommandProc ~ {
        key: ATOM ~ PopKey[frame];
        dict: Dict ~ PopDict[frame];
        Push[frame, Get[dict, key]];
        };

    ApplyPut: CommandProc ~ {
        val: REF ~ Pop[frame];
        key: ATOM ~ PopKey[frame];
        dict: Dict ~ PopDict[frame];
        Put[dict, key, val];
        CacheDel[frame, key]; -- in case dict is on stack
        };

    ApplyDel: CommandProc ~ {
        key: ATOM ~ PopKey[frame];
        dict: Dict ~ PopDict[frame];
        Del[dict, key];
        CacheDel[frame, key]; -- in case dict is on stack
        };

    ApplyClrDict: CommandProc ~ {
        dict: Dict ~ PopDict[frame];
        ClrDict[dict];
        CacheClear[frame]; -- in case dict is on stack
        };

    ApplyDictForAll: CommandProc ~ {
        x: REF ~ Pop[frame];
        dict: Dict ~ PopDict[frame];
        action: TupleAction ~ {
            PushAtom[frame, key];
            Push[frame, val];
            Execute[frame, x ! Exit => { quit Ź TRUE; CONTINUE }];
            };
        [] Ź DictForAll[dict, action];
        };

    ApplyAttachDict: CommandProc ~ {
        dict2: Dict ~ PopDict[frame];
        dict1: Dict ~ PopDict[frame];
        AttachDict[dict1, dict2];
        CacheClear[frame]; -- in case dict is on stack
        };

    ApplyDetachDict: CommandProc ~ {
        dict2: Dict ~ PopDict[frame];
        dict1: Dict ~ PopDict[frame];
        DetachDict[dict1, dict2];
        };

    ApplyDetachAll: CommandProc ~ {
        dict: Dict ~ PopDict[frame];
        DetachAll[dict];
        };

    ApplyAttachedForAll: CommandProc ~ {
        x: REF ~ Pop[frame];
        dict: Dict ~ PopDict[frame];
        action: DictAction ~ {
            PushDict[frame, dict];
            Execute[frame, x ! Exit => { quit Ź TRUE; CONTINUE }];
            };
        [] Ź AttachedForAll[dict, action];
        };

    ApplyKnown: CommandProc ~ {
        key: ATOM ~ PopKey[frame];
        dict: Dict ~ PopDict[frame];
        PushBool[frame, TryToGet[dict, key].found];
        };

    ApplyWhere: CommandProc ~ {
        key: ATOM ~ PopKey[frame];
        found: BOOL; where: Dict;
        [found, where] Ź Where[frame, key];
        IF found THEN PushDict[frame, where];
        PushBool[frame, found];
        };

    ApplyLoad: CommandProc ~ {
        key: ATOM ~ PopKey[frame];
        Push[frame, Load[frame, key]];
        };

    ApplyDef: CommandProc ~ {
        val: REF ~ Pop[frame];
        key: ATOM ~ PopKey[frame];
        Def[frame, key, val];
        };

    ApplyStore: CommandProc ~ {
        val: REF ~ Pop[frame];
        key: ATOM ~ PopKey[frame];
        Store[frame, key, val];
        };

    ApplyBegin: CommandProc ~ {
        dict: Dict ~ PopDict[frame];
        Begin[frame, dict];
        };

    ApplyEnd: CommandProc ~ {
        End[frame];
        };

    ApplyCurDict: CommandProc ~ {
        PushDict[frame, DictTop[frame]];
        };


    RegisterPrimitive[".dict", ApplyDict];
    RegisterPrimitive[".get", ApplyGet];
    RegisterPrimitive[".put", ApplyPut];
    RegisterPrimitive[".del", ApplyDel];
    RegisterPrimitive[".clrdict", ApplyClrDict];
    RegisterPrimitive[".known", ApplyKnown];
    RegisterPrimitive[".where", ApplyWhere];
    RegisterPrimitive[".def", ApplyDef];
    RegisterPrimitive[".load", ApplyLoad];
    RegisterPrimitive[".store", ApplyStore];
    RegisterPrimitive[".begin", ApplyBegin];
    RegisterPrimitive[".end", ApplyEnd];
    RegisterPrimitive[".dictforall", ApplyDictForAll];
    RegisterPrimitive[".curdict", ApplyCurDict];
    RegisterPrimitive[".attachdict", ApplyAttachDict];
    RegisterPrimitive[".detachdict", ApplyDetachDict];
    RegisterPrimitive[".attachedforall", ApplyAttachedForAll];
    RegisterPrimitive[".detachall", ApplyDetachAll];

    END.