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;

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,
 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 {
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,
	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] = {
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 EquivalentTypes[targetType, givenType]
OR (targetClass = unspecified AND TVSize[arg] = 1)
OR (targetClass = givenClass AND (targetClass = atom OR targetClass = rope))
THEN GOTO loophole;

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;
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];

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.

žInterpreterImpl.mesa
Russ Atkinson, May 2, 1983 5:26 pm
Paul Rovner, November 1, 1983 9:44 pm
Useful types
context # NIL.
AMModel.ContextClass[context]
= one of: world, prog(global frame), interface(ir), proc(local frame)
PROC [data: REF, head: EvalHead, parent: Tree, msg: ROPE];
returns first assignment in the tree
(where "first" is first in the preorder traversal)
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
strip off useless layers of record

NIL is handled specially
generate the default return
KLUDGE for conversion from REF opaque to REF concrete
Κ
Κ–

"cedar" style˜JšΟiœ™J™"Jš
œ%™%J˜š
Οk	˜	šœ	ž˜J˜z—Jšœžœ˜%JšœžœMžœ/˜‹
Jšœ	žœ˜Jšœžœ˜Jšœžœ˜,Jšœžœž
˜²
Jšœžœ˜Jšžœ
žœžœžœ˜-Jšœžœ	˜Jšœžœ˜$Jšœ
žœ!˜0Jšœ	žœ˜#Jšœžœ˜Jšœžœ	˜Jšœžœžœ˜Jšœžœ*˜;Jšœžœ˜Jšœžœ˜"J˜—šœž
˜š
ž˜Jšœ_žœ-˜Ž
—Jšžœ0˜7—J˜Jšœžœ
žœ*˜6J˜š
œ™Jšœ	žœ˜ Jšžœžœžœ
˜Jšžœžœžœ
žœ
˜Jšžœžœžœ
˜Jšœžœ˜J˜—Jšœžœžœžœ
˜/J˜šΟnœžœ
ž˜Jšœžœ
˜JšœžœΟc2˜LJšœžœ (˜DJšœžœžœ ˜?Jš
œ
˜
Jšžœ	žœžœ
žœžœžœžœžœ˜VJšœžœžœ
˜
š
œA˜AJšœžœ4žœ˜D—š	žœ
žœ
žœ
žœ
ž˜*šžœ˜Jšœ
žœžœ
˜šœžœ
žœžœ˜Jš	œžœ
žœžœ
žœ˜Jš
œ˜Jšœ	žœ˜Jš
œ˜—Jšœ"žœžœžœ˜FJšžœ
žœ/˜?Jš
œ˜——Jš
œ˜—J˜šŸœžœ
ž˜Jšœžœ
˜Jšœžœ 2˜LJšœžœ (˜DJšœžœžœ ˜?Jš
œ
˜
Jšžœ	žœžœ
žœžœ
žœžœ˜TšΟbœžœ
žœžœ
˜š
œ˜š
œ˜Jš
œD˜DJš
œ˜š
œ˜Jš
œ˜Jš
œ0˜0Jš
œ˜—Jšœ6žœ˜A——J˜—Jš	œ
žœ
žœžœ
žœ˜"J˜Jšžœžœ
žœ5˜JJšžœ
žœ
žœ˜.Jš
œ*˜*Jšœžœ˜(Jš
œ+˜+š
œ˜J˜——šŸœžœ
ž˜
procš
œ˜Kšœ
žœ
™š
œ™Kš
œE™E——Kšœ 
˜"Kšœžœžœ˜)Kšœ'žœžœ˜1Kšœ/žœžœ˜9Kšœ!žœžœ˜+Kšœ-žœžœ˜7Kšœ+žœžœ
˜4Kš
œ
˜
Jšžœ˜šžœ˜šžœ˜š
œ˜J˜J˜Kš
œ˜Kš
œ#˜#Kš
œ+˜+Kš
œ˜Kš
œ)˜)Kš
œ*˜*———J˜J˜—šœ(žœ˜1Jš
œ:™:Jšžœ˜!J˜J˜—šŸ	œžœ
žœžœ
ž	œžœžœ˜Tšžœ
˜š
œ˜Jš
œP˜PJš
œ˜——J˜J˜—š
Ÿœžœžœ
žœ
žœ˜9šžœžœ˜ Kšœ
žœ
˜Kšœ	žœ
˜Kš
œ˜š
œ˜š
œ
˜
Kš
œ˜š
œ˜Kšœžœ/˜9—Kš
œ˜Kš
œ˜——Kš	œžœ
žœ
žœžœ
˜MKš
œ˜—Kš
œ˜—J˜šŸœžœžœ˜4Jš
œ$™$Jš
œ2™2šžœžœ
žœ
˜šœžœ˜Jš
œ#˜#Jšœžœ˜%Jšžœžœ
žœ	˜%šžœžœ
žœžœ
˜!Jš
œ#˜#Jšžœžœ
žœ
žœ˜Jšžœ
˜——Jšžœ˜	—Jšžœžœ
˜J˜J˜—šŸœžœ
žœžœžœžœžœ˜MJšžœ˜Jš
œ1˜1J˜1J˜/J˜3Jšœ
žœ˜(J˜Jšžœžœ
žœ˜+J˜šœ
žœ
˜˜šžœž˜Jšœ žœ	˜-Jšžœžœ
˜J˜——Jš
œ—
™—
—šžœ'˜)Jšžœžœ˜2Jšžœžœžœ˜LJšžœ
žœ
˜J˜Jš
œ"™"—šžœžœž˜6Jšœžœ"˜(Jšžœžœ
žœ
˜J˜ J˜+J˜*Jšžœžœ
žœ˜,šžœ'˜)Jšžœžœžœ˜LJšžœ
žœ
˜—Jšžœ
˜J™—Jš
œ™—šžœž˜š
œΘ
˜Θ
šžœžœž˜4šžœ
ž˜JšœΙ
žœ˜η
Jšžœžœ	˜———šžœ
˜J˜—Jš
œ™—J˜˜Jš
œ5™5—š
žœžœžœ
žœ
žœ˜AJšœžœ˜!J˜&J˜*Jšžœ,žœ
žœ
˜AJ˜J˜—šžœ
ž˜˜7šœ
 9˜:Jšœžœ
žœ˜Jšœžœ
žœ˜J˜*J˜*Jšžœžœ
žœ˜.šžœžœ
˜J˜8J˜+J˜8˜gJšžœžœ
žœ	˜0Jšœžœ˜%Jš
œ˜—Jšžœžœ	˜—Jšœžœžœ
žœ˜"šžœ
ž˜Jšœžœžœ
žœ
˜7š
œ
˜
Jš
žœžœ
žœžœ
žœ	˜)J˜J˜—š
œ˜Jšžœžœ
žœ
žœžœžœ
žœ	˜9J˜J˜—˜J˜—˜Jšžœžœ
žœžœžœ
žœžœ
žœ	˜AJ˜J˜—Jšžœ˜!—Jšžœ˜J˜——Jšžœ
˜J˜$š
ž˜Jšœžœ$˜6Jšœžœ"žœ˜L—J˜J˜—šžœ
˜J˜——…— ή.F