Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 417 lines (365 sloc) 11.944 kb
adda7d23 »
2008-08-31 jslib + changes from my repository
1 (*
2 * This file is part of ocamljs, OCaml to Javascript compiler
fe7ebed0 »
2009-03-31 copyrights, miscellany
3 * Copyright (C) 2007-9 Skydeck, Inc
c88bb149 »
2010-08-19 copyrights
4 * Copyright (C) 2010 Jake Donham
adda7d23 »
2008-08-31 jslib + changes from my repository
5 *
fe7ebed0 »
2009-03-31 copyrights, miscellany
6 * This library is free software; you can redistribute it and/or
7 * modify it under the terms of the GNU Library General Public
8 * License as published by the Free Software Foundation; either
9 * version 2 of the License, or (at your option) any later version.
adda7d23 »
2008-08-31 jslib + changes from my repository
10 *
fe7ebed0 »
2009-03-31 copyrights, miscellany
11 * This library is distributed in the hope that it will be useful,
12 * but WITHOUT ANY WARRANTY; without even the implied warranty of
13 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
14 * Library General Public License for more details.
15 *
16 * You should have received a copy of the GNU Library General Public
17 * License along with this library; if not, write to the Free
18 * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
19 * MA 02111-1307, USA
adda7d23 »
2008-08-31 jslib + changes from my repository
20 *)
21
22 open Format
23 open Jslib_ast
24
25 (* XXX figure out how Format works *)
26
27 (*
28 precedence, see ECMA 262:
29 http://www.ecma-international.org/publications/files/EMCA-ST/Ecma-262.pdf
30 *)
31 let p = 0
32 let pAssignment = 2
33 let pConditional = 4
34 let pLogicalOR = 6
35 let pLogicalAND = 8
36 let pBitwiseOR = 10
37 let pBitwiseXOR = 12
38 let pBitwiseAND = 14
39 let pEquality = 16
40 let pRelational = 18
41 let pShift = 20
42 let pAdditive = 22
43 let pMultiplicative = 24
44 let pUnary = 26
45 let pPostfix = 28
46 let pLeftHandSide = 30
47 let pCall = 32
48 let pMember = 34
49 let pPrimary = 36
50
51
52 module JSString =
53 struct
15839087 »
2010-06-14 treating OCaml strings as UTF8 was a bad idea
54 external is_printable: char -> bool = "caml_is_printable"
adda7d23 »
2008-08-31 jslib + changes from my repository
55
56 let escaped s =
294abeee »
2009-11-24 UTF8 string escaping from redchrom
57 let buf = Buffer.create 0 in
29d14fd8 »
2010-08-25 print JS strings as UTF8, and UTF8 encode literal OCaml strings,
58 let escaped c =
59 if c > 0xFF then Printf.bprintf buf "\\u%04X" c
60 else
61 match Char.chr c with
62 | '\'' -> Buffer.add_string buf "\\'"
63 | '"' -> Buffer.add_string buf "\\\""
64 | '\\' -> Buffer.add_string buf "\\\\"
65 | '\n' -> Buffer.add_string buf "\\n"
66 | '\t' -> Buffer.add_string buf "\\t"
67 | '\r' -> Buffer.add_string buf "\\r"
68 | '\b' -> Buffer.add_string buf "\\b"
69 | c ->
70 if is_printable c
71 then Buffer.add_char buf c
72 else Printf.bprintf buf "\\x%02X" (Char.code c) in
73 Array.iter escaped (Utf8.to_int_array s 0 (String.length s));
294abeee »
2009-11-24 UTF8 string escaping from redchrom
74 Buffer.contents buf
adda7d23 »
2008-08-31 jslib + changes from my repository
75 end
76
77 let id ppf i = fprintf ppf "%s" i
78
79 let ids ppf is =
80 let com = ref false in
81 List.iter
82 (fun i ->
83 if !com then fprintf ppf ",@ " else com := true;
9601e661 »
2009-06-30 somewhat better pretty-printing
84 fprintf ppf "%a" id i)
adda7d23 »
2008-08-31 jslib + changes from my repository
85 is
86
87 let is_postop = function
88 | Jadd2_post | Jsub2_post -> true
89 | _ -> false
90
91 let unop_op = function
92 | Jdelete -> "delete"
93 | Jvoid -> "void"
94 | Jtypeof -> "typeof"
95 | Jadd2_pre -> "++"
96 | Jsub2_pre -> "--"
97 | Jadd_pre -> "+"
98 | Jsub_pre -> "-"
99 | Jtilde -> "~"
100 | Jnot -> "!"
101 | Jadd2_post -> "++"
102 | Jsub2_post -> "--"
103
104 let binop_op = function
105 | Jmul -> "*"
106 | Jdiv -> "/"
107 | Jmod -> "%"
108 | Jadd -> "+"
109 | Jsub -> "-"
110 | Jlsr -> ">>"
111 | Jlsl -> "<<"
112 | Jasr -> ">>>"
113 | Jlt -> "<"
114 | Jgt -> ">"
115 | Jleq -> "<="
116 | Jgeq -> ">="
117 | Jinstanceof -> assert false
118 | Jeq -> "=="
119 | Jneq -> "!="
120 | Jseq -> "==="
121 | Jsneq -> "!=="
122 | Jand -> "&"
123 | Jxor -> "^"
124 | Jor -> "|"
125 | Jland -> "&&"
126 | Jlor -> "||"
127 | Jcomma -> ","
128 | Jhashref -> assert false
129 | Jassign -> "="
130 | Jmul_assign -> "*="
131 | Jdiv_assign -> "/="
132 | Jmod_assign -> "%="
133 | Jadd_assign -> "+="
134 | Jsub_assign -> "-="
135 | Jlsl_assign -> "<<="
136 | Jlsr_assign -> ">>="
137 | Jasr_assign -> ">>>="
138 | Jand_assign -> "&="
139 | Jxor_assign -> "^="
140 | Jor_assign -> "|="
141
142 let binop_prec = function
143 | Jeq -> pEquality
144 | Jneq -> pEquality
145 | Jseq -> pEquality
146 | Jsneq -> pEquality
147 | Jhashref -> pCall
148 | Jlt -> pRelational
149 | Jgt -> pRelational
150 | Jleq -> pRelational
151 | Jgeq -> pRelational
152 | Jinstanceof -> pRelational
153 | Jlsr -> pShift
154 | Jlsl -> pShift
155 | Jasr -> pShift
156 | Jmul -> pMultiplicative
157 | Jdiv -> pMultiplicative
158 | Jmod -> pMultiplicative
159 | Jadd -> pAdditive
160 | Jsub -> pAdditive
161 | Jand -> pBitwiseAND
162 | Jxor -> pBitwiseXOR
163 | Jor -> pBitwiseOR
164 | Jland -> pLogicalAND
165 | Jlor -> pLogicalOR
166 | Jcomma -> p
167 | Jassign -> pAssignment
168 | Jmul_assign -> pAssignment
169 | Jdiv_assign -> pAssignment
170 | Jmod_assign -> pAssignment
171 | Jadd_assign -> pAssignment
172 | Jsub_assign -> pAssignment
173 | Jlsl_assign -> pAssignment
174 | Jlsr_assign -> pAssignment
175 | Jasr_assign -> pAssignment
176 | Jand_assign -> pAssignment
177 | Jxor_assign -> pAssignment
178 | Jor_assign -> pAssignment
179
180 let prec = function
181 | Jthis _ -> pPrimary
182 | Jvar _ -> pPrimary
183 | Jarray _ -> pPrimary
184 | Jobject _ -> pPrimary
185 | Jstring _ -> pPrimary
186 | Jnum _ -> pPrimary
187 | Jnull _ -> pPrimary
188 | Jfun _ -> pPrimary
189 | Jbool _ -> pPrimary
644aad65 »
2009-09-03 initial regexp support in jslib
190 | Jregexp _ -> pPrimary
adda7d23 »
2008-08-31 jslib + changes from my repository
191
192 | Jfieldref _ -> pMember
193 | Jnew _ -> pMember
194
195 | Junop (_, op, _) -> if is_postop op then pPostfix else pUnary
196 | Jbinop (_, op, _, _) -> binop_prec op
197
198 | Jite _ -> pConditional
199 | Jcall _ -> pCall
200 | Jexp_Ant _ -> pPrimary
201
3503c9f2 »
2009-02-18 internal exp list in AST + list antiquotation.
202 | Jexp_nil _ -> assert false
203 | Jexp_cons _ -> assert false
204
adda7d23 »
2008-08-31 jslib + changes from my repository
205 let opt f ppf x =
206 match x with
207 | None -> ()
208 | Some x -> f ppf x
209
210 let opt_nbsp f ppf x =
211 match x with
212 | None -> ()
213 | Some x ->
214 fprintf ppf " ";
215 f ppf x
216
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
217 let rec stmt_iter f = function
218 | Jstmt_nil _ -> ()
219 | Jstmt_cons (_, s1, s2) ->
220 stmt_iter f s1;
221 stmt_iter f s2
222 | s -> f s
223
adda7d23 »
2008-08-31 jslib + changes from my repository
224 let rec expp pr ppf e =
225 if prec e < pr
226 then fprintf ppf "(@[%a@])" exp e
227 else exp ppf e
228
229 and exp ppf = function
230 | Jthis _ -> fprintf ppf "this"
231 | Jvar (_, i) -> fprintf ppf "%s" i
9601e661 »
2009-06-30 somewhat better pretty-printing
232 | Jarray (_, es) -> fprintf ppf "@[<hv>[@;<1 2>%a@ ]@]" aexps es
adda7d23 »
2008-08-31 jslib + changes from my repository
233 | Jobject (_, kvs) ->
234 let keyvals ppf kvs =
235 let com = ref false in
236 List.iter
237 (fun (k, v) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
238 if !com then fprintf ppf ",@;<1 2>" else com := true;
239 fprintf ppf "@[<hv 2>%a:@ %a@]" (expp pAssignment) k (expp pAssignment) v)
adda7d23 »
2008-08-31 jslib + changes from my repository
240 kvs in
9601e661 »
2009-06-30 somewhat better pretty-printing
241 fprintf ppf "@[<hv>{@;<1 2>%a@ }@]" keyvals kvs
adda7d23 »
2008-08-31 jslib + changes from my repository
242 | Jstring (_, s, false) -> fprintf ppf "\"%s\"" (JSString.escaped s)
243 | Jstring (_, s, true) -> fprintf ppf "\'%s\'" (JSString.escaped s)
244 | Jnum (_, n) -> fprintf ppf "%s" n
245 | Jnull _ -> fprintf ppf "null"
246 | Jbool (_, b) -> fprintf ppf "%B" b
644aad65 »
2009-09-03 initial regexp support in jslib
247 | Jregexp (_, r, f) -> fprintf ppf "/%s/%s" r f
adda7d23 »
2008-08-31 jslib + changes from my repository
248 | Jfun (_, io, is, ss) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
249 fprintf ppf "@[<hv>function %a@[<hv 1>(%a)@]%a@]" (opt_nbsp id) io ids is block ss
adda7d23 »
2008-08-31 jslib + changes from my repository
250
9601e661 »
2009-06-30 somewhat better pretty-printing
251 | Jfieldref (_, e, i) -> fprintf ppf "@[<hv 2>%a.@,%s@]" (expp pMember) e i
adda7d23 »
2008-08-31 jslib + changes from my repository
252
253 | Junop (_, op, e) ->
254 if is_postop op
255 then
256 begin
257 fprintf ppf "@[%a%s@]" (expp pPostfix) e (unop_op op)
258 end
259 else
260 begin
261 match op with
9601e661 »
2009-06-30 somewhat better pretty-printing
262 | Jdelete | Jvoid | Jtypeof -> fprintf ppf "@[%s %a@]" (unop_op op) (expp pUnary) e
adda7d23 »
2008-08-31 jslib + changes from my repository
263 | _ -> fprintf ppf "@[%s%a@]" (unop_op op) (expp pUnary) e
264 end
265
266 | Jbinop (_, op, e1, e2) ->
267 begin
268 match op with
269 | Jhashref -> fprintf ppf "@[%a[%a]@]" (expp pCall) e1 (expp p) e2
270 | Jcomma -> fprintf ppf "@[%a, %a@]" (expp p) e1 (expp pAssignment) e2
271 | _ ->
272 let prec = binop_prec op in
9601e661 »
2009-06-30 somewhat better pretty-printing
273 fprintf ppf "@[<hv 2>%a %s@ %a@]" (expp prec) e1 (binop_op op) (expp (prec + 2)) e2
adda7d23 »
2008-08-31 jslib + changes from my repository
274 end
275
276 | Jite (_, i, t, e) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
277 fprintf ppf "@[<hv 2>%a ?@ %a :@ %a@]"
adda7d23 »
2008-08-31 jslib + changes from my repository
278 (expp pLogicalOR) i
279 (expp pAssignment) t
280 (expp pAssignment) e
281
9601e661 »
2009-06-30 somewhat better pretty-printing
282 | Jcall (_, e, es) -> fprintf ppf "@[%a@[<hov 1>(%a)@]@]" (expp pCall) e exps es
adda7d23 »
2008-08-31 jslib + changes from my repository
283
284 | Jnew (_, e, None) -> fprintf ppf "@[new %a@]" (expp pMember) e
9601e661 »
2009-06-30 somewhat better pretty-printing
285 | Jnew (_, e, Some es) -> fprintf ppf "@[new %a@[<hov 1>(%a)@]@]" (expp pMember) e exps es
adda7d23 »
2008-08-31 jslib + changes from my repository
286 | Jexp_Ant (_, s) -> fprintf ppf "$%s$" s
287
3503c9f2 »
2009-02-18 internal exp list in AST + list antiquotation.
288 | Jexp_nil _ -> assert false
289 | Jexp_cons _ -> assert false
290
291 and exps ppf e =
292 match e with
293 | Jexp_nil _ -> ()
294 | Jexp_cons (_, e1, e2) ->
295 exps ppf e1;
296 fprintf ppf ",@ ";
297 exps ppf e2;
298 | _ ->
9601e661 »
2009-06-30 somewhat better pretty-printing
299 (expp pAssignment) ppf e
300
301 and aexps ppf e =
302 match e with
303 | Jexp_nil _ -> ()
304 | Jexp_cons (_, e1, e2) ->
305 aexps ppf e1;
306 fprintf ppf ",@;<1 2>";
307 aexps ppf e2;
308 | _ ->
309 (expp pAssignment) ppf e
adda7d23 »
2008-08-31 jslib + changes from my repository
310
8c38f618 »
2010-05-31 handle for(var i= ...
311 and variableDeclarationList ppf = function
312 | [ (i, None) ] -> fprintf ppf "@[<hv 2>var %s@]" i
313 | [ (i, Some e) ] -> fprintf ppf "@[<hv 2>var %s =@ %a@]" i (expp pAssignment) e
314 | vars ->
315 let fvars ppf vars =
316 let comma = ref false in
317 List.iter
318 (fun (i, e) ->
319 if !comma then fprintf ppf ",@ " else comma := true;
320 match e with
321 | Some e -> fprintf ppf "%s =@;<1 2>%a" i (expp pAssignment) e
322 | None -> fprintf ppf "%s" i)
323 vars in
324 fprintf ppf "@[<hv 2>var@ %a@]" fvars vars
325
adda7d23 »
2008-08-31 jslib + changes from my repository
326 and stmt ppf = function
327 | Jvars (_, vars) ->
8c38f618 »
2010-05-31 handle for(var i= ...
328 fprintf ppf "%a;" variableDeclarationList vars
adda7d23 »
2008-08-31 jslib + changes from my repository
329
330 | Jfuns (_, i, is, ss) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
331 fprintf ppf "@[<hv>function %s @[<hv 1>(%a)@]%a@]" i ids is block ss
adda7d23 »
2008-08-31 jslib + changes from my repository
332
cdcc959a »
2008-12-12 bug with line break after return.
333 | Jreturn (_, e) -> fprintf ppf "@[<h>return%a;@]" (opt_nbsp (expp p)) e
9601e661 »
2009-06-30 somewhat better pretty-printing
334 | Jcontinue (_, i) -> fprintf ppf "@[<h>continue%a;@]" (opt_nbsp id) i
335 | Jbreak (_, i) -> fprintf ppf "@[<h>break%a;@]" (opt_nbsp id) i
adda7d23 »
2008-08-31 jslib + changes from my repository
336
337 | Jites (_, i, t, None) ->
338 fprintf ppf
9601e661 »
2009-06-30 somewhat better pretty-printing
339 "@[<hv>if (%a)%a@]"
340 (expp p) i maybe_block t
adda7d23 »
2008-08-31 jslib + changes from my repository
341
342 | Jites (_, i, t, Some e) ->
343 fprintf ppf
9601e661 »
2009-06-30 somewhat better pretty-printing
344 "@[<hv>if (%a)%a@ else%a@]"
345 (expp p) i maybe_block t maybe_block e
adda7d23 »
2008-08-31 jslib + changes from my repository
346
347 | Jswitch (_, e, cs, fss) ->
348 let cases ppf (cs, fss) =
349 let spc = ref false in
350 List.iter
351 (fun (i, ss) ->
352 if !spc then fprintf ppf "@ " else spc := true;
9601e661 »
2009-06-30 somewhat better pretty-printing
353 fprintf ppf "@[<hv>case %a:%a@]"
354 (expp p) i ind_stmts ss)
adda7d23 »
2008-08-31 jslib + changes from my repository
355 cs;
356 match fss with
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
357 | Jstmt_nil _ -> ()
358 | _ ->
adda7d23 »
2008-08-31 jslib + changes from my repository
359 if !spc then fprintf ppf "@ " else spc := true;
9601e661 »
2009-06-30 somewhat better pretty-printing
360 fprintf ppf "@[<hv>default:%a@]" ind_stmts fss in
adda7d23 »
2008-08-31 jslib + changes from my repository
361 fprintf ppf
362 "@[<hv>switch (%a)@ {@ %a@ }@]"
363 (expp p) e cases (cs, fss)
364
365 | Jthrow (_, e) -> fprintf ppf "@[throw %a;@]" (expp p) e
3e9bb557 »
2008-11-01 fixes. delay in froc-dom
366
367 | Jexps (_, (Jcall (_, Jfun _, _) as e)) -> fprintf ppf "@[(%a);@]" (expp p) e
adda7d23 »
2008-08-31 jslib + changes from my repository
368 | Jexps (_, e) -> fprintf ppf "@[%a;@]" (expp p) e
369
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
370 | Jtrycatch (_, ss, Some (ci, css), Jstmt_nil _) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
371 fprintf ppf "@[<hv>try%a@ catch (%s)%a@]" block ss ci block css
ed0d67b7 »
2009-08-13 single trycatch ast node
372 | Jtrycatch (_, ss, None, fss) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
373 fprintf ppf "@[<hv>try%a@ finally%a@]" block ss block fss
ed0d67b7 »
2009-08-13 single trycatch ast node
374 | Jtrycatch (_, ss, Some (ci, css), fss) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
375 fprintf ppf "@[<hv>try%a@ catch (%s)%a finally%a@]" block ss ci block css block fss
adda7d23 »
2008-08-31 jslib + changes from my repository
376
8c38f618 »
2010-05-31 handle for(var i= ...
377 | Jfor (_, [], e1, e2, e3, s) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
378 fprintf ppf "@[<hv>for @[<hv 1>(%a;@ %a;@ %a)@]%a@]" (opt (expp p)) e1 (opt (expp p)) e2 (opt (expp p)) e3 maybe_block s
8c38f618 »
2010-05-31 handle for(var i= ...
379 | Jfor (_, vars, None, e2, e3, s) ->
380 fprintf ppf "@[<hv>for @[<hv 1>(%a;@ %a;@ %a)@]%a@]" variableDeclarationList vars (opt (expp p)) e2 (opt (expp p)) e3 maybe_block s
381 | Jfor _ -> assert false
adda7d23 »
2008-08-31 jslib + changes from my repository
382
383 | Jdowhile (_, s, e) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
384 fprintf ppf "@[<hv>do%a@ while (%a);@]" maybe_block s (expp p) e
adda7d23 »
2008-08-31 jslib + changes from my repository
385
386 | Jwhile (_, e, s) ->
9601e661 »
2009-06-30 somewhat better pretty-printing
387 fprintf ppf "@[<hv>while (%a)%a@]" (expp p) e maybe_block s
adda7d23 »
2008-08-31 jslib + changes from my repository
388
9601e661 »
2009-06-30 somewhat better pretty-printing
389 | Jblock (_, ss) -> fprintf ppf "@[<hv>{%a@ }@]" ind_stmts ss
390 | Jwith (_, e, s) -> fprintf ppf "@[<hv>with (%a)%a@]" (expp p) e maybe_block s
391 | Jlabel (_, i, s) -> fprintf ppf "@[<hv>%s:%a@]" i maybe_block s
adda7d23 »
2008-08-31 jslib + changes from my repository
392 | Jstmt_Ant (_, s) -> fprintf ppf "$%s$" s
393
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
394 | (Jstmt_nil _ | Jstmt_cons _) as ss ->
395 stmts ppf ss
396
9601e661 »
2009-06-30 somewhat better pretty-printing
397 and block ppf ss = fprintf ppf " {%a@ }" ind_stmts ss
398
399 and maybe_block ppf = function
400 | Jblock (_, ss) -> block ppf ss
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
401 | Jstmt_nil _ -> fprintf ppf ";"
402 | Jstmt_cons (_loc, _, _) as s -> block ppf (Jblock (_loc, s))
9601e661 »
2009-06-30 somewhat better pretty-printing
403 | s -> fprintf ppf "@;<1 2>%a" stmt s
404
405 and ind_stmts ppf ss =
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
406 stmt_iter (fun s -> fprintf ppf "@;<1 2>%a" stmt s) ss
adda7d23 »
2008-08-31 jslib + changes from my repository
407
408 and stmts ppf ss =
9601e661 »
2009-06-30 somewhat better pretty-printing
409 let spc = ref false in
7e6ce992 »
2009-08-14 reworked stmt list AST / quotations
410 stmt_iter
9601e661 »
2009-06-30 somewhat better pretty-printing
411 (fun s ->
412 if !spc then fprintf ppf "@ " else spc := true;
413 stmt ppf s)
414 ss
8e2f16d9 »
2008-11-18 expose string escaping, added String.fromCharCode
415
416 let escaped = JSString.escaped
Something went wrong with that request. Please try again.