[Cyan]<Cedar6.0>AMModel>AMModelInterfaceImpl.Mesa!5

AMModelInterfaceImpl.mesa

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;

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.