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
18 let rec parse_primary = parser
19 (* numberexpr ::= number *)
20 | [< 'Token.Number n >] -> Ast.Number n
22 (* parenexpr ::= '(' expression ')' *)
23 | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
27 * ::= identifier '(' argumentexpr ')' *)
28 | [< 'Token.Ident id; stream >] ->
29 let rec parse_args accumulator = parser
30 | [< e=parse_expr; stream >] ->
32 | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
33 | [< >] -> e :: accumulator
35 | [< >] -> accumulator
37 let rec parse_ident id = parser
41 'Token.Kwd ')' ?? "expected ')'">] ->
42 Ast.Call (id, Array.of_list (List.rev args))
44 (* Simple variable ref. *)
45 | [< >] -> Ast.Variable id
49 (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
50 | [< 'Token.If; c=parse_expr;
51 'Token.Then ?? "expected 'then'"; t=parse_expr;
52 'Token.Else ?? "expected 'else'"; e=parse_expr >] ->
56 ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
58 'Token.Ident id ?? "expected identifier after for";
59 'Token.Kwd '=' ?? "expected '=' after for";
64 'Token.Kwd ',' ?? "expected ',' after for";
69 | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
74 | [< 'Token.In; body=parse_expr >] ->
75 Ast.For (id, start, end_, step, body)
77 raise (Stream.Error "expected 'in' after for")
80 raise (Stream.Error "expected '=' after for")
83 | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
88 and parse_unary = parser
89 (* If this is a unary operator, read it. *)
90 | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] ->
91 Ast.Unary (op, operand)
93 (* If the current token is not an operator, it must be a primary expr. *)
94 | [< stream >] -> parse_primary stream
97 * ::= ('+' primary)* *)
98 and parse_bin_rhs expr_prec lhs stream =
99 match Stream.peek stream with
100 (* If this is a binop, find its precedence. *)
101 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
102 let token_prec = precedence c in
104 (* If this is a binop that binds at least as tightly as the current binop,
105 * consume it, otherwise we are done. *)
106 if token_prec < expr_prec then lhs else begin
110 (* Parse the unary expression after the binary operator. *)
111 let rhs = parse_unary stream in
113 (* Okay, we know this is a binop. *)
115 match Stream.peek stream with
116 | Some (Token.Kwd c2) ->
117 (* If BinOp binds less tightly with rhs than the operator after
118 * rhs, let the pending operator take rhs as its lhs. *)
119 let next_prec = precedence c2 in
120 if token_prec < next_prec
121 then parse_bin_rhs (token_prec + 1) rhs stream
127 let lhs = Ast.Binary (c, lhs, rhs) in
128 parse_bin_rhs expr_prec lhs stream
133 * ::= primary binoprhs *)
134 and parse_expr = parser
135 | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream
139 * ::= binary LETTER number? (id, id)
140 * ::= unary LETTER number? (id) *)
141 let parse_prototype =
142 let rec parse_args accumulator = parser
143 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
144 | [< >] -> accumulator
146 let parse_operator = parser
147 | [< 'Token.Unary >] -> "unary", 1
148 | [< 'Token.Binary >] -> "binary", 2
150 let parse_binary_precedence = parser
151 | [< 'Token.Number n >] -> int_of_float n
155 | [< 'Token.Ident id;
156 'Token.Kwd '(' ?? "expected '(' in prototype";
158 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
160 Ast.Prototype (id, Array.of_list (List.rev args))
161 | [< (prefix, kind)=parse_operator;
162 'Token.Kwd op ?? "expected an operator";
163 (* Read the precedence if present. *)
164 binary_precedence=parse_binary_precedence;
165 'Token.Kwd '(' ?? "expected '(' in prototype";
167 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
168 let name = prefix ^ (String.make 1 op) in
169 let args = Array.of_list (List.rev args) in
171 (* Verify right number of arguments for operator. *)
172 if Array.length args != kind
173 then raise (Stream.Error "invalid number of operands for operator")
176 Ast.Prototype (name, args)
178 Ast.BinOpPrototype (name, args, binary_precedence)
180 raise (Stream.Error "expected function name in prototype")
182 (* definition ::= 'def' prototype expression *)
183 let parse_definition = parser
184 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
187 (* toplevelexpr ::= expression *)
188 let parse_toplevel = parser
189 | [< e=parse_expr >] ->
190 (* Make an anonymous proto. *)
191 Ast.Function (Ast.Prototype ("", [||]), e)
193 (* external ::= 'extern' prototype *)
194 let parse_extern = parser
195 | [< 'Token.Extern; e=parse_prototype >] -> e