-
Notifications
You must be signed in to change notification settings - Fork 125
/
jsCons.ml
275 lines (201 loc) · 7.93 KB
/
jsCons.ml
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
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
(*
Copyright © 2011 MLstate
This file is part of OPA.
OPA is free software: you can redistribute it and/or modify it under the
terms of the GNU Affero General Public License, version 3, as published by
the Free Software Foundation.
OPA is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
more details.
You should have received a copy of the GNU Affero General Public License
along with OPA. If not, see <http://www.gnu.org/licenses/>.
*)
(* CF mli *)
(* depends *)
module List = Base.List
module String = BaseString
(* shorthands *)
module J = JsAst
(* -- *)
let dummy_pos = FilePos.nopos "Javascript Constructor"
let label () =
Annot.next_label dummy_pos
let def_label = label
(*
If we need to have unicity of annotation,
we must replace rlabel by :
{[
let rlabel = Annot.refresh
]}
*)
external rlabel : Annot.label -> Annot.label = "%identity"
let object_prototype = StringSet.add_list [
"constructor"; "eval"; "hasOwnProperty"; "isPrototypeOf"; "propertyIsEnumerable";
"toSource"; "toLocalString"; "toString"; "unwatch"; "valueOf"; "watch";
] StringSet.empty
let can_object_field field =
StringSet.mem field object_prototype ||
String.is_prefix "__" field
let stmt_def ?(label=def_label()) ident =
J.Js_var (label, ident, None)
module Expr =
struct
let array ?(label=def_label()) content =
J.Je_array (label, content)
let assign ?(label=def_label()) e1 e2 =
J.Je_binop (label, J.Jb_assign, e1, e2)
let assign_ident ?(label=def_label()) ident e =
assign ~label (J.Je_ident (label, ident)) e
let binop ?(label=def_label()) binop e1 e2 =
J.Je_binop (label, binop, e1, e2)
let bool ?(label=def_label()) bool =
J.Je_bool (label, bool)
let true_ ?label () = bool ?label true
let false_ ?label () = bool ?label false
let call ?(label=def_label()) ~pure f args =
J.Je_call (label, f, args, pure)
let comma ?(label=def_label()) list last =
if List.is_empty list then last else
J.Je_comma (label, list, last)
let cond ?(label=def_label()) cond then_ else_ =
J.Je_cond (label, cond, then_, else_)
let dot ?(label=def_label()) expr field =
(* Check if the field can be an inherit field from Object, in this
case use hasOwnProperty to ensure the field is really owned by the
object.
Credit: Bug reported by Erling Ellingsen <reg.opa@alf.nu>
*)
if can_object_field field then
(* (e.hasOwnProperty("field") && e.field) || undefined *)
let check = J.Je_dot (label, expr, "hasOwnProperty") in
let check = J.Je_call (label, check, [J.Je_string (label, field, true)], true) in
let realldot = J.Je_dot (label, expr, field) in
let checkanddot = J.Je_binop (label, J.Jb_land, check, realldot) in
J.Je_binop (label, J.Jb_lor, checkanddot, J.Je_undefined label)
else
J.Je_dot (label, expr, field)
let equality ?(label=def_label()) e = binop ~label J.Jb_eq e
let exprident ?(label=def_label()) ident =
J.Je_ident (label, J.ExprIdent ident)
let hashref ?label expr1 expr2 =
binop ?label J.Jb_hashref expr1 expr2
let native ?(label=def_label()) ident =
J.Je_ident (label, J.Native (`local, ident))
let native_global ?(label=def_label()) ident =
J.Je_ident (label, J.Native (`global, ident))
let field = dot
let float ?(label=def_label()) float =
let s =
match classify_float float with
| FP_normal
| FP_subnormal
| FP_zero -> string_of_float float
| FP_infinite -> if float > 0. then "Infinity" else "-Infinity"
| FP_nan -> "NaN" in
J.Je_num (label, s)
let function_ ?(label=def_label()) ident params body =
J.Je_function (label, ident, params, body)
let greater ?(label=def_label()) e = binop ~label J.Jb_gt e
let hole ?(label=def_label()) expr =
J.Je_hole (label, expr)
let ident ?(label=def_label()) ident =
J.Je_ident (label, ident)
let in_ ?(label=def_label()) a b =
binop ~label J.Jb_in a b
let int ?(label=def_label()) int =
J.Je_num (label, string_of_int int)
let int_as_string ?(label=def_label()) int =
J.Je_num (label, int)
let land_ ?(label=def_label()) a b = binop ~label J.Jb_land a b
let list ?(label=def_label()) list =
J.Je_array (label, list)
let lor_ ?(label=def_label()) a b = binop ~label J.Jb_lor a b
let neq ?(label=def_label()) e = binop ~label J.Jb_neq e
let not_ ?(label=def_label()) e =
J.Je_unop (label, J.Ju_not, e)
let null ?(label=def_label()) () =
J.Je_null label
let obj ?(label=def_label()) fields =
J.Je_object (label, fields)
let runtime ?(label=def_label()) expr =
J.Je_runtime (label, expr)
let strict_equality ?(label=def_label()) e = binop ~label J.Jb_seq e
let strict_neq ?(label=def_label()) e = binop ~label J.Jb_sneq e
let string ?(label=def_label()) string =
J.Je_string (label, string, true)
let this ?(label=def_label()) () =
J.Je_this label
let unop ?(label=def_label()) unop e1 =
J.Je_unop (label, unop, e1)
let undefined ?(label=def_label()) () =
J.Je_undefined label
let scope l e =
let decls = List.map (fun v -> J.Js_var (def_label (), v, None)) l in
let return = J.Js_return (def_label (), Some e) in
let fun_ = function_ None [] (decls @ [return]) in
call ~pure:false fun_ []
let maybe_scope l e =
if l = [] then e else scope l e
(* deprecated *)
let deprecated_lambda ?(label=def_label()) params locals expr =
let locals = List.rev_map (fun ident -> stmt_def ~label:(rlabel label) ident) locals in
let return = J.Js_return (rlabel label, Some expr) in
let body = return :: locals in
let body = List.rev body in
function_ ~label None params body
let deprecated_letin ?(label=def_label()) bindings expr =
let map (id, expr) =
let id = ident ~label:(rlabel label) id in
J.Je_binop (rlabel label, J.Jb_assign, id, expr)
in
J.Je_comma (label, List.map map bindings, expr)
end
module Statement =
struct
let def = stmt_def
let assign ?(label=def_label()) e1 e2 =
J.Js_expr (label, Expr.assign ~label e1 e2)
let assign_ident ?(label=def_label()) ident e =
J.Js_expr (label, Expr.assign_ident ~label ident e)
let block ?(label=def_label()) stms =
J.Js_block (label, stms)
let comment ?(label=def_label()) ?(kind=`simple) string =
J.Js_comment (label, kind, string)
let continue ?(label=def_label()) ?label:label2 () =
J.Js_continue (label, label2)
let expr ?(label=def_label()) e =
J.Js_expr (label, e)
let function_ ?(label=def_label()) ident params body =
J.Js_function (label, ident, params, body)
let if_ ?(label=def_label()) expr stm1 stm2 =
J.Js_if (label, expr, stm1, Some stm2)
let if_no_else ?(label=def_label()) expr stm1 =
J.Js_if (label, expr, stm1, None)
let return ?(label=def_label()) expr =
J.Js_return (label, Some expr)
let switch ?(label=def_label()) ?default e l =
J.Js_switch (label, e, l, default)
let var ?(label=def_label()) ?expr ident =
J.Js_var (label, ident, expr)
let while_ ?(label=def_label()) expr stm =
J.Js_while (label, expr, stm)
(* deprecated *)
let deprecated_function ?(label=def_label()) ident params locals expr =
let locals = List.rev_map (fun ident -> def ~label:(rlabel label) ident) locals in
let return = J.Js_return (rlabel label, Some expr) in
let body = return :: locals in
let body = List.rev body in
function_ ~label ident params body
end
(* exported at the end, for not covering compilerlib.Ident *)
module Ident =
struct
let ident id = J.ExprIdent id
let fresh_qml ident =
J.ExprIdent (Ident.refresh ~map:(fun s -> "js_internal_" ^ s) ident)
let fresh ident =
J.ExprIdent (Ident.next ("js_internal_" ^ (JsPrint.string_of_ident ident)))
let native id = J.Native (`local, id)
let native_global id = J.Native (`global, id)
end