91 lines
2.2 KiB
OCaml
91 lines
2.2 KiB
OCaml
|
open Ast
|
||
|
|
|
||
|
|
exception Expected of string
|
||
|
|
exception Unexpected_token of string
|
||
|
|
|
||
|
|
let expected t =
|
||
|
|
raise (Expected t)
|
||
|
|
|
||
|
|
let unexpected_token t =
|
||
|
|
raise @@ Unexpected_token (Token.to_string t)
|
||
|
|
|
||
|
|
let precedence = [
|
||
|
|
"+", 10;
|
||
|
|
"-", 10;
|
||
|
|
"*", 20;
|
||
|
|
"/", 20;
|
||
|
|
] |> List.to_seq |> Hashtbl.of_seq
|
||
|
|
|
||
|
|
let precedence_of op =
|
||
|
|
Hashtbl.find precedence (Ast.binop_to_string op)
|
||
|
|
|
||
|
|
let token_to_op = function
|
||
|
|
| Token.Plus -> Add
|
||
|
|
| Minus -> Sub
|
||
|
|
| Asterisk -> Mul
|
||
|
|
| Slash -> Div
|
||
|
|
| _ -> failwith "Parser.token_to_op"
|
||
|
|
|
||
|
|
let parse : type a. Token.t Seq.t -> a Ast.t = fun ts ->
|
||
|
|
(* value := int | ( expr ) *)
|
||
|
|
let rec value seq =
|
||
|
|
match seq () with
|
||
|
|
| Seq.Nil -> assert false
|
||
|
|
| Seq.Cons (x, seq) -> begin match x with
|
||
|
|
| Token.Int n -> Value (Int n), seq
|
||
|
|
| LParen -> expr seq
|
||
|
|
| _ -> unexpected_token x
|
||
|
|
end
|
||
|
|
|
||
|
|
(* binop := binop op binop *)
|
||
|
|
and binop pre left seq =
|
||
|
|
match seq () with
|
||
|
|
| Seq.Nil -> left, Seq.empty
|
||
|
|
| Seq.Cons (x, seq) -> begin match x with
|
||
|
|
| Token.Plus | Minus | Asterisk | Slash as op ->
|
||
|
|
let op = token_to_op op in
|
||
|
|
let o = precedence_of op in
|
||
|
|
if o > pre then
|
||
|
|
let v, seq = value seq in
|
||
|
|
let right, seq = binop o v seq in
|
||
|
|
binop pre (Ast.binop left op right) seq
|
||
|
|
else
|
||
|
|
left, Seq.cons x seq
|
||
|
|
| RParen -> left, seq
|
||
|
|
| _ -> unexpected_token x
|
||
|
|
end
|
||
|
|
|
||
|
|
and operator seq =
|
||
|
|
match seq () with
|
||
|
|
| Seq.Nil -> expected "operator"
|
||
|
|
| Seq.Cons (x, seq) ->
|
||
|
|
try token_to_op x, seq with
|
||
|
|
| _ -> expected "operator"
|
||
|
|
|
||
|
|
and set_conf seq =
|
||
|
|
match seq () with
|
||
|
|
| Seq.Nil -> expected "ident"
|
||
|
|
| Seq.Cons (x, seq) -> begin match x with
|
||
|
|
| Token.Ident "level" ->
|
||
|
|
let op, seq = operator seq in
|
||
|
|
let v, seq = value seq in
|
||
|
|
Set_binop_pre (op, v), seq
|
||
|
|
| _ -> expected "argument"
|
||
|
|
end
|
||
|
|
|
||
|
|
and expr seq =
|
||
|
|
match seq () with
|
||
|
|
| Seq.Nil -> Value Unit (* nop *)
|
||
|
|
| Seq.Cons (x, s) -> begin match x with
|
||
|
|
| Ident "set" -> set_conf s
|
||
|
|
| _ ->
|
||
|
|
let left, seq = value seq in
|
||
|
|
binop ~-1 left seq
|
||
|
|
end
|
||
|
|
in
|
||
|
|
let ast, _ = expr ts in
|
||
|
|
(*
|
||
|
|
if rest () <> Seq.Nil then failwith "Parser.parse";
|
||
|
|
*)
|
||
|
|
ast
|