ReleaseNotes: shrink-wrapping; by Quentin Colombet
[oota-llvm.git] / examples / OCaml-Kaleidoscope / Chapter3 / parser.ml
1 (*===---------------------------------------------------------------------===
2  * Parser
3  *===---------------------------------------------------------------------===*)
4
5 (* binop_precedence - This holds the precedence for each binary operator that is
6  * defined *)
7 let binop_precedence:(char, int) Hashtbl.t = Hashtbl.create 10
8
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
11
12 (* primary
13  *   ::= identifier
14  *   ::= numberexpr
15  *   ::= parenexpr *)
16 let 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)* *)
51 and 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 *)
87 and parse_expr = parser
88   | [< lhs=parse_primary; stream >] -> parse_bin_rhs 0 lhs stream
89
90 (* prototype
91  *   ::= id '(' id* ')' *)
92 let 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 *)
110 let parse_definition = parser
111   | [< 'Token.Def; p=parse_prototype; e=parse_expr >] ->
112       Ast.Function (p, e)
113
114 (* toplevelexpr ::= expression *)
115 let parse_toplevel = parser
116   | [< e=parse_expr >] ->
117       (* Make an anonymous proto. *)
118       Ast.Function (Ast.Prototype ("", [||]), e)
119
120 (*  external ::= 'extern' prototype *)
121 let parse_extern = parser
122   | [< 'Token.Extern; e=parse_prototype >] -> e