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, LOOPHOLE[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 => {
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
Copyright c 1985 by Xerox Corporation.  All rights reserved.
Russ Atkinson, February 20, 1985 8:34:16 pm PST
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
these are cases not handled properly by AMTypes.Coerce
Κ
§–

"cedar" style˜
codešΟiœ™Kšœ
Οm
œ1™<K™/Kš
œ%™%—K˜š
Οk	˜	Kšœ	Ÿœ{˜‰
KšœŸœ˜%KšœŸœMŸœ/˜‹
Kšœ	Ÿœ˜KšœŸœ˜KšœŸœ˜,KšœŸœž
˜²
KšœŸœ˜KšŸœ
ŸœŸœŸœ˜-KšœŸœ	˜KšœŸœ˜$Kšœ
Ÿœ!˜0Kšœ	Ÿœ˜#KšœŸœ˜KšœŸœ	˜KšœŸœŸœ˜KšœŸœ*˜;KšœŸœ˜KšœŸœ˜"K˜—šœŸ
˜KšŸœ`Ÿœ-˜–
KšŸœ0˜7KšœŸœ
Ÿœ*˜6—K˜š
œ™Kšœ	Ÿœ˜ KšŸœŸœŸœ
˜KšŸœŸœŸœ
Ÿœ
˜KšŸœŸœŸœ
˜KšœŸœ˜K˜—KšœŸœŸœŸœ
˜/K˜šΟnœŸœ
Ÿ˜KšœŸœ
˜KšœŸœΟc2˜LKšœŸœ‘(˜DKšœŸœŸœ‘˜?Kš
œ
˜
KšŸœ	ŸœŸœ
ŸœŸœŸœŸœŸœ˜VKšœŸœŸœ
˜
š
œA˜AKšœŸœ4Ÿœ˜D—š	Ÿœ
Ÿœ
Ÿœ
Ÿœ
Ÿ˜*šŸœ˜Kšœ
ŸœŸœ
˜šœŸœ
ŸœŸœ˜Kš	œŸœ
ŸœŸœ
Ÿœ˜Kš
œ˜Kšœ	Ÿœ˜Kš
œ˜—Kšœ"ŸœŸœŸœ˜FKšŸœ
Ÿœ/˜?Kš
œ˜——Kš
œ˜—K˜š œŸœ
Ÿ˜KšœŸœ
˜KšœŸœ‘2˜LKšœŸœ‘(˜DKšœŸœŸœ‘˜?Kš
œ
˜
KšŸœ	ŸœŸœ
ŸœŸœ
ŸœŸœ˜TšΟbœŸœ
ŸœŸœ
˜š
œ˜š
œ˜Kš
œD˜DKš
œ˜š
œ˜Kš
œ˜Kš
œ0˜0Kš
œ˜—Kšœ6Ÿœ˜A——K˜—Kš	œ
Ÿœ
ŸœŸœ
Ÿœ˜"K˜KšŸœŸœ
Ÿœ5˜JKšŸœ
Ÿœ
Ÿœ˜.Kš
œ*˜*KšœŸœ˜(Kš
œ+˜+š
œ˜K˜——š œŸœ
Ÿ˜š
œ˜Kšœ
Ÿœ
™š
œ™Kš
œE™E——Kšœ‘
˜"KšœŸœŸœ˜)Kšœ'ŸœŸœ˜1Kšœ/ŸœŸœ˜9Kšœ!ŸœŸœ˜+Kšœ-ŸœŸœ˜7Kšœ+ŸœŸœ
˜4Kš
œ
˜
KšŸœ˜šŸœ˜šŸœ˜š
œ˜K˜K˜Kš
œ˜Kš
œ#˜#Kš
œ+˜+Kš
œ˜Kš
œ)˜)Kš
œ*˜*———K˜K˜—šœ(Ÿœ˜1Kš
œ:™:KšŸœ˜!K˜K˜—š 	œŸœ
ŸœŸœ
Ÿ	œŸœŸœ˜TšŸœ
˜š
œ˜Kš
œP˜PKš
œ˜——K˜K˜—š œŸœŸœ
Ÿœ
ŸœŸœŸœ˜Yšœ
Ÿœ
˜Kšœ	Ÿœ
˜Kš
œ˜š
œ˜KšœŸœŸœ:˜w—Kš	œŸœ
Ÿœ
ŸœŸœ
˜MKš
œ˜—Kš
œ˜—K˜š œŸœŸœ˜4Kš
œ$™$Kš
œ2™2šŸœŸœ
Ÿœ
˜šœŸœ˜Kš
œ#˜#KšœŸœ˜%KšŸœŸœ
Ÿœ	˜%šŸœŸœ
ŸœŸœ
˜!Kš
œ#˜#KšŸœŸœ
Ÿœ
Ÿœ˜KšŸœ
˜——KšŸœ˜	—KšŸœŸœ
˜K˜K˜—š œŸœ
ŸœŸœŸœŸœŸœ˜MKšŸœ˜Kš
œ1˜1K˜1K˜/K˜3Kšœ
Ÿœ˜(K˜KšŸœŸœ
Ÿœ˜+K˜šœ
Ÿœ
˜˜šŸœŸ˜Kšœ Ÿœ	˜-KšŸœŸœ
˜K˜——Kš
œ—
™—
—šŸœ'˜)KšŸœŸœ˜2KšŸœŸœŸœ˜LKšŸœ
Ÿœ
˜K˜Kš
œ"™"—šŸœŸœŸ˜6KšœŸœ"˜(KšŸœŸœ
Ÿœ
˜K˜ K˜+K˜*KšŸœŸœ
Ÿœ˜,šŸœ'˜)KšŸœŸœŸœ˜LKšŸœ
Ÿœ
˜—KšŸœ
˜K™—Kš
œ™šŸœŸ˜š
œΘ
˜Θ
šŸœŸœŸ˜4šŸœ
Ÿ˜KšœΙ
Ÿœ˜η
KšŸœŸœ	˜———šŸœ
˜K˜——K˜Kš
œ™K˜Kš
œ5™5š
ŸœŸœŸœ
Ÿœ
Ÿœ˜AKšœŸœ˜!K˜&K˜*KšŸœ,Ÿœ
Ÿœ
˜AK˜K˜—šŸœ
Ÿ˜š
œ9˜9Kš
œ6™6KšœŸœ
Ÿœ˜KšœŸœ
Ÿœ˜K˜*K˜*KšŸœŸœ
Ÿœ˜.šŸœŸœ
˜K˜8K˜+K˜8˜gKšŸœŸœ
Ÿœ	˜0KšœŸœ˜%Kš
œ˜—KšŸœŸœ	˜—KšœŸœŸœ
Ÿœ˜"šŸœ
Ÿ˜KšœŸœŸœ
Ÿœ
˜7š
œ
˜
Kš
ŸœŸœ
ŸœŸœ
Ÿœ	˜)K˜K˜—š
œ˜KšŸœŸœ
Ÿœ
ŸœŸœŸœ
Ÿœ	˜9K˜K˜—˜K˜—˜KšŸœŸœ
ŸœŸœŸœ
ŸœŸœ
Ÿœ	˜AK˜K˜—KšŸœ˜!—KšŸœ˜K˜—KšŸœ
˜K˜$š
Ÿ˜KšœŸœ$˜6KšœŸœ"Ÿœ˜L—K˜K˜——šŸœ
˜K˜——…— ¦.m