
<<PLEvalImpl.Mesa >>
<<Copyright (c) Xerox Corporation, 1981.  All rights reserved.>>
<<Last Modified by JHM>>
<<last edited by Satterthwaite, April 18, 1986 5:09:49 pm PST>>

<<used to be Eval.Mesa>>

DIRECTORY
Disp: TYPE USING [Print],
IO: TYPE USING [char, Put, 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,
MakeInt, 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;
<<>>
N: ZONE = P.Z;

NodeType: TYPE = PL.NodeType;
Node: TYPE = PL.Node;
NodeRecord: TYPE = PL.NodeRecord;
ListNodeRecord: TYPE = NodeRecord.LST;
LSTNode: TYPE = PL.LSTNode;
Environment: TYPE = PL.Environment;
ERecord: TYPE = PL.ERecord;
ROPE: TYPE = Rope.ROPE;
Symbol: TYPE = PL.Symbol;
Stream: TYPE = PString.Stream;
<<>>
Fail: Node;
MTSt: rSTR;
Nail: LSTNode;

Left, Right: REF P.SymbolRecord.VALUE;

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: INT _ S.MakeInt[f.str];
neg: BOOL _ 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[BOOL] = {
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: BOOL] =
{ m: Node _ NIL;
P.OS.Put[IO.rope[mess], IO.rope[": "], IO.rope[est]];
P.OS.Put[IO.rope[", in"], IO.char['\n]];
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: BOOL]=
{loop _ FALSE;
SELECT x.Type  FROM
PLUS=>
{ P: PROC[i,j: ROPE] RETURNS[ROPE] =
{RETURN[S.MakeNUM[S.MakeInt[i]+S.MakeInt[j]]]};
ans _ Binary[lop, rop, P];
};
MINUS=>
{ M: PROC[i,j: ROPE] RETURNS[ROPE] =
{RETURN[S.MakeNUM[S.MakeInt[i]-S.MakeInt[j]]]};
ans _ Binary[lop, rop, M];
};
SEQ => {
from: INT = S.MakeInt[BlessString[lop]];
to: INT _ S.MakeInt[BlessString[rop]];
inc: INT = 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=$VALUE 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[BOOL] =
{RETURN[x.Equal[y]]};

VEqual: PUBLIC PROC[lx,rx: Node] RETURNS [res: BOOL] =
{
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: CHAR;
[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: BOOL,
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=$VALUE 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: INT _ 0;
l1 _ p.str.Length;
UNTIL i=l1 DO
IF S.EmptyS[s] THEN  { ans _ Fail; EXIT };
{c: CHAR;
[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[NodeRecord.STR _ 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[NodeRecord.STR _ [TRUE,STR[s]]]]};

BlessVAL: PROC[x: P.Symbol] RETURNS [REF P.SymbolRecord.VALUE] =
{WITH x SELECT FROM
r: rVAL => RETURN[r];
ENDCASE => ERROR;
};

[Fail,MTSt,Nail] _ P.GetSpecialNodes[];

Left _ BlessVAL[P.Insert["left", [,,VALUE[NIL]]]];
Right _ BlessVAL[P.Insert["right", [,,VALUE[NIL]]]];

}.

