1 (*===---------------------------------------------------------------------===
3 *===---------------------------------------------------------------------===*)
5 (* binop_precedence - This holds the precedence for each binary operator that is
7 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
9 (* precedence - Get the precedence of the pending binary operator token. *)
10 let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
16 let rec parse_primary = parser
17 (* numberexpr ::= number *)
18 | [< 'Token.Number n >] -> Ast.Number n
20 (* parenexpr ::= '(' expression ')' *)
21 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
25 * ::= identifier '(' argumentexpr ')' *)
26 | [< 'Token.Ident id; stream >] ->
27 let rec parse_args accumulator = parser
28 | [< e=parse_expr; stream >] ->
30 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
31 | [< >] -> e :: accumulator
33 | [< >] -> accumulator
35 let rec parse_ident id = parser
39 'Token.Kwd ')' ?? "expected ')'">] ->
40 Ast.Call (id, Array.of_list (List.rev args))
42 (* Simple variable ref. *)
43 | [< >] -> Ast.Variable id
47 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
50 * ::= ('+' primary)* *)
51 and parse_bin_rhs expr_prec lhs stream =
52 match Stream.peek stream with
53 (* If this is a binop, find its precedence. *)
54 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
55 let token_prec = precedence c in
57 (* If this is a binop that binds at least as tightly as the current binop,
58 * consume it, otherwise we are done. *)
59 if token_prec < expr_prec then lhs else begin
63 (* Parse the primary expression after the binary operator. *)
64 let rhs = parse_primary stream in
66 (* Okay, we know this is a binop. *)
68 match Stream.peek stream with
69 | Some (Token.Kwd c2) ->
70 (* If BinOp binds less tightly with rhs than the operator after
71 * rhs, let the pending operator take rhs as its lhs. *)
72 let next_prec = precedence c2 in
73 if token_prec < next_prec
74 then parse_bin_rhs (token_prec + 1) rhs stream
80 let lhs = Ast.Binary (c, lhs, rhs) in
81 parse_bin_rhs expr_prec lhs stream
86 * ::= primary binoprhs *)
87 and parse_expr = parser
88 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
91 * ::= id '(' id* ')' *)
93 let rec parse_args accumulator = parser
94 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
95 | [< >] -> accumulator
100 'Token.Kwd '(' ?? "expected '(' in prototype";
102 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
104 Ast.Prototype (id, Array.of_list (List.rev args))
107 raise (Stream.Error "expected function name in prototype")
109 (* definition ::= 'def' prototype expression *)
110 let parse_definition = parser
111 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
114 (* toplevelexpr ::= expression *)
115 let parse_toplevel = parser
116 | [< e=parse_expr >] ->
117 (* Make an anonymous proto. *)
118 Ast.Function (Ast.Prototype ("", [||]), e)
120 (* external ::= 'extern' prototype *)
121 let parse_extern = parser
122 | [< 'Token.Extern; e=parse_prototype >] -> e