[ivy]<Satterthwaite>Poplar>PLEvalImpl.Mesa!6

PLEvalImpl.Mesa

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];

};

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"];

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𡤎val[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𡤎val[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𡤎val[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𡤎val[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𡤎val[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]]]];

}.