-- PLEvalImpl.Mesa Last Modified by JHM
-- used to be Eval.Mesa
DIRECTORY
Disp: TYPE USING [Print],
IO: TYPE USING [char, CR, Put, rope, ROPE],
PL: TYPE USING [Dist, EndDisplay, Environment, ERecord, GetSpecialNodes,
Insert, Interrupt, LSTNode, Node, NodeRecord, NodeType, OS, PBug, rASS, rCAT,
rCATL, rCLOSURE, rCOMB, rDELETE, rEQUAL, RErr, rFAIL, rFCN, rGOBBLE,
rGTR, rHOLE, rID, rITER, rLST, rMAPPLY, rMINUS, rOPT, rPALT, rPAPPLY,
rPATTERN, rPFUNC, rPFUNC1, rPLUS, rPROG, rSEQ, rSEQOF, rSEQOFC,
rSTR, rTILDE, rUNARY, rUNDEFINED, rVAL, rWILD, rZARY, SErr,
Symbol, SymbolRecord, Z],
Process: TYPE USING [Yield],
PString: TYPE USING [ConvertStream, CopyStream, Empty, EmptyS, Item,
MakeInteger, MakeNUM, NewStream, Stream, Sub, SubString,
SubStringStream],
Rope: TYPE USING [Concat, Equal, Length, ROPE],
Route: TYPE USING [KeyRoutine];
PLEvalImpl: CEDAR PROGRAM IMPORTS P: PL, S: PString, Disp, Route, Process, Rope, IO EXPORTS PL = {
OPEN P, Rope, IO;
--
N: ZONE = P.Z;
NodeType: TYPE = PL.NodeType;
Node: TYPE = PL.Node;
NodeRecord: TYPE = PL.NodeRecord;
ListNodeRecord: TYPE = LST NodeRecord;
LSTNode: TYPE = PL.LSTNode;
Environment: TYPE = PL.Environment;
ERecord: TYPE = PL.ERecord;
Symbol: TYPE = PL.Symbol;
Stream: TYPE = PString.Stream;
--
Fail: Node;
MTSt: rSTR;
Nail: LSTNode;
Left, Right: REF VAL P.SymbolRecord;
Apply: PROC[val, func: Node] RETURNS [ret: Node] = {
CK;
WITH func SELECT FROM
f: rID => WITH f.name SELECT FROM
x: rZARY => ret ← x.p[val];
ENDCASE => P.RErr["Primitive out of context"];
f: rCOMB => WITH f.proc SELECT FROM
x: rUNARY => ret ← x.p[val,f.parm];
ENDCASE => P.RErr["Primitive out of context"];
f: rCLOSURE =>
WITH f.exp SELECT FROM
g: rFCN =>
ret ← Eval[g.fcn, ExtendEnv[f.env, g.parms, val]];
g: rPATTERN =>
WITH val SELECT FROM
v: rSTR => ret ← Match[v.str, g.pattern, f.env];
ENDCASE => P.RErr["Pattern applied to non-string"];
ENDCASE => P.PBug["Bad closure"];
f: rSTR => WITH val SELECT FROM
l: rLST => { -- subscript operation
i: LONG INTEGER ← S.MakeInteger[f.str];
neg: BOOLEAN ← FALSE;
t: LSTNode ← l;
IF i=0 THEN P.RErr["Zero subscript"];
IF i<0 THEN { i ← -i; neg← TRUE };
UNTIL i=1
DO
IF t.listhead=NIL THEN P.RErr["Subscript too big"];
t ← t.listtail;
i ← i-1;
ENDLOOP;
IF t.listhead=NIL THEN P.RErr["Subscript too big"];
ret ← IF neg THEN t.listtail ELSE t.listhead;
};
ENDCASE => P.RErr["String applied to non-list"];
f: rLST =>
{
m: PROC[x: Node] RETURNS [t: Node] =
{t ← Apply[val, x]};
ret ← MapList[f, m];
}
ENDCASE => P.RErr["Bad application"];
ret.e ← TRUE;
};
Binary: PROC[vi, vj: Node, p: PROC[ROPE, ROPE] RETURNS [ROPE]] RETURNS[ans: Node] = {
WITH vi SELECT FROM
i: rSTR => WITH vj SELECT FROM
j: rSTR => ans ← SN[p[i.str, j.str]];
j: rLST =>
{C: PROC [j: Node] RETURNS [Node] =
{WITH j SELECT FROM
x: rSTR => RETURN [SN[p[i.str, x.str]]];
ENDCASE =>
ERROR P.RErr["Binary operation to list of non-strings"]};
ans ← MapList[j, C]};
ENDCASE => ERROR P.RErr["second operand mal-formed"];
i: rLST => WITH vj SELECT FROM
j: rSTR =>
{C: PROC [i: Node] RETURNS [t:Node] =
{WITH i SELECT FROM
x: rSTR => RETURN [SN[p[x.str, j.str]]];
ENDCASE =>
ERROR P.RErr["Binary operation to list of non-strings"]};
ans ← MapList[i, C]};
j: rLST =>
{ti: LSTNode ← i;
tj: LSTNode ← j;
tk: LSTNode ← NewNail[];
ans ← tk;
UNTIL ti.listhead=NIL AND tj.listhead=NIL
DO
IF ti.listhead=NIL OR tj.listhead=NIL THEN
P.RErr["List lengths differ"];
WITH ti.listhead SELECT FROM
hi: rSTR =>
WITH tj.listhead SELECT FROM
hj: rSTR => {
tk↑ ← [TRUE,LST[SN[p[hi.str, hj.str]],NewNail[]]];
tk ← tk.listtail;
ti ← ti.listtail;
tj ← tj.listtail};
ENDCASE =>
P.RErr["Binary operation to list of non-strings"];
ENDCASE =>
P.RErr["Binary operation to list of non-strings"];
ENDLOOP}
ENDCASE => P.RErr["second operand mal-formed"];
ENDCASE => P.RErr["first operand mal-formed"];
};
BlessLST: PUBLIC PROC[x: Node] RETURNS[LSTNode] = {
WITH x SELECT FROM
xl: rLST => RETURN[xl];
ENDCASE => ERROR P.PBug["Non-list"]};
BlessString: PUBLIC PROC[x: Node] RETURNS[ROPE] = {
WITH x SELECT FROM
s: rSTR => RETURN[s.str];
ENDCASE => ERROR P.PBug["Non-string"]};
CK: PROC = {
Process.Yield[];
--IF TypeScript.UserAbort[Disp.H] THEN
-- {TypeScript.ResetUserAbort[Disp.H]; P.Interrupt;};
};
ConcL: PROC[vi, vj: Node] RETURNS [ans: LSTNode] =
{
WITH vi SELECT FROM li: rLST =>
WITH vj SELECT FROM vj: rLST =>
{t: LSTNode ← NewNail[];
ti: LSTNode ← li;
ans ← t;
UNTIL ti.listhead=NIL
DO
t↑ ← [TRUE, LST[ti.listhead, NewNail[]]];
t ← t.listtail;
ti ← ti.listtail;
ENDLOOP;
t↑ ← vj↑};
ENDCASE => P.RErr["Right operand of ,, is a non-list"];
ENDCASE => P.RErr["Left operand of ,, is a non-list"];
};
EmptyString: PROC[n: Node] RETURNS[BOOLEAN] = {
RETURN[WITH n SELECT FROM
s: rSTR => S.Empty[s.str],
ENDCASE => FALSE];
};
ErrorProcess: PROC[mess, est: ROPE, env: Environment, x,lop,rop: Node] RETURNS [proceed: BOOLEAN] =
{ m: Node ← NIL;
P.OS.Put[rope[mess], rope[": "], rope[est]];
P.OS.Put[rope[", in"], char[CR]];
Disp.Print[x];
Left.v ← lop;
Right.v ← rop;
DO
m ← Route.KeyRoutine[SN[">"]];
WITH m SELECT FROM
f: rFAIL => P.EndDisplay;
s: rSTR => IF EmptyString[m] THEN RETURN[FALSE]
ELSE IF EQ[s.str,"pr"] THEN RETURN[TRUE]
ELSE
{
m← P.Dist[s.str !
P.SErr => LOOP];
m ← Eval[m, env];
Disp.Print[m];
};
ENDCASE=>ERROR;
ENDLOOP;
};
Eval: PUBLIC PROC[x: Node, env: Environment]
RETURNS [ans: Node] = {
lop: Node ← Nail;
rop: Node ← Nail;
IF x.e THEN RETURN [x];
{ ENABLE {
P.RErr =>
IF ErrorProcess["Run-time error", est, env,x, lop,rop] THEN RETRY;
P.PBug =>
IF ErrorProcess["Poplar Bug!!", est, env,x, lop,rop] THEN RETRY;
P.Interrupt => IF ErrorProcess["***Interrupt***", "", env,x, lop,rop]
THEN RESUME
};
CK;
DO
B: PROC[lop, rop: Node] RETURNS [loop: BOOLEAN]=
{loop ← FALSE;
SELECT x.Type FROM
PLUS=>
{ P: PROC[i,j: ROPE] RETURNS[ROPE] =
{RETURN[S.MakeNUM[S.MakeInteger[i]+S.MakeInteger[j]]]};
ans ← Binary[lop, rop, P];
};
MINUS=>
{ M: PROC[i,j: ROPE] RETURNS[ROPE] =
{RETURN[S.MakeNUM[S.MakeInteger[i]-S.MakeInteger[j]]]};
ans ← Binary[lop, rop, M];
};
SEQ => {
from: LONG INTEGER = S.MakeInteger[BlessString[lop]];
to: LONG INTEGER ← S.MakeInteger[BlessString[rop]];
inc: LONG INTEGER = IF from>to THEN 1 ELSE -1;
tl: LSTNode ←
N.NEW[ListNodeRecord ←
[TRUE, LST[SN[S.MakeNUM[to]], Nail]]];
UNTIL from=to
DO
to ← to+inc;
tl ← N.NEW[ListNodeRecord ←
[TRUE,LST[SN[S.MakeNUM[to]], tl]]];
ENDLOOP;
ans ← tl;
};
PAPPLY => {
WITH rop SELECT FROM r: rCLOSURE =>
WITH r.exp SELECT FROM f: rFCN =>
{env ← ExtendEnv[r.env, f.parms, lop];
x ← f.fcn;
loop ← TRUE}; -- tail recursion
ENDCASE => ans ← Apply[lop,rop];
ENDCASE => ans ← Apply[lop,rop];
};
MAPPLY =>
WITH lop SELECT FROM il: rLST =>
{lx: LSTNode ← NewNail[];
tl: LSTNode ← il;
ans ← lx;
FOR tl ← tl, tl.listtail UNTIL tl.listhead=NIL
DO
t: Node = Apply[tl.listhead, rop];
IF t.Type#FAIL THEN
{lx↑ ← [TRUE, LST[t, NewNail[]]];
lx← lx.listtail};
ENDLOOP};
ENDCASE => P.RErr["Non-list before //"];
GOBBLE =>
WITH lop SELECT FROM lx: rLST =>
{ GMap: PROC[x: Node] =
{ans ← N.NEW[NodeRecord
← [,LST[ans,
N.NEW[ListNodeRecord
← [,LST[x, Nail]]]]]];
ans ← Apply[ans, rop];
};
IF lx.listhead=NIL THEN P.RErr["[] before ///"];
ans ← lx.listhead;
Map[lx.listtail, GMap];
};
ENDCASE => P.RErr["Non-list before ///"];
ITER => DO
ans ← lop;
lop ← Apply[lop, rop];
IF lop.Type=FAIL THEN EXIT;
ENDLOOP;
CAT => ans ← IF EmptyString[lop] THEN rop
ELSE IF EmptyString[rop] THEN lop
ELSE Binary[lop, rop, Rope.Concat];
CATL => ans ← ConcL[lop, rop];
EQUAL => { -- this will occur only in checking mode
IF ~VEqual[lop,rop] THEN P.RErr["Equality Check"];
ans ← lop;
};
ENDCASE}; -- End of B
WITH x SELECT FROM
n: rID => ans ← IF n.name.t=VAL THEN Look[n.name,env] ELSE x;
n: rHOLE => ans ←x;
n: rFAIL => ans ←x;
n: rSTR => ans ←x;
n: rWILD => ans ←x;
n: rPATTERN => ans ← N.NEW[NodeRecord ←[,CLOSURE[x,env]]];
n: rFCN =>
{
WITH n.parms SELECT FROM ne: rEQUAL =>
{
ElimEq: PROC[n: Node] RETURNS [a: Node] = {
a ← n;
IF n = NIL THEN RETURN;
WITH n SELECT FROM
x: rEQUAL => RETURN[ElimEq[x.left]];
x: rFAIL => NULL;
x: rID => NULL;
x: rWILD => NULL;
x: rHOLE => NULL;
x: rUNDEFINED => NULL;
x: rSTR => NULL;
x: rCOMB => x.parm ← ElimEq[x.parm];
x: rASS => x.rhs ← ElimEq[x.rhs];
x: rLST => {IF x.listhead=NIL THEN RETURN;
x.listhead ← ElimEq[x.listhead];
x.listtail ← BlessLST[ElimEq[x.listtail]]};
x: rSEQOF => x.pat ← ElimEq[x.pat];
x: rSEQOFC => x.pat ← ElimEq[x.pat];
x: rOPT => x.pat ← ElimEq[x.pat];
x: rDELETE => x.pat ← ElimEq[x.pat];
x: rCAT=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rCATL=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rGTR=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rPALT=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rPAPPLY=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rMAPPLY=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rGOBBLE=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rITER=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rPROG=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rSEQ=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rPLUS=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rMINUS=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rEQUAL=> {x.left ← ElimEq[x.left]; x.right ← ElimEq[x.right]};
x: rTILDE => x.not ← ElimEq[x.not];
x: rPATTERN => x.pattern ← ElimEq[x.pattern];
x: rFCN=> {x.parms ← ElimEq[x.parms]; x.fcn ← ElimEq[x.fcn]};
ENDCASE => P.PBug["Unknown variant"];
};
[] ← Eval[n.fcn, ExtendEnv[env, ne.left, ne.right]];
[] ← ElimEq[x];
};
ENDCASE;
ans ← N.NEW[NodeRecord ← [,CLOSURE[x,env]]];
};
n: rCOMB => ans ← N.NEW[NodeRecord ← [,COMB[n.proc,Eval[n.parm,env]]]];
n: rCAT => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rCATL => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rEQUAL => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rPAPPLY => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rMAPPLY => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rGOBBLE => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rITER => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rPLUS => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rMINUS => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rSEQ => IF B[Eval[n.left,env], Eval[n.right,env]] THEN LOOP;
n: rASS => {
e: Environment ← env;
ans ← Eval[n.rhs, env];
DO
IF e=NIL THEN
WITH n.lhs SELECT FROM
i: rVAL => { i.v ← ans; EXIT };
ENDCASE => P.RErr["Assignment to built-in primitive"];
-- assume global
IF e.name=n.lhs THEN { e.val ← ans; EXIT };
e ← e.next;
ENDLOOP;
};
n: rTILDE =>
{
ans ← Eval[n.not,env];
ans ← IF ans.Type=FAIL THEN MTSt ELSE Fail;
};
n: rPROG => {
[] ← Eval[n.left,env];
x ← n.right;
LOOP;
};
n: rGTR => {
ans ← Eval[n.left,env];
IF ans.Type#FAIL THEN { x ← n.right; LOOP };
};
n: rPALT => {
ans ← Eval[n.left,env];
IF ans.Type=FAIL THEN { x ← n.right; LOOP };
};
n: rLST => IF n.listhead=NIL THEN ans ← x
ELSE ans ← N.NEW[NodeRecord ← [,LST[Eval[n.listhead, env],
BlessLST[Eval[n.listtail, env]]]]];
ENDCASE => P.PBug["Unknown type"];
ans.e ← TRUE;
RETURN;
ENDLOOP;
};
};
EQ: PUBLIC PROC[x, y: ROPE] RETURNS[BOOLEAN] =
{RETURN[Equal[x,y]]};
VEqual: PUBLIC PROC[lx,rx: Node] RETURNS [res: BOOLEAN] =
{
DO
WITH lx SELECT FROM
ll: rLST => WITH rx SELECT FROM
rl: rLST =>
IF ll.listhead=NIL THEN res ← rl.listhead=NIL
ELSE IF rl.listhead=NIL THEN res ← FALSE
ELSE IF ~VEqual[ll.listhead, rl.listhead] THEN
res ← FALSE
ELSE {
lx ← ll.listtail;
rx ← rl.listtail;
LOOP;
};
ENDCASE => res ← FALSE;
ll: rSTR =>
WITH rx SELECT FROM
rs: rSTR =>
{a,b: Stream;
a ← S.NewStream[ll.str];
b ← S.NewStream[rs.str];
DO
IF S.EmptyS[a] THEN {res ← S.EmptyS[b]; EXIT};
IF S.EmptyS[b] THEN {res ← FALSE; EXIT};
{ac,bc: CHARACTER;
[ac,a] ← S.Item[a];
[bc, b] ← S.Item[b];
IF ac=bc THEN LOOP};
res ← FALSE; EXIT;
ENDLOOP;
};
ENDCASE => P.RErr["Illegal equality check"];
ENDCASE => P.RErr["Illegal equality check"];
EXIT;
ENDLOOP;
};
ExtendEnv: PROC[e: Environment, bv,val: Node] RETURNS [nev: Environment] =
{
nev ← e;
WITH bv SELECT FROM
bvx: rID =>
nev ← N.NEW[ERecord ← [bvx.name, val, nev]];
bvx: rLST =>
WITH val SELECT FROM
vl1: rLST => {bl: LSTNode ← bvx;
vl: LSTNode ← vl1;
DO
IF bl.listhead=NIL AND vl.listhead=NIL
THEN EXIT;
IF bl.listhead=NIL THEN
P.RErr["Too many parameters for function"];
IF vl.listhead=NIL THEN
P.RErr["Too few parameters for function"];
nev ← ExtendEnv[nev, bl.listhead, vl.listhead];
vl ← vl.listtail;
bl ← bl.listtail;
ENDLOOP};
ENDCASE => P.RErr["Non-list before /"];
ENDCASE => P.RErr["Illegal BV"]};
LengthList: PUBLIC PROC[n: LSTNode] RETURNS[i:CARDINAL] = {
i ← 0;
WHILE n.listhead ~= NIL DO
i ← i + 1;
n ← n.listtail;
ENDLOOP;
};
Look: PROC[n: Symbol, e: Environment] RETURNS[Node] = {
FOR e ← e, e.next UNTIL e=NIL DO
IF e.name=n THEN RETURN[e.val]
ENDLOOP;
WITH n SELECT FROM
v: rVAL => IF v.v#NIL THEN RETURN[v.v];
ENDCASE;
ERROR P.RErr["Undefined variable"]
};
Map: PUBLIC PROC[l: LSTNode, p: PROC[Node]] =
{
FOR l ← l, l.listtail UNTIL l.listhead=NIL
DO IF l.Type#LST THEN ERROR P.PBug["Malformed List"];
p[l.listhead]; ENDLOOP;
};
MapList: PUBLIC PROC[l: LSTNode, p: PROC[Node] RETURNS [Node]] RETURNS [ans: LSTNode] =
{
tans: LSTNode ← NewNail[];
ans ← tans;
UNTIL l.listhead=NIL
DO
tans↑ ← [,LST[p[l.listhead], NewNail[]]];
tans ← tans.listtail;
l ← l.listtail;
ENDLOOP;
};
Match: PROC
[subject: ROPE, pattern: Node, env: Environment]
RETURNS [struc: Node] = {
s: Stream;
HolePassed: SIGNAL [holeString: rSTR] = CODE;
M2: PROC[xp: Node, discarding: BOOLEAN,
env: Environment] RETURNS [ans: Node] =
-- The state of s is an implict input and output of M2
{
BinaryMatch: PROC[left, right: Node]
RETURNS [lans: Node, rans:Node] =
{
holeNode: rSTR ← NIL;
lans ← M2[left, discarding, env!
HolePassed => {
holeNode ← holeString;
RESUME
}];
IF lans.Type # FAIL THEN
{IF holeNode=NIL THEN
rans ← M2[right, discarding, env]
ELSE { -- unanchored match allowed
i: CARDINAL ← 0;
s1: ROPE ← S.ConvertStream[s];
s2: Stream ← S.CopyStream[s];
DO
rans ← M2[right, discarding, env];
IF rans.Type#FAIL THEN
{IF discarding THEN EXIT;
holeNode↑ ←
SN[S.SubString[s1,0,i]]↑;
lans←Eval[lans,env];
EXIT};
IF S.EmptyS[s2] THEN EXIT;
[, s2] ← S.Item[s2];
s ← S.CopyStream[s2];
i ← i+1;
ENDLOOP;
};
};
};
{ ENABLE {
P.RErr =>
IF ErrorProcess["Run-time error", est,
env, xp,SN[S.ConvertStream[s]],Nail] THEN RETRY;
P.PBug =>
IF ErrorProcess["Poplar Bug!!", est,
env, xp,SN[S.ConvertStream[s]],Nail] THEN RETRY;
P.Interrupt => IF ErrorProcess["***Interrupt***", "",
env, xp,SN[S.ConvertStream[s]],Nail]
THEN RESUME
};
CK;
ans ← NIL;
DO
WITH xp SELECT FROM
p: rPATTERN => xp ← p.pattern;
p: rID => IF p.name.t=VAL THEN xp ← Look[p.name, env]
ELSE EXIT;
p: rCLOSURE =>
{ env ← p.env; xp ← p.exp }
ENDCASE => EXIT;
ENDLOOP;
WITH xp SELECT FROM
p: rID => {WITH p.name SELECT FROM t: rPFUNC=>
{[ans, s] ← t.p[s];
ans.e ← TRUE};
ENDCASE => P.RErr["Primitive out of context"]
};
p: rCOMB => {WITH p.proc SELECT FROM t: rPFUNC1=>
{ans ← Eval[p.parm, env];
[ans, s] ← t.p[s, ans];
ans.e ← TRUE};
ENDCASE => P.RErr["Primitive out of context"]
};
p: rGTR=> {
t: Node ← M2[p.left, TRUE, env];
IF t.Type= FAIL THEN ans ← Fail
ELSE IF ~discarding THEN
{ans ← N.NEW[NodeRecord ← [,GTR[t, p.right]]];
IF t.e THEN ans ← Eval[ans,env]}
ELSE ans ← MTSt;
};
p: rPAPPLY => {
t: Node ← M2[p.left, discarding, env];
IF t.Type= FAIL THEN ans ← Fail
ELSE IF ~discarding THEN
{ans ← N.NEW[NodeRecord ← [,PAPPLY[t, p.right]]];
IF t.e THEN ans ← Eval[ans,env];
}
ELSE ans ← MTSt;
};
p: rMAPPLY => {
t: Node ← M2[p.left, discarding, env];
IF t.Type= FAIL THEN ans ← Fail
ELSE IF ~discarding THEN
{ans ← N.NEW[NodeRecord ← [,MAPPLY[t, p.right]]];
IF t.e THEN ans ← Eval[ans,env];
}
ELSE ans ← MTSt;
};
p: rGOBBLE => {
t: Node ← M2[p.left, discarding, env];
IF t.Type= FAIL THEN ans ← Fail
ELSE IF ~discarding THEN
{ans ← N.NEW[NodeRecord ← [,GOBBLE[t, p.right]]];
IF t.e THEN ans ← Eval[ans,env];
}
ELSE ans ← MTSt;
};
p: rITER => {
t: Node ← M2[p.left, discarding, env];
IF t.Type= FAIL THEN ans ← Fail
ELSE IF ~discarding THEN
{ans ← N.NEW[NodeRecord ← [,ITER[t, p.right]]];
IF t.e THEN ans ← Eval[ans,env];
}
ELSE ans ← MTSt;
};
p: rTILDE => {
s1: Stream ← S.CopyStream[s];
ans ← M2[p.not, TRUE, env];
s ← s1;
ans ← IF ans.Type=FAIL THEN MTSt
ELSE Fail;
};
p: rDELETE => {
ans ← M2[p.pat, TRUE, env];
IF ans.Type#FAIL THEN ans ← MTSt;
};
p: rSTR => {
s1: ROPE ← S.ConvertStream[s];
l1, i: LONG INTEGER ← 0;
l1 ← Rope.Length[p.str];
UNTIL i=l1 DO
IF S.EmptyS[s] THEN { ans ← Fail; EXIT };
{c: CHARACTER;
[c,s] ← S.Item[s];
IF c#S.Sub[p.str, i]
THEN { ans ← Fail; EXIT }};
i ← i+1;
REPEAT
FINISHED =>
IF discarding THEN ans ← MTSt
ELSE {ans ← SN[S.SubString[s1,0,i]];
ans.e ← TRUE};
ENDLOOP;
};
p: rWILD => {
IF S.EmptyS[s] THEN ans ← Fail
ELSE {
IF discarding THEN ans ← MTSt
ELSE {ans ← SN[S.SubStringStream[s,0,1]];
ans.e ← TRUE;
};
[,s] ← S.Item[s];
};
};
p: rHOLE => { h: rSTR = N.NEW[STR NodeRecord ← MTSt↑];
ans ← h;
-- empty string, to be overwritten
ans.e ← FALSE;
SIGNAL HolePassed[h];
};
p: rLST => {
IF p.listhead=NIL THEN ans ← xp
ELSE IF p.listtail.listhead=NIL
THEN { -- not really binary
ans ← M2[p.listhead, discarding, env];
IF ans.Type#FAIL AND ~discarding
THEN
{ans ← N.NEW[NodeRecord
← [ans.e,
LST[ans,Nail]]];
}}
ELSE {lans, rans: Node;
[lans, rans] ← BinaryMatch[p.listhead, p.listtail];
IF lans.Type=FAIL OR rans.Type=FAIL
THEN ans ← Fail
ELSE IF discarding THEN ans ← MTSt
ELSE ans ← N.NEW[NodeRecord
←[lans.e AND rans.e,
LST[lans,BlessLST[rans]]]]}};
p: rCAT=> {lans, rans: Node;
[lans, rans] ← BinaryMatch[p.left, p.right];
IF lans.Type=FAIL OR rans.Type=FAIL
THEN ans ← Fail
ELSE IF discarding THEN ans ← MTSt
ELSE { ans ← N.NEW[NodeRecord ← [,CAT[lans, rans]]];
IF lans.e AND rans.e THEN ans←Eval[ans,env]};
};
p: rPLUS=> {lans, rans: Node;
[lans, rans] ← BinaryMatch[p.left, p.right];
IF lans.Type=FAIL OR rans.Type=FAIL
THEN ans ← Fail
ELSE IF discarding THEN ans ← MTSt
ELSE { ans ← N.NEW[NodeRecord ← [,PLUS[lans, rans]]];
IF lans.e AND rans.e THEN ans←Eval[ans,env]};
};
p: rMINUS => {lans, rans: Node;
[lans, rans] ← BinaryMatch[p.left, p.right];
IF lans.Type=FAIL OR rans.Type=FAIL
THEN ans ← Fail
ELSE IF discarding THEN ans ← MTSt
ELSE { ans ← N.NEW[NodeRecord ← [,MINUS[lans, rans]]];
IF lans.e AND rans.e THEN ans←Eval[ans,env]};
};
p: rCATL => {lans, rans: Node;
[lans, rans] ← BinaryMatch[p.left, p.right];
IF lans.Type=FAIL OR rans.Type=FAIL
THEN ans ← Fail
ELSE IF discarding THEN ans ← MTSt
ELSE { ans ← N.NEW[NodeRecord ← [,CATL[lans, rans]]];
IF lans.e AND rans.e THEN ans←Eval[ans,env]};
};
p: rSEQOF => {
ans ← Fail;
DO
s1: Stream = S.CopyStream[s];
t: Node = M2[p.pat, discarding, env !
HolePassed => { holeString.e ← TRUE;
RESUME }];
-- The user probably didn't mean to
-- put "..." at the end of a seq, but
-- what can we do?
IF t.Type=FAIL THEN { s ← s1; EXIT };
IF discarding THEN ans ← MTSt
ELSE IF ans.Type=FAIL THEN ans ← t
ELSE ans ← Binary[ans, t, Rope.Concat];
ENDLOOP;
};
p: rSEQOFC => {
tans: LSTNode ← NewNail[];
tans1: LSTNode = tans;
ans ← tans;
DO
s1: Stream = S.CopyStream[s];
t: Node = M2[p.pat, discarding, env !
HolePassed =>
{ holeString.e ← TRUE; RESUME }];
IF t.Type=FAIL THEN { s ← s1; EXIT };
IF discarding THEN ans ← MTSt
ELSE {tans↑ ← [TRUE,
LST[t,NewNail[]]];
tans ← tans.listtail};
ENDLOOP;
IF tans1.listhead=NIL THEN ans ← Fail;
};
p: rOPT => { -- (optional part) has single pattern as part
s1: Stream ← S.CopyStream[s];
ans ← M2[p.pat, discarding, env];
IF ans.Type=FAIL THEN { ans ← MTSt; s ← s1 };
};
p: rPALT => {
s1: Stream ← S.CopyStream[s];
ans ← M2[p.left, discarding, env];
IF ans.Type=FAIL THEN
{ s ← s1; ans ← M2[p.right, discarding, env] };
};
p: rFAIL => ans ← Fail;
ENDCASE => P.RErr["Unknown pattern type"];
}};
holeNode: rSTR ← NIL;
struc ← NIL;
s ← S.NewStream[subject];
struc ← M2[pattern, FALSE, env !
HolePassed => { holeNode ← holeString; RESUME }];
IF holeNode#NIL THEN
{
holeNode↑ ← SN[S.ConvertStream[s]]↑;
struc ← Eval[struc,env];
}
ELSE IF ~S.EmptyS[s] THEN struc ← Fail;
struc.e ← TRUE;
};
NewNail: PUBLIC PROC RETURNS [LSTNode] =
{RETURN[N.NEW[ListNodeRecord ← [TRUE,LST[NIL,NIL]]]]};
SN: PUBLIC PROC [s: ROPE] RETURNS [rSTR] =
{RETURN[N.NEW[STR NodeRecord ← [TRUE,STR[s]]]]};
BlessVAL: PROC[x: P.Symbol] RETURNS [REF VAL P.SymbolRecord] =
{WITH x SELECT FROM
r: rVAL => RETURN[r];
ENDCASE => ERROR;
};
[Fail,MTSt,Nail] ← P.GetSpecialNodes[];
Left ← BlessVAL[P.Insert["left", [,,VAL[NIL]]]];
Right ← BlessVAL[P.Insert["right", [,,VAL[NIL]]]];
}.