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 *)
18let rec parse_primary = parser
19  (* numberexpr ::= number *)
20  | [< 'Token.Number n >] -> Ast.Number n
21
22  (* parenexpr ::= '(' expression ')' *)
23  | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
24
25  (* identifierexpr
26   *   ::= identifier
27   *   ::= identifier '(' argumentexpr ')' *)
28  | [< 'Token.Ident id; stream >] ->
29      let rec parse_args accumulator = parser
30        | [< e=parse_expr; stream >] ->
31            begin parser
32              | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
33              | [< >] -> e :: accumulator
34            end stream
35        | [< >] -> accumulator
36      in
37      let rec parse_ident id = parser
38        (* Call. *)
39        | [< 'Token.Kwd '(';
40             args=parse_args [];
41             'Token.Kwd ')' ?? "expected ')'">] ->
42            Ast.Call (id, Array.of_list (List.rev args))
43
44        (* Simple variable ref. *)
45        | [< >] -> Ast.Variable id
46      in
47      parse_ident id stream
48
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 >] ->
53      Ast.If (c, t, e)
54
55  (* forexpr
56        ::= 'for' identifier '=' expr ',' expr (',' expr)? 'in' expression *)
57  | [< 'Token.For;
58       'Token.Ident id ?? "expected identifier after for";
59       'Token.Kwd '=' ?? "expected '=' after for";
60       stream >] ->
61      begin parser
62        | [<
63             start=parse_expr;
64             'Token.Kwd ',' ?? "expected ',' after for";
65             end_=parse_expr;
66             stream >] ->
67            let step =
68              begin parser
69              | [< 'Token.Kwd ','; step=parse_expr >] -> Some step
70              | [< >] -> None
71              end stream
72            in
73            begin parser
74            | [< 'Token.In; body=parse_expr >] ->
75                Ast.For (id, start, end_, step, body)
76            | [< >] ->
77                raise (Stream.Error "expected 'in' after for")
78            end stream
79        | [< >] ->
80            raise (Stream.Error "expected '=' after for")
81      end stream
82
83  | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
84
85(* binoprhs
86 *   ::= ('+' primary)* *)
87and 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
92
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
96        (* Eat the binop. *)
97        Stream.junk stream;
98
99        (* Parse the primary expression after the binary operator. *)
100        let rhs = parse_primary stream in
101
102        (* Okay, we know this is a binop. *)
103        let rhs =
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
111              else rhs
112          | _ -> rhs
113        in
114
115        (* Merge lhs/rhs. *)
116        let lhs = Ast.Binary (c, lhs, rhs) in
117        parse_bin_rhs expr_prec lhs stream
118      end
119  | _ -> lhs
120
121(* expression
122 *   ::= primary binoprhs *)
123and parse_expr = parser
124  | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
125
126(* prototype
127 *   ::= id '(' id* ')' *)
128let parse_prototype =
129  let rec parse_args accumulator = parser
130    | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
131    | [< >] -> accumulator
132  in
133
134  parser
135  | [< 'Token.Ident id;
136       'Token.Kwd '(' ?? "expected '(' in prototype";
137       args=parse_args [];
138       'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
139      (* success. *)
140      Ast.Prototype (id, Array.of_list (List.rev args))
141
142  | [< >] ->
143      raise (Stream.Error "expected function name in prototype")
144
145(* definition ::= 'def' prototype expression *)
146let parse_definition = parser
147  | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
148      Ast.Function (p, e)
149
150(* toplevelexpr ::= expression *)
151let parse_toplevel = parser
152  | [< e=parse_expr >] ->
153      (* Make an anonymous proto. *)
154      Ast.Function (Ast.Prototype ("", [||]), e)
155
156(*  external ::= 'extern' prototype *)
157let parse_extern = parser
158  | [< 'Token.Extern; e=parse_prototype >] -> e
159