
<<ExpressParserImpl.mesa>>
<<Implementation of vanilla recursive descent parser for the Express package>>
<<Created Tuesday, July 17, 1984 10:16 pm PDT>>
<<Last edited by Eric Nickell, July 31, 1984 10:56:38 pm PDT>>
<<>>
DIRECTORY
AMBridge,
AMTypes,
Convert,
Express,
ExpressParser,
ExpressToken,
ExpressTree,
Real,
RealFns,
Rope;

ExpressParserImpl: CEDAR PROGRAM
IMPORTS AMBridge, AMTypes, Convert, ExpressToken, ExpressTree, Real, RealFns, Rope
EXPORTS Express, ExpressParser
~ {
OPEN ExpressParser, E: Express, ETk: ExpressToken, ET: ExpressTree, RF: RealFns;

ROPE: TYPE ~ Rope.ROPE;
Token: TYPE ~ ETk.Token;
ErrorDesc: TYPE ~ E.ErrorDesc;

ParseError: PUBLIC ERROR [ErrorDesc] ~ CODE;
IllegalClientProcedure: PUBLIC ERROR ~ CODE;

ParseExpression: PUBLIC PROC [ts: TokenStream, symbols: Symbols, cProcs: ClientProcList _ NIL] RETURNS [expression: XTree] ~ {
<<Converts the token stream into an expression tree>>
<<>>
<<Utility procs under this section>>
Error: PROC [message: ROPE] ~ {
<<Theoretically, at least, the offending token should be on the stack>>
ERROR ParseError[[message, ETk.TokenPosition[ts]]];
};

RopeToReal: PROC [rope: ROPE] RETURNS [value: REAL] ~ {
OPEN C: Convert;
IF Rope.Find[rope, "."]=-1
THEN value _ C.CardFromDecimalLiteral[rope ! ANY => Error["Expected value"]]
ELSE value _ C.RealFromRope[rope ! ANY => Error["Expected value"]];
};
ClientProcInfo: PROC [procName: ROPE] RETURNS [nItems: NAT, proc: PROC ANY RETURNS [REAL]] ~ TRUSTED {
FOR cProc: ClientProcList _ cProcs, cProc.rest UNTIL cProc=NIL DO
IF Rope.Equal[cProc.first.userRope, procName, FALSE] THEN {
<<First, see how many args the proc takes>>
OPEN AMTypes;

procType: Type _ TVType[ AMBridge.TVForProc[cProc.first.proc]];
domain: Type _ Domain[procType];
range: Type _ Range[procType];
proc _ cProc.first.proc;
IF Size[Range[procType]]#2 THEN ERROR IllegalClientProcedure[];
nItems _ NComponents[domain];        --Ah, but are they all the right size?
FOR i: Index IN [1..nItems] DO
IF Size[IndexToType[domain, 1]]#2 THEN ERROR IllegalClientProcedure[];
ENDLOOP;
<<Here, we know the proc is of the form PROC [arg1, ..., argn] RETURNS [val], where val and argi are all 2 words.>>
RETURN;
};
ENDLOOP;
ERROR;
};
Type: PROC RETURNS [ATOM] ~ {
RETURN[GetToken[].kind];
};
PeekType: PROC RETURNS [ATOM] ~ {
token: Token _ GetToken[];
Push[token];
RETURN[token.kind];
};
Skip: PROC ~ {                    --Peeked at token, and now wants to throw it away...
[] _ GetToken[];
};
GetToken: PROC RETURNS [Token] ~ {RETURN[ETk.GetNextToken[ts, symbols, cProcs]]};

Push: PROC [t: Token] ~ {ETk.PushToken[ts, t]};
Relop: PROC [kind: ATOM] RETURNS [BOOLEAN] ~ {
RETURN[SELECT kind FROM
$LT, $GT, $LE, $GE, $EQ, $NE => TRUE,
ENDCASE => FALSE];
};
InvertRelop: PROC [kind: ATOM] RETURNS [ATOM] ~ {
RETURN[SELECT kind FROM
$LT => $GE,
$GT => $LE,
$LE => $GT,
$GE => $LT,
$EQ => $NE,
$NE => $EQ,
ENDCASE => kind]
};
<<END of the Utility procs>>
<<Parsing procs>>
ParseExp: PROC RETURNS [XTree] ~ {
IF PeekType[]=$If THEN {
e1, e2, e3: XTree;
Skip[];                                                    --IF
e1 _ ParseDisjunct[];                                    --exp1
IF Type[]#$Then THEN Error["Expected THEN"];    --THEN
e2 _ ParseExp[];                                            --exp2
IF Type[]#$Else THEN Error["Expected ELSE"];        --ELSE
e3 _ ParseExp[];                                            --exp3
RETURN[ET.ApplyTrinOp[$If, e1, e2, e3]];
}
ELSE {
RETURN[ParseSum[]];
};
};
ParseSum: PROC RETURNS [exp: XTree] ~ {
token: Token;
exp _ ParseProduct[];
DO
token _ GetToken[];
SELECT token.kind FROM
$Add, $Subtract => exp _ ET.ApplyBinOp[token.kind, exp, ParseProduct[]];
ENDCASE => {Push[token]; EXIT};
ENDLOOP;
};
ParseProduct: PROC RETURNS [exp: XTree] ~ {
token: Token;
exp _ ParseFactor[];
DO
token _ GetToken[];
SELECT token.kind FROM
$Multiply, $Divide => exp _ ET.ApplyBinOp[token.kind, exp, ParseFactor[]]; 
$mod => exp _ ET.ApplyFcn[KindToProc[token.kind], LIST[exp, ParseFactor[]]];
ENDCASE => {Push[token]; EXIT};
ENDLOOP;
};
ParseDisjunct: PROC RETURNS [exp: XTree] ~ {
token: Token;
exp _ ParseConjunct[];
DO
token _ GetToken[];
SELECT token.kind FROM
$or => exp _ ET.ApplyBinOp[token.kind, exp, ParseConjunct[]];
ENDCASE => {Push[token]; EXIT};
ENDLOOP;
};
ParseConjunct: PROC RETURNS [exp: XTree] ~ {
token: Token;
exp _ ParseNegation[];
DO
token _ GetToken[];
SELECT token.kind FROM
$and, $xor => exp _ ET.ApplyBinOp[token.kind, exp, ParseNegation[]];
ENDCASE => {Push[token]; EXIT};
ENDLOOP;
};
ParseNegation: PROC RETURNS [XTree] ~ {
IF PeekType[]=$not THEN {
kind: ATOM _ GetToken[].kind;                        --Get the $not
RETURN[ET.ApplyUnOp[kind, ParseRelation[]]]
}
ELSE RETURN[ParseRelation[]];
};
ParseRelation: PROC RETURNS [XTree] ~ {
relop: ATOM;
e1, e2: XTree;
IF PeekType[]=$LPar THEN {
kind: ATOM _ GetToken[].kind;
xTree: XTree _ ParseDisjunct[];
IF Type[]#$RPar THEN Error["Expected Right Parenthesis"];
RETURN[xTree];
}
ELSE {
e1 _ ParseExp[];                                --exp1
relop _ ParseRelop[];                        --relop
e2 _ ParseExp[];                                --exp2
RETURN[ET.ApplyBinOp[relop, e1, e2]];
};
};
ParseRelop: PROC RETURNS [kind: ATOM] ~ {
token: Token _ GetToken[];
SELECT TRUE FROM
token.kind=$not => {RETURN[InvertRelop[ParseRelop[]]]};
Relop[token.kind] => {RETURN[token.kind]};
ENDCASE => Error["Expected Relational Operator"];
};
ParseFactor: PROC RETURNS [XTree] ~ {
token: Token _ GetToken[];
SELECT token.kind FROM
$Add => RETURN[ParseExponentiation[]];
$Subtract => RETURN[ET.ApplyUnOp[$Negate, ParseExponentiation[]]];
ENDCASE => {Push[token]; RETURN[ParseExponentiation[]]};
};
ParseExponentiation: PROC RETURNS [exp: XTree] ~ {
token: Token;
exp _ ParsePrimary[];
DO
token _ GetToken[];
SELECT token.kind FROM
$power => exp _ ET.ApplyFcn[KindToProc[token.kind], LIST[exp, ParsePrimary[]]];
ENDCASE => {Push[token]; EXIT};
ENDLOOP;
};
ParsePrimary: PROC RETURNS [exp: XTree] ~ {
token: Token _ GetToken[];
args: LIST OF XTree;
SELECT token.kind FROM
$Id1, $Id2, $Id3, $Id4, $Id5 => RETURN[ET.XTreeFromId[token.kind]];
$Constant => RETURN[ET.XTreeFromConstant[RopeToReal[token.rope]]];
$LPar => {
exp _ ParseExp[];
IF Type[]#$RPar THEN Error["Expected Right Parenthesis"];
};
$sin, $cos, $tan, $sqrt, $atan, $exp, $ln, $abs => {
args _ ParseRecord[1];    --Parse a 1-valued domain
RETURN[ET.ApplyFcn[KindToProc[token.kind], args]]
};
$min, $max => {
args _ ParseRecord[2];    --Parse a 2-valued domain (built into the proc builder)
RETURN[ET.ApplyBinOp[token.kind, args.first, args.rest.first]];
};
$atanxy, $log => {    --Parse a 2-valued domain (for which this module supplies a procedure)
args _ ParseRecord[2];
IF token.kind=$atanxy THEN args _ LIST[args.rest.first, args.first];        --Mumble, mumble, mumble ... This allows the user to 
type in his arguments in the form atan[x, y] , but the actual implementation pushes the y argument on the stack first, in order 
that the procedure called (which is RealFns.ArcTan) has y as the first argument.
RETURN[ET.ApplyFcn[KindToProc[token.kind], args]];
};
$CProc => {
nItems: INT;
proc: PROC ANY RETURNS [REAL];
[nItems, proc] _ ClientProcInfo[token.rope];
args _ ParseRecord[nItems];
RETURN[ET.ApplyFcn[proc, args]]
};
ENDCASE => Error["Illegal symbol"];
};
ParseRecord: PROC [nItems: INT] RETURNS [args: LIST OF XTree _ NIL] ~ {
argsTail: LIST OF XTree _ NIL;                    --Tail of args list

IF nItems=0 THEN RETURN[NIL];
IF Type[]#$LBracket THEN Error["Expected Left Bracket"];
argsTail _ args _ CONS[ParseExp[], NIL];        --First argument
THROUGH (1..nItems] DO
IF Type[]#$Comma THEN Error["Expected Comma"];
argsTail _ argsTail.rest _ CONS[ParseExp[], NIL];
ENDLOOP;
IF Type[]#$RBracket THEN Error["Expected Right Bracket"];
};
<<Main routine for ParseExpression>>
expression _ ParseExp[];
IF Type[]#$EndOfStream THEN Error["Garbage on end of expression"];
};

FcnList: TYPE ~ LIST OF RECORD [kind: ATOM, proc: PROC ANY RETURNS ANY];
fcnList: FcnList _ NIL;
RegisterFcn: PROC [rope: ROPE, kind: ATOM, proc: PROC ANY RETURNS ANY] ~ {
ETk.RegisterToken[rope, kind];
fcnList _ CONS[[kind, proc], fcnList];
};

KindToProc: PROC [kind: ATOM] RETURNS [proc: PROC ANY RETURNS ANY] ~ {
FOR fcns: FcnList _ fcnList, fcns.rest UNTIL fcns=NIL DO
IF fcns.first.kind=kind THEN RETURN[fcns.first.proc];
ENDLOOP;
ERROR;
};

Init: PROC ~ {
RegisterFcn["sin", $sin, RF.Sin];
RegisterFcn["cos", $cos, RF.Cos];
RegisterFcn["tan", $tan, RF.Tan];
RegisterFcn["sqrt", $sqrt, RF.SqRt];
RegisterFcn["log", $log, RF.Log];
RegisterFcn["^", $power, RF.Power];
RegisterFcn["atan", $atan, EvArcTan];
RegisterFcn["exp", $exp, RF.Exp];
RegisterFcn["ln", $ln, RF.Ln];
RegisterFcn["atanxy", $atanxy, RF.ArcTan];
RegisterFcn["abs", $abs, EvAbs];
RegisterFcn["mod", $mod, EvMod];
};

<<This section contains the procedures which implement operations not found elsewhere>>
EvMod: PROC [a, b: REAL] RETURNS [REAL] ~ {        --RETURN a mod b
RETURN[a-b*Real.Fix[a/b]];
};

EvArcTan: PROC [a: REAL] RETURNS [REAL] ~ {
RETURN[RF.ArcTan[a, 1.0]];
};

EvAbs: PROC [a: REAL] RETURNS [REAL] ~ {
RETURN[IF a<0 THEN -a ELSE a];
};

<<START code for ExpressParser>>
Init[];
}.