DIRECTORY AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandExtras, CommandTool, EvalQuote, Interpreter, InterpreterOps, InterpreterPrivate, IO, List, PPLeaves, PPP1, PPTree, PPTreeOps, PrincOps, PrincOpsUtils, PrintTV, ProcessProps, Real, Rope, SafeStorage, StatementInterpreter, StatementInterpreterPrivate, SymTab, SymTabImpl, WorldVM;

StatementCommands: CEDAR PROGRAM
IMPORTS AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandExtras, CommandTool, EvalQuote, InterpreterOps, InterpreterPrivate, IO, List, PPP1, PPTreeOps, PrincOpsUtils, ProcessProps, Real, Rope, StatementInterpreter, StatementInterpreterPrivate, SymTab, SymTabImpl, WorldVM
EXPORTS StatementInterpreter, StatementInterpreterPrivate, SymTab
SHARES SymTabImpl =

BEGIN OPEN StatementInterpreter, StatementInterpreterPrivate;

SymbolTable: TYPE = REF SymTabRep;
SymTabRep: PUBLIC TYPE = SymTabImpl.SymTabRep;

empty: PUBLIC TV _ AMTypes.GetEmptyTV[];
typeType: PUBLIC Type;

Exit: PUBLIC ERROR = CODE;
Loop: PUBLIC ERROR = CODE;
Return: PUBLIC ERROR [fields: Fields] = CODE;
Resume: PUBLIC ERROR [fields: Fields] = CODE;
GoTo: PUBLIC ERROR [label: ROPE] = CODE;
DecideSignal: PUBLIC ERROR [decision: BasicSignalDecisionType] = CODE;

NarrowToSymbolTable: PUBLIC PROC [ra: REF ANY] RETURNS [st: SymbolTable] = {
st _ NARROW[ra];
};

StatementCommand: PROC [cmd: Commander.Handle] RETURNS [result: REF _ NIL, msg: ROPE _ NIL] --Commander.CommandProc-- = {
blockAsRope: ROPE _ Rope.Cat["{", cmd.commandLine];
len: INT _ blockAsRope.Length[];
errorRope: ROPE;
head: InterpreterOps.EvalHead = NARROW[List.Assoc[$EvalHead, ProcessProps.GetPropList[]]];
context: AMModel.Context;
symTab: SymbolTable;
IF len < 1 THEN RETURN;
IF blockAsRope.Fetch[len-1] = '\n THEN blockAsRope _ blockAsRope.Substr[len: len - 1];
IF head = NIL
THEN TRUSTED {context _ AMModel.RootContext[WorldVM.LocalWorld[]]}
ELSE {
context _ head.context;
IF context = NIL
THEN TRUSTED {context _ AMModel.RootContext[InterpreterOps.WorldFromHead[head]]};
};
TRUSTED {symTab _ NarrowToSymbolTable[List.Assoc[$SymTab, cmd.propertyList]]};
IF symTab = NIL THEN {
symTab _ SymTab.Create[];
[] _ List.PutAssoc[key: $SymTab, val: symTab, aList: cmd.propertyList];
};
errorRope _ InterpretStatement[blockAsRope, context, symTab];
IF errorRope # NIL THEN cmd.out.PutRope[Rope.Cat["Error: ", errorRope, "\n"]];
};

InterpretStatement: PUBLIC PROC [blockAsRope: ROPE, context: Context _ NIL, symTab: SymbolTable _ NIL, abort: InterpreterOps.AbortClosure _ Interpreter.nilAbortClosure] RETURNS [errorRope: ROPE] = {
Inner: PROC = {
bodyTree: Tree _ ParseBlock[blockAsRope, errorStream];
Interp[
asTree: bodyTree,
head: InterpreterOps.NewEvalHead[
context: context,
specials: symTab,
helpFatalClosure: [myHelpFatal, errorStream],
abortClosure: abort],
nest: FALSE
!FatalInterpreterError => {errorStream.PutRope[msg]; CONTINUE}];
};
errorStream: IO.STREAM _ IO.ROS[];
IF context = NIL THEN TRUSTED {context _ AMModel.RootContext[WorldVM.LocalWorld[]]};
IF symTab = NIL THEN symTab _ SymTab.Create[];
errorStream.PutRope[BackStop.Call[Inner]];
errorRope _ IO.RopeFromROS[errorStream];
};

FatalInterpreterError: ERROR[msg: ROPE] = CODE;
myHelpFatal: PROC [data: REF, head: EvalHead, parent: Tree, msg: ROPE] --InterpreterOps.HelpFatal-- = TRUSTED {
ERROR FatalInterpreterError[msg];
};

First: PROC [nn: PPTree.NodeName, in: Tree] RETURNS [out: Tree] = {
IF in = NIL THEN RETURN [NIL];
WITH in SELECT FROM
n: Node => {
IF n.name = nn THEN RETURN [n];
FOR i: NAT IN [1 .. n.sonLimit) DO
out _ First[nn, n.son[i]];
IF out # NIL THEN RETURN;
ENDLOOP};
ENDCASE;
out _ NIL};

Interp: PUBLIC PROC [asTree: Tree, head: EvalHead, nest: BOOL _ TRUE] = {
Inner: PROC = {InterpNoProps[NARROW[asTree], head, nest]};
ProcessProps.AddPropList[List.PutAssoc[$EvalHead, head, NIL], Inner];
};

