
<<PLParseImpl.Mesa>>
<<Copyright (c) 1981 by Xerox Corporation.  All rights reserved.>>
<<lasted edited by Satterthwaite, April 18, 1986 5:06:41 pm PST>>

<<used to be parse.mesa>>

DIRECTORY
Ascii: TYPE USING [Control],
Disp: TYPE USING [Print],
IO: TYPE USING [char, int, Put, PutF, rope],
PL: TYPE USING [Eval, GetSpecialNodes, Insert, Lookup, LSTNode, LSTNodeRecord,
Node, NodeRecord, NodeType, OS, Preorder, rEQUAL, RErr, rFCN, rID, rPFUNC1,
rSTR, rUNARY, SErr, SN, Symbol, Z],
PString: TYPE USING [CopyStream, EmptyS, Item, MakeNUM, NewStream, Stream],
Rope: TYPE USING [Concat, FromRefText, ROPE];

PLParseImpl: CEDAR PROGRAM
IMPORTS Ascii, Disp, S: PString, P:PL, Rope, IO EXPORTS PL = {
OPEN PL;

N: ZONE = P.Z;

TokType: TYPE = {ZERO,LP,RP,LB,RB,COMMA,EOF,SEP,LC,RC,
COLON,HOLE,DIV,STR,ID,GTR,ASS,PROG,FCN,SEQOF,OPT,
DELETE,SEQOFC,MAPPLY, PLUS,MINUS,
GOBBLE,TILDE,PALT,COMB, SEQ, CATL, WILD, FAIL,ITER,SCREEN,EQUAL};
NodeType: TYPE = PL.NodeType;
LSTNode: TYPE = PL.LSTNode;
LSTNodeRecord: TYPE = PL.LSTNodeRecord;
Node: TYPE = PL.Node;
NodeRecord: TYPE = PL.NodeRecord;
ROPE: TYPE = Rope.ROPE;
Symbol: TYPE = PL.Symbol;
String: TYPE = ROPE;
<<>>
progstr: PString.Stream;
currn: Node _ NIL;

tokenType: TokType _ ZERO;
tokenString: String _ NIL;
tokenID: Symbol _ NIL;

nchar: CHAR;
stcnt, linecnt, charcnt: INT;
Fail,MTSt: Node;
Nail: PL.LSTNode;
savinput: PString.Stream;
checking: BOOL _ FALSE; -- set by CheckRoutine, used by BinaryExp and FunctionBody
<<dist: prog EOF>>
<<prog: stmt { SEP prog } | stmt SEP>>
<<stmt: var ASS stmt | exp >>
<<ChoiceExp: ThenExp {PALT ThenExp} >>
<<ThenExp: BinaryExp {GTR BinaryExp} >>
<<BinaryExp: BinaryExp {(DIV | MAPPLY| GOBBLE| ITER | PLUS | MINUS | CATL | SEQ | EQUAL ) PrefixExp} | BinaryExp PrefixExp  >>
<<PrefixExp:  UNARY PrefixExp | PFUNC1 PrefixExp | MINUS PrefixExp | TILDE PrefixExp | SimpleExp {SEQOF | SEQOFC | OPT | DELETE} >>
<<SimpleExp: STR | ID  | PFUNC | SCREEN | WILD | FAIL | HOLE | LB RB | LB prog RB | LC stmt RC | ID COLON  {= PrefixExp ;}prog | LB 
prog RB COLON {= PrefixExp ;} prog>>
<<| LP stmt RP>>
<<>>
<<Convention: peektok is the first token for each of the routines, e.g.>>
<<peektok = STR for the Base>>

CheckRoutine: PROC[prog: Node]
RETURNS [ans: Node] =
{
Ch: PROC[n:Node] RETURNS[BOOL] =
{
WITH n SELECT FROM f: rFCN => 
WITH f.parms SELECT FROM p: rEQUAL =>
{
[] _ P.Eval[n, NIL];
};
ENDCASE;
ENDCASE;
RETURN[TRUE];
};
Ch1: PROC[n:Node] RETURNS[BOOL] =
{
IF n.Type=EQUAL THEN
{
P.OS.Put[IO.rope["Missed Equality Check"], IO.char['\n]];
Disp.Print[n];
};
RETURN[TRUE];
};
WITH prog SELECT FROM
s: rSTR => 
{checking _ TRUE;
{p: Node _ Dist[s.str ! UNWIND => checking _ FALSE];
checking _ FALSE;
[] _ P.Eval[p, NIL];
P.Preorder[p, Ch];
P.Preorder[p, Ch1];
ans _ Nail}};
ENDCASE => P.RErr["input to check not string"];
};

FillRoutine: PROC[prog: Node]
RETURNS [ans: Node] =
{WITH prog SELECT FROM
s: rSTR => 
{ans _ Dist[s.str];
[] _ P.Eval[ans, NIL]};
ENDCASE => P.RErr["input to check not string"];
};


Dist: PUBLIC PROC [p: ROPE] RETURNS[Node] = {
<<this is the kickoff routine - call only once>>
<<p is the node to which has the string to be compiled>>
n: Node _ NIL;
progstr _ S.NewStream[p];
savinput _ S.CopyStream[progstr];
charcnt _ stcnt _ linecnt _ 1;
nchar _ ' ;
GetTok;                        -- set up peek vals
n _ Prog[];
IF tokenType ~= EOF THEN ErrorMsg["Parser expected EOF"];
P.Preorder[n,CheckPattern];
RETURN[n];
};

CheckPattern: PROC[n: Node] RETURNS[BOOL] = {
IF n.Type = PATTERN THEN RETURN[FALSE];
IF n.Type = SEQOF
OR n.Type = SEQOFC 
OR n.Type = OPT 
OR n.Type = DELETE
OR n.Type = HOLE THEN ErrorMsg["Pattern operator not surrounded by { }"];
RETURN[TRUE];
};

Prog: PROC RETURNS [res: Node] = {
res _ NIL;
res _ Stmt[];
IF tokenType = SEP THEN {
GetTok;
IF tokenType ~= EOF THEN res _ N.NEW[NodeRecord_[,PROG[res,Prog[]]]];
};
};

Stmt: PROC RETURNS[i: Node] = {
i _ ChoiceExp[];
IF tokenType = ASS THEN {
WITH i SELECT FROM
x: rID =>{t: Symbol = x.name;
GetTok;
i _ N.NEW[NodeRecord_[,ASS[t,Stmt[]]]];
}
ENDCASE => ErrorMsg["Missing ; or assignment to non-variable"];
};
RETURN[i];
};

<<this parses left-assoc instead of right assoc.>>
ChoiceExp: PROC RETURNS[Node] = {
i,j: Node _ NIL;
IF tokenType = PALT THEN i _ currn
ELSE i _ ThenExp[];
WHILE tokenType =  PALT DO
GetTok;
j _ ThenExp[];
i _ N.NEW[NodeRecord_[,PALT[i,j]]]
ENDLOOP;
RETURN[i];
};

ThenExp: PROC RETURNS[Node] = {
i,j: Node _ NIL;
IF tokenType = GTR THEN i _ currn
ELSE i _ BinaryExp[];
WHILE tokenType =  GTR DO
GetTok;
j _ BinaryExp[];
i _ N.NEW[NodeRecord_[,GTR[i,j]]]
ENDLOOP;
RETURN[i];
};

BinaryExp: PROC RETURNS[i: Node] = {
loop: BOOL _ TRUE;
p: TokType _ tokenType;
i _ IF p = DIV OR p = MAPPLY OR p = GOBBLE OR p = ITER OR p = PLUS OR p = CATL OR p = SEQ OR p = PLUS OR p = CATL OR p = SEQ THEN 
currn ELSE PrefixExp[];
WHILE loop DO
loop _ TRUE;
SELECT tokenType FROM
DIV => {
GetTok;
i _ N.NEW[NodeRecord_[,PAPPLY[i,PrefixExp[]]]];
};
MAPPLY => {
GetTok;
i _ N.NEW[NodeRecord_[,MAPPLY[i,PrefixExp[]]]];
};
GOBBLE => {
GetTok;
i _ N.NEW[NodeRecord_[,GOBBLE[i,PrefixExp[]]]];
};
ITER => {
GetTok;
i _ N.NEW[NodeRecord_[,ITER[i,PrefixExp[]]]];
};
PLUS => {
GetTok;
i _ N.NEW[NodeRecord_[,PLUS[i,PrefixExp[]]]];
};
MINUS => {
GetTok;
i _ N.NEW[NodeRecord_[,MINUS[i,PrefixExp[]]]];
};
CATL => {
GetTok;
i _ N.NEW[NodeRecord_[,CATL[i,PrefixExp[]]]];
};
SEQ => {
GetTok;
i _ N.NEW[NodeRecord_[,SEQ[i,PrefixExp[]]]];
};
EQUAL => {
GetTok;
IF checking THEN
i _ N.NEW[NodeRecord_[,EQUAL[i,PrefixExp[]]]]
ELSE [] _ PrefixExp[];
};
ENDCASE => {
<<check to see if this is a cat>>
<<the list below must be kept up to date.>>
<<It is those things in First[PreFixExp]>>
p _ tokenType;
IF p=ID OR p=STR OR p = COMB OR p = LB OR p = LC OR p = LP OR p = TILDE OR p = MINUS OR p = SCREEN OR p = HOLE OR p=WILD OR p = 
FAIL THEN
i _ N.NEW[NodeRecord_[,CAT[i,PrefixExp[]]]]
ELSE loop _ FALSE;
};
ENDLOOP;
RETURN[i];
};

PrefixExp: PROC RETURNS[i:Node] = {
SELECT tokenType FROM
ID => 
WITH tokenID SELECT FROM
s: rUNARY => {t: Symbol _ tokenID;
GetTok;
RETURN[N.NEW[NodeRecord _[,COMB[t,PrefixExp[]]]]];
};
s: rPFUNC1 => {t: Symbol _ tokenID;
GetTok;
RETURN[N.NEW[NodeRecord _[,COMB[t,PrefixExp[]]]]];
};
ENDCASE;
TILDE => {
GetTok;
RETURN[N.NEW[NodeRecord _[,TILDE[PrefixExp[]]]]];
};
MINUS => {
GetTok;
i _ N.NEW[NodeRecord _[,MINUS[P.SN[S.MakeNUM[0]],PrefixExp[]]]];
RETURN;
};
ENDCASE;
i _ SimpleExp[];
WHILE tokenType = SEQOF OR tokenType = SEQOFC OR tokenType = OPT OR tokenType = DELETE DO
IF tokenType = SEQOF THEN {
GetTok;
i _ N.NEW[NodeRecord _[,SEQOF[i]]];
}
ELSE IF tokenType = SEQOFC THEN {
GetTok;
i _ N.NEW[NodeRecord _[,SEQOFC[i]]];
}
ELSE IF tokenType = OPT THEN {
GetTok;
i _ N.NEW[NodeRecord _[,OPT[i]]];
}
ELSE IF tokenType = DELETE THEN {
GetTok;
i _ N.NEW[NodeRecord _[,DELETE[i]]];
};
ENDLOOP;
};

SimpleExp: PROC RETURNS[t: Node] = {
SELECT tokenType FROM
STR =>        {x:String=tokenString; GetTok; RETURN[P.SN[x]]; };
ID =>        {
t _ N.NEW[NodeRecord _ [,ID[tokenID]]];
GetTok;
IF tokenType=COLON THEN t _ FunctionBody[t];
RETURN;
};
SCREEN => { GetTok; RETURN[currn] };
HOLE => { GetTok; RETURN[N.NEW[NodeRecord _ [,HOLE[]]]]; };
WILD => { GetTok; RETURN[N.NEW[NodeRecord _ [,WILD[]]]]; };
FAIL => { GetTok; RETURN[Fail]; };
LB =>        {
GetTok;
IF tokenType = RB THEN { GetTok;RETURN[Nail]};
{pans: LSTNode _ N.NEW[LSTNodeRecord _ [,LST[Prog[],Nail]]];
t _ pans;
WHILE tokenType = COMMA DO
GetTok;
pans.listtail _ N.NEW[LSTNodeRecord _ [,LST[Prog[],Nail]]];
pans _ pans.listtail;
ENDLOOP;
IF tokenType ~= RB THEN ErrorMsg["Missing ']'"];
GetTok;
IF tokenType=COLON THEN t _ FunctionBody[t];
RETURN};
};
LP =>        {        -- used solely for parenthesization
GetTok;
t _ Prog[];
IF tokenType ~= RP THEN ErrorMsg["Parser expected ')'"];
GetTok;
RETURN[t];
};
LC =>        {
GetTok;
t _ Prog[];
IF tokenType ~= RC THEN ErrorMsg["Parser expected '}'"];
GetTok;
RETURN[N.NEW[NodeRecord_[,PATTERN[t]]]];
};
ENDCASE;
ErrorMsg["Parser did not recognize Simple Expression"];
};

FunctionBody: PROC[bv: Node] RETURNS [b: Node] =
{
GetTok;
IF tokenType=EQUAL THEN
{
testVal: Node _ NIL;
b _NIL;
GetTok;
testVal _ PrefixExp[];
IF tokenType#SEP THEN ErrorMsg["Missing ; after :="];
GetTok;
IF checking THEN
bv _ N.NEW[NodeRecord _ [,EQUAL[bv,testVal]]];
};
b _ N.NEW[NodeRecord _ [,FCN[bv, Prog[]]]];
};

wk: REF TEXT _ NEW[TEXT[100]];

GetTok: PROC= {
i: CARDINAL;
sym: Symbol;
got: BOOL _ FALSE;
c: CHAR;
loop: BOOL _ TRUE;
uc: BOOL;

WHILE loop DO
loop _ FALSE;
WHILE nchar = '  OR nchar = '\t OR nchar = '\n DO
[] _ GetNChar[]
ENDLOOP;
SELECT nchar FROM
0C => tokenType _ EOF;
'" => { st: Node _ NIL;
t: String _ "";
i _ 0;
DO
IF i = wk.maxLength THEN
{
wk.length _ i;
t _ t.Concat[Rope.FromRefText[wk]];
i _ 0;
};
wk[i] _ GetNChar[];
IF wk[i] = 0C THEN
ErrorMsg["String ran off end, probably omitted quote"];
IF wk[i] = '" THEN
{
wk.length _ i;
t _ t.Concat[Rope.FromRefText[wk]];
EXIT;
};
IF wk[i] = '^ THEN
wk[i] _ Usual[GetNChar[]];
i  _ i + 1;
ENDLOOP;
tokenType _ STR; tokenString_t};
IN ['0..'9] => {
wk[0] _ nchar;
i _ 1;
WHILE i < wk.maxLength DO
wk[i] _ GetNChar[];
IF wk[i] = 0C THEN EXIT;
IF wk[i] NOT IN ['0..'9] THEN EXIT;
i  _ i + 1;
ENDLOOP;
IF i >= wk.maxLength THEN ErrorMsg["Number too long for parser"];
wk.length _ i;
tokenType _ STR; tokenString _ Rope.FromRefText[wk];
got _ TRUE;
};
'' => {                -- single quote, just like " except terminated diff.
i _ 0;
WHILE i < wk.maxLength AND (GetNChar[] IN ['A..'Z] OR nchar IN ['a..'z] OR nchar IN ['0..'9] OR nchar = '. OR nchar = '^) DO
wk[i] _ IF nchar = '^ THEN Usual[GetNChar[]] ELSE nchar;
i  _ i + 1;
ENDLOOP;
IF i >= wk.maxLength THEN ErrorMsg["String too long for parser"];
wk.length _ i;
tokenType _ STR; tokenString _ Rope.FromRefText[wk];
got _ TRUE;
};
'( => tokenType _LP;
') => tokenType _RP;
'[ => tokenType _LB;
'] => tokenType _RB;
'{ => tokenType _LC;
'} => tokenType _RC;
': => tokenType _COLON;
'~ => tokenType _TILDE;
'% => tokenType _ITER;
'@ => tokenType _SCREEN;
'/ => {
[] _ GetNChar[];
IF nchar ~= '/ THEN {
tokenType _DIV;
got _ TRUE;
}
ELSE {
[] _ GetNChar[];
IF nchar ~= '/ THEN {
tokenType _MAPPLY;
got _ TRUE;
}
ELSE tokenType _GOBBLE;
};
};
', => {
[] _ GetNChar[];
IF nchar = ', THEN tokenType _CATL
ELSE IF nchar = '! THEN {
tokenType _SEQOFC;
}
ELSE IF nchar ~= ', THEN {
tokenType _COMMA;
got _ TRUE;
};
};
'| => tokenType _PALT;
'. => {
[] _ GetNChar[];
IF nchar ~= '. THEN ErrorMsg["Unknown character '.'"]
ELSE {
[] _ GetNChar[];
IF nchar ~= '. THEN ErrorMsg["Unknown character '.'"]
ELSE tokenType _HOLE;
};
};
'+ => tokenType _PLUS;
'* => tokenType _DELETE;
'> => tokenType _GTR;
'# => tokenType _WILD;
'; => {
stcnt _ stcnt + 1;
tokenType _SEP;
};
'_ => tokenType _ASS;
'= =>  tokenType _ EQUAL;
'- => {
[] _  GetNChar[] ;
IF nchar = '- THEN {
[] _ GetNChar[];
IF nchar ~= '- THEN {
tokenType _SEQ;
got _ TRUE;
}
ELSE {
DO
c _ GetNChar[];
IF c = 0C OR c = '\n THEN EXIT;
IF c ~= '- THEN LOOP;
c _ GetNChar[];
IF c = 0C OR c = '\n THEN EXIT;
IF c ~= '- THEN LOOP;
c _ GetNChar[];
IF c = '- OR c = 0C OR c = '\n THEN EXIT;
ENDLOOP;
loop _ TRUE;
got _ TRUE;
}
}
ELSE {
tokenType _MINUS;
got _ TRUE;
};
};
'? => tokenType _OPT;
'! => tokenType _SEQOF;
IN ['a..'z], IN ['A..'Z] => {
i _ 0;
uc _ FALSE;
WHILE nchar IN ['a..'z] OR nchar IN ['A..'Z] OR nchar IN ['0..'9] DO
wk[i] _ nchar;
uc _ uc OR nchar IN['A..'Z];
i _ i + 1;
[] _ GetNChar[];
ENDLOOP;
wk.length _ i;
sym _ P.Lookup[Rope.FromRefText[wk]];
IF sym = NIL THEN {
IF ~uc AND i > 1 THEN ErrorMsg["Unknown primitive function name"];
tokenType _ ID;
tokenID _ P.Insert[Rope.FromRefText[wk],[,,VALUE[NIL]]];
}
ELSE {tokenType _ ID; tokenID _ sym};
got _ TRUE;
};
ENDCASE => ErrorMsg["Unknown character"];
IF ~got THEN [] _ GetNChar[];
ENDLOOP;
};


