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