
    <<AMModelInterfaceImpl.mesa>>
        <<Copyright © 1985 by Xerox Corporation.  All rights reserved.>>
        <<created by Rovner>>
        <<Russ Atkinson (RRA) November 12, 1985 3:13:15 pm PST>>

        DIRECTORY
            AMBridge USING [TVForGFHReferent, TVForRemoteGFHReferent],
            AMMiniModel USING [],
            AMTypes USING [Error, GlobalParent, IndexToTV, NameToIndex, TVToName, TVType, TypedVariable, UnderClass],
            Atom USING [GetPName, GetProp, MakeAtom, MapAtoms, PutProp],
            BcdDefs USING [NullVersion, VersionStamp],
            LoaderOps USING [IR, GetIR, IRRecord],
            LoadState USING [Acquire, ConfigID, CopiesList, EnumerateAllModules, local, ModuleIndex, ModuleInfo, Release],
            PrincOps USING [GlobalFrameHandle],
            Rope USING [Concat, Fetch, Length, ROPE, Substr],
            RTCommon USING [ShortenLongPointer],
            RTSymbolDefs USING [nullHandle, SymbolIdIndex, SymbolIndex, SymbolTableBase, SymbolTableHandle],
            RTSymbolOps USING [AcquireType, EnumerateCtxIseis, ISEPublic, ISEType, STBDirectoryCTX],
            RTSymbols USING [AcquireSTB, GetSTHForModule, ReleaseSTB],
            RTTypesBasicPrivate USING [MapTiTd],
            RTTypesPrivate USING [TypedVariableRec],
            RuntimeError USING [UNCAUGHT],
            SafeStorage USING [Type],
            VersionMap USING [MapList, RangeList, RangeToEntry, ShortNameToRanges],
            VersionMapDefaults USING [GetMapList],
            WorldVM USING [LocalWorld, World];
