-- 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[];
}.