-- PLParseImpl.Mesa

-- used to be parse.mesa

DIRECTORY
  Disp: TYPE USING [Print],
  IO: TYPE USING [char, CR, int, Put, PutF, rope, ROPE, TAB],
  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, Control, FromRefText, ROPE];

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

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;
Symbol: TYPE = PL.Symbol;
String: TYPE = ROPE;
--
progstr: PString.Stream;
currn: Node _ NIL;

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

nchar: CHARACTER;
stcnt, linecnt, charcnt: INT;
Fail,MTSt: Node;
Nail: PL.LSTNode;
savinput: PString.Stream;
checking: BOOLEAN _ 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[BOOLEAN] =
	   {
	   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[BOOLEAN] =
	   {
	   IF n.Type=EQUAL THEN
		 {
		 P.OS.Put[rope["Missed Equality Check"], char[CR]];
		 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[BOOLEAN] = {
	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: BOOLEAN _ 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: BOOLEAN _ FALSE;
c: CHARACTER;
loop: BOOLEAN _ TRUE;
uc: BOOLEAN;

WHILE loop DO
      loop _ FALSE;
      WHILE nchar = '  OR nchar = TAB OR nchar = CR 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 _ Rope.Concat[t, 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 _ Rope.Concat[t, 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 = CR THEN EXIT;
			     IF c ~= '- THEN LOOP;
			     c _ GetNChar[];
			     IF c = 0C OR c = CR THEN EXIT;
			     IF c ~= '- THEN LOOP;
			     c _ GetNChar[];
			     IF c = '- OR c = 0C OR c = CR 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],[,,VAL[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 [CHARACTER] = {
IF nchar = CR THEN savinput _ progstr;
[nchar, progstr] _ S.Item[progstr];
IF nchar = Control['Z] THEN
      WHILE nchar ~= CR DO [nchar,progstr] _ S.Item[progstr] ENDLOOP;
charcnt _ IF nchar = CR THEN 1 ELSE charcnt + 1;
IF nchar = CR THEN linecnt _ linecnt + 1;
RETURN[nchar];
};

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

Usual: PROC[c: CHARACTER] RETURNS[CHARACTER] = {
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",[,,VAL[Fail]]]};

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