AMModelInterfaceImpl: PROGRAM
    IMPORTS AMBridge, AMTypes, Atom, LoaderOps, LoadState, Rope, RTCommon, RTSymbolOps, RTSymbols, RTTypesBasicPrivate, RuntimeError, 
    VersionMap, VersionMapDefaults, WorldVM
    EXPORTS AMMiniModel
    = BEGIN OPEN AMBridge, AMTypes, Rope, SafeStorage, RTSymbolDefs, RTSymbolOps, RTSymbols, RTTypesPrivate, WorldVM;

    World: TYPE = WorldVM.World;

    ImplementorName: PUBLIC SAFE PROC [defsName, itemName: ROPE, world: World _ NIL] RETURNS [ROPE] = TRUSTED {
        inst: TypedVariable;
        type: Type;
        item: TypedVariable;
        IF world = NIL THEN world _ WorldVM.LocalWorld[];
        {
            ENABLE RuntimeError.UNCAUGHT, AMTypes.Error => GOTO returnNil;
            inst _ GetInterfaceRecord[defsName, world];
            type _ TVType[inst];
            item _ IndexToTV[inst, NameToIndex[type, itemName]];
            IF item = NIL THEN GOTO returnNil;
            };
        SELECT AMTypes.UnderClass[TVType[item]] FROM
            procedure, signal, error => RETURN[TVToName[GlobalParent[item]]];
            program => RETURN[TVToName[item]];
            type, opaque => RETURN[defsName]; -- opaque types: not yet NOTE
            nil => RETURN[defsName];  -- may be an INLINE
            ENDCASE =>
                WITH item SELECT FROM
                    rtr: REF TypedVariableRec =>
                        WITH h: rtr.head SELECT FROM
                            gfh => RETURN[TVToName[TVForGFHReferent[h.gfh]]];
                            remoteGFH =>
                                RETURN[TVToName[TVForRemoteGFHReferent[h.remoteGlobalFrameHandle]]];
                            pointer => {
                                FindEnclosingGFH: PROC [p: POINTER] RETURNS [gfh: PrincOps.GlobalFrameHandle _ NIL] = {
                                    pInt: INT = LOOPHOLE[LONG[p], INT];
                                    minDel: INT _ 200000B;  -- some large number
                                    proc: PROC [ci: LoadState.ConfigID, mx: LoadState.ModuleIndex] RETURNS [stop: BOOL _ FALSE] = {
                                        tgfh: PrincOps.GlobalFrameHandle;
                                        copies: LoadState.CopiesList;
                                        del, gfhInt: INT;
                                        [gfh: tgfh, copies: copies] _ LoadState.local.ModuleInfo[ci, mx];
                                        gfhInt _ LOOPHOLE[LONG[tgfh], INT];
                                        del _ pInt-gfhInt;
                                        IF del >= 0 AND del < minDel THEN {gfh _ tgfh; minDel _ del};
                                        FOR c: LoadState.CopiesList _ copies, c.rest UNTIL c = NIL DO
                                            gfhInt _ LOOPHOLE[LONG[c.first], INT];
                                            del _ pInt-gfhInt;
                                            IF del >= 0 AND del < minDel THEN {gfh _ c.first; minDel _ del};
                                            ENDLOOP;
                                        };
                                    IF p = NIL THEN RETURN[NIL];
                                    LoadState.local.Acquire[];
                                    [] _ LoadState.local.EnumerateAllModules[newestFirst, proc
                                        ! UNWIND => LoadState.local.Release[]];
                                    LoadState.local.Release[];
                                    };
                                gfh: PrincOps.GlobalFrameHandle
                                    = FindEnclosingGFH[RTCommon.ShortenLongPointer[h.ptr]];
                                IF gfh # NIL
                                    THEN RETURN[TVToName[TVForGFHReferent[gfh]]]
                                    ELSE RETURN[NIL];
                                };
                            ENDCASE;
                ENDCASE;
        RETURN[NIL];
        EXITS returnNil => RETURN[NIL];
        };

    GetInterfaceRecord: PUBLIC SAFE PROC [defsName: ROPE, world: World] RETURNS [tv: TypedVariable _ NIL] = TRUSTED {
        ir: LoaderOps.IR;
        irType: REF Type;
        atom: ATOM = Atom.MakeAtom[defsName];
        version: BcdDefs.VersionStamp; 
        local: World _ WorldVM.LocalWorld[];
        SELECT world FROM
            NIL => world _ local;
            local => {};
            ENDCASE => ERROR Error[reason: notImplemented, msg: "access to remote IRs"];
        [interface: ir, versionStamp: version] _ LoaderOps.GetIR[atom: atom];
        IF ir = NIL THEN RETURN;
        irType _ NARROW[Atom.GetProp[atom, $IRType]];
        IF irType = NIL THEN {
            irType _ NEW[Type _ AcquireIRType[defsName, version]];
            Atom.PutProp[atom, $IRType, irType];
            };
        tv _ NEW[TypedVariableRec
            _ [referentType: [type: irType^],
                 head: [reference[ref: ir]],
                 field: embedded[fd: [wordOffset: SIZE[LoaderOps.IRRecord],
                 extent: large[size: ir.size]]]]];
        };

    GetInterfaceRecordFromType: PUBLIC SAFE PROC [type: Type, world: World] RETURNS [tv: TypedVariable _ NIL] = TRUSTED {
        ir: LoaderOps.IR;
        atom: ATOM;
        local: World _ WorldVM.LocalWorld[];
        SELECT world FROM
            NIL => world _ local;
            local => {};
            ENDCASE => ERROR Error[reason: notImplemented, msg: "access to remote IRs"];
        [name: atom, interface: ir]
            _ LoaderOps.GetIR[version: RTTypesBasicPrivate.MapTiTd[type].utf.umid];
        IF ir = NIL THEN RETURN;
        IF NARROW[Atom.GetProp[atom, $IRType], REF Type] = NIL THEN {
            Atom.PutProp[atom, $IRType, NEW[Type _ type]];
            };
        tv _ NEW[TypedVariableRec
            _ [referentType: [type: type],
                 head: [reference[ref: ir]],
                 field: embedded[fd: [wordOffset: SIZE[LoaderOps.IRRecord],
                 extent: large[size: ir.size]]]]];
        };

    GetInterfaceRecordNames: PUBLIC SAFE PROC [world: World] RETURNS [l: LIST OF ROPE _ NIL] = TRUSTED {
        p: SAFE PROC [atom: ATOM] = TRUSTED {
            IF Atom.GetProp[atom, $IR] # NIL THEN l _ CONS[Atom.GetPName[atom], l];
            };
        local: World _ WorldVM.LocalWorld[];
        SELECT world FROM
            NIL => world _ local;
            local => {};
            ENDCASE => ERROR Error[reason: notImplemented, msg: "access to remote IRs"];
        Atom.MapAtoms[p];
        };

    AcquireIRType: PUBLIC SAFE PROC [defsName: ROPE, version: BcdDefs.VersionStamp _ BcdDefs.NullVersion] RETURNS [type: Type] = 
    TRUSTED {
        irType: REF Type;
        irVersion: REF BcdDefs.VersionStamp;
        atom: ATOM = Atom.MakeAtom[defsName];
        stb: SymbolTableBase;
        seIndex: SymbolIndex;
        p: PROC [stb: SymbolTableBase, isei: SymbolIdIndex] RETURNS [stop: BOOL] = {
            IF (stop _ ISEPublic[stb, isei]) THEN seIndex _ ISEType[stb, isei];
            };
        irType _ NARROW[Atom.GetProp[atom, $IRType]];
        irVersion _ NARROW[Atom.GetProp[atom, $version]];
        IF irType # NIL AND irVersion # NIL
            AND (version = BcdDefs.NullVersion OR version = irVersion^)
            THEN RETURN[irType^];
        IF version = BcdDefs.NullVersion AND irVersion # NIL THEN version _ irVersion^;
        stb _ AcquireSTBForDefs[defsName, version];
        {
            ENABLE UNWIND => ReleaseSTB[stb];
            IF NOT EnumerateCtxIseis[stb: stb, ctx: STBDirectoryCTX[stb], proc: p] THEN ERROR;
            type _ AcquireType[stb: stb, seIndex: seIndex];
            };
        ReleaseSTB[stb];
        };

    AcquireSTBForDefs: PROC [fileName: ROPE, version: BcdDefs.VersionStamp _ BcdDefs.NullVersion] RETURNS [stb: SymbolTableBase] = {
        sth: SymbolTableHandle _ nullHandle;
        moduleName: ROPE _ NIL;
        len: INT _ Rope.Length[fileName];
        dot: INT _ len;
        pos: INT _ dot;
        angle: INT _ 0;
        WHILE pos > 0 DO
            SELECT Rope.Fetch[fileName, pos _ pos - 1] FROM
                '. => dot _ pos;
                '/, '>, '] => {angle _ pos+1; EXIT};
                ENDCASE;
            ENDLOOP;
        moduleName _ Rope.Substr[fileName, angle, dot-angle];
        IF dot = len THEN fileName _ Rope.Concat[fileName, ".bcd"];
        {
            ENABLE AMTypes.Error => IF version = BcdDefs.NullVersion THEN GO TO tryVersionMap;
            sth _ GetSTHForModule[stamp: version, fileName: fileName, moduleName: moduleName];
            stb _ AcquireSTB[sth];
            EXITS tryVersionMap => {
                <<At this point we can try the version map, since everything else has bombed>>
                mapList: VersionMap.MapList _ VersionMapDefaults.GetMapList[$Symbols];
                IF mapList # NIL THEN {
                    foundList: VersionMap.RangeList _ VersionMap.ShortNameToRanges[mapList, Rope.Concat[moduleName, ".bcd"]];
                    FOR each: VersionMap.RangeList _ foundList, each.rest WHILE each # NIL DO
                        IF each.first.len # 0 THEN {
                            [name: fileName, stamp: version] _ VersionMap.RangeToEntry[each.first];
                            IF version # BcdDefs.NullVersion THEN
                                RETURN AcquireSTBForDefs[fileName: fileName, version: version];
                            };
                        ENDLOOP;
                    ERROR AMTypes.Error[reason: noSymbols, msg: fileName];
                    };
                };
            };
        WITH stb SELECT FROM
            t: SymbolTableBase.x => IF t.e.stHandle.definitionsFile THEN RETURN;
            t: SymbolTableBase.y => IF t.e.stHandle.definitionsFile THEN RETURN;
            ENDCASE => ERROR;
        ReleaseSTB[stb];
        ERROR AMTypes.Error[
            reason: noSymbols,
            msg: Rope.Concat[fileName, " not a defs module (is it loaded?)"]
            ];
        };

    END.