InterpreterImpl.mesa
Copyright © 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
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;
Useful types
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,
context # NIL.
AMModel.ContextClass[context]
= one of: world, prog(global frame), interface(ir), proc(local frame)
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 {
PROC [data: REF, head: EvalHead, parent: Tree, msg: ROPE];
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] = {
returns first assignment in the tree
(where "first" is first in the preorder traversal)
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 types are equivalent, then just LOOPHOLE; if target is UNSPECIFIED, any 1-word match will do; if targetClass = givenClass, we have two special cases
IF EquivalentTypes[targetType, givenType]
OR (targetClass = unspecified AND TVSize[arg] = 1)
OR (targetClass = givenClass AND (targetClass = atom OR targetClass = rope))
THEN GOTO loophole;
strip off useless layers of record
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;
NIL is handled specially
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;
rtn ← AMTypes.New[fullType];
generate the default return
KLUDGE for conversion from REF opaque to REF concrete
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];
}};