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(* unary
86 *   ::= primary
87 *   ::= '!' unary *)
88and 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)
92
93  (* If the current token is not an operator, it must be a primary expr. *)
94  | [< stream >] -> parse_primary stream
95
96(* binoprhs
97 *   ::= ('+' primary)* *)
98and 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
103
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
107        (* Eat the binop. *)
108        Stream.junk stream;
109
110        (* Parse the unary expression after the binary operator. *)
111        let rhs = parse_unary stream in
112
113        (* Okay, we know this is a binop. *)
114        let rhs =
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
122              else rhs
123          | _ -> rhs
124        in
125
126        (* Merge lhs/rhs. *)
127        let lhs = Ast.Binary (c, lhs, rhs) in
128        parse_bin_rhs expr_prec lhs stream
129      end
130  | _ -> lhs
131
132(* expression
133 *   ::= primary binoprhs *)
134and parse_expr = parser
135  | [< lhs=parse_unary; stream >] -> parse_bin_rhs 0 lhs stream
136
137(* prototype
138 *   ::= id '(' id* ')'
139 *   ::= binary LETTER number? (id, id)
140 *   ::= unary LETTER number? (id) *)
141let parse_prototype =
142  let rec parse_args accumulator = parser
143    | [< 'Token.Ident id; e=parse_args (id::accumulator) >] -> e
144    | [< >] -> accumulator
145  in
146  let parse_operator = parser
147    | [< 'Token.Unary >] -> "unary", 1
148    | [< 'Token.Binary >] -> "binary", 2
149  in
150  let parse_binary_precedence = parser
151    | [< 'Token.Number n >] -> int_of_float n
152    | [< >] -> 30
153  in
154  parser
155  | [< 'Token.Ident id;
156       'Token.Kwd '(' ?? "expected '(' in prototype";
157       args=parse_args [];
158       'Token.Kwd ')' ?? "expected ')' in prototype" >] ->
159      (* success. *)
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";
166        args=parse_args [];
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
170
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")
174      else
175        if kind == 1 then
176          Ast.Prototype (name, args)
177        else
178          Ast.BinOpPrototype (name, args, binary_precedence)
179  | [< >] ->
180      raise (Stream.Error "expected function name in prototype")
181
182(* definition ::= 'def' prototype expression *)
183let parse_definition = parser
184  | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
185      Ast.Function (p, e)
186
187(* toplevelexpr ::= expression *)
188let parse_toplevel = parser
189  | [< e=parse_expr >] ->
190      (* Make an anonymous proto. *)
191      Ast.Function (Ast.Prototype ("", [||]), e)
192
193(*  external ::= 'extern' prototype *)
194let parse_extern = parser
195  | [< 'Token.Extern; e=parse_prototype >] -> e
196