Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 533 lines (510 sloc) 18.672 kb
fccc685 Initial open-source release
MLstate authored
1 (*
2 Copyright © 2011 MLstate
3
4 This file is part of OPA.
5
6 OPA is free software: you can redistribute it and/or modify it under the
7 terms of the GNU Affero General Public License, version 3, as published by
8 the Free Software Foundation.
9
10 OPA is distributed in the hope that it will be useful, but WITHOUT ANY
11 WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
12 FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for
13 more details.
14
15 You should have received a copy of the GNU Affero General Public License
16 along with OPA. If not, see <http://www.gnu.org/licenses/>.
17 *)
18 module J = JsAst
19 open JsLex (* bringing token in the scope *)
20
21 let dummy_pos = FilePos.nopos "jsParse"
22 let label () = Annot.next_label dummy_pos
23 let native_ident = JsCons.Ident.native
24
25 let string_of_token = function
26 | Break -> "break"
27 | Case -> "case"
28 | Catch -> "catch"
29 | Continue -> "continue"
30 | Debugger -> "debugger"
31 | Default -> "default"
32 | Delete -> "delete"
33 | Do -> "do"
34 | Else -> "else"
35 | Finally -> "finally"
36 | For -> "for"
37 | Function -> "function"
38 | If -> "if"
39 | In -> "in"
40 | Instanceof -> "instanceof"
41 | New -> "new"
42 | Return -> "return"
43 | Switch -> "switch"
44 | This -> "this"
45 | Throw -> "throw"
46 | Try -> "try"
47 | Typeof -> "typeof"
48 | Var -> "var"
49 | Void -> "void"
50 | While -> "while"
51 | With -> "with"
52 | Class -> "class"
53 | Const -> "const"
54 | Enum -> "enum"
55 | Export -> "export"
56 | Extends -> "extends"
57 | Import -> "import"
58 | Super -> "super"
59 | Implements -> "implements"
60 | Interface -> "interface"
61 | Let -> "let"
62 | Package -> "package"
63 | Private -> "private"
64 | Protected -> "protected"
65 | Public -> "public"
66 | Static -> "static"
67 | Yield -> "yield"
68 | True -> "true"
69 | False -> "false"
70 | Null -> "null"
71 | Regexp (s1,s2) -> Printf.sprintf "Regexp /%s/%s" s1 s2
72 | String s -> Printf.sprintf "%S" s
73 | Ident s -> "Ident " ^ s
74 | Integer s -> s
75 | LT -> "LT"
76 | EOF -> "EOF"
77 | Lbracket -> "["
78 | Rbracket -> "]"
79 | Lcurly -> "{"
80 | Rcurly -> "}"
81 | Lparen -> "("
82 | Rparen -> ")"
83 | Dot -> "."
84 | Semic -> ";"
85 | Comma -> ","
86 | Lt -> "<"
87 | Gt -> ">"
88 | Le -> "<="
89 | Ge -> ">="
90 | EqualEqual -> "=="
91 | BangEqual -> "!="
92 | EqualEqualEqual -> "==="
93 | BangEqualEqual -> "!=="
94 | Plus -> "+"
95 | Minus -> "-"
96 | Times -> "*"
97 | Percent -> "%"
98 | PlusPlus -> "++"
99 | MinusMinus -> "--"
100 | LtLt -> "<<"
101 | GtGt -> ">>"
102 | GtGtGt -> ">>>"
103 | Amper -> "&"
104 | Bar -> "|"
105 | Chapeau -> "^"
106 | Bang -> "!"
107 | Tilda -> "~"
108 | AmperAmper -> "&&"
109 | BarBar -> "||"
110 | Question -> "?"
111 | Colon -> ":"
112 | Equal -> "="
113 | PlusEqual -> "+="
114 | MinusEqual -> "-="
115 | TimesEqual -> "*="
116 | PercentEqual -> "%="
117 | LtLtEqual -> "<<="
118 | GtGtEqual -> ">>="
119 | GtGtGtEqual -> ">>>="
120 | AmperEqual -> "&="
121 | BarEqual -> "|="
122 | ChapeauEqual -> "^="
123 | Div -> "/"
124 | DivEqual -> "/="
125
126 module Stream =
127 struct
128 type 'a t = 'a Stream.t
129 exception Failure = Stream.Failure
130 exception Error = Stream.Error
131 let from = Stream.from
132 let junk_no_newline = Stream.junk
133 let junk stream =
134 (match Stream.peek stream with
135 | Some LT -> Stream.junk stream
136 | _ -> ());
137 Stream.junk stream
138 let peek_no_newline = Stream.peek
139 (*let peek stream =
140 match Stream.npeek 2 stream with
141 | [LT; a] -> Some a
142 | [LT] -> None
143 | a :: _ -> Some a
144 | [] -> None*)
145 let peek stream = (* this Stream.peek makes the parsing really faster *)
146 match Stream.peek stream with
147 | Some LT ->
148 (match Stream.npeek 2 stream with
149 | _ :: t :: _ -> Some t
150 | _ -> None)
151 | o -> o
152 let empty s =
153 match peek s with
154 | None -> ()
155 | Some _ -> raise Stream.Failure
156 end
157
158 let rev_list0_aux acc parser_ stream =
159 let rec aux acc = parser
160 | [< e = parser_; stream >] -> aux (e :: acc) stream
161 | [< >] -> acc in
162 aux acc stream
163 let rev_list0 parser_ stream =
164 rev_list0_aux [] parser_ stream
165 let list0 parser_ stream =
166 List.rev (rev_list0 parser_ stream)
167 let rev_list1 parser_ = parser
168 | [< v = parser_; r = rev_list0_aux [v] parser_ >] -> r
169 let list1 parser_ = parser
170 | [< v = parser_; l = list0 parser_ >] -> v :: l
171 let rev_list1_sep parser_ sep stream =
172 let rec aux acc = parser
173 | [< _op = sep; e = parser_; stream >] -> aux (e :: acc) stream
174 | [< >] -> acc in
175 match stream with parser
176 | [< e = parser_; stream >] -> aux [e] stream
177
178 let list1_sep_left_assoc parser_ sep stream =
179 let rec aux acc = parser
180 | [< op = sep; e = parser_; stream >] -> aux (J.Je_binop (label(),op,acc,e)) stream
181 | [< >] -> acc in
182 match stream with parser
183 | [< e = parser_; stream >] -> aux e stream
184 let list1_sep_right_assoc parser_ sep stream =
185 let rec aux acc = parser
186 | [< op = sep; e = parser_; stream >] -> aux ((op, e) :: acc) stream
187 | [< >] -> acc in
188 match stream with parser
189 | [< r = parser_; stream >] ->
190 match aux [] stream with
191 | [] -> r
192 | (op,e) :: t ->
193 let op, e =
194 List.fold_left (fun (op,e1) (op2,e2) -> (op2, J.Je_binop (label(),op,e2,e1))) (op,e) t in
195 J.Je_binop(label(),op,r,e)
196
197 let rev_list0_sep parser_ sep stream =
198 let rec aux acc = parser
199 | [< _ = sep; v = parser_; stream >] -> aux (v :: acc) stream
200 | [< >] -> acc in
201 match stream with parser
202 | [< r = parser_; stream >] -> aux [r] stream
203 | [< >] -> []
204 let list1_sep parser_ sep stream = List.rev (rev_list1_sep parser_ sep stream)
205 let list0_sep parser_ sep stream = List.rev (rev_list0_sep parser_ sep stream)
206 let option parser_ = parser
207 | [< r = parser_ >] -> Some r
208 | [< >] -> None
209 let option_default default parser_ = parser
210 | [< r = parser_ >] -> r
211 | [< >] -> default
212 let option_no_newline parser_ stream =
213 match Stream.peek_no_newline stream with
214 | Some LT -> None
215 | _ -> option parser_ stream
216
217 let semic stream =
218 match Stream.peek_no_newline stream with
219 | None
220 | Some (Semic | LT) -> Stream.junk_no_newline stream
221 | Some Rcurly -> () (* do not discard the bracket! *)
222 | _ -> raise Stream.Failure
223 let ident = parser
224 | [< 'Ident i >] -> i
225 let native = parser
226 | [< 'Ident i >] -> native_ident i
227 let comma = parser
228 | [< 'Comma >] -> ()
229 let barbar = parser
230 | [< 'BarBar >] -> J.Jb_lor
231 let amperamper = parser
232 | [< 'AmperAmper >] -> J.Jb_land
233 let bar = parser
234 | [< 'Bar >] -> J.Jb_or
235 let chapeau = parser
236 | [< 'Chapeau >] -> J.Jb_xor
237 let amper = parser
238 | [< 'Amper >] -> J.Jb_and
239 let assignmentoperator = parser
240 | [< 'TimesEqual >] -> J.Jb_mul_assign
241 | [< 'PlusEqual >] -> J.Jb_add_assign
242 | [< 'PercentEqual >] -> J.Jb_mod_assign
243 | [< 'MinusEqual >] -> J.Jb_sub_assign
244 | [< 'LtLtEqual >] -> J.Jb_lsl_assign
245 | [< 'GtGtGtEqual >] -> J.Jb_asr_assign
246 | [< 'GtGtEqual >] -> J.Jb_lsr_assign
247 | [< 'Equal >] -> J.Jb_assign
248 | [< 'DivEqual >] -> J.Jb_div_assign
249 | [< 'ChapeauEqual >] -> J.Jb_xor_assign
250 | [< 'BarEqual >] -> J.Jb_or_assign
251 | [< 'AmperEqual >] -> J.Jb_and_assign
252 let equalityoperator = parser
253 | [< 'EqualEqual >] -> J.Jb_eq
254 | [< 'EqualEqualEqual >] -> J.Jb_seq
255 | [< 'BangEqual >] -> J.Jb_neq
256 | [< 'BangEqualEqual >] -> J.Jb_sneq
257 let relationaloperator = parser
258 | [< 'Lt >] -> J.Jb_lt
259 | [< 'Gt >] -> J.Jb_gt
260 | [< 'Le >] -> J.Jb_leq
261 | [< 'Ge >] -> J.Jb_geq
262 | [< 'Instanceof >] -> J.Jb_instanceof
263 | [< 'In >] -> J.Jb_in
264 let shiftoperator = parser
265 | [< 'LtLt >] -> J.Jb_lsl
266 | [< 'GtGt >] -> J.Jb_lsr
267 | [< 'GtGtGt >] -> J.Jb_asr
268 let additiveoperator = parser
269 | [< 'Plus >] -> J.Jb_add
270 | [< 'Minus >] -> J.Jb_sub
271 let multiplicativeoperator = parser
272 | [< 'Times >] -> J.Jb_mul
273 | [< 'Div >] -> J.Jb_div
274 | [< 'Percent >] -> J.Jb_mod
275 let unaryoperator = parser
276 | [< 'PlusPlus >] -> J.Ju_add2_pre
277 | [< 'Delete >] -> J.Ju_delete
278 | [< 'Typeof >] -> J.Ju_typeof
279 | [< 'Void >] -> J.Ju_void
280 | [< 'MinusMinus >] -> J.Ju_sub2_pre
281 | [< 'Plus >] -> J.Ju_add_pre
282 | [< 'Minus >] -> J.Ju_sub_pre
283 | [< 'Tilda >] -> J.Ju_tilde
284 | [< 'Bang >] -> J.Ju_not
285 let postfixoperator = parser
286 | [< 'PlusPlus >] -> J.Ju_add2_post
287 | [< 'MinusMinus >] -> J.Ju_sub2_post
288
289 let rec statement = parser
290 | [< 'Function; 'Ident name ?? "expected an identifier after 'function' in a statement"; 'Lparen; params = list0_sep native comma; 'Rparen; 'Lcurly; body = statements; 'Rcurly >] ->
291 J.Js_function (label(), native_ident name, params, body)
292 | [< 'Lcurly; block = statements; 'Rcurly ?? "expected a closing curly brace" >] ->
293 J.Js_block (label(),block)
294 | [< 'Semic; stream >] ->
295 statement stream
296 | [< 'Var; l = list1_sep vardeclaration comma; _ = semic >] ->
297 (match l with
298 | [(i,o)] -> J.Js_var (label (), i, o)
299 | _ -> J.Js_block (label(), List.map (fun (i,o) -> J.Js_var (label(),i,o)) l))
300 | [< 'If; 'Lparen; e = expr; 'Rparen; s1 = statement; stream >] ->
301 let o =
302 match stream with parser
303 | [< 'Else; s2 = statement >] -> Some s2
304 | [< >] -> None in
305 J.Js_if (label(),e,s1,o)
306 | [< 'Do; s = statement; 'While; 'Lparen; e = expr; 'Rparen; _ = semic >] ->
307 J.Js_dowhile (label(),s,e)
308 | [< 'While; 'Lparen; e = expr; 'Rparen; s = statement >] ->
309 J.Js_while (label(),e,s)
310 | [< 'For; 'Lparen; stream >] -> (
311 match stream with parser
312 | [< 'Var; (i,o) = vardeclaration; stream >] ->
313 (match o with
314 | Some (J.Je_binop (_,J.Jb_in,e1,e2)) ->
315 (match stream with parser
316 | [< 'Rparen; s = statement >] ->
317 let s1 = J.Js_var (label(), i, Some e1) in
318 let s2 = J.Js_forin (label(), J.Je_ident (label(),i), e2, s) in
319 J.Js_block (label (), [s1; s2])
320 )
321 | _ ->
322 match stream with parser
323 | [< 'In; e2 = expr; 'Rparen; s = statement >] ->
324 let s1 = J.Js_var (label(), i, o) in
325 let s2 = J.Js_forin (label(), J.Je_ident(label(),i), e2, s) in
326 J.Js_block (label (), [s1; s2])
327 | [< 'Comma; l = list1_sep vardeclaration comma; 'Semic; e2 = option expr; 'Semic; e3 = option expr; 'Rparen; s = statement >] ->
328 let s1 = J.Js_var (label(), i, o) in
329 let s1_more = List.map (fun (i,o) -> J.Js_var (label(),i,o)) l in
330 let s2 = J.Js_for (label(), None, e2, e3, s) in
331 J.Js_block (label (), s1 :: s1_more @ [s2])
332 | [< 'Semic; e2 = option expr; 'Semic; e3 = option expr; 'Rparen; s = statement >] ->
333 let s1 = J.Js_var (label(), i, o) in
334 let s2 = J.Js_for (label(), None, e2, e3, s) in
335 J.Js_block (label (), [s1;s2])
336 )
337 | [< o1 = option expr; stream >] -> (
338 match o1 with
339 | Some J.Je_binop (_,J.Jb_in,e1,e2) -> (
340 match stream with parser
341 | [< 'Rparen; s = statement >] ->
342 J.Js_forin (label(), e1, e2, s)
343 )
344 | _ ->
345 match stream with parser
346 | [< _ = semic; e2 = option expr; _ = semic; e3 = option expr; 'Rparen; s = statement >] ->
347 J.Js_for (label(), o1, e2, e3, s)
348 )
349 )
350 | [< 'Continue; o = option_no_newline ident; _ = semic >] -> J.Js_continue (label(), o)
351 | [< 'Break; o = option_no_newline ident; _ = semic >] -> J.Js_break (label(), o)
352 | [< 'Return; o = option_no_newline expr; _ = semic >] -> J.Js_return (label(), o)
353 | [< 'With; 'Lparen; e = expr; 'Rparen; s = statement >] -> J.Js_with (label(),e,s)
354 | [< 'Switch; 'Lparen; e = expr; 'Rparen; 'Lcurly; clauses = list0 caseclause; default = option defaultclause; 'Rcurly >] -> J.Js_switch (label(),e,clauses,default)
355 | [< 'Throw; e = expr; _ = semic >] -> J.Js_throw (label(),e)
356 (* the specification seems crazy, where is the problem with a newline here? *)
357 | [< 'Debugger >] -> (*SDebugger*) failwith "No ast node for \"debugger\""
358 | [< 'Try; b = block_stm; stream >] -> (
359 match stream with parser
360 | [< (i,s) = catch_block; o = option finally >] ->
361 J.Js_trycatch (label(), b, [(i,None,s)], o)
362 | [< c = finally >] ->
363 J.Js_trycatch (label(), b, [], Some c)
364 )
365 | [< e = expr; stream >] ->
366 match stream with parser
367 | [< 'Colon; s = statement >] ->
368 (match e with
369 | J.Je_ident (label,i) ->
370 (match i with
371 | J.Native (_, i) -> J.Js_label (label,i,s)
372 | _ -> assert false)
373 | _ -> raise (Stream.Error "Invalid label"))
374 | [< _ = semic >] -> J.Js_expr (label(), e)
375
376 and block = parser
377 | [< 'Lcurly; l = statements; 'Rcurly >] -> l
378 and block_stm stream =
379 J.Js_block (label(), block stream)
380
381 and vardeclaration = parser
382 | [< 'Ident i; stream >] ->
383 match stream with parser
384 | [< 'Equal; e = assignmentexpr >] -> (native_ident i, Some e)
385 | [< >] -> (native_ident i, None)
386
387 and caseclause = parser
388 | [< 'Case; e = expr; 'Colon; l = statements_stm >] -> (e, l)
389 and defaultclause = parser
390 | [< 'Default; 'Colon; l = statements_stm >] -> l
391
392 and catch_block = parser
393 | [< 'Catch; 'Lparen; 'Ident i; 'Rparen; b = block_stm >] -> (native_ident i,b)
394 and finally = parser
395 | [< 'Finally; b = block_stm >] -> b
396
397 and expr stream =
398 match rev_list1_sep assignmentexpr comma stream with
399 | [] -> assert false
400 | [e] -> e
401 | e :: l -> J.Je_comma (label(), List.rev l, e)
402 and assignmentexpr stream =
403 list1_sep_right_assoc conditionalexpr assignmentoperator stream
404 and conditionalexpr = parser
405 | [< e = logicalorexpr; stream >] ->
406 match stream with parser
407 | [< 'Question; e2 = assignmentexpr; 'Colon; e3 = conditionalexpr >] -> J.Je_cond (label(),e,e2,e3)
408 | [< >] -> e
409 and logicalorexpr stream =
410 list1_sep_left_assoc logicalandexpr barbar stream
411 and logicalandexpr stream =
412 list1_sep_left_assoc bitwiseorexpr amperamper stream
413 and bitwiseorexpr stream =
414 list1_sep_left_assoc bitwisexorexpr bar stream
415 and bitwisexorexpr stream =
416 list1_sep_left_assoc bitwiseandexpr chapeau stream
417 and bitwiseandexpr stream =
418 list1_sep_left_assoc equalityexpr amper stream
419 and equalityexpr stream =
420 list1_sep_left_assoc relationalexpr equalityoperator stream
421 and relationalexpr stream =
422 list1_sep_left_assoc shiftexpr relationaloperator stream
423 and shiftexpr stream =
424 list1_sep_left_assoc additiveexpr shiftoperator stream
425 and additiveexpr stream =
426 list1_sep_left_assoc multiplicativeexpr additiveoperator stream
427 and multiplicativeexpr stream =
428 list1_sep_left_assoc unaryexpr multiplicativeoperator stream
429 and unaryexpr = parser
430 | [< l = rev_list1 unaryoperator; e = postfixexpr ?? "expected an expression after a postfix operator" >] ->
431 List.fold_left (fun e op -> J.Je_unop (label(),op,e)) e l
432 | [< e = postfixexpr >] -> e
433 and postfixexpr = parser
434 | [< e = lefthandsideexpr false; o = option_no_newline postfixoperator >] ->
435 match o with
436 | None -> e
437 | Some op -> J.Je_unop(label(),op,e)
438 and lefthandsideexpr new_ = parser
439 | [< 'New; e = lefthandsideexpr true; el = option_default [] arguments; stream >] ->
440 let e = J.Je_new (label(),e,el) in
441 dot_hashref_call true e stream
442 | [< 'Function; name = option native; 'Lparen; params = list0_sep native comma; 'Rparen; 'Lcurly; body = statements; 'Rcurly; stream >] ->
443 (* put the this rule into primaryexpr instead? *)
444 let e = J.Je_function (label(),name,params,body) in
445 dot_hashref_call (not new_) e stream
446 | [< e = primaryexpr; r = dot_hashref_call (not new_) e >] -> r
447 and dot_hashref_call can_call e = parser
448 | [< 'Dot; 'Ident i; stream >] ->
449 dot_hashref_call can_call (J.Je_dot (label(),e,i)) stream
450 | [< 'Lbracket; i = expr; 'Rbracket; stream >] ->
451 dot_hashref_call can_call (J.Je_binop (label(),J.Jb_hashref,e,i)) stream
452 | [< 'Lparen when can_call; l = list0_sep assignmentexpr comma; 'Rparen; stream >] ->
453 (* refusing to parse arguments when under a new because in [new f()], the arguments are given to new_
454 * not to f *)
455 dot_hashref_call can_call (J.Je_call (label(),e,l,false)) stream
456 | [< >] -> e
457 and arguments = parser
458 | [< 'Lparen; l = list0_sep assignmentexpr comma; 'Rparen >] -> l
459 and primaryexpr = parser
460 | [< 'Null >] -> J.Je_null (label())
461 | [< 'This >] -> J.Je_this (label())
462 | [< 'Ident i >] -> J.Je_ident (label(), native_ident i)
463 | [< 'Integer i >] -> J.Je_num (label(), i)
464 | [< 'True >] -> J.Je_bool (label(), true)
465 | [< 'False >] -> J.Je_bool (label(), false)
466 | [< 'String s >] -> J.Je_string (label(), s, true)
467 | [< 'Lbracket; l = list0_sep assignmentexpr comma; 'Rbracket >] -> J.Je_array (label(), l)
468 | [< 'Lcurly; l = list0_sep property_assignment comma; _ = option comma; 'Rcurly >] -> J.Je_object(label(), l)
469 | [< 'Lparen; e = expr; 'Rparen >] -> e
470 | [< 'Regexp (s1,s2) >] -> J.Je_regexp (label(),s1,s2)
471 and statements stream = list0 statement stream
472 and statements_stm stream = J.Js_block (label(),statements stream)
473 and property_name = parser
474 | [< 'Ident i >] -> i
475 | [< 'String s >] -> s
476 | [< 'Integer i >] -> i
477 and property_assignment = parser
478 | [< p = property_name; 'Colon; e = assignmentexpr >] ->
479 (p,e)
480
481 let code = parser
482 | [< r = statements; _ = Stream.empty >] -> r
483 let expr = parser
484 | [< e = expr; _ = Stream.empty >] -> e
485 let stm = parser
486 | [< s = statement; _ = Stream.empty >] -> s
487
488 type error = (int * int * string * string)
489 exception Exception of error
490 let pp f (start,end_,lexem,s) =
491 Format.fprintf f "Parse error at %d-%d on %S%s"
492 start
493 end_
494 lexem
495 (if s = "" then s else ": " ^ s)
496
497 let build_parser ?(throw_exn=false) ?(globalize=fun x -> x) parser_ (stream,lexbuf) =
498 try
499 let code = parser_ stream in
500 globalize code
501 with Stream.Error s ->
502 let tuple = (Lexing.lexeme_start lexbuf,Lexing.lexeme_end lexbuf,Lexing.lexeme lexbuf,s) in
503 if throw_exn then
504 raise (Exception tuple)
505 else (
506 Format.eprintf "%a@." pp tuple;
507 exit 1
508 )
509
510 let global_expr ?(globalize=false) expr =
511 if globalize then
512 JsWalk.Expr.map (
513 function
514 | J.Je_ident (loc, J.Native (`local, id)) ->
515 J.Je_ident (loc, J.Native (`global, id))
516 | e -> e
517 ) expr
518 else
519 expr
520
521 module String =
522 struct
523 let code ?throw_exn str = build_parser ?throw_exn code (JsLex.stream_of_string str)
524 let expr ?throw_exn ?globalize str = build_parser ?throw_exn ~globalize:(global_expr ?globalize) expr (JsLex.stream_of_string str)
525 let stm ?throw_exn str = build_parser ?throw_exn stm (JsLex.stream_of_string str)
526 end
527 module File =
528 struct
529 let code ?throw_exn file = build_parser ?throw_exn code (JsLex.stream_of_file file)
530 let expr ?throw_exn ?globalize file = build_parser ?throw_exn ~globalize:(global_expr ?globalize) expr (JsLex.stream_of_file file)
531 let stm ?throw_exn file = build_parser ?throw_exn stm (JsLex.stream_of_file file)
532 end
Something went wrong with that request. Please try again.