diff --git a/.gitignore b/.gitignore index af84d820997c..08c7618fa637 100644 --- a/.gitignore +++ b/.gitignore @@ -413,5 +413,3 @@ _ocamltest lib/ocaml/ man/ -_esy -esy.lock diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 184f79cbcbe7..cb376c756965 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -1447,7 +1447,7 @@ struct let make_isout h arg = Cop (Ccmpa Clt, [h ; arg], Debuginfo.none) let make_isin h arg = Cop (Ccmpa Cge, [h ; arg], Debuginfo.none) let make_if cond ifso ifnot = Cifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases actions _names = + let make_switch loc arg cases actions ~offset:_ _names = make_switch arg cases actions (Debuginfo.from_location loc) let bind arg body = bind "switcher" arg body diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index a825fdcdb16c..0a01b71e564b 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1954,10 +1954,10 @@ module SArg = struct let make_isout h arg = Lprim (Pisout, [h ; arg],Location.none) let make_isin h arg = Lprim (Pnot,[make_isout h arg],Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) - let make_switch loc arg cases acts sw_names = + let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in for i = Array.length cases-1 downto 0 do - l := (i,acts.(cases.(i))) :: !l + l := (offset + i,acts.(cases.(i))) :: !l done ; Lswitch(arg, {sw_numconsts = Array.length cases ; sw_consts = !l ; @@ -2500,6 +2500,11 @@ let make_test_sequence_variant_constant : ref = ref make_test_sequence_variant_constant +let is_poly_var_constant : Lambda.primitive lazy_t = lazy ( + if !Config.bs_only then + Pccall (Primitive.simple ~name:"#is_poly_var_const" ~arity:1 ~alloc:false) + else Pisint ) + let combine_variant names loc row arg partial ctx def (tag_lambda_list, total1, _pats) = let row = Btype.row_repr row in @@ -2514,9 +2519,9 @@ let combine_variant names loc row arg partial ctx def else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse(Lprim (Pisint, [arg], loc), if_int, if_block) in + Lifthenelse(Lprim (Lazy.force is_poly_var_constant, [arg], loc), if_int, if_block) in let sig_complete = List.length tag_lambda_list = !num_constr - and one_action = same_actions tag_lambda_list in + and one_action = same_actions tag_lambda_list in (* reduandant work under bs context *) let fail, local_jumps = if sig_complete || (match partial with Total -> true | _ -> false) diff --git a/bytecomp/switch.ml b/bytecomp/switch.ml index b7c2f4a11096..165347b7956e 100644 --- a/bytecomp/switch.ml +++ b/bytecomp/switch.ml @@ -106,7 +106,7 @@ module type S = val make_isout : act -> act -> act val make_isin : act -> act -> act val make_if : act -> act -> act -> act - val make_switch : Location.t -> act -> int array -> act array -> Lambda.switch_names option -> act + val make_switch : Location.t -> act -> int array -> act array -> offset:int -> Lambda.switch_names option -> act val make_catch : act -> int * (act -> act) val make_exit : int -> act end @@ -560,6 +560,9 @@ and enum top cases = do_make_if_out (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> + if (*true || *)!Config.bs_only then + do_make_if_out + (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> @@ -575,6 +578,9 @@ and enum top cases = do_make_if_in (Arg.make_const d) ctx.arg (mk_ifso ctx) (mk_ifno ctx) | _ -> + if (*true || *) !Config.bs_only then + do_make_if_in + (Arg.make_const d) (Arg.make_offset ctx.arg (-l)) (mk_ifso ctx) (mk_ifno ctx) else Arg.bind (Arg.make_offset ctx.arg (-l)) (fun arg -> @@ -750,12 +756,15 @@ let make_switch loc {cases=cases ; actions=actions} i j sw_names = (fun act i -> acts.(i) <- actions.(act)) t ; (fun ctx -> + if !Config.bs_only then + Arg.make_switch ~offset:(ll+ctx.off) loc ctx.arg tbl acts sw_names + else match -ll-ctx.off with - | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names + | 0 -> Arg.make_switch loc ctx.arg tbl acts sw_names ~offset:0 | _ -> Arg.bind (Arg.make_offset ctx.arg (-ll-ctx.off)) - (fun arg -> Arg.make_switch loc arg tbl acts sw_names)) + (fun arg -> Arg.make_switch loc arg tbl acts sw_names ~offset:0)) let make_clusters loc ({cases=cases ; actions=actions} as s) n_clusters k sw_names = diff --git a/bytecomp/switch.mli b/bytecomp/switch.mli index 28b4ad560c1a..2dc3e2c56dd0 100644 --- a/bytecomp/switch.mli +++ b/bytecomp/switch.mli @@ -79,7 +79,7 @@ module type S = make_switch arg cases acts NB: cases is in the value form *) val make_switch : - Location.t -> act -> int array -> act array -> Lambda.switch_names option -> act + Location.t -> act -> int array -> act array -> offset:int -> Lambda.switch_names option -> act (* Build last minute sharing of action stuff *) val make_catch : act -> int * (act -> act) val make_exit : int -> act diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index c58b026b2b68..a7597a777b2b 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -940,6 +940,9 @@ let try_ids = Hashtbl.create 8 let rec transl_exp e = List.iter (Translattribute.check_attribute e) e.exp_attributes; +#if BS_ONLY then + transl_exp0 e +#else let eval_once = (* Whether classes for immediate objects must be cached *) match e.exp_desc with @@ -948,7 +951,7 @@ let rec transl_exp e = in if eval_once then transl_exp0 e else Translobj.oo_wrap e.exp_env true transl_exp0 e - +#end and transl_exp0 e = match e.exp_desc with Texp_ident(path, _, {val_kind = Val_prim p}) -> @@ -1263,6 +1266,15 @@ and transl_exp0 e = | Texp_for(param, _, low, high, dir, body) -> Lfor(param, transl_exp low, transl_exp high, dir, event_before body (transl_exp body)) +#if BS_ONLY then + | Texp_send(expr,met,_) -> + let obj = transl_exp expr in + begin match met with + | Tmeth_name nm -> + Lsend(Public(Some nm),Lambda.lambda_unit,obj,[],e.exp_loc) + | _ -> assert false + end +#else | Texp_send(_, _, Some exp) -> transl_exp exp | Texp_send(expr, met, None) -> let obj = transl_exp expr in @@ -1275,6 +1287,7 @@ and transl_exp0 e = Lsend (kind, tag, obj, cache, e.exp_loc) in event_after e lam +#end | Texp_new (cl, {Location.loc=loc}, _) -> Lapply{ap_should_be_tailcall=false; ap_loc=loc; @@ -1288,6 +1301,9 @@ and transl_exp0 e = | Texp_setinstvar(path_self, path, _, expr) -> transl_setinstvar e.exp_loc (transl_normal_path path_self) path expr | Texp_override(path_self, modifs) -> +#if BS_ONLY then + assert false +#else let cpy = Ident.create "copy" in Llet(Strict, Pgenval, cpy, Lapply{ap_should_be_tailcall=false; @@ -1302,6 +1318,7 @@ and transl_exp0 e = (Lvar cpy) path expr, rem)) modifs (Lvar cpy)) +#end | Texp_letmodule(id, loc, modl, body) -> let defining_expr = #if true diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml index d4d7c967e7b3..b2cf2c2d457a 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -15,7 +15,14 @@ (* Translation from typed abstract syntax to lambda terms, for the module language *) - +#if BS_ONLY then +module Translobj = struct + let oo_wrap _env _b f a = f a + let reset_labels () : unit = () + let transl_store_label_init _ _ _ _ : int * _ = assert false + let transl_label_init f = f () +end +#end open Misc open Asttypes open Longident @@ -25,7 +32,7 @@ open Typedtree open Lambda open Translobj open Translcore -open Translclass + type error = Circular_dependency of Ident.t @@ -364,15 +371,15 @@ let rec bound_value_identifiers = function (* Code to translate class entries in a structure *) - +#if undefined BS_ONLY then let transl_class_bindings cl_list = let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in (ids, List.map (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) -> - (id, transl_class ids id meths cl vf)) + (id, Translclass.transl_class ids id meths cl vf)) cl_list) - +#end (* Compile one or more functors, merging curried functors to produce multi-argument functors. Any [@inline] attribute on a functor that is merged must be consistent with any other [@inline] attribute(s) on the @@ -632,6 +639,7 @@ and transl_structure loc fields cc rootpath final_env = function body in lam, size +#if undefined BS_ONLY then | Tstr_class cl_list -> let (ids, class_bindings) = transl_class_bindings cl_list in let body, size = @@ -639,6 +647,9 @@ and transl_structure loc fields cc rootpath final_env = function cc rootpath final_env rem in Lletrec(class_bindings, body), size +#else + | Tstr_class _ -> assert false +#end | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in @@ -972,6 +983,9 @@ let transl_store_structure glob map prims str = bindings (Lsequence(store_idents Location.none ids, transl_store rootpath (add_idents true ids subst) rem)) +#if BS_ONLY then + | Tstr_class _ -> assert false +#else | Tstr_class cl_list -> let (ids, class_bindings) = transl_class_bindings cl_list in let lam = @@ -979,7 +993,7 @@ let transl_store_structure glob map prims str = in Lsequence(subst_lambda subst lam, transl_store rootpath (add_idents false ids subst) rem) - +#end | Tstr_include{ incl_loc=loc; incl_mod= { @@ -1235,12 +1249,16 @@ let transl_toplevel_item item = (fun id modl _loc -> transl_module Tcoerce_none (Some(Pident id)) modl) bindings (make_sequence toploop_setvalue_id idents) +#if BS_ONLY then + | Tstr_class _ -> assert false +#else | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) let (ids, class_bindings) = transl_class_bindings cl_list in List.iter set_toplevel_unique_name ids; Lletrec(class_bindings, make_sequence toploop_setvalue_id ids) +#end | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in let modl = incl.incl_mod in diff --git a/package.json b/package.json deleted file mode 100644 index 719b5aa920b8..000000000000 --- a/package.json +++ /dev/null @@ -1,39 +0,0 @@ -{ - "name": "ocaml", - "version": "4.06.1000+BS", - "description": "BuckleScript's OCaml Compiler as an npm Package", - "esy": { - "build": [ - "./configure -no-cfi -prefix $cur__install", - "make -j world.opt" - ], - "install": [ - "make install" - ], - "buildsInSource": true, - "exportedEnv": { - "OCAMLLIB": { - "val": "#{self.lib / 'ocaml' }", - "scope": "global" - }, - "CAML_LD_LIBRARY_PATH": { - "val": "#{self.lib / 'ocaml' / 'stublibs' : self.lib / 'ocaml' : $CAML_LD_LIBRARY_PATH}", - "scope": "global" - }, - "OCAML_TOPLEVEL_PATH": { - "val": "#{self.lib / 'ocaml' }", - "scope": "global" - } - } - }, - "repository": { - "type": "git", - "url": "git://github.com/BuckleScript/ocaml.git" - }, - "keywords": [ - "ocaml", - "flow", - "opam" - ], - "license": "QPL - See LICENSE at https://github.com/ocaml/ocaml" -} diff --git a/parsing/builtin_attributes.ml b/parsing/builtin_attributes.ml index e0de1b0e670b..7aa03e606981 100755 --- a/parsing/builtin_attributes.ml +++ b/parsing/builtin_attributes.ml @@ -63,7 +63,8 @@ let cat s1 s2 = if s2 = "" then s1 else #if undefined BS_NO_COMPILER_PATCH then if Clflags.bs_vscode then s1 ^ " " ^ s2 - else s1 ^ "\n" ^ s2 + (* 2 spaces indentation for the next line *) + else s1 ^ "\n " ^ s2 #else s1 ^ "\n" ^ s2 #end diff --git a/parsing/lexer.ml b/parsing/lexer.ml index 12892b6f8b97..72b509606ce9 100644 --- a/parsing/lexer.ml +++ b/parsing/lexer.ml @@ -287,8 +287,7 @@ let directive_parse token_with_comments lexbuf = let rec skip () = match token_with_comments lexbuf with | COMMENT _ - | DOCSTRING _ - (*| EOL*) -> skip () + | DOCSTRING _ -> skip () | EOF -> raise (Error (Unterminated_if, Location.curr lexbuf)) | t -> t in skip () @@ -713,7 +712,7 @@ let () = ) -# 717 "parsing/lexer.ml" +# 716 "parsing/lexer.ml" let __ocaml_lex_tables = { Lexing.lex_base = "\000\000\162\255\163\255\224\000\003\001\038\001\073\001\108\001\ @@ -2347,131 +2346,131 @@ let rec token lexbuf = and __ocaml_lex_token_rec lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> -# 770 "parsing/lexer.mll" +# 769 "parsing/lexer.mll" ( if not !escaped_newlines then raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), Location.curr lexbuf)); update_loc lexbuf None 1 false 0; token lexbuf ) -# 2358 "parsing/lexer.ml" +# 2357 "parsing/lexer.ml" | 1 -> -# 777 "parsing/lexer.mll" +# 776 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 0; EOL ) -# 2364 "parsing/lexer.ml" +# 2363 "parsing/lexer.ml" | 2 -> -# 780 "parsing/lexer.mll" +# 779 "parsing/lexer.mll" ( token lexbuf ) -# 2369 "parsing/lexer.ml" +# 2368 "parsing/lexer.ml" | 3 -> -# 782 "parsing/lexer.mll" +# 781 "parsing/lexer.mll" ( UNDERSCORE ) -# 2374 "parsing/lexer.ml" +# 2373 "parsing/lexer.ml" | 4 -> -# 784 "parsing/lexer.mll" +# 783 "parsing/lexer.mll" ( TILDE ) -# 2379 "parsing/lexer.ml" +# 2378 "parsing/lexer.ml" | 5 -> -# 786 "parsing/lexer.mll" +# 785 "parsing/lexer.mll" ( LABEL (get_label_name lexbuf) ) -# 2384 "parsing/lexer.ml" +# 2383 "parsing/lexer.ml" | 6 -> -# 788 "parsing/lexer.mll" +# 787 "parsing/lexer.mll" ( warn_latin1 lexbuf; LABEL (get_label_name lexbuf) ) -# 2389 "parsing/lexer.ml" +# 2388 "parsing/lexer.ml" | 7 -> -# 790 "parsing/lexer.mll" +# 789 "parsing/lexer.mll" ( QUESTION ) -# 2394 "parsing/lexer.ml" +# 2393 "parsing/lexer.ml" | 8 -> -# 792 "parsing/lexer.mll" +# 791 "parsing/lexer.mll" ( OPTLABEL (get_label_name lexbuf) ) -# 2399 "parsing/lexer.ml" +# 2398 "parsing/lexer.ml" | 9 -> -# 794 "parsing/lexer.mll" +# 793 "parsing/lexer.mll" ( warn_latin1 lexbuf; OPTLABEL (get_label_name lexbuf) ) -# 2404 "parsing/lexer.ml" +# 2403 "parsing/lexer.ml" | 10 -> -# 796 "parsing/lexer.mll" +# 795 "parsing/lexer.mll" ( let s = Lexing.lexeme lexbuf in try Hashtbl.find keyword_table s with Not_found -> LIDENT s ) -# 2411 "parsing/lexer.ml" +# 2410 "parsing/lexer.ml" | 11 -> -# 800 "parsing/lexer.mll" +# 799 "parsing/lexer.mll" ( warn_latin1 lexbuf; LIDENT (Lexing.lexeme lexbuf) ) -# 2416 "parsing/lexer.ml" +# 2415 "parsing/lexer.ml" | 12 -> -# 802 "parsing/lexer.mll" +# 801 "parsing/lexer.mll" ( UIDENT(Lexing.lexeme lexbuf) ) -# 2421 "parsing/lexer.ml" +# 2420 "parsing/lexer.ml" | 13 -> -# 804 "parsing/lexer.mll" +# 803 "parsing/lexer.mll" ( warn_latin1 lexbuf; UIDENT(Lexing.lexeme lexbuf) ) -# 2426 "parsing/lexer.ml" +# 2425 "parsing/lexer.ml" | 14 -> -# 805 "parsing/lexer.mll" +# 804 "parsing/lexer.mll" ( INT (Lexing.lexeme lexbuf, None) ) -# 2431 "parsing/lexer.ml" +# 2430 "parsing/lexer.ml" | 15 -> let -# 806 "parsing/lexer.mll" +# 805 "parsing/lexer.mll" lit -# 2437 "parsing/lexer.ml" +# 2436 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + -1) and -# 806 "parsing/lexer.mll" +# 805 "parsing/lexer.mll" modif -# 2442 "parsing/lexer.ml" +# 2441 "parsing/lexer.ml" = Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_curr_pos + -1) in -# 807 "parsing/lexer.mll" +# 806 "parsing/lexer.mll" ( INT (lit, Some modif) ) -# 2446 "parsing/lexer.ml" +# 2445 "parsing/lexer.ml" | 16 -> -# 809 "parsing/lexer.mll" +# 808 "parsing/lexer.mll" ( FLOAT (Lexing.lexeme lexbuf, None) ) -# 2451 "parsing/lexer.ml" +# 2450 "parsing/lexer.ml" | 17 -> let -# 810 "parsing/lexer.mll" +# 809 "parsing/lexer.mll" lit -# 2457 "parsing/lexer.ml" +# 2456 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos (lexbuf.Lexing.lex_curr_pos + -1) and -# 810 "parsing/lexer.mll" +# 809 "parsing/lexer.mll" modif -# 2462 "parsing/lexer.ml" +# 2461 "parsing/lexer.ml" = Lexing.sub_lexeme_char lexbuf (lexbuf.Lexing.lex_curr_pos + -1) in -# 811 "parsing/lexer.mll" +# 810 "parsing/lexer.mll" ( FLOAT (lit, Some modif) ) -# 2466 "parsing/lexer.ml" +# 2465 "parsing/lexer.ml" | 18 -> -# 813 "parsing/lexer.mll" +# 812 "parsing/lexer.mll" ( raise (Error(Invalid_literal (Lexing.lexeme lexbuf), Location.curr lexbuf)) ) -# 2472 "parsing/lexer.ml" +# 2471 "parsing/lexer.ml" | 19 -> -# 816 "parsing/lexer.mll" +# 815 "parsing/lexer.mll" ( reset_string_buffer(); is_in_string := true; let string_start = lexbuf.lex_start_p in @@ -2480,10 +2479,10 @@ and is_in_string := false; lexbuf.lex_start_p <- string_start; STRING (get_stored_string(), None) ) -# 2484 "parsing/lexer.ml" +# 2483 "parsing/lexer.ml" | 20 -> -# 825 "parsing/lexer.mll" +# 824 "parsing/lexer.mll" ( reset_string_buffer(); let delim = Lexing.lexeme lexbuf in let delim = String.sub delim 1 (String.length delim - 2) in @@ -2494,70 +2493,70 @@ and is_in_string := false; lexbuf.lex_start_p <- string_start; STRING (get_stored_string(), Some delim) ) -# 2498 "parsing/lexer.ml" +# 2497 "parsing/lexer.ml" | 21 -> -# 836 "parsing/lexer.mll" +# 835 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 1; CHAR (Lexing.lexeme_char lexbuf 1) ) -# 2504 "parsing/lexer.ml" +# 2503 "parsing/lexer.ml" | 22 -> -# 839 "parsing/lexer.mll" +# 838 "parsing/lexer.mll" ( CHAR(Lexing.lexeme_char lexbuf 1) ) -# 2509 "parsing/lexer.ml" +# 2508 "parsing/lexer.ml" | 23 -> -# 841 "parsing/lexer.mll" +# 840 "parsing/lexer.mll" ( CHAR(char_for_backslash (Lexing.lexeme_char lexbuf 2)) ) -# 2514 "parsing/lexer.ml" +# 2513 "parsing/lexer.ml" | 24 -> -# 843 "parsing/lexer.mll" +# 842 "parsing/lexer.mll" ( CHAR(char_for_decimal_code lexbuf 2) ) -# 2519 "parsing/lexer.ml" +# 2518 "parsing/lexer.ml" | 25 -> -# 845 "parsing/lexer.mll" +# 844 "parsing/lexer.mll" ( CHAR(char_for_octal_code lexbuf 3) ) -# 2524 "parsing/lexer.ml" +# 2523 "parsing/lexer.ml" | 26 -> -# 847 "parsing/lexer.mll" +# 846 "parsing/lexer.mll" ( CHAR(char_for_hexadecimal_code lexbuf 3) ) -# 2529 "parsing/lexer.ml" +# 2528 "parsing/lexer.ml" | 27 -> -# 849 "parsing/lexer.mll" +# 848 "parsing/lexer.mll" ( let l = Lexing.lexeme lexbuf in let esc = String.sub l 1 (String.length l - 1) in raise (Error(Illegal_escape esc, Location.curr lexbuf)) ) -# 2537 "parsing/lexer.ml" +# 2536 "parsing/lexer.ml" | 28 -> -# 854 "parsing/lexer.mll" +# 853 "parsing/lexer.mll" ( let s, loc = with_comment_buffer comment lexbuf in COMMENT (s, loc) ) -# 2543 "parsing/lexer.ml" +# 2542 "parsing/lexer.ml" | 29 -> -# 857 "parsing/lexer.mll" +# 856 "parsing/lexer.mll" ( let s, loc = with_comment_buffer comment lexbuf in if !handle_docstrings then DOCSTRING (Docstrings.docstring s loc) else COMMENT ("*" ^ s, loc) ) -# 2553 "parsing/lexer.ml" +# 2552 "parsing/lexer.ml" | 30 -> let -# 863 "parsing/lexer.mll" +# 862 "parsing/lexer.mll" stars -# 2559 "parsing/lexer.ml" +# 2558 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 3) lexbuf.Lexing.lex_curr_pos in -# 864 "parsing/lexer.mll" +# 863 "parsing/lexer.mll" ( let s, loc = with_comment_buffer (fun lexbuf -> @@ -2566,32 +2565,32 @@ let lexbuf in COMMENT (s, loc) ) -# 2570 "parsing/lexer.ml" +# 2569 "parsing/lexer.ml" | 31 -> -# 873 "parsing/lexer.mll" +# 872 "parsing/lexer.mll" ( if !print_warnings then Location.prerr_warning (Location.curr lexbuf) Warnings.Comment_start; let s, loc = with_comment_buffer comment lexbuf in COMMENT (s, loc) ) -# 2578 "parsing/lexer.ml" +# 2577 "parsing/lexer.ml" | 32 -> let -# 877 "parsing/lexer.mll" +# 876 "parsing/lexer.mll" stars -# 2584 "parsing/lexer.ml" +# 2583 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 2) (lexbuf.Lexing.lex_curr_pos + -2) in -# 878 "parsing/lexer.mll" +# 877 "parsing/lexer.mll" ( if !handle_docstrings && stars="" then (* (**) is an empty docstring *) DOCSTRING(Docstrings.docstring "" (Location.curr lexbuf)) else COMMENT (stars, Location.curr lexbuf) ) -# 2592 "parsing/lexer.ml" +# 2591 "parsing/lexer.ml" | 33 -> -# 884 "parsing/lexer.mll" +# 883 "parsing/lexer.mll" ( let loc = Location.curr lexbuf in Location.prerr_warning loc Warnings.Comment_not_end; lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_curr_pos - 1; @@ -2599,25 +2598,25 @@ let lexbuf.lex_curr_p <- { curpos with pos_cnum = curpos.pos_cnum - 1 }; STAR ) -# 2603 "parsing/lexer.ml" +# 2602 "parsing/lexer.ml" | 34 -> let -# 891 "parsing/lexer.mll" +# 890 "parsing/lexer.mll" num -# 2609 "parsing/lexer.ml" +# 2608 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_mem.(1) and -# 892 "parsing/lexer.mll" +# 891 "parsing/lexer.mll" name -# 2614 "parsing/lexer.ml" +# 2613 "parsing/lexer.ml" = Lexing.sub_lexeme_opt lexbuf lexbuf.Lexing.lex_mem.(4) lexbuf.Lexing.lex_mem.(3) and -# 892 "parsing/lexer.mll" +# 891 "parsing/lexer.mll" directive -# 2619 "parsing/lexer.ml" +# 2618 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_start_pos lexbuf.Lexing.lex_mem.(2) in -# 894 "parsing/lexer.mll" +# 893 "parsing/lexer.mll" ( match int_of_string num with | exception _ -> @@ -2633,300 +2632,300 @@ and update_loc lexbuf name line_num true 0; token lexbuf ) -# 2637 "parsing/lexer.ml" +# 2636 "parsing/lexer.ml" | 35 -> -# 909 "parsing/lexer.mll" +# 908 "parsing/lexer.mll" ( HASH ) -# 2642 "parsing/lexer.ml" +# 2641 "parsing/lexer.ml" | 36 -> -# 910 "parsing/lexer.mll" +# 909 "parsing/lexer.mll" ( AMPERSAND ) -# 2647 "parsing/lexer.ml" +# 2646 "parsing/lexer.ml" | 37 -> -# 911 "parsing/lexer.mll" +# 910 "parsing/lexer.mll" ( AMPERAMPER ) -# 2652 "parsing/lexer.ml" +# 2651 "parsing/lexer.ml" | 38 -> -# 912 "parsing/lexer.mll" +# 911 "parsing/lexer.mll" ( BACKQUOTE ) -# 2657 "parsing/lexer.ml" +# 2656 "parsing/lexer.ml" | 39 -> -# 913 "parsing/lexer.mll" +# 912 "parsing/lexer.mll" ( QUOTE ) -# 2662 "parsing/lexer.ml" +# 2661 "parsing/lexer.ml" | 40 -> -# 914 "parsing/lexer.mll" +# 913 "parsing/lexer.mll" ( LPAREN ) -# 2667 "parsing/lexer.ml" +# 2666 "parsing/lexer.ml" | 41 -> -# 915 "parsing/lexer.mll" +# 914 "parsing/lexer.mll" ( RPAREN ) -# 2672 "parsing/lexer.ml" +# 2671 "parsing/lexer.ml" | 42 -> -# 916 "parsing/lexer.mll" +# 915 "parsing/lexer.mll" ( STAR ) -# 2677 "parsing/lexer.ml" +# 2676 "parsing/lexer.ml" | 43 -> -# 917 "parsing/lexer.mll" +# 916 "parsing/lexer.mll" ( COMMA ) -# 2682 "parsing/lexer.ml" +# 2681 "parsing/lexer.ml" | 44 -> -# 918 "parsing/lexer.mll" +# 917 "parsing/lexer.mll" ( MINUSGREATER ) -# 2687 "parsing/lexer.ml" +# 2686 "parsing/lexer.ml" | 45 -> -# 919 "parsing/lexer.mll" +# 918 "parsing/lexer.mll" ( DOT ) -# 2692 "parsing/lexer.ml" +# 2691 "parsing/lexer.ml" | 46 -> -# 920 "parsing/lexer.mll" +# 919 "parsing/lexer.mll" ( DOTDOT ) -# 2697 "parsing/lexer.ml" +# 2696 "parsing/lexer.ml" | 47 -> let -# 921 "parsing/lexer.mll" +# 920 "parsing/lexer.mll" s -# 2703 "parsing/lexer.ml" +# 2702 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf (lexbuf.Lexing.lex_start_pos + 1) lexbuf.Lexing.lex_curr_pos in -# 921 "parsing/lexer.mll" +# 920 "parsing/lexer.mll" ( DOTOP s ) -# 2707 "parsing/lexer.ml" +# 2706 "parsing/lexer.ml" | 48 -> -# 922 "parsing/lexer.mll" +# 921 "parsing/lexer.mll" ( COLON ) -# 2712 "parsing/lexer.ml" +# 2711 "parsing/lexer.ml" | 49 -> -# 923 "parsing/lexer.mll" +# 922 "parsing/lexer.mll" ( COLONCOLON ) -# 2717 "parsing/lexer.ml" +# 2716 "parsing/lexer.ml" | 50 -> -# 924 "parsing/lexer.mll" +# 923 "parsing/lexer.mll" ( COLONEQUAL ) -# 2722 "parsing/lexer.ml" +# 2721 "parsing/lexer.ml" | 51 -> -# 925 "parsing/lexer.mll" +# 924 "parsing/lexer.mll" ( COLONGREATER ) -# 2727 "parsing/lexer.ml" +# 2726 "parsing/lexer.ml" | 52 -> -# 926 "parsing/lexer.mll" +# 925 "parsing/lexer.mll" ( SEMI ) -# 2732 "parsing/lexer.ml" +# 2731 "parsing/lexer.ml" | 53 -> -# 927 "parsing/lexer.mll" +# 926 "parsing/lexer.mll" ( SEMISEMI ) -# 2737 "parsing/lexer.ml" +# 2736 "parsing/lexer.ml" | 54 -> -# 928 "parsing/lexer.mll" +# 927 "parsing/lexer.mll" ( LESS ) -# 2742 "parsing/lexer.ml" +# 2741 "parsing/lexer.ml" | 55 -> -# 929 "parsing/lexer.mll" +# 928 "parsing/lexer.mll" ( LESSMINUS ) -# 2747 "parsing/lexer.ml" +# 2746 "parsing/lexer.ml" | 56 -> -# 930 "parsing/lexer.mll" +# 929 "parsing/lexer.mll" ( EQUAL ) -# 2752 "parsing/lexer.ml" +# 2751 "parsing/lexer.ml" | 57 -> -# 931 "parsing/lexer.mll" +# 930 "parsing/lexer.mll" ( LBRACKET ) -# 2757 "parsing/lexer.ml" +# 2756 "parsing/lexer.ml" | 58 -> -# 932 "parsing/lexer.mll" +# 931 "parsing/lexer.mll" ( LBRACKETBAR ) -# 2762 "parsing/lexer.ml" +# 2761 "parsing/lexer.ml" | 59 -> -# 933 "parsing/lexer.mll" +# 932 "parsing/lexer.mll" ( LBRACKETLESS ) -# 2767 "parsing/lexer.ml" +# 2766 "parsing/lexer.ml" | 60 -> -# 934 "parsing/lexer.mll" +# 933 "parsing/lexer.mll" ( LBRACKETGREATER ) -# 2772 "parsing/lexer.ml" +# 2771 "parsing/lexer.ml" | 61 -> -# 935 "parsing/lexer.mll" +# 934 "parsing/lexer.mll" ( RBRACKET ) -# 2777 "parsing/lexer.ml" +# 2776 "parsing/lexer.ml" | 62 -> -# 936 "parsing/lexer.mll" +# 935 "parsing/lexer.mll" ( LBRACE ) -# 2782 "parsing/lexer.ml" +# 2781 "parsing/lexer.ml" | 63 -> -# 937 "parsing/lexer.mll" +# 936 "parsing/lexer.mll" ( LBRACELESS ) -# 2787 "parsing/lexer.ml" +# 2786 "parsing/lexer.ml" | 64 -> -# 938 "parsing/lexer.mll" +# 937 "parsing/lexer.mll" ( BAR ) -# 2792 "parsing/lexer.ml" +# 2791 "parsing/lexer.ml" | 65 -> -# 939 "parsing/lexer.mll" +# 938 "parsing/lexer.mll" ( BARBAR ) -# 2797 "parsing/lexer.ml" +# 2796 "parsing/lexer.ml" | 66 -> -# 940 "parsing/lexer.mll" +# 939 "parsing/lexer.mll" ( BARRBRACKET ) -# 2802 "parsing/lexer.ml" +# 2801 "parsing/lexer.ml" | 67 -> -# 941 "parsing/lexer.mll" +# 940 "parsing/lexer.mll" ( GREATER ) -# 2807 "parsing/lexer.ml" +# 2806 "parsing/lexer.ml" | 68 -> -# 942 "parsing/lexer.mll" +# 941 "parsing/lexer.mll" ( GREATERRBRACKET ) -# 2812 "parsing/lexer.ml" +# 2811 "parsing/lexer.ml" | 69 -> -# 943 "parsing/lexer.mll" +# 942 "parsing/lexer.mll" ( RBRACE ) -# 2817 "parsing/lexer.ml" +# 2816 "parsing/lexer.ml" | 70 -> -# 944 "parsing/lexer.mll" +# 943 "parsing/lexer.mll" ( GREATERRBRACE ) -# 2822 "parsing/lexer.ml" +# 2821 "parsing/lexer.ml" | 71 -> -# 945 "parsing/lexer.mll" +# 944 "parsing/lexer.mll" ( LBRACKETAT ) -# 2827 "parsing/lexer.ml" +# 2826 "parsing/lexer.ml" | 72 -> -# 946 "parsing/lexer.mll" +# 945 "parsing/lexer.mll" ( LBRACKETATAT ) -# 2832 "parsing/lexer.ml" +# 2831 "parsing/lexer.ml" | 73 -> -# 947 "parsing/lexer.mll" +# 946 "parsing/lexer.mll" ( LBRACKETATATAT ) -# 2837 "parsing/lexer.ml" +# 2836 "parsing/lexer.ml" | 74 -> -# 948 "parsing/lexer.mll" +# 947 "parsing/lexer.mll" ( LBRACKETPERCENT ) -# 2842 "parsing/lexer.ml" +# 2841 "parsing/lexer.ml" | 75 -> -# 949 "parsing/lexer.mll" +# 948 "parsing/lexer.mll" ( LBRACKETPERCENTPERCENT ) -# 2847 "parsing/lexer.ml" +# 2846 "parsing/lexer.ml" | 76 -> -# 950 "parsing/lexer.mll" +# 949 "parsing/lexer.mll" ( BANG ) -# 2852 "parsing/lexer.ml" +# 2851 "parsing/lexer.ml" | 77 -> -# 951 "parsing/lexer.mll" +# 950 "parsing/lexer.mll" ( INFIXOP0 "!=" ) -# 2857 "parsing/lexer.ml" +# 2856 "parsing/lexer.ml" | 78 -> -# 952 "parsing/lexer.mll" +# 951 "parsing/lexer.mll" ( PLUS ) -# 2862 "parsing/lexer.ml" +# 2861 "parsing/lexer.ml" | 79 -> -# 953 "parsing/lexer.mll" +# 952 "parsing/lexer.mll" ( PLUSDOT ) -# 2867 "parsing/lexer.ml" +# 2866 "parsing/lexer.ml" | 80 -> -# 954 "parsing/lexer.mll" +# 953 "parsing/lexer.mll" ( PLUSEQ ) -# 2872 "parsing/lexer.ml" +# 2871 "parsing/lexer.ml" | 81 -> -# 955 "parsing/lexer.mll" +# 954 "parsing/lexer.mll" ( MINUS ) -# 2877 "parsing/lexer.ml" +# 2876 "parsing/lexer.ml" | 82 -> -# 956 "parsing/lexer.mll" +# 955 "parsing/lexer.mll" ( MINUSDOT ) -# 2882 "parsing/lexer.ml" +# 2881 "parsing/lexer.ml" | 83 -> -# 959 "parsing/lexer.mll" +# 958 "parsing/lexer.mll" ( PREFIXOP(Lexing.lexeme lexbuf) ) -# 2887 "parsing/lexer.ml" +# 2886 "parsing/lexer.ml" | 84 -> -# 961 "parsing/lexer.mll" +# 960 "parsing/lexer.mll" ( PREFIXOP(Lexing.lexeme lexbuf) ) -# 2892 "parsing/lexer.ml" +# 2891 "parsing/lexer.ml" | 85 -> -# 963 "parsing/lexer.mll" +# 962 "parsing/lexer.mll" ( INFIXOP0(Lexing.lexeme lexbuf) ) -# 2897 "parsing/lexer.ml" +# 2896 "parsing/lexer.ml" | 86 -> -# 965 "parsing/lexer.mll" +# 964 "parsing/lexer.mll" ( INFIXOP1(Lexing.lexeme lexbuf) ) -# 2902 "parsing/lexer.ml" +# 2901 "parsing/lexer.ml" | 87 -> -# 967 "parsing/lexer.mll" +# 966 "parsing/lexer.mll" ( INFIXOP2(Lexing.lexeme lexbuf) ) -# 2907 "parsing/lexer.ml" +# 2906 "parsing/lexer.ml" | 88 -> -# 969 "parsing/lexer.mll" +# 968 "parsing/lexer.mll" ( INFIXOP4(Lexing.lexeme lexbuf) ) -# 2912 "parsing/lexer.ml" +# 2911 "parsing/lexer.ml" | 89 -> -# 970 "parsing/lexer.mll" +# 969 "parsing/lexer.mll" ( PERCENT ) -# 2917 "parsing/lexer.ml" +# 2916 "parsing/lexer.ml" | 90 -> -# 972 "parsing/lexer.mll" +# 971 "parsing/lexer.mll" ( INFIXOP3(Lexing.lexeme lexbuf) ) -# 2922 "parsing/lexer.ml" +# 2921 "parsing/lexer.ml" | 91 -> -# 974 "parsing/lexer.mll" +# 973 "parsing/lexer.mll" ( HASHOP(Lexing.lexeme lexbuf) ) -# 2927 "parsing/lexer.ml" +# 2926 "parsing/lexer.ml" | 92 -> -# 975 "parsing/lexer.mll" +# 974 "parsing/lexer.mll" ( if !if_then_else <> Dir_out then if !if_then_else = Dir_if_true then @@ -2936,14 +2935,14 @@ let EOF ) -# 2940 "parsing/lexer.ml" +# 2939 "parsing/lexer.ml" | 93 -> -# 985 "parsing/lexer.mll" +# 984 "parsing/lexer.mll" ( raise (Error(Illegal_character (Lexing.lexeme_char lexbuf 0), Location.curr lexbuf)) ) -# 2947 "parsing/lexer.ml" +# 2946 "parsing/lexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_token_rec lexbuf __ocaml_lex_state @@ -2953,15 +2952,15 @@ and comment lexbuf = and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> -# 991 "parsing/lexer.mll" +# 990 "parsing/lexer.mll" ( comment_start_loc := (Location.curr lexbuf) :: !comment_start_loc; store_lexeme lexbuf; comment lexbuf ) -# 2962 "parsing/lexer.ml" +# 2961 "parsing/lexer.ml" | 1 -> -# 996 "parsing/lexer.mll" +# 995 "parsing/lexer.mll" ( match !comment_start_loc with | [] -> assert false | [_] -> comment_start_loc := []; Location.curr lexbuf @@ -2969,10 +2968,10 @@ and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = store_lexeme lexbuf; comment lexbuf ) -# 2973 "parsing/lexer.ml" +# 2972 "parsing/lexer.ml" | 2 -> -# 1004 "parsing/lexer.mll" +# 1003 "parsing/lexer.mll" ( string_start_loc := Location.curr lexbuf; store_string_char '\"'; @@ -2990,10 +2989,10 @@ and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = is_in_string := false; store_string_char '\"'; comment lexbuf ) -# 2994 "parsing/lexer.ml" +# 2993 "parsing/lexer.ml" | 3 -> -# 1022 "parsing/lexer.mll" +# 1021 "parsing/lexer.mll" ( let delim = Lexing.lexeme lexbuf in let delim = String.sub delim 1 (String.length delim - 2) in @@ -3015,43 +3014,43 @@ and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = store_string delim; store_string_char '}'; comment lexbuf ) -# 3019 "parsing/lexer.ml" +# 3018 "parsing/lexer.ml" | 4 -> -# 1045 "parsing/lexer.mll" +# 1044 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3024 "parsing/lexer.ml" +# 3023 "parsing/lexer.ml" | 5 -> -# 1047 "parsing/lexer.mll" +# 1046 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 1; store_lexeme lexbuf; comment lexbuf ) -# 3032 "parsing/lexer.ml" +# 3031 "parsing/lexer.ml" | 6 -> -# 1052 "parsing/lexer.mll" +# 1051 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3037 "parsing/lexer.ml" +# 3036 "parsing/lexer.ml" | 7 -> -# 1054 "parsing/lexer.mll" +# 1053 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3042 "parsing/lexer.ml" +# 3041 "parsing/lexer.ml" | 8 -> -# 1056 "parsing/lexer.mll" +# 1055 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3047 "parsing/lexer.ml" +# 3046 "parsing/lexer.ml" | 9 -> -# 1058 "parsing/lexer.mll" +# 1057 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3052 "parsing/lexer.ml" +# 3051 "parsing/lexer.ml" | 10 -> -# 1060 "parsing/lexer.mll" +# 1059 "parsing/lexer.mll" ( match !comment_start_loc with | [] -> assert false | loc :: _ -> @@ -3059,20 +3058,20 @@ and __ocaml_lex_comment_rec lexbuf __ocaml_lex_state = comment_start_loc := []; raise (Error (Unterminated_comment start, loc)) ) -# 3063 "parsing/lexer.ml" +# 3062 "parsing/lexer.ml" | 11 -> -# 1068 "parsing/lexer.mll" +# 1067 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 0; store_lexeme lexbuf; comment lexbuf ) -# 3071 "parsing/lexer.ml" +# 3070 "parsing/lexer.ml" | 12 -> -# 1073 "parsing/lexer.mll" +# 1072 "parsing/lexer.mll" ( store_lexeme lexbuf; comment lexbuf ) -# 3076 "parsing/lexer.ml" +# 3075 "parsing/lexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_comment_rec lexbuf __ocaml_lex_state @@ -3082,56 +3081,56 @@ and string lexbuf = and __ocaml_lex_string_rec lexbuf __ocaml_lex_state = match Lexing.new_engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> -# 1077 "parsing/lexer.mll" +# 1076 "parsing/lexer.mll" ( () ) -# 3088 "parsing/lexer.ml" +# 3087 "parsing/lexer.ml" | 1 -> let -# 1078 "parsing/lexer.mll" +# 1077 "parsing/lexer.mll" space -# 3094 "parsing/lexer.ml" +# 3093 "parsing/lexer.ml" = Lexing.sub_lexeme lexbuf lexbuf.Lexing.lex_mem.(0) lexbuf.Lexing.lex_curr_pos in -# 1079 "parsing/lexer.mll" +# 1078 "parsing/lexer.mll" ( update_loc lexbuf None 1 false (String.length space); if in_comment () then store_lexeme lexbuf; string lexbuf ) -# 3101 "parsing/lexer.ml" +# 3100 "parsing/lexer.ml" | 2 -> -# 1084 "parsing/lexer.mll" +# 1083 "parsing/lexer.mll" ( store_escaped_char lexbuf (char_for_backslash(Lexing.lexeme_char lexbuf 1)); string lexbuf ) -# 3108 "parsing/lexer.ml" +# 3107 "parsing/lexer.ml" | 3 -> -# 1088 "parsing/lexer.mll" +# 1087 "parsing/lexer.mll" ( store_escaped_char lexbuf (char_for_decimal_code lexbuf 1); string lexbuf ) -# 3114 "parsing/lexer.ml" +# 3113 "parsing/lexer.ml" | 4 -> -# 1091 "parsing/lexer.mll" +# 1090 "parsing/lexer.mll" ( store_escaped_char lexbuf (char_for_octal_code lexbuf 2); string lexbuf ) -# 3120 "parsing/lexer.ml" +# 3119 "parsing/lexer.ml" | 5 -> -# 1094 "parsing/lexer.mll" +# 1093 "parsing/lexer.mll" ( store_escaped_char lexbuf (char_for_hexadecimal_code lexbuf 2); string lexbuf ) -# 3126 "parsing/lexer.ml" +# 3125 "parsing/lexer.ml" | 6 -> -# 1097 "parsing/lexer.mll" +# 1096 "parsing/lexer.mll" ( store_escaped_uchar lexbuf (uchar_for_uchar_escape lexbuf); string lexbuf ) -# 3132 "parsing/lexer.ml" +# 3131 "parsing/lexer.ml" | 7 -> -# 1100 "parsing/lexer.mll" +# 1099 "parsing/lexer.mll" ( if not (in_comment ()) then begin (* Should be an error, but we are very lax. raise (Error (Illegal_escape (Lexing.lexeme lexbuf), @@ -3143,29 +3142,29 @@ let store_lexeme lexbuf; string lexbuf ) -# 3147 "parsing/lexer.ml" +# 3146 "parsing/lexer.ml" | 8 -> -# 1112 "parsing/lexer.mll" +# 1111 "parsing/lexer.mll" ( if not (in_comment ()) then Location.prerr_warning (Location.curr lexbuf) Warnings.Eol_in_string; update_loc lexbuf None 1 false 0; store_lexeme lexbuf; string lexbuf ) -# 3157 "parsing/lexer.ml" +# 3156 "parsing/lexer.ml" | 9 -> -# 1119 "parsing/lexer.mll" +# 1118 "parsing/lexer.mll" ( is_in_string := false; raise (Error (Unterminated_string, !string_start_loc)) ) -# 3163 "parsing/lexer.ml" +# 3162 "parsing/lexer.ml" | 10 -> -# 1122 "parsing/lexer.mll" +# 1121 "parsing/lexer.mll" ( store_string_char(Lexing.lexeme_char lexbuf 0); string lexbuf ) -# 3169 "parsing/lexer.ml" +# 3168 "parsing/lexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_string_rec lexbuf __ocaml_lex_state @@ -3175,34 +3174,34 @@ and quoted_string delim lexbuf = and __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> -# 1127 "parsing/lexer.mll" +# 1126 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 0; store_lexeme lexbuf; quoted_string delim lexbuf ) -# 3184 "parsing/lexer.ml" +# 3183 "parsing/lexer.ml" | 1 -> -# 1132 "parsing/lexer.mll" +# 1131 "parsing/lexer.mll" ( is_in_string := false; raise (Error (Unterminated_string, !string_start_loc)) ) -# 3190 "parsing/lexer.ml" +# 3189 "parsing/lexer.ml" | 2 -> -# 1135 "parsing/lexer.mll" +# 1134 "parsing/lexer.mll" ( let edelim = Lexing.lexeme lexbuf in let edelim = String.sub edelim 1 (String.length edelim - 2) in if delim = edelim then () else (store_lexeme lexbuf; quoted_string delim lexbuf) ) -# 3200 "parsing/lexer.ml" +# 3199 "parsing/lexer.ml" | 3 -> -# 1142 "parsing/lexer.mll" +# 1141 "parsing/lexer.mll" ( store_string_char(Lexing.lexeme_char lexbuf 0); quoted_string delim lexbuf ) -# 3206 "parsing/lexer.ml" +# 3205 "parsing/lexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_quoted_string_rec delim lexbuf __ocaml_lex_state @@ -3212,26 +3211,26 @@ and skip_hash_bang lexbuf = and __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state = match Lexing.engine __ocaml_lex_tables __ocaml_lex_state lexbuf with | 0 -> -# 1147 "parsing/lexer.mll" +# 1146 "parsing/lexer.mll" ( update_loc lexbuf None 3 false 0 ) -# 3218 "parsing/lexer.ml" +# 3217 "parsing/lexer.ml" | 1 -> -# 1149 "parsing/lexer.mll" +# 1148 "parsing/lexer.mll" ( update_loc lexbuf None 1 false 0 ) -# 3223 "parsing/lexer.ml" +# 3222 "parsing/lexer.ml" | 2 -> -# 1150 "parsing/lexer.mll" +# 1149 "parsing/lexer.mll" ( () ) -# 3228 "parsing/lexer.ml" +# 3227 "parsing/lexer.ml" | __ocaml_lex_state -> lexbuf.Lexing.refill_buff lexbuf; __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state ;; -# 1152 "parsing/lexer.mll" +# 1151 "parsing/lexer.mll" let at_bol lexbuf = let pos = Lexing.lexeme_start_p lexbuf in @@ -3463,4 +3462,4 @@ and __ocaml_lex_skip_hash_bang_rec lexbuf __ocaml_lex_state = preprocessor := Some (init, preprocess) -# 3467 "parsing/lexer.ml" +# 3466 "parsing/lexer.ml" diff --git a/parsing/lexer.mli b/parsing/lexer.mli index 1d284a63da29..16da20297802 100644 --- a/parsing/lexer.mli +++ b/parsing/lexer.mli @@ -42,10 +42,7 @@ type error = exception Error of error * Location.t -open Format -val report_error: formatter -> error -> unit - (* Deprecated. Use Location.{error_of_exn, report_error}. *) val in_comment : unit -> bool;; val in_string : unit -> bool;; diff --git a/parsing/location.ml b/parsing/location.ml index fc668c4c7cef..d8de6003f524 100644 --- a/parsing/location.ml +++ b/parsing/location.ml @@ -72,153 +72,9 @@ let set_input_name name = if name <> "" then input_name := name (* Terminal info *) -let status = ref Terminfo.Uninitialised -let num_loc_lines = ref 0 (* number of lines already printed after input *) -let print_updating_num_loc_lines ppf f arg = - let open Format in - let out_functions = pp_get_formatter_out_functions ppf () in - let out_string str start len = - let rec count i c = - if i = start + len then c - else if String.get str i = '\n' then count (succ i) (succ c) - else count (succ i) c in - num_loc_lines := !num_loc_lines + count start 0 ; - out_functions.out_string str start len in - pp_set_formatter_out_functions ppf - { out_functions with out_string } ; - f ppf arg ; - pp_print_flush ppf (); - pp_set_formatter_out_functions ppf out_functions - -(* Highlight the locations using standout mode. *) - -let highlight_terminfo ppf num_lines lb locs = - Format.pp_print_flush ppf (); (* avoid mixing Format and normal output *) - (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) - let pos0 = -lb.lex_abs_pos in - (* Do nothing if the buffer does not contain the whole phrase. *) - if pos0 < 0 then raise Exit; - (* Count number of lines in phrase *) - let lines = ref !num_loc_lines in - for i = pos0 to lb.lex_buffer_len - 1 do - if Bytes.get lb.lex_buffer i = '\n' then incr lines - done; - (* If too many lines, give up *) - if !lines >= num_lines - 2 then raise Exit; - (* Move cursor up that number of lines *) - flush stdout; Terminfo.backup !lines; - (* Print the input, switching to standout for the location *) - let bol = ref false in - print_string "# "; - for pos = 0 to lb.lex_buffer_len - pos0 - 1 do - if !bol then (print_string " "; bol := false); - if List.exists (fun loc -> pos = loc.loc_start.pos_cnum) locs then - Terminfo.standout true; - if List.exists (fun loc -> pos = loc.loc_end.pos_cnum) locs then - Terminfo.standout false; - let c = Bytes.get lb.lex_buffer (pos + pos0) in - print_char c; - bol := (c = '\n') - done; - (* Make sure standout mode is over *) - Terminfo.standout false; - (* Position cursor back to original location *) - Terminfo.resume !num_loc_lines; - flush stdout - -(* Highlight the location by printing it again. *) - -let highlight_dumb ppf lb loc = - (* Char 0 is at offset -lb.lex_abs_pos in lb.lex_buffer. *) - let pos0 = -lb.lex_abs_pos in - (* Do nothing if the buffer does not contain the whole phrase. *) - if pos0 < 0 then raise Exit; - let end_pos = lb.lex_buffer_len - pos0 - 1 in - (* Determine line numbers for the start and end points *) - let line_start = ref 0 and line_end = ref 0 in - for pos = 0 to end_pos do - if Bytes.get lb.lex_buffer (pos + pos0) = '\n' then begin - if loc.loc_start.pos_cnum > pos then incr line_start; - if loc.loc_end.pos_cnum > pos then incr line_end; - end - done; - (* Print character location (useful for Emacs) *) - Format.fprintf ppf "@[Characters %i-%i:@," - loc.loc_start.pos_cnum loc.loc_end.pos_cnum; - (* Print the input, underlining the location *) - Format.pp_print_string ppf " "; - let line = ref 0 in - let pos_at_bol = ref 0 in - for pos = 0 to end_pos do - match Bytes.get lb.lex_buffer (pos + pos0) with - | '\n' -> - if !line = !line_start && !line = !line_end then begin - (* loc is on one line: underline location *) - Format.fprintf ppf "@, "; - for _i = !pos_at_bol to loc.loc_start.pos_cnum - 1 do - Format.pp_print_char ppf ' ' - done; - for _i = loc.loc_start.pos_cnum to loc.loc_end.pos_cnum - 1 do - Format.pp_print_char ppf '^' - done - end; - if !line >= !line_start && !line <= !line_end then begin - Format.fprintf ppf "@,"; - if pos < loc.loc_end.pos_cnum then Format.pp_print_string ppf " " - end; - incr line; - pos_at_bol := pos + 1 - | '\r' -> () (* discard *) - | c -> - if !line = !line_start && !line = !line_end then - (* loc is on one line: print whole line *) - Format.pp_print_char ppf c - else if !line = !line_start then - (* first line of multiline loc: - print a dot for each char before loc_start *) - if pos < loc.loc_start.pos_cnum then - Format.pp_print_char ppf '.' - else - Format.pp_print_char ppf c - else if !line = !line_end then - (* last line of multiline loc: print a dot for each char - after loc_end, even whitespaces *) - if pos < loc.loc_end.pos_cnum then - Format.pp_print_char ppf c - else - Format.pp_print_char ppf '.' - else if !line > !line_start && !line < !line_end then - (* intermediate line of multiline loc: print whole line *) - Format.pp_print_char ppf c - done; - Format.fprintf ppf "@]" - -(* Highlight the location using one of the supported modes. *) - -let rec highlight_locations ppf locs = - match !status with - Terminfo.Uninitialised -> - status := Terminfo.setup stdout; highlight_locations ppf locs - | Terminfo.Bad_term -> - begin match !input_lexbuf with - None -> false - | Some lb -> - let norepeat = - try Sys.getenv "TERM" = "norepeat" with Not_found -> false in - if norepeat then false else - let loc1 = List.hd locs in - try highlight_dumb ppf lb loc1; true - with Exit -> false - end - | Terminfo.Good_term num_lines -> - begin match !input_lexbuf with - None -> false - | Some lb -> - try highlight_terminfo ppf num_lines lb locs; true - with Exit -> false - end +let num_loc_lines = ref 0 (* number of lines already printed after input *) (* Print the location in some way or another *) @@ -262,13 +118,15 @@ let setup_colors () = let print_loc ppf loc = setup_colors (); let (file, line, startchar) = get_pos_info loc.loc_start in -#if undefined BS_NO_COMPILER_PATCH then +#if true then let startchar = if Clflags.bs_vscode then startchar + 1 else startchar in #end let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in if file = "//toplevel//" then begin +#if false then if highlight_locations ppf [loc] then () else +#end fprintf ppf "Characters %i-%i" loc.loc_start.pos_cnum loc.loc_end.pos_cnum end else begin @@ -281,9 +139,12 @@ let print_loc ppf loc = let default_printer ppf loc = setup_colors (); +#if false then if loc.loc_start.pos_fname = "//toplevel//" - && highlight_locations ppf [loc] then () - else fprintf ppf "@{%a@}%s@," print_loc loc msg_colon + && highlight_locations ppf [loc] then () + else +#end + fprintf ppf "@{%a@}%s@," print_loc loc msg_colon ;; let printer = ref default_printer @@ -298,9 +159,12 @@ let print_error_prefix ppf = ;; let print_compact ppf loc = +#if false then if loc.loc_start.pos_fname = "//toplevel//" && highlight_locations ppf [loc] then () - else begin + else +#end + begin let (file, line, startchar) = get_pos_info loc.loc_start in let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in fprintf ppf "%a:%i" print_filename file line; @@ -336,8 +200,8 @@ let default_warning_printer loc ppf w = let warning_printer = ref default_warning_printer ;; -let print_warning loc ppf w = - print_updating_num_loc_lines ppf (!warning_printer loc) w +let print_warning loc ppf w = + !warning_printer loc ppf w ;; let formatter_for_warnings = ref err_formatter;; @@ -413,29 +277,16 @@ let error_of_exn exn = in loop !error_of_exn -let rec default_error_reporter ppf ({loc; msg; sub; if_highlight} as err) = - let highlighted = - if if_highlight <> "" && loc.loc_start.pos_fname = "//toplevel//" then - let rec collect_locs locs {loc; sub; _} = - List.fold_left collect_locs (loc :: locs) sub - in - let locs = collect_locs [] err in - highlight_locations ppf locs - else - false - in - if highlighted then - Format.pp_print_string ppf if_highlight - else begin + +let rec default_error_reporter ppf ({loc; msg; sub}) = fprintf ppf "@[%a %s" print_error loc msg; List.iter (Format.fprintf ppf "@,@[<2>%a@]" default_error_reporter) sub; fprintf ppf "@]" - end - + let error_reporter = ref default_error_reporter let report_error ppf err = - print_updating_num_loc_lines ppf !error_reporter err + !error_reporter ppf err ;; let error_of_printer loc print x = diff --git a/parsing/location.mli b/parsing/location.mli index f4bc64e0f43d..4c1aab735050 100644 --- a/parsing/location.mli +++ b/parsing/location.mli @@ -58,8 +58,10 @@ val get_pos_info: Lexing.position -> string * int * int (* file, line, char *) val print_loc: formatter -> t -> unit val print_error: formatter -> t -> unit val print_error_cur_file: formatter -> unit -> unit +#if undefined BS_ONLY then (* Not using below APIs in ReScript *) val print_warning: t -> formatter -> Warnings.t -> unit val formatter_for_warnings : formatter ref +#end val prerr_warning: t -> Warnings.t -> unit val echo_eof: unit -> unit val reset: unit -> unit @@ -73,8 +75,6 @@ val warning_printer : (t -> formatter -> Warnings.t -> unit) ref val default_warning_printer : t -> formatter -> Warnings.t -> unit (** Original warning printer for use in hooks. *) -val highlight_locations: formatter -> t list -> bool - type 'a loc = { txt : 'a; loc : t; @@ -111,7 +111,7 @@ exception Error of error val error: ?loc:t -> ?sub:error list -> ?if_highlight:string -> string -> error -#if undefined BS_NO_COMPILER_PATCH then +#if true then val print_error_prefix : Format.formatter -> unit val pp_ksprintf : ?before:(formatter -> unit) -> (string -> 'a) -> ('b, formatter, unit, 'a) format4 -> 'b #end diff --git a/typing/ctype.ml b/typing/ctype.ml index df46de1f6763..357aaa981d84 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -397,10 +397,11 @@ let rec class_type_arity = (*******************************************) (* Miscellaneous operations on row types *) (*******************************************) +type row_fields = (Asttypes.label * Types.row_field) list +type row_pairs = (Asttypes.label * Types.row_field * Types.row_field) list +let sort_row_fields : row_fields -> row_fields = List.sort (fun (p,_) (q,_) -> compare (p : string) q) -let sort_row_fields = List.sort (fun (p,_) (q,_) -> compare p q) - -let rec merge_rf r1 r2 pairs fi1 fi2 = +let rec merge_rf (r1 : row_fields) (r2 : row_fields) (pairs : row_pairs) (fi1 : row_fields) (fi2 : row_fields) = match fi1, fi2 with (l1,f1 as p1)::fi1', (l2,f2 as p2)::fi2' -> if l1 = l2 then merge_rf r1 r2 ((l1,f1,f2)::pairs) fi1' fi2' else @@ -409,7 +410,7 @@ let rec merge_rf r1 r2 pairs fi1 fi2 = | [], _ -> (List.rev r1, List.rev_append r2 fi2, pairs) | _, [] -> (List.rev_append r1 fi1, List.rev r2, pairs) -let merge_row_fields fi1 fi2 = +let merge_row_fields (fi1 : row_fields) (fi2 : row_fields) : row_fields * row_fields * row_pairs = match fi1, fi2 with [], _ | _, [] -> (fi1, fi2, []) | [p1], _ when not (List.mem_assoc (fst p1) fi2) -> (fi1, fi2, []) @@ -2630,7 +2631,8 @@ and unify_row env row1 row2 = let rm1 = row_more row1 and rm2 = row_more row2 in if unify_eq rm1 rm2 then () else let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if r1 <> [] && r2 <> [] then begin + if not !Config.bs_only && (r1 <> [] && r2 <> []) then begin + (* pairs are the intersection, r1 , r2 should be disjoint *) let ht = Hashtbl.create (List.length r1) in List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; List.iter diff --git a/typing/includemod.ml b/typing/includemod.ml index a5d82a3c5414..1bc24648b8eb 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -681,11 +681,30 @@ let report_error ppf errs = fprintf ppf "@[%a%a@]" print_errs errs include_err err +let better_candidate_loc (x : error list) = + match x with + | [ (_,_,Interface_mismatch _); (_,_,descr)] + -> + begin match descr with + | Value_descriptions (_,d1,_) -> Some d1.val_loc + | Type_declarations (_,tdcl1,_,_) -> + Some tdcl1.type_loc + | Missing_field (_,loc,_) -> Some loc + | _ -> None + end + | _ -> None + (* We could do a better job to split the individual error items as sub-messages of the main interface mismatch on the whole unit. *) let () = Location.register_error_of_exn (function - | Error err -> Some (Location.error_of_printer_file report_error err) + | Error err -> + begin match better_candidate_loc err with + | None -> + Some (Location.error_of_printer_file report_error err) + | Some loc -> + Some (Location.error_of_printer loc report_error err) + end | _ -> None ) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index e1c9619ee67a..a05e27fa7281 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1609,12 +1609,7 @@ let super_trace ppf = fprintf ppf "Further expanded:@," end; fprintf ppf - "@[\ - @[%a@]@,\ - vs@,\ - @[%a@]\ - %a\ - @]" + "@[%a@ vs@ %a@]%a" (super_type_expansion ~tag:"error" t1) t1' (super_type_expansion ~tag:"info" t2) t2' (super_trace false) rem; @@ -1638,14 +1633,8 @@ let super_unification_error unif tr txt1 ppf txt2 = begin let tr = List.map prepare_expansion tr in fprintf ppf "@[\ - @[\ - %t@,\ - @[<2>%a@]\ - @]@,\ - @[\ - %t@,\ - @[<2>%a@]\ - @]\ + @[%t@ %a@]@,\ + @[%t@ %a@]\ %a\ %t\ @]" diff --git a/typing/typecore.ml b/typing/typecore.ml index 3f72f7d4c79c..f421f4407a65 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -4873,6 +4873,11 @@ let type_expression env sexp = Typetexp.reset_type_variables(); begin_def(); let exp = type_exp env sexp in + if Warnings.is_active Bs_toplevel_expression_unit then + (try unify env exp.exp_type + (instance_def Predef.type_unit) with + | Unify _ + | Tags _ -> Location.prerr_warning sexp.pexp_loc Bs_toplevel_expression_unit); end_def(); if not (is_nonexpansive exp) then generalize_expansive env exp.exp_type; generalize exp.exp_type; diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6f64cd7e7013..1a12a44957b7 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -444,7 +444,7 @@ let transl_declaration env sdecl id = raise(Error(sdecl.ptype_loc, Duplicate_constructor name)); all_constrs := StringSet.add name !all_constrs) scstrs; - if List.length + if not !Config.bs_only && List.length (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 5347c42da223..064d862b0e37 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -512,19 +512,25 @@ and transl_type_aux env policy styp = row_bound=(); row_closed=true; row_fixed=false; row_name=None}) in let hfields = Hashtbl.create 17 in + let collection_detect = Hashtbl.create 17 in let add_typed_field loc l f = - let h = Btype.hash_variant l in + if not !Config.bs_only then begin + let h = Btype.hash_variant l in + if Hashtbl.mem collection_detect h then + let l' = Hashtbl.find collection_detect h in + (* Check for tag conflicts *) + if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + else Hashtbl.add collection_detect h l + end ; try - let (l',f') = Hashtbl.find hfields h in - (* Check for tag conflicts *) - if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); + let (_,f') = Hashtbl.find hfields l in let ty = mkfield l f and ty' = mkfield l f' in if equal env false [ty] [ty'] then () else try unify env ty ty' with Unify _trace -> raise(Error(loc, env, Constructor_mismatch (ty,ty'))) with Not_found -> - Hashtbl.add hfields h (l,f) + Hashtbl.add hfields l (l,f) in let add_field = function Rtag (l, attrs, c, stl) -> @@ -555,13 +561,10 @@ and transl_type_aux env policy styp = {desc=Tconstr(p, tl, _)} -> Some(p, tl) | _ -> None in - begin try + begin (* Set name if there are no fields yet *) - Hashtbl.iter (fun _ _ -> raise Exit) hfields; - name := nm - with Exit -> - (* Unset it otherwise *) - name := None + if Hashtbl.length hfields <> 0 then name := None + else name := nm end; let fl = match expand_head env cty.ctyp_type, nm with {desc=Tvariant row}, _ when Btype.static_row row -> diff --git a/utils/config.mli b/utils/config.mli index d6c167c05a98..c4fa6c0b40b9 100644 --- a/utils/config.mli +++ b/utils/config.mli @@ -21,6 +21,8 @@ val version: string val standard_library: string (* The directory containing the standard libraries *) +val syntax_kind : [ `ml | `reason | `rescript ] ref + val bs_only : bool ref val standard_runtime: string diff --git a/utils/config.mlp b/utils/config.mlp index d5228556644b..dc861e39d105 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -34,6 +34,7 @@ let standard_library = #end standard_library_default let bs_only = ref false +let syntax_kind = ref `ml let standard_runtime = "%%BYTERUN%%" let ccomp_type = "%%CCOMPTYPE%%" let c_compiler = "%%CC%%" diff --git a/utils/warnings.ml b/utils/warnings.ml index a05a97807f44..788bee35dc28 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -57,7 +57,9 @@ type t = | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (*30 *) +#if undefined BS_ONLY then | Multiple_definition of string * string * string (* 31 *) +#end | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) @@ -77,14 +79,18 @@ type t = | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string * string option (* 49 *) | Bad_docstring of bool (* 50 *) +#if undefined BS_ONLY then | Expect_tailcall (* 51 *) +#end | Fragile_literal_pattern (* 52 *) | Misplaced_attribute of string (* 53 *) | Duplicated_attribute of string (* 54 *) | Inlining_impossible of string (* 55 *) | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) +#if undefined BS_ONLY then | No_cmx_file of string (* 58 *) +#end | Assignment_to_non_mutable_value (* 59 *) | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) @@ -99,6 +105,7 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) + | Bs_toplevel_expression_unit (* 109 *) #end ;; @@ -139,7 +146,9 @@ let number = function | Wildcard_arg_to_constant_constr -> 28 | Eol_in_string -> 29 | Duplicate_definitions _ -> 30 +#if undefined BS_ONLY then | Multiple_definition _ -> 31 +#end | Unused_value_declaration _ -> 32 | Unused_open _ -> 33 | Unused_type_declaration _ -> 34 @@ -159,14 +168,18 @@ let number = function | Eliminated_optional_arguments _ -> 48 | No_cmi_file _ -> 49 | Bad_docstring _ -> 50 +#if undefined BS_ONLY then | Expect_tailcall -> 51 +#end | Fragile_literal_pattern -> 52 | Misplaced_attribute _ -> 53 | Duplicated_attribute _ -> 54 | Inlining_impossible _ -> 55 | Unreachable_case -> 56 | Ambiguous_pattern _ -> 57 +#if undefined BS_ONLY then | No_cmx_file _ -> 58 +#end | Assignment_to_non_mutable_value -> 59 | Unused_module _ -> 60 | Unboxable_type_in_prim_decl _ -> 61 @@ -181,10 +194,11 @@ let number = function | Bs_unimplemented_primitive _ -> 106 | Bs_integer_literal_overflow -> 107 | Bs_uninterpreted_delimiters _ -> 108 + | Bs_toplevel_expression_unit -> 109 #end ;; -let last_warning_number = 108 +let last_warning_number = 109 let letter_all = let rec loop i = if i = 0 then [] else i :: loop (i - 1) in loop last_warning_number @@ -319,7 +333,7 @@ let parse_options errflag s = current := {error; active} (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-32..42-44-45-48-50-60-102";; +let defaults_w = "+a-4-6-7-9-27-29-32..42-44-45-48-50-60-102-109";; let defaults_warn_error = "-a+31";; let () = @@ -360,15 +374,27 @@ let message = function ("the following methods are overridden by the class" :: cname :: ":\n " :: slist) | Method_override [] -> assert false +#if true then + | Partial_match "" -> + "You forgot to handle a possible case here, though we don't have more information on the value." + | Partial_match s -> + "You forgot to handle a possible case here, for example: \n " ^ s +#else | Partial_match "" -> "this pattern-matching is not exhaustive." | Partial_match s -> "this pattern-matching is not exhaustive.\n\ Here is an example of a case that is not matched:\n" ^ s +#end | Non_closed_record_pattern s -> "the following labels are not bound in this record pattern:\n" ^ s ^ "\nEither bind these labels explicitly or add '; _' to the pattern." +#if true then + | Statement_type -> + "This expression returns a value, but you're not doing anything with it. If this is on purpose, wrap it with `ignore`." +#else | Statement_type -> "this expression should have type unit." +#end | Unused_match -> "this match case is unused." | Unused_pat -> "this sub-pattern is unused." | Instance_variable_override [lab] -> @@ -384,7 +410,17 @@ let message = function | Implicit_public_methods l -> "the following private methods were made public implicitly:\n " ^ String.concat " " l ^ "." +#if true then + | Unerasable_optional_argument -> + String.concat "" + ["This optional parameter in final position will, in practice, not be optional.\n"; + " Reorder the parameters so that at least one non-optional one is in final position or, if all parameters are optional, insert a final ().\n\n"; + " Explanation: If the final parameter is optional, it'd be unclear whether a function application that omits it should be considered fully applied, or partially applied. Imagine writing `let title = display(\"hello!\")`, only to realize `title` isn't your desired result, but a curried call that takes a final optional argument, e.g. `~showDate`.\n\n"; + " Formal rule: an optional argument is considered intentionally omitted when the 1st positional (i.e. neither labeled nor optional) argument defined after it is passed in." + ] +#else | Unerasable_optional_argument -> "this optional argument cannot be erased." +#end | Undeclared_virtual_method m -> "the virtual method "^m^" is not declared." | Not_principal s -> s^" is not principal." | Without_principality s -> s^" without principality." @@ -393,10 +429,21 @@ let message = function "this statement never returns (or has an unsound type.)" | Preprocessor s -> s | Useless_record_with -> + begin match !Config.syntax_kind with + | `ml -> "all the fields are explicitly listed in this record:\n\ the 'with' clause is useless." + | `reason | `rescript -> + "All the fields are already explicitly listed in this record. You can remove the `...` spread." + end +#if true then | Bad_module_name (modname) -> + "This file's name is potentially invalid. The build systems conventionally turn a file name into a module name by upper-casing the first letter. " ^ modname ^ " isn't a valid module name.\n" ^ + "Note: some build systems might e.g. turn kebab-case into CamelCase module, which is why this isn't a hard error." +#else + | Bad_module_name (modname) -> "bad source file name: \"" ^ modname ^ "\" is not a valid module name." +#end | All_clauses_guarded -> "this pattern-matching is not exhaustive.\n\ All clauses in this pattern-matching are guarded." @@ -408,10 +455,12 @@ let message = function | Duplicate_definitions (kind, cname, tc1, tc2) -> Printf.sprintf "the %s %s is defined in both types %s and %s." kind cname tc1 tc2 +#if undefined BS_ONLY then | Multiple_definition(modname, file1, file2) -> Printf.sprintf "files %s and %s both define a module named %s" file1 file2 modname +#end | Unused_value_declaration v -> "unused value " ^ v ^ "." | Unused_open s -> "unused open " ^ s ^ "." | Unused_type_declaration s -> "unused type " ^ s ^ "." @@ -491,8 +540,10 @@ let message = function | Bad_docstring unattached -> if unattached then "unattached documentation comment (ignored)" else "ambiguous documentation comment" +#if undefined BS_ONLY then | Expect_tailcall -> Printf.sprintf "expected tailcall" +#end | Fragile_literal_pattern -> Printf.sprintf "Code should not depend on the actual values of\n\ @@ -521,10 +572,12 @@ let message = function "Ambiguous or-pattern variables under guard;\n\ %s may match different arguments. (See manual section 8.5)" msg +#if undefined BS_ONLY then | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ and its interface was not compiled with -opaque" name +#end | Assignment_to_non_mutable_value -> "A potential assignment to a non-mutable value was detected \n\ in this source file. Such assignments may generate incorrect code \n\ @@ -541,23 +594,25 @@ let message = function #if true then | Bs_unused_attribute s -> - "Unused BuckleScript attribute: " ^ s ^ "\n\ + "Unused attribute: " ^ s ^ "\n\ This means such annotation is not annotated properly. \n\ for example, some annotations is only meaningful in externals \n" | Bs_polymorphic_comparison -> - "polymorphic comparison introduced (maybe unsafe)" + "Polymorphic comparison introduced (maybe unsafe)" | Bs_ffi_warning s -> - "BuckleScript FFI warning: " ^ s + "FFI warning: " ^ s | Bs_derive_warning s -> - "BuckleScript bs.deriving warning: " ^ s + "bs.deriving warning: " ^ s | Bs_fragile_external s -> - "BuckleScript warning: " ^ s ^" : the external name is inferred from val name is unsafe from refactoring when changing value name" + s ^ " : the external name is inferred from val name is unsafe from refactoring when changing value name" | Bs_unimplemented_primitive s -> - "BuckleScript warning: Unimplemented primitive used:" ^ s + "Unimplemented primitive used:" ^ s | Bs_integer_literal_overflow -> - "BuckleScript warning: Integer literal exceeds the range of representable integers of type int" + "Integer literal exceeds the range of representable integers of type int" | Bs_uninterpreted_delimiters s -> - "BuckleScript warning: Uninterpreted delimiters " ^ s + "Uninterpreted delimiters " ^ s + | Bs_toplevel_expression_unit -> + "Toplevel expression is expected to have unit type." #end ;; @@ -569,6 +624,7 @@ let sub_locs = function ] | _ -> [] +let has_warnings = ref false ;; let nerrors = ref 0;; type reporting_information = @@ -588,23 +644,14 @@ let report w = match is_active w with | false -> `Inactive | true -> + has_warnings := true; if is_error w then incr nerrors; `Active { number = number w; message = message w; is_error = is_error w; sub_locs = sub_locs w; } ;; -#if true then -let super_report message w = - match is_active w with - | false -> `Inactive - | true -> - if is_error w then incr nerrors; - `Active { number = number w; message = message w; is_error = is_error w; - sub_locs = sub_locs w; - } -;; -#end + exception Errors;; let reset_fatal () = @@ -694,14 +741,15 @@ let descriptions = 62, "Type constraint on GADT type declaration"; #if true then - 101, "BuckleScript warning: Unused bs attributes"; - 102, "BuckleScript warning: polymorphic comparison introduced (maybe unsafe)"; - 103, "BuckleScript warning: about fragile FFI definitions" ; - 104, "BuckleScript warning: bs.deriving warning with customized message "; - 105, "BuckleScript warning: the external name is inferred from val name is unsafe from refactoring when changing value name"; - 106, "BuckleScript warning: Unimplemented primitive used:"; - 107, "BuckleScript warning: Integer literal exceeds the range of representable integers of type int"; - 108, "BuckleScript warning: Uninterpreted delimiters (for unicode)" + 101, "Unused bs attributes"; + 102, "Polymorphic comparison introduced (maybe unsafe)"; + 103, "Fragile FFI definitions" ; + 104, "bs.deriving warning with customized message "; + 105, "External name is inferred from val name is unsafe from refactoring when changing value name"; + 106, "Unimplemented primitive used:"; + 107, "Integer literal exceeds the range of representable integers of type int"; + 108, "Uninterpreted delimiters (for unicode)" ; + 109, "Toplevel expression has unit type" #end ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index d05ae3a45815..96df7d23005f 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -50,7 +50,9 @@ type t = | Wildcard_arg_to_constant_constr (* 28 *) | Eol_in_string (* 29 *) | Duplicate_definitions of string * string * string * string (* 30 *) +#if undefined BS_ONLY then | Multiple_definition of string * string * string (* 31 *) +#end | Unused_value_declaration of string (* 32 *) | Unused_open of string (* 33 *) | Unused_type_declaration of string (* 34 *) @@ -70,14 +72,18 @@ type t = | Eliminated_optional_arguments of string list (* 48 *) | No_cmi_file of string * string option (* 49 *) | Bad_docstring of bool (* 50 *) +#if undefined BS_ONLY then | Expect_tailcall (* 51 *) +#end | Fragile_literal_pattern (* 52 *) | Misplaced_attribute of string (* 53 *) | Duplicated_attribute of string (* 54 *) | Inlining_impossible of string (* 55 *) | Unreachable_case (* 56 *) | Ambiguous_pattern of string list (* 57 *) +#if undefined BS_ONLY then | No_cmx_file of string (* 58 *) +#end | Assignment_to_non_mutable_value (* 59 *) | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) @@ -91,6 +97,7 @@ type t = | Bs_unimplemented_primitive of string (* 106 *) | Bs_integer_literal_overflow (* 107 *) | Bs_uninterpreted_delimiters of string (* 108 *) + | Bs_toplevel_expression_unit (* 109 *) #end ;; @@ -127,10 +134,9 @@ val mk_lazy: (unit -> 'a) -> 'a Lazy.t (** Like [Lazy.of_fun], but the function is applied with the warning settings at the time [mk_lazy] is called. *) -#if undefined BS_NO_COMPILER_PATCH then +#if true then +val has_warnings : bool ref +val nerrors : int ref val message : t -> string val number: t -> int -val super_report : - (t -> string) -> - t -> [ `Active of reporting_information | `Inactive ] #end