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 *)
16let rec parse_primary = parser
17  (* numberexpr ::= number *)
18  | [< 'Token.Number n >] -> Ast.Number n
19
20  (* parenexpr ::= '(' expression ')' *)
21  | [< 'Token.Kwd '('; e=parse_expr; 'Token.Kwd ')' ?? "expected ')'" >] -> e
22
23  (* identifierexpr
24   *   ::= identifier
25   *   ::= identifier '(' argumentexpr ')' *)
26  | [< 'Token.Ident id; stream >] ->
27      let rec parse_args accumulator = parser
28        | [< e=parse_expr; stream >] ->
29            begin parser
30              | [< 'Token.Kwd ','; e=parse_args (e :: accumulator) >] -> e
31              | [< >] -> e :: accumulator
32            end stream
33        | [< >] -> accumulator
34      in
35      let rec parse_ident id = parser
36        (* Call. *)
37        | [< 'Token.Kwd '(';
38             args=parse_args [];
39             'Token.Kwd ')' ?? "expected ')'">] ->
40            Ast.Call (id, Array.of_list (List.rev args))
41
42        (* Simple variable ref. *)
43        | [< >] -> Ast.Variable id
44      in
45      parse_ident id stream
46
47  | [< >] -> raise (Stream.Error "unknown token when expecting an expression.")
48
49(* binoprhs
50 *   ::= ('+' primary)* *)
51and 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
56
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
60        (* Eat the binop. *)
61        Stream.junk stream;
62
63        (* Parse the primary expression after the binary operator. *)
64        let rhs = parse_primary stream in
65
66        (* Okay, we know this is a binop. *)
67        let rhs =
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
75              else rhs
76          | _ -> rhs
77        in
78
79        (* Merge lhs/rhs. *)
80        let lhs = Ast.Binary (c, lhs, rhs) in
81        parse_bin_rhs expr_prec lhs stream
82      end
83  | _ -> lhs
84
85(* expression
86 *   ::= primary binoprhs *)
87and parse_expr = parser
88  | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
89
90(* prototype
91 *   ::= id '(' id* ')' *)
92let parse_prototype =
93  let rec parse_args accumulator = parser
94    | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
95    | [< >] -> accumulator
96  in
97
98  parser
99  | [< 'Token.Ident id;
100       'Token.Kwd '(' ?? "expected '(' in prototype";
101       args=parse_args [];
102       'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
103      (* success. *)
104      Ast.Prototype (id, Array.of_list (List.rev args))
105
106  | [< >] ->
107      raise (Stream.Error "expected function name in prototype")
108
109(* definition ::= 'def' prototype expression *)
110let parse_definition = parser
111  | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
112      Ast.Function (p, e)
113
114(* toplevelexpr ::= expression *)
115let parse_toplevel = parser
116  | [< e=parse_expr >] ->
117      (* Make an anonymous proto. *)
118      Ast.Function (Ast.Prototype ("", [||]), e)
119
120(*  external ::= 'extern' prototype *)
121let parse_extern = parser
122  | [< 'Token.Extern; e=parse_prototype >] -> e
123