1(*===---------------------------------------------------------------------===
2 * Parser
3 *===---------------------------------------------------------------------===*)
4
5(* binop_precedence - This holds the precedence for each binary operator that is
6 * defined *)
7let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
8
9(* precedence - Get the precedence of the pending binary operator token. *)
10let precedence c = try Hashtbl.find binop_precedence c with Not_found -> -1
11
12(* primary
13 *   ::= identifier
14 *   ::= numberexpr
15 *   ::= parenexpr
16 *   ::= ifexpr
17 *   ::= forexpr
18 *   ::= varexpr *)
19let rec parse_primary = parser
20  (* numberexpr ::= number *)
21  | [< 'Token.Number n >] -> Ast.Number n
22
23  (* parenexpr ::= '(' expression ')' *)
24  | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
25
26  (* identifierexpr
27   *   ::= identifier
28   *   ::= identifier '(' argumentexpr ')' *)
29  | [< 'Token.Ident id; stream >] ->
30      let rec parse_args accumulator = parser
31        | [< e=parse_expr; stream >] ->
32            begin parser
33              | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
34              | [< >] -> e :: accumulator
35            end stream
36        | [< >] -> accumulator
37      in
38      let rec parse_ident id = parser
39        (* Call. *)
40        | [< 'Token.Kwd '(';
41             args=parse_args [];
42             'Token.Kwd ')' ?? "expected ')'">] ->
43            Ast.Call (id, Array.of_list (List.rev args))
44
45        (* Simple variable ref. *)
46        | [< >] -> Ast.Variable id
47      in
48      parse_ident id stream
49
50  (* ifexpr ::= 'if' expr 'then' expr 'else' expr *)
51  | [< 'Token.If; c=parse_expr;
52       'Token.Then ?? "expected 'then'"; t=parse_expr;
53       'Token.Else ?? "expected 'else'"; e=parse_expr >] ->
54      Ast.If (c, t, e)
55
56  (* forexpr
57        ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
58  | [< 'Token.For;
59       'Token.Ident id ?? "expected identifier after for";
60       'Token.Kwd '=' ?? "expected '=' after for";
61       stream >] ->
62      begin parser
63        | [<
64             start=parse_expr;
65             'Token.Kwd ',' ?? "expected ',' after for";
66             end_=parse_expr;
67             stream >] ->
68            let step =
69              begin parser
70              | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
71              | [< >] -> None
72              end stream
73            in
74            begin parser
75            | [< 'Token.In; body=parse_expr >] ->
76                Ast.For (id, start, end_, step, body)
77            | [< >] ->
78                raise (Stream.Error "expected 'in' after for")
79            end stream
80        | [< >] ->
81            raise (Stream.Error "expected '=' after for")
82      end stream
83
84  (* varexpr
85   *   ::= 'var' identifier ('=' expression?
86   *             (',' identifier ('=' expression)?)* 'in' expression *)
87  | [< 'Token.Var;
88       (* At least one variable name is required. *)
89       'Token.Ident id ?? "expected identifier after var";
90       init=parse_var_init;
91       var_names=parse_var_names [(id, init)];
92       (* At this point, we have to have 'in'. *)
93       'Token.In ?? "expected 'in' keyword after 'var'";
94       body=parse_expr >] ->
95      Ast.Var (Array.of_list (List.rev var_names), body)
96
97  | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
98
99(* unary
100 *   ::= primary
101 *   ::= '!' unary *)
102and parse_unary = parser
103  (* If this is a unary operator, read it. *)
104  | [< 'Token.Kwd op when op != '(' && op != ')'; operand=parse_expr >] ->
105      Ast.Unary (op, operand)
106
107  (* If the current token is not an operator, it must be a primary expr. *)
108  | [< stream >] -> parse_primary stream
109
110(* binoprhs
111 *   ::= ('+' primary)* *)
112and parse_bin_rhs expr_prec lhs stream =
113  match Stream.peek stream with
114  (* If this is a binop, find its precedence. *)
115  | Some (Token.Kwd c) when Hashtbl.mem binop_precedence c ->
116      let token_prec = precedence c in
117
118      (* If this is a binop that binds at least as tightly as the current binop,
119       * consume it, otherwise we are done. *)
120      if token_prec < expr_prec then lhs else begin
121        (* Eat the binop. *)
122        Stream.junk stream;
123
124        (* Parse the primary expression after the binary operator. *)
125        let rhs = parse_unary stream in
126
127        (* Okay, we know this is a binop. *)
128        let rhs =
129          match Stream.peek stream with
130          | Some (Token.Kwd c2) ->
131              (* If BinOp binds less tightly with rhs than the operator after
132               * rhs, let the pending operator take rhs as its lhs. *)
133              let next_prec = precedence c2 in
134              if token_prec < next_prec
135              then parse_bin_rhs (token_prec + 1) rhs stream
136              else rhs
137          | _ -> rhs
138        in
139
140        (* Merge lhs/rhs. *)
141        let lhs = Ast.Binary (c, lhs, rhs) in
142        parse_bin_rhs expr_prec lhs stream
143      end
144  | _ -> lhs
145
146and parse_var_init = parser
147  (* read in the optional initializer. *)
148  | [< 'Token.Kwd '='; e=parse_expr >] -> Some e
149  | [< >] -> None
150
151and parse_var_names accumulator = parser
152  | [< 'Token.Kwd ',';
153       'Token.Ident id ?? "expected identifier list after var";
154       init=parse_var_init;
155       e=parse_var_names ((id, init) :: accumulator) >] -> e
156  | [< >] -> accumulator
157
158(* expression
159 *   ::= primary binoprhs *)
160and parse_expr = parser
161  | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream
162
163(* prototype
164 *   ::= id '(' id* ')'
165 *   ::= binary LETTER number? (id, id)
166 *   ::= unary LETTER number? (id) *)
167let parse_prototype =
168  let rec parse_args accumulator = parser
169    | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
170    | [< >] -> accumulator
171  in
172  let parse_operator = parser
173    | [< 'Token.Unary >] -> "unary", 1
174    | [< 'Token.Binary >] -> "binary", 2
175  in
176  let parse_binary_precedence = parser
177    | [< 'Token.Number n >] -> int_of_float n
178    | [< >] -> 30
179  in
180  parser
181  | [< 'Token.Ident id;
182       'Token.Kwd '(' ?? "expected '(' in prototype";
183       args=parse_args [];
184       'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
185      (* success. *)
186      Ast.Prototype (id, Array.of_list (List.rev args))
187  | [< (prefix, kind)=parse_operator;
188       'Token.Kwd op ?? "expected an operator";
189       (* Read the precedence if present. *)
190       binary_precedence=parse_binary_precedence;
191       'Token.Kwd '(' ?? "expected '(' in prototype";
192        args=parse_args [];
193       'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
194      let name = prefix ^ (String.make 1 op) in
195      let args = Array.of_list (List.rev args) in
196
197      (* Verify right number of arguments for operator. *)
198      if Array.length args != kind
199      then raise (Stream.Error "invalid number of operands for operator")
200      else
201        if kind == 1 then
202          Ast.Prototype (name, args)
203        else
204          Ast.BinOpPrototype (name, args, binary_precedence)
205  | [< >] ->
206      raise (Stream.Error "expected function name in prototype")
207
208(* definition ::= 'def' prototype expression *)
209let parse_definition = parser
210  | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
211      Ast.Function (p, e)
212
213(* toplevelexpr ::= expression *)
214let parse_toplevel = parser
215  | [< e=parse_expr >] ->
216      (* Make an anonymous proto. *)
217      Ast.Function (Ast.Prototype ("", [||]), e)
218
219(*  external ::= 'extern' prototype *)
220let parse_extern = parser
221  | [< 'Token.Extern; e=parse_prototype >] -> e
222