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.")
86 * ::= ('+' primary)* *)
87 and parse_bin_rhs expr_prec lhs stream =
88 match Stream.peek stream with
89 (* If this is a binop, find its precedence. *)
90 | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
91 let token_prec = precedence c in
93 (* If this is a binop that binds at least as tightly as the current binop,
94 * consume it, otherwise we are done. *)
95 if token_prec < expr_prec then lhs else begin
99 (* Parse the primary expression after the binary operator. *)
100 let rhs = parse_primary stream in
102 (* Okay, we know this is a binop. *)
104 match Stream.peek stream with
105 | Some (Token.Kwd c2) ->
106 (* If BinOp binds less tightly with rhs than the operator after
107 * rhs, let the pending operator take rhs as its lhs. *)
108 let next_prec = precedence c2 in
109 if token_prec < next_prec
110 then parse_bin_rhs (token_prec + 1) rhs stream
116 let lhs = Ast.Binary (c, lhs, rhs) in
117 parse_bin_rhs expr_prec lhs stream
122 * ::= primary binoprhs *)
123 and parse_expr = parser
124 | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
127 * ::= id '(' id* ')' *)
128 let parse_prototype =
129 let rec parse_args accumulator = parser
130 | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
131 | [< >] -> accumulator
135 | [< 'Token.Ident id;
136 'Token.Kwd '(' ?? "expected '(' in prototype";
138 'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
140 Ast.Prototype (id, Array.of_list (List.rev args))
143 raise (Stream.Error "expected function name in prototype")
145 (* definition ::= 'def' prototype expression *)
146 let parse_definition = parser
147 | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
150 (* toplevelexpr ::= expression *)
151 let parse_toplevel = parser
152 | [< e=parse_expr >] ->
153 (* Make an anonymous proto. *)
154 Ast.Function (Ast.Prototype ("", [||]), e)
156 (* external ::= 'extern' prototype *)
157 let parse_extern = parser
158 | [< 'Token.Extern; e=parse_prototype >] -> e