StatementCommands.Mesa
Last Edited by: Spreitzer, May 10, 1986 3:56:39 pm PDT
DIRECTORY AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandTool, EvalQuote, FS, Interpreter, InterpreterOps, InterpreterPrivate, IntHashTable, IO, List, PPLeaves, PPP1, PPTree, PPTreeOps, PrincOps, PrincOpsUtils, PrintTV, Process, ProcessProps, Real, Rope, SafeStorage, StatementInterpreter, StatementInterpreterPrivate, SymTab, WorldVM;
StatementCommands:
CEDAR
PROGRAM
IMPORTS AMBridge, AMModel, AMTypes, BackStop, BBUrpEval, CBinary, Commander, CommandTool, EvalQuote, FS, InterpreterOps, InterpreterPrivate, IntHashTable, IO, List, PPP1, PPTreeOps, PrincOpsUtils, Process, ProcessProps, Real, Rope, SafeStorage, StatementInterpreter, StatementInterpreterPrivate, SymTab, WorldVM
EXPORTS StatementInterpreter, StatementInterpreterPrivate =
BEGIN OPEN StatementInterpreter, StatementInterpreterPrivate;
SymbolTable: TYPE = SymTab.Ref;
empty: PUBLIC TV ← AMTypes.GetEmptyTV[];
typeType: PUBLIC Type;
Exit: PUBLIC ERROR = CODE;
Loop: PUBLIC ERROR = CODE;
GetReturnFields: PUBLIC SIGNAL RETURNS [fields: Fields] = CODE;
Return: PUBLIC ERROR [fields: Fields] = CODE;
GetResumeFields: PUBLIC SIGNAL RETURNS [fields: Fields] = CODE;
Resume: PUBLIC ERROR [fields: Fields] = CODE;
GoTo: PUBLIC ERROR [label: ROPE] = CODE;
DecideSignal: PUBLIC ERROR [decision: BasicSignalDecisionType] = CODE;
ProcTypeBufferList: TYPE = LIST OF ProcTypeBuffer;
ProcTypeBuffer:
TYPE =
RECORD [
procType: Type,
fileName: ROPE,
free: DummyStuffList ← NIL
];
procTypeBuffers: ProcTypeBufferList ← NIL;
prefix: ROPE = "Dummy";
prefixLength: INT = prefix.Length[];
RegisterDummys:
PUBLIC
PROC [fileName:
ROPE, gfh: PrincOps.GlobalFrameHandle] = {
fullFile: ROPE = FS.ExpandName[fileName].fullFName;
gftv, globals: TV;
globalsType: Type;
TRUSTED {gftv ← AMBridge.TVForGFHReferent[gfh]};
globals ← AMTypes.Globals[gftv];
globalsType ← AMTypes.TVType[globals];
FOR i:
INT
IN [1 .. AMTypes.NComponents[globalsType]]
DO
ds: DummyStuff;
name: ROPE = AMTypes.IndexToName[globalsType, i];
tv: TV;
type: Type;
bl: ProcTypeBufferList;
IF Rope.Run[s1: name, s2: prefix] # prefixLength THEN LOOP;
tv ← AMTypes.IndexToTV[globals, i];
type ← AMTypes.TVType[tv];
SELECT AMTypes.UnderClass[type]
FROM
procedure => NULL;
ENDCASE => LOOP;
TRUSTED {
ds ←
NEW [DummyStuffPrivate ← [
proc: AMBridge.TVToProc[tv],
asTV: tv]];
};
bl ← FindProcBuffer[type];
IF bl = NIL THEN bl ← procTypeBuffers ← CONS[[type, fullFile], procTypeBuffers];
bl.first.free ← CONS[ds, bl.first.free];
ENDLOOP;
};
FindProcBuffer:
PROC [procType: Type]
RETURNS [bl: ProcTypeBufferList] = {
FOR bl ← procTypeBuffers, bl.rest WHILE bl # NIL AND NOT SafeStorage.EquivalentTypes[procType, bl.first.procType] DO NULL ENDLOOP;
};
FindConsdProcBuffer:
PROC [l: Lambda]
RETURNS [bl: ProcTypeBufferList] = {
FOR bl ← procTypeBuffers, bl.rest WHILE bl # NIL AND NOT (FTConform[l.args, AMTypes.Domain[bl.first.procType]] AND FTConform[l.rets, AMTypes.Range[bl.first.procType]]) DO NULL ENDLOOP;
};
FTConform:
PROC [fields: Fields, recordType: Type]
RETURNS [conform:
BOOL] = {
rLen:
INT =
SELECT AMTypes.UnderClass[recordType]
FROM
nil => 0,
record, structure => AMTypes.NComponents[recordType],
ENDCASE => ERROR;
IF rLen # fields.length THEN RETURN [FALSE];
FOR i:
INT
IN [0 .. fields.length)
DO
rName: ROPE = AMTypes.IndexToName[recordType, i+1];
fName: ROPE = fields[i].name;
IF rName.Length[] # 0 AND fName.Length[] # 0 AND NOT rName.Equal[fName] THEN RETURN [FALSE];
IF NOT SafeStorage.EquivalentTypes[fields[i].type, AMTypes.IndexToType[recordType, i+1]] THEN RETURN [FALSE];
ENDLOOP;
conform ← TRUE;
};
procDataMap: IntHashTable.Table ← IntHashTable.Create[];
AllocProc:
PROC [procType: Type]
RETURNS [ds: DummyStuff] = {
bl: ProcTypeBufferList ← FindProcBuffer[procType];
IF bl = NIL THEN RETURN [NIL];
IF bl.first.free =
NIL
THEN {
[] ← CommandTool.Run[bcdName: bl.first.fileName, runEvenIfAlreadyRun: TRUE];
};
IF bl.first.free = NIL THEN RETURN [NIL];
ds ← bl.first.free.first;
bl.first.free ← bl.first.free.rest;
IF NOT procDataMap.Store[LOOPHOLE[ds.proc, CARDINAL], ds] THEN ERROR;
};
AllocConsdProc:
PROC [l: Lambda]
RETURNS [ds: DummyStuff] = {
bl: ProcTypeBufferList ← FindConsdProcBuffer[l];
IF bl = NIL THEN RETURN [NIL];
IF bl.first.free =
NIL
THEN {
[] ← CommandTool.Run[bcdName: bl.first.fileName, runEvenIfAlreadyRun: TRUE];
};
IF bl.first.free = NIL THEN RETURN [NIL];
ds ← bl.first.free.first;
bl.first.free ← bl.first.free.rest;
IF NOT procDataMap.Store[LOOPHOLE[ds.proc, CARDINAL], ds] THEN ERROR;
};
GetStuff:
PUBLIC
PROC [dummy:
PROCANY]
RETURNS [ds: DummyStuff] = {
ds ← NARROW[procDataMap.Fetch[LOOPHOLE[dummy, CARDINAL]].value];
};
NarrowToSymbolTable:
PUBLIC
PROC [ra:
REF
ANY]
RETURNS [st: SymbolTable] = {
st ← NARROW[ra];
};
commandProcResultType: Type = AMTypes.GroundStar[AMTypes.Range[CODE[Commander.CommandProc]]];
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;
resultsTV: TV = AMTypes.New[commandProcResultType];
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];
};
[] ← symTab.Store["commandResults", resultsTV];
errorRope ← InterpretStatement[blockAsRope, context, symTab];
IF errorRope #
NIL
THEN {
cmd.out.PutRope[Rope.Cat["Error: ", errorRope, "\n"]];
result ← $Failure;
RETURN};
TRUSTED {
result ← AMBridge.TVToRef[AMTypes.IndexToTV[resultsTV, 1]];
msg ← NARROW[AMBridge.TVToRef[AMTypes.IndexToTV[resultsTV, 2]]];
};
};
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};
HandleEnable:
PROC [inner:
PROC, data:
REF
ANY, call, catch: Tree, head: EvalHead]
--InterpreterPrivate.ErrorHandler-- =
{Enable[NARROW[catch], head, inner]};
Interp:
PUBLIC
PROC [asTree: Tree, head: EvalHead, nest:
BOOL ←
TRUE] = {
Inner: PROC = {InterpNoProps[NARROW[asTree], head, nest]};
InterpreterPrivate.EnableBlock[head: head, handler: HandleEnable, data: NIL];
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, signal, error => [] ← EvalExpr[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;
syserror => {
SIGNAL BackStop.SuspendBackStop[];
ERROR;
don't bother: SIGNAL BackStop.ResumeBackStop[]
};
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];
};
open => EvalOpen[node, head, nest];
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]};
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: Node ← NARROW[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]] = {
innerHead: EvalHead ← head;
FOR i:
INT ← Initial[], Delta[]
WHILE Test[]
DO
SIGNAL BackStop.SuspendBackStop[];
Process.CheckForAbort[];
SIGNAL BackStop.ResumeBackStop[];
IF opens #
NIL
THEN {
innerHead ← NestHead[head];
AddOpens[innerHead, opens];
};
InterpNoProps[body, innerHead !
Exit => EXIT;
Loop => CONTINUE;
GoTo => IF MatchingLabel[label, exits, innerHead] THEN EXIT;
];
REPEAT
FINISHED => InterpNoProps[finishedExit, innerHead];
ENDLOOP;
innerHead ← innerHead};
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;
At this point the values must be arithmetic.
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 {
ForceArithmetic forces the given value to be arithmetic; the result is a TV with class = real or class = longInteger.
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
OR opens #
NIL
THEN {
IF nest THEN head ← NestHead[head];
IF opens # NIL THEN AddOpens[head, opens];
IF decls # NIL THEN 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];
};
EvalOpen:
PROC [node: Node, head: EvalHead, nest:
BOOL] = {
opens: Node ← NARROW[node.son[1]];
stmts: Node ← NARROW[node.son[2]];
IF opens #
NIL
THEN {
IF nest THEN head ← NestHead[head];
AddOpens[head, opens];
};
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 {
PerProcName:
PROC [nameT: Tree] = {
AddProcDecl[NARROW[nameT], typeN, bodyN, head];
nameT ← nameT};
typeN: Node = NARROW[typeT];
bodyN: Node;
IF typeN.name = procTC
THEN {
bodyN ← NARROW[valueT];
PPTreeOps.ScanList[namesT, PerProcName];
namesT ← namesT;
RETURN};
namesT ← namesT;
};
--otherwise--{
type: Type ← ForceType[EvalExpr[typeT, head, typeType], head, typeT];
PerName:
PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
val: TV ← AMTypes.New[type];
IF valueT # NIL THEN AMTypes.Assign[val, EvalExpr[valueT, head, type]];
[] ← head.specials.Store[name.name, val];
};
PerProc:
PROC [nameT: Tree] = {
name: PPLeaves.HTIndex = NARROW[nameT];
AddTypedProc[name, type, NARROW[valueT], head];
};
PPTreeOps.ScanList[
namesT,
SELECT AMTypes.UnderClass[type]
FROM
procedure => PerProc,
ENDCASE => 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;
head ← head};
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,
head: head]];
ds: DummyStuff = AllocConsdProc[l];
ltv: TV;
IF ds #
NIL
THEN {
procType: Type = AMTypes.TVType[ltv ← ds.asTV];
l.argsType ← AMTypes.Domain[procType];
l.retsType ← AMTypes.Range[procType];
ds.asLambda ← l;
EvalQuote.Register[l.name, NIL, head.specials, NIL];
[] ← head.specials.Store[l.name, ltv];
}
ELSE {
TRUSTED {ltv ← AMBridge.TVForReferent[NEW [Lambda ← l]]};
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];
IF nameToo THEN [] ← head.specials.Store[l.name, ltv];
};
ltv ← ltv;
};
nameToo: BOOL ← TRUE;
AddTypedProc:
PROC [nameT: PPLeaves.HTIndex, procType: Type, body: Node, head: EvalHead] = {
procArgs: Type = AMTypes.Domain[procType];
procRets: Type = AMTypes.Range[procType];
l: Lambda =
NEW[LambdaRep ← [
name: nameT.name,
args: FieldsFromType[procArgs],
rets: FieldsFromType[procRets],
argsType: procArgs,
retsType: procRets,
body: body,
head: head]];
ds: DummyStuff = AllocProc[procType];
ltv: TV;
IF ds #
NIL
THEN {
ltv ← ds.asTV;
ds.asLambda ← l;
EvalQuote.Register[l.name, NIL, head.specials, NIL];
[] ← head.specials.Store[l.name, ltv];
}
ELSE {
TRUSTED {ltv ← AMBridge.TVForReferent[NEW [Lambda ← l]]};
EvalQuote.Register[l.name, EvalProcedure, head.specials, l];
IF nameToo THEN [] ← head.specials.Store[l.name, ltv];
};
ltv ← ltv;
};
AddOpens:
PROC [head: EvalHead, opens: Node] = {
PerOpen:
PROC [t: Tree]
--PPTree.Scan-- = {
open: Node = NARROW[t];
nameT: PPLeaves.HTIndex = NARROW[open.son[1]];
valueT: Tree = open.son[2];
IF open.name # item THEN ERROR;
IF nameT #
NIL
THEN AddSimpleOpen[head, nameT.name, valueT, dontSelect]
ELSE AddComplexOpen[head, valueT];
};
PPTreeOps.ScanList[opens, PerOpen];
};
AddComplexOpen:
PROC [head: EvalHead, recordT: Tree] = {
recordTV: TV ← EvalExpr[recordT, head];
recordType: Type ← DeRefToRecord[head, recordT, recordTV].type;
FOR i:
INT
IN [1 .. AMTypes.NComponents[recordType]]
DO
name: ROPE = AMTypes.IndexToName[recordType, i];
IF name.Length[] = 0 THEN BBUrpEval.UrpFatal[head, recordT, "Can't handle anonymouse field"];
AddSimpleOpen[head, name, recordT, i]
ENDLOOP;
head ← head;
};
DeRefToRecord:
PROC [head: EvalHead, recordT: Tree, ur:
TV]
RETURNS [tv:
TV, type: Type] = {
tv ← ur;
DO
class: AMTypes.Class = AMTypes.TypeClass[type ← AMTypes.UnderType[AMTypes.TVType[tv]]];
SELECT class
FROM
record, structure => EXIT;
definition => ERROR;
ref, pointer, longPointer => tv ← AMTypes.Referent[tv];
globalFrame => tv ← AMTypes.Globals[tv];
ENDCASE => BBUrpEval.UrpFatal[head, recordT, "Not a record TYPE"];
ENDLOOP;
head ← head;
};
dontSelect: INTEGER = FIRST[INTEGER];
AddSimpleOpen:
PROC [head: EvalHead, name:
ROPE, recordT: Tree, i:
INTEGER] = {
EvalQuote.RegisterNameProc[
name: name,
symTab: head.specials,
proc: OpenName,
data: NEW [OpenRep ← [head, recordT, i]]
];
};
OpenRep: TYPE = RECORD [head: EvalHead, tree: Tree, i: INTEGER];
OpenName:
PROC [head: EvalHead, nameAsRope:
ROPE, nameAsTree: Tree, target: Type ← nullType, data:
REF ←
NIL]
RETURNS [value:
TV]
--EvalQuote.NameProc-- = {
ro: REF OpenRep = NARROW[data];
ur: TV ← EvalExpr[ro.tree, ro.head];
IF ro.i = dontSelect THEN RETURN [ur];
value ← AMTypes.IndexToTV[DeRefToRecord[ro.head, ro.tree, ur].tv, ro.i];
};
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]]],
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
Try to get the right stuff.
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
Try to get the right stuff.
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[
key: "{",
proc: StatementCommand,
doc: "a statement evaluation command",
interpreted: FALSE];
AddMissingTypes[];
};
Start[];
END.