## precedence-parser.pkg
#
# A really stupid but (hopefully) working precedence parser
#
# --Allen Leung (leunga@cs.nyu.edu)
# Compiled by:
# src/lib/compiler/back/low/tools/precedence-parser.lib### "It's fine to work on any problem,
### so long as it generates interesting
### mathematics along the way -- even if you
### don't solve it at the end of the day."
###
### -- Andrew Wiles
api Precedence_Parser {
Precedence_Stack;
Fixity = INFIX Int
| INFIXR Int
| NONFIX;
Token X = ID String
| EXP X;
exception PRECEDENCE_ERROR;
empty: Precedence_Stack;
declare: (Precedence_Stack, String, Fixity) -> Precedence_Stack;
parse: { stack: Precedence_Stack,
apply: (X, X) -> X,
tuple: List(X) -> X,
id: String -> X,
error: String -> Void,
to_string: X -> String,
kind: String
} -> List( Token(X) ) -> X;
};
package precedence_parser
: (weak) Precedence_Parser # Precedence_Parser is from src/lib/compiler/back/low/tools/precedence-parser/precedence-parser.pkg{
Fixity = INFIX Int
| INFIXR Int
| NONFIX;
Token X = ID String
| EXP X;
Precedence_Stack = List( (String, Fixity) );
empty = [];
fun declare (stack, id, fixity)
=
(id, fixity) ! stack;
exception PRECEDENCE_ERROR;
fun parse { stack, tuple, apply, id, to_string, error, kind } tokens
=
{ fun fixity x
=
f stack
where
fun f [] => NONFIX;
f ((y, fix) ! sss) => if (x == y ) fix; else f sss;fi;
end;
end;
toks = map \\ ID x => (id x, fixity x);
EXP e => (e, NONFIX);
end
tokens;
fun err msg
=
{ error ( msg + " in " + kind + ": "
+
(list::fold_backward
\\ ((x, _), "") => to_string x;
((x, _), s) => to_string x + " " + s;
end
""
toks
)
);
raise exception PRECEDENCE_ERROR;
};
fun err' (msg, x)
=
err (msg + " " + to_string x);
# Parse with precedence.
#
fun scan (p, tokens)
=
case tokens
(f, NONFIX) ! (x, NONFIX) ! rest
=>
scan (p, (apply (f, x), NONFIX) ! rest); # Application
[(x, NONFIX)]
=>
(x, []);
(x, INFIX _) ! _
=>
err'("dangling infix symbol", x);
(x, INFIXR _) ! _
=>
err'("dangling infixr symbol", x);
(left, NONFIX) ! (rest as (f, INFIX q) ! rest')
=>
if (p >= q)
(left, rest);
else
my (right, rest) = scan (q, rest');
scan (p, (apply (f, tuple [left, right]), NONFIX) ! rest);
fi;
(left, NONFIX) ! (rest as (f, INFIXR q) ! rest')
=>
if (p > q)
(left, rest);
else
my (right, rest) = scan (q, rest');
scan (p, (apply (f, tuple [left, right]), NONFIX) ! rest);
fi;
_ =>
err("parse error");
esac;
fun scan_all [(x, INFIX _)] => x;
scan_all [(x, INFIXR _)] => x;
scan_all tokens => #1 (scan(-1, tokens));
end;
scan_all toks;
};
};