InterpNoProps: PUBLIC PROC [tree: Tree, head: EvalHead, nest: BOOL _ TRUE] = {
IF tree # NIL THEN WITH tree SELECT FROM
node: Node => {
SELECT node.name FROM
list => FOR i: NAT IN[1 .. node.sonLimit) DO
InterpNoProps[node.son[i], head];
ENDLOOP;
assignx, assign, extractx, extract => [] _ EvalExpr[node, head];
apply => TryApplyCatch[node, head];
body => EvalBody[node, head, nest];
block => EvalBlock[node, head, nest];
if => EvalIf[node, head];
do => EvalDo[node, head];
label => EvalLabelled[node, head];
return => EvalReturn[node, head];
resume => EvalResume[node, head];
exit => ERROR Exit;
loop => ERROR Loop;
goto => {name: PPLeaves.HTIndex _ NARROW[node.son[1]];
ERROR GoTo[name.name]};
reject => ERROR DecideSignal[Reject];
retry => ERROR DecideSignal[Retry];
continue => ERROR DecideSignal[Continue];
null => NULL;
enable => {
EvalInner: PROC = {InterpNoProps[NARROW[node.son[2]], head]};
Enable[NARROW[node.son[1]], head, EvalInner];
};
syserror => {
SIGNAL BackStop.SuspendBackStop[];
ERROR;
}
ENDCASE => GOTO NYI;
EXITS
NYI => BBUrpEval.UrpFatal[head, node, Rope.Cat["Not Implemented: ", nodeNames[node.name]]];
};
ENDCASE => [] _ EvalExpr[tree, head];
};

EvalExpr: PUBLIC PROC [tree: Tree, head: EvalHead, target: Type _ nullType] RETURNS [tv: TV] =
{tv _ InterpreterPrivate.EvalNoProps[tree, head, target]};

TryApplyCatch: PROC [node: Node, head: EvalHead] = {
IF node.sonLimit = 4 THEN {
third: Tree _ node.son[3];
WITH third SELECT FROM
n: Node => IF n.name = catch THEN {
DoCall: PROC = {[] _ EvalExpr[node, head]};
Enable[catches: n, head: head, inner: DoCall];
RETURN};
ENDCASE;
};
[] _ EvalExpr[node, head];
};

EvalIf: PROC [node: Node, head: EvalHead] = {
cond: Tree = node.son[1];
thenClause: Node = NARROW[node.son[2]];
elseClause: Node = NARROW[node.son[3]];
ans: BOOL _ ForceBoolean[EvalExpr[cond, head, underBOOL], head, cond];
InterpNoProps[IF ans THEN thenClause ELSE elseClause, head];
};

EvalLabelled: PROC [node: Node, head: EvalHead] = {
stmt: Tree _ node.son[1];
exits: Node _ NARROW[node.son[2]];
InterpNoProps[stmt, head !GoTo => IF MatchingLabel[label, exits, head] THEN CONTINUE];
};

MatchingLabel: PROC [label: ROPE, exits: Node, head: EvalHead] RETURNS [match: BOOL] = {
SELECT exits.name FROM
item => {name: PPLeaves.HTIndex _ NARROW[exits.son[1]];
IF match _ label.Equal[name.name]
THEN InterpNoProps[exits.son[2], head]};
list => {
FOR i: NAT IN [1 .. exits.sonLimit) DO
IF MatchingLabel[label, NARROW[exits.son[i]], head] THEN RETURN [TRUE];
ENDLOOP;
match _ FALSE};
ENDCASE => ERROR};