SetCurrentNode: PUBLIC PROC[n:Node] = {
currn _ n;
};

GetNChar: PROC RETURNS [CHAR] = {
IF nchar = '\n THEN savinput _ progstr;
[nchar, progstr] _ S.Item[progstr];
IF nchar = Ascii.Control['Z] THEN
WHILE nchar ~= '\n DO [nchar,progstr] _ S.Item[progstr] ENDLOOP;
charcnt _ IF nchar = '\n THEN 1 ELSE charcnt + 1;
IF nchar = '\n THEN linecnt _ linecnt + 1;
RETURN[nchar];
};

ErrorMsg: PROC[str: ROPE] = {
c: CHAR;
P.OS.PutF["Syntax error, Line: %g, Stmt: %g, Char: %g  %g\nIn command ",
IO.int[linecnt],
IO.int[stcnt],
IO.int[charcnt],
IO.rope[str]];
WHILE ~S.EmptyS[savinput] DO
[c, savinput] _ S.Item[savinput];
IF c = '\n THEN EXIT;
P.OS.Put[IO.char[c]];
ENDLOOP;
P.OS.Put[IO.char['\n]];
P.SErr[""]
};

Usual: PROC[c: CHAR] RETURNS[CHAR] = {
j: CARDINAL;
SELECT c FROM
'  =>        RETURN[' ];
'" =>        RETURN['"];
'^ =>        RETURN['^];
'' =>        RETURN[''];
IN ['0..'9] =>{
j _ (c - '0)*64;
j _ j + (GetNChar[] - '0) * 8;
j _ j + (GetNChar[] - '0);
RETURN[LOOPHOLE[j]];
};
ENDCASE => RETURN[IF c<100C THEN c ELSE c - 100B];
};

ParseSetup: PUBLIC PROC = {
SetCurrentNode[Nail];
[] _ P.Insert["check",[,,ZARY[CheckRoutine]]];
[] _ P.Insert["fill",[,,ZARY[FillRoutine]]];
[] _ P.Insert["fail",[,,VALUE[Fail]]]};

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