EvalDo: PROC [node: Node, head: EvalHead] = {
for: Node _ NARROW[node.son[1]];
test: Tree _ node.son[2];
opens: Tree _ node.son[3];
body: Node _ NARROW[node.son[4]];
exits: Node _ NARROW[node.son[5]];
finishedExit: Node _ NARROW[node.son[6]];
LoopWork: PROC [Initial, Delta: PROC RETURNS [INT], Test: PROC RETURNS [BOOL]] = {
FOR i: INT _ Initial[], Delta[] WHILE Test[] DO
InterpNoProps[body, head !
Exit => EXIT;
Loop => CONTINUE;
GoTo => IF MatchingLabel[label, exits, head] THEN EXIT;
];
REPEAT
FINISHED => InterpNoProps[finishedExit, head];
ENDLOOP};
IF for = NIL THEN {
Dull: PROC RETURNS [i: INT] = {i _ 1};
Vanilla: PROC RETURNS [b: BOOL] = {b _ test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test]};
LoopWork[Dull, Dull, Vanilla]}
ELSE SELECT for.name FROM
forseq => {
cv: PPLeaves.HTIndex;
ctl: Tree = for.son[1];
initial: Tree = for.son[2];
delta: Tree = for.son[3];
InitialFor: PROC RETURNS [i: INT] = {
EvalAssign[cv, initial, head];
i _ 0};
DeltaFor: PROC RETURNS [i: INT] = {
EvalAssign[cv, delta, head];
i _ 1};
TestFor: PROC RETURNS [b: BOOL] = {
b _ test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test]};
WITH ctl SELECT FROM
hti: PPLeaves.HTIndex => cv _ hti;
n: Node => {IF n.name # decl THEN ERROR;
head _ NestHead[head];
AddDecls[head, n];
cv _ NARROW[n.son[1]]};
ENDCASE => ERROR;
LoopWork[InitialFor, DeltaFor, TestFor];
};
upthru, downthru => {
ctl: Tree = for.son[1];
range: Tree = for.son[2];
unknown: Tree = for.son[3];
ctv, cur: TV;
rangeType: Type;
int: Interval;
inRange: BOOL;
InitialUp: PROC RETURNS [i: INT] = {
[cur, inRange] _ IntFirst[int, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
DeltaUp: PROC RETURNS [i: INT] = {
[cur, inRange] _ IntNext[int, ctv, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
TestRange: PROC RETURNS [b: BOOL] = {
b _ inRange AND (test = NIL OR ForceBoolean[EvalExpr[test, head, underBOOL], head, test])};
InitialDown: PROC RETURNS [i: INT] = {
[cur, inRange] _ IntLast[int, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
DeltaDown: PROC RETURNS [i: INT] = {
[cur, inRange] _ IntPrev[int, ctv, head, range];
IF inRange THEN AMTypes.Assign[ctv, cur]};
IF unknown # NIL THEN ERROR;
IF ctl = NIL
THEN {
int _ EvalInterval[range, head, nullType];
ctv _ AMTypes.Copy[int.low]}
ELSE WITH ctl SELECT FROM
hti: PPLeaves.HTIndex => {
ctv _ EvalExpr[hti, head];
rangeType _ AMTypes.TVType[ctv];
int _ EvalInterval[range, head, rangeType]};
n: Node => {name: Tree _ n.son[1];
type: Tree _ n.son[2];
IF n.name # decl THEN ERROR;
head _ NestHead[head];
AddDecls[head, n];
ctv _ EvalExpr[name, head];
rangeType _ AMTypes.TVType[ctv];
int _ EvalInterval[range, head, rangeType]};
ENDCASE => ERROR;
SELECT for.name FROM
upthru => LoopWork[InitialUp, DeltaUp, TestRange];
downthru => LoopWork[InitialDown, DeltaDown, TestRange];
ENDCASE => ERROR;
};
ENDCASE => ERROR;
};

EvalInterval: PROC [tree: Tree, head: EvalHead, target: Type] RETURNS [int: Interval] =
BEGIN
node: Node _ IF ISTYPE[tree, Node] THEN NARROW[tree] ELSE NIL;
intC: BOOL _ TRUE;
int _ NEW [IntervalRep _ []];
IF node = NIL THEN intC _ FALSE
ELSE SELECT node.name FROM
intOO => int.lowClosed _ int.highClosed _ FALSE;
intOC => int.lowClosed _ NOT (int.highClosed _ TRUE);
intCO => int.lowClosed _ NOT (int.highClosed _ FALSE);
intCC => int.lowClosed _ int.highClosed _ TRUE;
ENDCASE => intC _ FALSE;
IF intC
THEN {
lowTree: Tree _ node.son[1];
highTree: Tree _ node.son[2];
int.low _ EvalExpr[lowTree, head, target];
int.high _ EvalExpr[highTree, head, target];
}
ELSE {
type: Type _ ForceType[EvalExpr[tree, head, typeType], head, tree];
int.low _ AMTypes.First[type];
int.high _ AMTypes.Last[type];
int.lowClosed _ int.highClosed _ TRUE;
};
END;

IntFirst: PROC [int: Interval, head: EvalHead, parent: Tree] RETURNS [first: TV, inRange: BOOL] =
BEGIN
rtv: TV;
first _ int.low;
IF NOT int.lowClosed THEN first _ AMTypes.Next[first];
IF first = NIL THEN RETURN [NIL, FALSE];
rtv _ EvalBinop[first, int.high, IF int.highClosed THEN relLE ELSE relL, head, underBOOL, parent];
inRange _ SELECT rtv FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;

IntNext: PROC [int: Interval, cur: TV, head: EvalHead, parent: Tree] RETURNS [next: TV, inRange: BOOL] =
BEGIN
rtv: TV;
next _ AMTypes.Next[cur];
IF next = NIL THEN RETURN [NIL, FALSE];
rtv _ EvalBinop[next, int.high, IF int.highClosed THEN relLE ELSE relL, head, underBOOL, parent];
inRange _ SELECT rtv FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;

IntLast: PROC [int: Interval, head: EvalHead, parent: Tree] RETURNS [last: TV, inRange: BOOL] =
BEGIN
rtv: TV;
last _ int.high;
IF NOT int.highClosed THEN last _ Prev[last, head, parent];
IF last = NIL THEN RETURN [NIL, FALSE];
rtv _ EvalBinop[last, int.low, IF int.lowClosed THEN relGE ELSE relG, head, underBOOL, parent];
inRange _ SELECT rtv FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;

IntPrev: PROC [int: Interval, cur: TV, head: EvalHead, parent: Tree] RETURNS [prev: TV, inRange: BOOL] =
BEGIN
rtv: TV;
prev _ Prev[cur, head, parent];
IF prev = NIL THEN RETURN [NIL, FALSE];
rtv _ EvalBinop[prev, int.low, IF int.lowClosed THEN relGE ELSE relG, head, underBOOL, parent];
inRange _ SELECT rtv FROM
true => TRUE,
false => FALSE,
ENDCASE => ERROR;
END;

Prev: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [prev: TV] =
{IF AMTypes.TVEqual[tv, AMTypes.First[AMTypes.TVType[tv]]] THEN RETURN [NIL];
prev _ EvalBinop[tv, one, minus, head, nullType, parent]};

true, false, one: TV _ NIL;

EvalBinop: PROC [lval, rval: TV, kind: PPTree.NodeName, head: EvalHead, target: Type, parent: Tree] RETURNS [rtn: TV _ NIL] = {
op: PPTree.NodeName _ kind;
ltype, rtype, ttype, altype, artype: Type;
lclass, rclass, alclass, arclass, targClass: AMTypes.Class;
rtnBit: BOOL;
ttype _ AMTypes.TVType[lval];
ltype _ AMTypes.UnderType[ttype];
lclass _ AMTypes.TypeClass[ltype];
IF target = nullType THEN target _ ttype;
rtype _ AMTypes.UnderType[AMTypes.TVType[rval]];
rclass _ AMTypes.TypeClass[rtype];
targClass _ AMTypes.TypeClass[AMTypes.GroundStar[target]];
SELECT kind FROM
relE, relN =>
SELECT lclass FROM
subrange, cardinal, integer, character, longInteger, longCardinal,
real, unspecified => -- these values must be arithmetic
op _ minus
ENDCASE => {
eq: BOOL _ AMTypes.TVEqual[lval, rval];
IF kind = relN THEN eq _ NOT eq;
RETURN [IF eq THEN true ELSE false];
};
relL, relGE, relG, relLE => op _ minus
ENDCASE; 


lval _ ForceArithmetic[lval, head, parent];
altype _ AMTypes.UnderType[AMTypes.TVType[lval]];
alclass _ AMTypes.TypeClass[altype];
rval _ ForceArithmetic[rval, head, parent];
artype _ AMTypes.UnderType[AMTypes.TVType[rval]];
arclass _ AMTypes.TypeClass[artype];
IF alclass = real OR arclass = real THEN TRUSTED {
-- raise conciousness to the real level
lreal: REAL _ AMBridge.TVToReal[lval];
rreal: REAL _ AMBridge.TVToReal[rval];
IF lclass # real THEN lreal _ AMBridge.TVToLI[lval];
IF rclass # real THEN rreal _ AMBridge.TVToLI[rval];
SELECT op FROM
plus => lreal _ lreal + rreal;
minus => lreal _ lreal - rreal;
times => lreal _ lreal * rreal;
div => lreal _ lreal / rreal;
mod => lreal _ Real.FRem[lreal, rreal];
min => lreal _ MIN[lreal, rreal];
max => lreal _ MAX[lreal, rreal]
ENDCASE => ERROR;
SELECT kind FROM
relE => rtnBit _ lreal = 0.0;
relN => rtnBit _ lreal # 0.0;
relL => rtnBit _ lreal < 0.0;
relGE => rtnBit _ lreal >= 0.0;
relG => rtnBit _ lreal > 0.0;
relLE => rtnBit _ lreal <= 0.0;
ENDCASE => IF targClass = enumerated THEN BBUrpEval.UrpFatal[head, parent, "can't do REAL arithmatic with enumerated values"] ELSE RETURN [InterpreterPrivate.NewReal[lreal]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
};
TRUSTED {
lint: INT _ AMBridge.TVToLI[lval];
rint: INT _ AMBridge.TVToLI[rval];
SELECT op FROM
plus => lint _ lint + rint;
minus => lint _ lint - rint;
times => lint _ lint * rint;
div => lint _ lint / rint;
mod => lint _ lint MOD rint;
min => lint _ MIN[lint, rint];
max => lint _ MAX[lint, rint]
ENDCASE => ERROR;
SELECT kind FROM
relE => rtnBit _ lint = 0;
relN => rtnBit _ lint # 0;
relL => rtnBit _ lint < 0;
relGE => rtnBit _ lint >= 0;
relG => rtnBit _ lint > 0;
relLE => rtnBit _ lint <= 0;
ENDCASE => IF targClass = enumerated
THEN {new: TV _ AMTypes.New[target];
AMBridge.SetTVFromLC[new, LOOPHOLE[lint]];
RETURN [new]}
ELSE RETURN [InterpreterPrivate.NewInt[lint]];
IF rtnBit THEN RETURN [true] ELSE RETURN [false];
}
}; 

ForceArithmetic: PROC [val: TV, head: EvalHead, parent: Tree] RETURNS [rtn: TV] = TRUSTED {
type: Type;
ground: Type;
class: AMTypes.Class;
rtn _ StripSingleComponentRecord[val];
type _ AMTypes.TVType[rtn];
ground _ AMTypes.GroundStar[type];
class _ AMTypes.TypeClass[ground];
SELECT class FROM
real =>
IF type # ground THEN rtn _ InterpreterPrivate.NewReal[AMBridge.TVToReal[rtn]];
cardinal, character, unspecified =>
rtn _ InterpreterPrivate.NewInt[AMBridge.TVToCardinal[rtn]];
integer =>
rtn _ InterpreterPrivate.NewInt[AMBridge.TVToInteger[rtn]];
longCardinal =>
rtn _ InterpreterPrivate.NewInt[LOOPHOLE[AMBridge.TVToLC[rtn], INT]];
longInteger =>
IF type # ground THEN rtn _ InterpreterPrivate.NewInt[AMBridge.TVToLI[rtn]];
enumerated => rtn _ InterpreterPrivate.NewInt[AMBridge.TVToCardinal[rtn]];
ENDCASE => BBUrpEval.UrpFatal[head, parent, "not a number"];
}; 

EvalAssign: PROC [name: PPLeaves.HTIndex, valueT: Tree, head: EvalHead] = {
n: Node _ NEW [PPTree.Node[assTemp.sonLimit]];
n.name _ assTemp.name;
n.attr _ assTemp.attr;
n.info _ assTemp.info;
n.son[1] _ name;
n.son[2] _ valueT;
IF assTemp.sonLimit # 3 THEN ERROR;
[] _ InterpNoProps[n, head]};

assTemp: Node _ NARROW[First[assign, ParseBlock["{x _ 1}", IO.ROS[]]]];

EvalBody: PROC [node: Node, head: EvalHead, nest: BOOL] = {
opens: Node _ NARROW[node.son[1]];
decls: Node _ NARROW[node.son[2]];
stmts: Node _ NARROW[node.son[3]];
IF decls # NIL THEN {
IF nest THEN head _ NestHead[head];
AddDecls[head, decls]};
InterpNoProps[stmts, head];
};

EvalBlock: PROC [node: Node, head: EvalHead, nest: BOOL] = {
decls: Node _ NARROW[node.son[1]];
stmts: Node _ NARROW[node.son[2]];
IF decls # NIL THEN {
IF nest THEN head _ NestHead[head];
AddDecls[head, decls]};
InterpNoProps[stmts, head];
};

NestHead: PUBLIC PROC [outer: EvalHead, st: SymbolTable _ NIL] RETURNS [inner: EvalHead] =
BEGIN
found: BOOL;
sttv, sttv2: TV;
IF st = NIL THEN st _ outer.specials;
inner _ NEW [InterpreterOps.EvalHeadRep _ outer^];
inner.specials _ CopySymbolTable[st];
[found, sttv] _ inner.specials.Fetch["&EvalQuoteSymTab"];
IF found THEN {
eqst, eqst2: SymbolTable;
TRUSTED {eqst _ NarrowToSymbolTable[AMBridge.RefFromTV[sttv]]};
eqst2 _ CopySymbolTable[eqst];
TRUSTED {sttv2 _ AMBridge.TVForReferent[eqst2]};
[] _ inner.specials.Store["&EvalQuoteSymTab", sttv2]};
END;

CopySymbolTable: PROC [old: SymbolTable] RETURNS [new: SymbolTable] =
BEGIN
ToNew: PROC [key: SymTab.Key, val: SymTab.Val] RETURNS [quit: BOOL] --SymTab.EachPairAction-- =
{[] _ SymTab.Store[new, key, val]; quit _ FALSE};
new _ SymTab.Create[];
[] _ SymTab.Pairs[old, ToNew];
END;

AddDecls: PROC [head: EvalHead, decls: Node] = {
AddDecl: PROC [namesT, typeT, valueT: Tree] = {
IF typeT # NIL AND valueT # NIL AND ISTYPE[typeT, Node] AND ISTYPE[valueT, Node]
THEN {
PerName: PROC [nameT: Tree] =
{AddProcDecl[NARROW[nameT], typeN, bodyN, head]};
typeN: Node = NARROW[typeT];
bodyN: Node _ NARROW[valueT];
IF typeN.name = procTC THEN {
PPTreeOps.ScanList[namesT, PerName];
RETURN}};
--otherwise--{
PerName: PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
[] _ head.specials.Store[name.name, val];
};
type: Type _ ForceType[EvalExpr[typeT, head, typeType], head, typeT];
val: TV _ AMTypes.New[type];
IF valueT # NIL THEN AMTypes.Assign[val, EvalExpr[valueT, head, type]];
PPTreeOps.ScanList[namesT, PerName];
}
};
AddTypeDecl: PROC [namesT, typeT: Tree] = {
PerName: PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
[] _ head.specials.Store[name.name, val];
};
type: Type _ ForceType[EvalExpr[typeT, head, typeType], head, typeT];
val: TV;
TRUSTED {val _ AMBridge.TVForType[type]};
PPTreeOps.ScanList[namesT, PerName];
};
SELECT decls.name FROM
decl => AddDecl[decls.son[1], decls.son[2], decls.son[3]];
typedecl => AddTypeDecl[decls.son[1], decls.son[2]];
list => FOR i: NAT IN [1 .. decls.sonLimit) DO
AddDecls[head, NARROW[decls.son[i]]];
ENDLOOP;
ENDCASE => ERROR};

AddProcDecl: PROC [nameT: PPLeaves.HTIndex, procTypeC, body: Node, head: EvalHead] = {
procArgs: Node _ NARROW[procTypeC.son[1]];
procRets: Node _ NARROW[procTypeC.son[2]];
l: Lambda _ NEW[LambdaRep _ [
name: nameT.name,
args: DigestFields[procArgs, TRUE, FALSE, head],
rets: DigestFields[procRets, TRUE, FALSE, head],
body: body,
symbols: head.specials]];
IF l.name.Length[] < 2 OR l.name.Fetch[0] # '& THEN BBUrpEval.UrpFatal[head, nameT, "Can only fake &-procs"];
IF l.rets.length > 1 THEN BBUrpEval.UrpFatal[head, procTypeC, "Can't handle more than one return"];
EvalQuote.Register[l.name, EvalProcedure, head.specials, l];
};

ParseModule: PUBLIC PROC [asRope: ROPE, errout: IO.STREAM] RETURNS [asTree: Tree] = {
complete: BOOL;
nErrors: CARDINAL;
PPTreeOps.Initialize[];
TRUSTED {[complete, , nErrors] _ PPP1.Parse[
asRope,
LOOPHOLE[PrincOpsUtils.Codebase[LOOPHOLE[CBinary.MesaTab, PrincOps.GlobalFrameHandle]]],
errout
]};
asTree _ IF complete AND nErrors = 0 THEN PPTreeOps.PopTree[] ELSE PPTree.Null;
PPTreeOps.Finalize[];
};

ParseBlock: PUBLIC PROC [asRope: ROPE, errout: IO.STREAM] RETURNS [asTree: Tree] = {
asRope _ Rope.Cat["Block: PROGRAM = ", asRope, "."];
asTree _ ParseModule[asRope: asRope, errout: errout];
asTree _ First[body, asTree];
};

StripSingleComponentRecord: PROC [tv: TV, max: NAT _ 100] RETURNS [rtn: TV] = TRUSTED {
rtn _ tv;
THROUGH [0..max) DO
under: Type = AMTypes.UnderType[AMTypes.TVType[rtn]];
class: AMTypes.Class _ AMTypes.UnderClass[under];
IF (class # record AND class # structure) OR (AMTypes.NComponents[under] # 1) THEN EXIT;
rtn _ AMTypes.IndexToTV[rtn, 1];
ENDLOOP;
}; 

underBOOL: Type _ AMTypes.UnderType[CODE[BOOL]];
trueCard: CARDINAL _ LOOPHOLE[TRUE, CARDINAL];
falseCard: CARDINAL _ LOOPHOLE[FALSE, CARDINAL]; 

ForceBoolean: PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [BOOL] = TRUSTED {
rtn: TV _ tv;
DO
rtn _ StripSingleComponentRecord[rtn];
IF AMTypes.UnderType[AMTypes.TVType[rtn]] = underBOOL THEN {
card: CARDINAL _ AMBridge.TVToCardinal[rtn];
IF card = trueCard THEN RETURN [TRUE];
IF card = falseCard THEN RETURN [FALSE]};
rtn _ BBUrpEval.UrpWrongType[head, parent, rtn, underBOOL, "not boolean"]
ENDLOOP
}; 

underType: Type _ AMTypes.UnderType[CODE[Type]];

ForceType: PUBLIC PROC [tv: TV, head: EvalHead, parent: Tree] RETURNS [Type] = TRUSTED {
rtn: TV _ tv;
DO
ut: Type = AMTypes.UnderType[AMTypes.TVType[rtn]];
IF ut = underType THEN RETURN [AMTypes.TVToType[rtn]];
IF AMTypes.TypeClass[ut] = type THEN RETURN [AMTypes.TVToType[rtn]];
rtn _ BBUrpEval.UrpWrongType[head, parent, rtn, underType, "not Type"]
ENDLOOP
}; 

AddMissingTypes: PROC = TRUSTED {
st: SymTab.Ref _ InterpreterPrivate.GetGlobalSymTab[];
IF NOT st.Fetch["REAL"].found THEN {IF NOT st.Store["REAL", AMBridge.TVForType[CODE[REAL]]] THEN ERROR};
IF NOT st.Fetch["NAT"].found THEN {IF NOT st.Store["NAT", AMBridge.TVForType[CODE[NAT]]] THEN ERROR};
IF NOT st.Fetch["UNWIND"].found THEN {IF NOT st.Store["UNWIND", AMBridge.TVForSignal[UNWIND]] THEN ERROR};
IF NOT st.Fetch["ABORTED"].found THEN {IF NOT st.Store["ABORTED", AMBridge.TVForSignal[ABORTED]] THEN ERROR};
};

nodeNames: ARRAY PPTree.NodeName OF ROPE;

Start: PROC = {
rnn: REF PPTree.NodeName _ NEW [PPTree.NodeName];
tvnn: TV;
TRUSTED {tvnn _ AMBridge.TVForReferent[rnn]};
FOR nn: PPTree.NodeName IN PPTree.NodeName DO
rnn^ _ nn;
nodeNames[nn] _ AMTypes.TVToName[tvnn];
ENDLOOP;
TRUSTED {
typeType _ AMTypes.TVType[AMBridge.TVForType[CODE[BOOL]]];
true _ AMBridge.TVForReferent[NEW[BOOL _ TRUE]];
false _ AMBridge.TVForReferent[NEW[BOOL _ FALSE]];
one _ AMBridge.TVForReferent[NEW[NAT _ 1]];
};
IF AMTypes.TypeClass[typeType] # type THEN ERROR;
Commander.Register["{", StatementCommand, "a statement evaluation command"];
CommandExtras.MakeUninterpreted[ Commander.Lookup[ CommandTool.CurrentWorkingDirectory[].Cat["{"]]];
AddMissingTypes[];
};

Start[];

END.

bStatementCommands.Mesa
Last Edited by: Spreitzer, January 7, 1985 10:52:20 pm PST
don't bother: SIGNAL BackStop.ResumeBackStop[]
At this point the values must be arithmetic.
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
Try to get the right stuff.
Try to get the right stuff.
ส;–

"cedar" style˜Icode™K™:K˜Kšฯk	œž
œร
˜์K˜šะbxœœ
˜ Kšœ‘
œ
˜ชKšœ:˜AKšœ
˜—K˜Kšœ
œ3˜=K˜Kšœ
œœ˜"Kšœœ
œ˜.K˜Jšœœ
œ˜(Kšœ
œ˜J˜Kšœœ
œœ
˜Kšœœ
œœ
˜Kšœœ
œœ
˜-Kšœœ
œœ
˜-Kš	œœ
œ	œœ
˜(Kšœœ
œ'œ
˜FK˜šฯnœœ
œœ
œœ˜LKšœœ˜Kš
œ˜—K˜šŸœœœ
œœœœฯcœ˜yKšœ
œ"˜3Kšœœ˜ Kšœœ
˜Kšœ œ4˜ZKš
œ˜Kš
œ˜Kšœ	œ
œ
˜Kšœ œ0˜Všœ˜
Kšœ
œ6˜Bšœ˜Kš
œ˜šœ˜Kšœ
œE˜Q—Kš
œ˜——KšœG˜Nšœ
œ
œ˜Kš
œ˜Kš
œG˜GKš
œ˜—K˜=Kšœ
œ
œ7˜NK˜—K˜šŸœœ
œœœœDœ
œ˜ฦ
šŸœœ˜Kš
œ6˜6š
œ˜Kš
œ˜š
œ!˜!Kš
œ˜Kš
œ˜Kš
œ-˜-Kš
œ˜—Kšœ˜Kšœ5œ˜@—K˜—Kš	œ
œ
œœ
œ˜"Kšœœ
œ
œ7˜TKšœ
œ
œ˜.Kš
œ*˜*Kšœœ˜(Kš
œ˜—K˜Kšœœœœ
˜/šœ
œœ%œ œœ˜oKšœ˜!K˜—K˜šŸœœ!œ˜CKš
œœ
œ
œœ˜šœœ
˜˜Kšœ
œ
œ˜šœœ
œ˜"K˜Kšœœ
œ
œ
˜Kšœ˜	——Kšœ
˜—Kšœœ˜—K˜š
Ÿœœ
œ&œœ˜IKšŸœœœ˜:Kšœ8œ
˜EKš
œ˜—K˜š
Ÿ
œœ
œ$œœ˜Nšœœ
œ
œœ
˜(˜šœ˜šœœœ
œ˜,Kš
œ!˜!Kšœ
˜—Kš
œ@˜@K˜#K˜#K˜%K˜K˜K˜"K˜!Kš
œ!˜!Kšœœ˜Kšœœ˜šœ"œ˜6Kšœ˜—Kšœ
œ˜%Kšœ	œ˜#Kšœœ˜)Kšœœ
˜
š
œ˜KšŸ	œœœ˜=Kšœœ ˜-Kš
œ˜—š
œ
˜
Kšœ˜"Kšœ
˜Kš
œ.™.K˜
—Kšœœ
œ
˜—š
˜KšœX˜[—K˜—Kšœ˜%—Kš
œ˜—K˜š
Ÿœœ
œ7œœ˜^Kš
œ:˜:—K˜šŸ
œœ!˜4šœœ˜K˜šœœ
˜šœœœ˜#KšŸœœ˜+Kš
œ.˜.Kšœ˜—Kšœ
˜—K˜—K˜K˜—K˜šŸœœ!˜-K˜Kšœœ˜'Kšœœ˜'Kšœœ=˜FKšœœœœ˜<K˜—K˜šŸœœ!˜3K˜Kšœœ˜"Kšœ"œ#œ
œ˜VK˜—K˜š
Ÿ
œœ	œœ	œ˜Xšœ˜šœ"œ˜7šœ˜!Kšœ$˜(——š
œ	˜	šœœ
œ˜&Kš
œœœ
œœ˜GKšœ
˜—Kšœœ˜—Kšœœ˜——K˜šŸœœ!˜-Kšœœ˜ Kš
œ˜K˜Kšœ
œ˜!Kšœœ˜"Kšœœ˜)šŸœœŸœœ
œœŸœœ
œœ˜Ršœœœ˜/š
œ˜Kšœœ
˜
Kšœœ
˜Kšœœ#œ
œ
˜7Kš
œ˜—š
˜Kšœ&˜.—Kšœ˜	——šœœ
œ˜KšŸœœ
œœ˜&KšŸœœ
œœœ
œ<˜pKš
œ˜—šœ
œ
˜š
œ˜Kš
œ˜K˜Kš
œ˜Kš
œ˜šŸ
œœ
œœ˜%K˜K˜—šŸœœ
œœ˜#Kš
œ˜K˜—šŸœœ
œœ˜#Kšœœ
œ<˜M—šœœ
˜Kš
œ"˜"šœœœ
œ
˜(K˜K˜Kšœœ˜—Kšœœ
˜—Kš
œ(˜(Kš
œ˜—š
œ˜K˜K˜K˜Kšœ
œ
˜
K˜K˜Kšœ	œ
˜šŸ	œœ
œœ˜$K˜,Kšœ	œ˜*—šŸœœ
œœ˜"K˜0Kšœ	œ˜*—šŸ	œœ
œœ˜%Kšœœ	œ
œ=˜[—šŸœœ
œœ˜&K˜+Kšœ	œ˜*—šŸ	œœ
œœ˜$K˜0Kšœ	œ˜*—Kšœœ
œ
œ
˜šœ˜šœ˜Kš
œ*˜*Kš
œ˜—šœ
œœ
˜š
œ˜K˜K˜ K˜,—š
œ"˜"K˜Kšœœ
œ
˜K˜K˜K˜K˜ K˜,—Kšœœ
˜——šœ
˜Kš
œ2˜2Kš
œ8˜8Kšœœ
˜—K˜—Kšœœ
˜—K˜—K˜šŸœœ,œ˜WKš
˜Kš
œ
œ
œ
œ
œœ
œ
˜>Kšœœœ
˜Kšœœ˜Kšœœ
œ˜šœ
œ˜Kšœ*œ
˜0Kšœœœ˜5Kšœœœ˜6Kšœ*œ
˜/Kšœœ
˜—šœ˜šœ˜K˜K˜K˜*K˜,K˜
—šœ˜Kš
œC˜CK˜K˜Kšœ!œ
˜&K˜——Kšœ
˜—K˜š
Ÿœœ/œ	œœ˜aKš
˜Kšœœ
˜K˜Kšœ
œœ˜6Kšœ	œ
œ
œœœ˜(Kšœ!œœœ ˜bšœ
œ˜Kšœœ
˜
Kšœ	œ
˜Kšœœ
˜—Kšœ
˜—K˜šŸœœœ œœœ˜hKš
˜Kšœœ
˜K˜Kšœœ
œ
œœœ˜'Kšœ œœœ ˜ašœ
œ˜Kšœœ
˜
Kšœ	œ
˜Kšœœ
˜—Kšœ
˜—K˜š
Ÿœœ/œœœ˜_Kš
˜Kšœœ
˜Kš
œ˜Kšœ
œœ!˜;Kšœœ
œ
œœœ˜'Kšœœœœ ˜_šœ
œ˜Kšœœ
˜
Kšœ	œ
˜Kšœœ
˜—Kšœ
˜—K˜šŸœœœ œœœ˜hKš
˜Kšœœ
˜Kš
œ˜Kšœœ
œ
œœœ˜'Kšœœœœ ˜_šœ
œ˜Kšœœ
˜
Kšœ	œ
˜Kšœœ
˜—Kšœ
˜—K˜š
Ÿœœœ œœ˜FKš	œ
œ8œ
œœ˜MK˜:—K˜Jšœœœ
˜J˜šŸ	œœœEœœœ˜K˜K˜*K˜;Kšœœ
˜
K˜K˜!K˜"Kšœœ˜)K˜0K˜"K˜:šœ˜˜
šœ˜K˜Bšœ "˜7K˜
—šœ˜Kšœœ˜'Kšœ
œœ˜ Kšœœœœ˜$Kš
œ˜———K˜&Kšœ˜	K˜—Kš
œ,™,K˜K˜+K˜1K˜$K˜+K˜1K˜$šœœœ
œ˜2Kš
 '˜'Kšœœ˜&Kšœœ˜&Kšœœ˜4Kšœœ˜4šœ˜K˜K˜K˜K˜K˜'Kšœœ˜!Kšœœ˜ Kšœœ
˜—šœ˜Kšœœ
˜Kšœœ
˜Kšœœ
˜Kšœœ˜Kšœœ
˜Kšœœ˜Kš
œœœUœ
œ%˜ฎ
—Kš
œœ
œœ
œ	˜1Kš
œ˜—šœ˜	Kšœœ˜"Kšœœ˜"šœ˜K˜K˜K˜K˜Kšœœ˜Kšœœ
˜Kšœœ˜Kšœœ
˜—šœ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜Kš
œ˜šœœ˜$šœœ˜$Kšœœ˜*Kšœ˜
—Kšœ
œ#˜.——Kš
œœ
œœ
œ	˜1Kš
œ
˜
—K˜—J˜šŸœœœœœœ˜[š
œu™uK˜K˜
K˜Kš
œ&˜&K˜K˜"K˜"šœ˜˜Kšœœ:˜O—˜#K˜<—˜
K˜;—˜Kšœ œœ˜E—˜Kšœœ7˜L—K˜JKšœ5˜<——K˜—J˜šŸ
œœ;˜KKšœ
œ!˜.K˜K˜K˜Kš
œ˜Kš
œ˜Kšœœ
œ
˜#Kš
œ˜—K˜Kšœœ%œ
œ˜GK˜šŸœœ$œ˜;Kšœœ˜"Kšœœ˜"Kšœœ˜"šœ	œ
œ˜Kšœœ˜#K˜—Kš
œ˜K˜—K˜šŸ	œœ$œ˜<Kšœœ˜"Kšœœ˜"šœ	œ
œ˜Kšœœ˜#K˜—Kš
œ˜K˜—K˜š
Ÿœœ
œ%œœ˜ZKš
˜Kšœœ
˜Kšœ
œ
˜Kšœœ
œ˜%Kšœœ'˜2Kš
œ%˜%Jš
œ9˜9šœœ˜Jš
œ˜Jšœ8˜?J˜Jšœ)˜0Jš
œ6˜6—Kšœ
˜—K˜šŸœœœ˜EKš
˜š
Ÿœœ$œœ œ˜_Kšœ*œ˜1—K˜K˜Kšœ
˜—K˜šŸœœ"˜0šŸœœ"˜/šœ	œ
œ
œ
œ
œœ
œ˜Pšœ˜šŸœœ˜Kšœ
œ˜1—Kšœœ˜Kšœœ	˜šœœ˜Kš
œ$˜$Kšœ˜	———š 
œ
˜šŸœœ˜Kšœœ˜'K˜)K˜—Kš
œE˜EKšœœ˜Kšœ
œ
œ3˜GK˜$K˜
—K˜—šŸœœ˜+šŸœœ˜Kšœœ˜'Kš
œ)˜)K˜—Kš
œE˜EKšœœ
˜Kšœ"˜)K˜$K˜—šœ˜K˜:K˜4šœœœ
œ˜.Kšœœ˜%Kšœ
˜—Kšœœ˜——K˜šŸœœE˜VKšœœ˜*Kšœœ˜*šœœ˜Kš
œ˜Kšœœœ˜0Kšœœœ˜0K˜Kš
œ˜—Kš
œm˜mKšœœJ˜cK˜<K˜—K˜šŸœœ
œ
œ
œ
œœ˜UKšœ
œ
˜Kšœ	œ
˜Kš
œ˜šœ%˜,Kš
œ˜Kšœœ0˜Xš
œ˜Kš
œ˜——Kš	œ	œ
œ
œœ
˜OKš
œ˜K˜—K˜šŸ
œœ
œ
œ
œ
œœ˜TK˜4K˜5K˜K˜—K˜šŸœœœœœœœ˜WKš
œ	˜	šœ
˜K˜5K˜1Kš
œœœœ
œ
˜XKš
œ ˜ Kšœ
˜—K˜—K˜Kšœ$œ
œ˜0Jš	œ
œœ
œœ˜.Jš	œœœ
œœ˜1J˜šŸœœœ œœœ˜TKšœœ˜
š
˜Kš
œ™Kš
œ&˜&šœ4œ˜<Kšœœ˜,Kšœœ
œœ˜&Kšœœ
œœ˜)—K˜IKš
˜—K˜—J˜Kšœ$œ˜0J˜šŸ	œœ
œœ œ
œ˜XKšœœ˜
š
˜Kš
œ™Kš
œ2˜2Kšœœ
œ˜6Kšœœ
œ˜DKš
œF˜FKš
˜—K˜—J˜šŸœœœ˜!K˜6Kšœ
œœœ
œ%œ
œœ
œ˜hKšœ
œœœ
œ$œ
œœ
œ˜eKšœ
œœœ
œ)œœ
œ˜jKšœ
œœœ
œ*œœ
œ˜mK˜—J˜Kšœœœ
œ
˜)K˜šŸœœ˜Kšœœœ˜1Kšœœ
˜	Kšœ&˜-šœœ˜-K˜
K˜'Kšœ
˜—šœ˜	Kšœ-œ
œ˜:Kšœœ
œœ˜0Kšœœ
œœ˜2Kšœœ
œ˜+Kš
œ˜—Kšœ$œ
œ
˜1K˜LKš
œd˜dK˜K˜—K˜K˜K˜Kšœ
˜—…—X&tร