diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index d018fd68ec..f9629bd9e8 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -17,10 +17,6 @@ jobs: os: - ubuntu-latest ocaml-compiler: - - 4.04.x - - 4.05.x - - 4.06.x - - 4.07.x - 4.08.x - 4.09.x - 4.10.x diff --git a/CHANGES.md b/CHANGES.md index 455d45e221..72d3f609b8 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,10 @@ +# dev (20??-??) - ?? +## Features/Changes +* Misc: bump min ocaml version to 4.08 + +## Bug fixes + + # 5.0.1 (2022-12-20) - Lille ## Features/Changes diff --git a/compiler/lib/base64.ml b/compiler/lib/base64.ml index cfd048c37e..0928c3aa3a 100644 --- a/compiler/lib/base64.ml +++ b/compiler/lib/base64.ml @@ -38,11 +38,8 @@ let unsafe_get_uint8 t off = Char.code (String.unsafe_get t off) let unsafe_set_uint8 t off v = Bytes.unsafe_set t off (Char.chr v) -external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_string_set16u" - [@@noalloc] [@@if ocaml_version < (4, 7, 0)] - external unsafe_set_uint16 : bytes -> int -> int -> unit = "%caml_bytes_set16u" - [@@noalloc] [@@if ocaml_version >= (4, 7, 0)] + [@@noalloc] external unsafe_get_uint16 : string -> int -> int = "%caml_string_get16u" [@@noalloc] diff --git a/compiler/lib/instr.ml b/compiler/lib/instr.ml index 0bf3976c35..6354e0915c 100644 --- a/compiler/lib/instr.ml +++ b/compiler/lib/instr.ml @@ -199,24 +199,10 @@ type desc = } let ops = - let if_v407 = - match Ocaml_version.v with - | `V4_04 | `V4_06 -> fun _ -> K_will_not_happen - | `V4_07 | `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 | `V4_13 | `V4_14 | `V5_00 -> - fun k -> k - in let if_v500 = match Ocaml_version.v with - | `V4_04 - | `V4_06 - | `V4_07 - | `V4_08 - | `V4_09 - | `V4_10 - | `V4_11 - | `V4_12 - | `V4_13 - | `V4_14 -> fun _ -> K_will_not_happen + | `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 | `V4_13 | `V4_14 -> + fun _ -> K_will_not_happen | `V5_00 -> fun k -> k in let instrs = @@ -368,7 +354,7 @@ let ops = ; BREAK, K_will_not_happen, "BREAK" ; RERAISE, KStop 0, "RERAISE" ; RAISE_NOTRACE, KStop 0, "RAISE_NOTRACE" - ; GETSTRINGCHAR, if_v407 KNullary, "GETSTRINGCHAR" + ; GETSTRINGCHAR, KNullary, "GETSTRINGCHAR" ; PERFORM, if_v500 KNullaryCall, "PERFORM" ; RESUME, if_v500 KNullaryCall, "RESUME" ; RESUMETERM, if_v500 (KStop 1), "RESUMETERM" diff --git a/compiler/lib/magic_number.ml b/compiler/lib/magic_number.ml index 8126159533..91e005b977 100644 --- a/compiler/lib/magic_number.ml +++ b/compiler/lib/magic_number.ml @@ -67,9 +67,6 @@ let equal a b = compare a b = 0 let current_exe = let v = match Ocaml_version.v with - | `V4_04 -> 11 - | `V4_06 -> 11 - | `V4_07 -> 23 | `V4_08 -> 25 | `V4_09 -> 26 | `V4_10 -> 27 @@ -84,9 +81,6 @@ let current_exe = let current_cmo = let v = match Ocaml_version.v with - | `V4_04 -> 11 - | `V4_06 -> 22 - | `V4_07 -> 23 | `V4_08 -> 25 | `V4_09 -> 26 | `V4_10 -> 27 @@ -101,9 +95,6 @@ let current_cmo = let current_cma = let v = match Ocaml_version.v with - | `V4_04 -> 12 - | `V4_06 -> 22 - | `V4_07 -> 23 | `V4_08 -> 25 | `V4_09 -> 26 | `V4_10 -> 27 diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 21a86b1d16..8a1d701fc2 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -34,142 +34,32 @@ let rec constant_of_const : _ -> Code.constant = | Const_float_array sl -> let l = List.map ~f:(fun f -> Code.Float (float_of_string f)) sl in Tuple (Obj.double_array_tag, Array.of_list l, Unknown) - | ((Const_pointer (i, _)) [@if BUCKLESCRIPT]) -> + | ((Const_pointer i) [@if ocaml_version < (4, 12, 0)]) -> Int (Int32.of_int_warning_on_overflow i) - | ((Const_block (tag, _, l)) [@if BUCKLESCRIPT]) -> - let l = Array.of_list (List.map l ~f:constant_of_const) in - Tuple (tag, l, Unknown) - | ((Const_pointer i) [@ifnot BUCKLESCRIPT] [@if ocaml_version < (4, 12, 0)]) -> - Int (Int32.of_int_warning_on_overflow i) - | ((Const_block (tag, l)) [@ifnot BUCKLESCRIPT]) -> + | Const_block (tag, l) -> let l = Array.of_list (List.map l ~f:constant_of_const) in Tuple (tag, l, Unknown) let rec find_loc_in_summary ident' = function | Env.Env_empty -> None - | Env.Env_value (_summary, ident, description) - when Poly.(ident = ident') -> - Some description.Types.val_loc - | Env.Env_value (summary,_,_) + | Env.Env_value (_summary, ident, description) when Poly.(ident = ident') -> + Some description.Types.val_loc + | Env.Env_value (summary, _, _) | Env.Env_type (summary, _, _) | Env.Env_extension (summary, _, _) - | (Env.Env_module (summary, _, _,_) [@if ocaml_version >= (4,8,0)]) - | (Env.Env_module (summary, _, _) [@if ocaml_version < (4,8,0)]) + | Env.Env_module (summary, _, _, _) | Env.Env_modtype (summary, _, _) | Env.Env_class (summary, _, _) | Env.Env_cltype (summary, _, _) - | (Env.Env_open (summary, _) [@if ocaml_version >= (4,8,0)]) - | (Env.Env_open (summary, _, _) [@if ocaml_version < (4,8,0)] [@if ocaml_version >= (4,7,0)]) - | (Env.Env_open (summary, _) [@if ocaml_version < (4,7,0)]) + | Env.Env_open (summary, _) | Env.Env_functor_arg (summary, _) - | (Env.Env_constraints (summary, _) [@if ocaml_version >= (4,4,0)]) - | (Env.Env_copy_types (summary, _) [@if ocaml_version >= (4,6,0)] [@if ocaml_version < (4,10,0)]) - | (Env.Env_copy_types (summary) [@if ocaml_version >= (4,10,0)]) - | (Env.Env_persistent (summary, _) [@if ocaml_version >= (4,8,0)]) - | (Env.Env_value_unbound (summary, _, _) [@if ocaml_version >= (4,10,0)]) - | (Env.Env_module_unbound (summary, _, _) [@if ocaml_version >= (4,10,0)]) - -> find_loc_in_summary ident' summary -[@@ocamlformat "disable"] - -(* Copied from ocaml/utils/tbl.ml *) -module Tbl = struct - [@@@ocaml.warning "-unused-field"] - - open Poly - - type ('a, 'b) t = - | Empty - | Node of ('a, 'b) t * 'a * 'b * ('a, 'b) t * int - - let empty = Empty - - let height = function - | Empty -> 0 - | Node (_, _, _, _, h) -> h - - let create l x d r = - let hl = height l and hr = height r in - Node (l, x, d, r, if hl >= hr then hl + 1 else hr + 1) - - let bal l x d r = - let hl = height l and hr = height r in - if hl > hr + 1 - then - match l with - | Node (ll, lv, ld, lr, _) when height ll >= height lr -> - create ll lv ld (create lr x d r) - | Node (ll, lv, ld, Node (lrl, lrv, lrd, lrr, _), _) -> - create (create ll lv ld lrl) lrv lrd (create lrr x d r) - | _ -> assert false - else if hr > hl + 1 - then - match r with - | Node (rl, rv, rd, rr, _) when height rr >= height rl -> - create (create l x d rl) rv rd rr - | Node (Node (rll, rlv, rld, rlr, _), rv, rd, rr, _) -> - create (create l x d rll) rlv rld (create rlr rv rd rr) - | _ -> assert false - else create l x d r - - let rec add x data = function - | Empty -> Node (Empty, x, data, Empty, 1) - | Node (l, v, d, r, h) -> - let c = compare x v in - if c = 0 - then Node (l, x, data, r, h) - else if c < 0 - then bal (add x data l) v d r - else bal l v d (add x data r) - - let rec iter f = function - | Empty -> () - | Node (l, v, d, r, _) -> - iter f l; - f v d; - iter f r - - let rec find compare x = function - | Empty -> raise Not_found - | Node (l, v, d, r, _) -> - let c = compare x v in - if c = 0 then d else find compare x (if c < 0 then l else r) - - let rec fold f m accu = - match m with - | Empty -> accu - | Node (l, v, d, r, _) -> fold f r (f v d (fold f l accu)) -end -[@@if ocaml_version < (4, 8, 0)] - -module Symtable = struct - type 'a numtable = - { num_cnt : int - ; num_tbl : ('a, int) Tbl.t - } - - module GlobalMap = struct - type t = Ident.t numtable - - let filter_global_map (p : Ident.t -> bool) gmap = - let newtbl = ref Tbl.empty in - Tbl.iter (fun id num -> if p id then newtbl := Tbl.add id num !newtbl) gmap.num_tbl; - { num_cnt = gmap.num_cnt; num_tbl = !newtbl } - - let find nn t = - Tbl.find (fun x1 x2 -> String.compare (Ident.name x1) (Ident.name x2)) nn t.num_tbl - - let iter nn t = Tbl.iter nn t.num_tbl - - let fold f t acc = Tbl.fold f t.num_tbl acc - end - - let reloc_ident name = - let buf = Bytes.create 4 in - Symtable.patch_object buf [ Reloc_setglobal (Ident.create_persistent name), 0 ]; - let get i = Char.code (Bytes.get buf i) in - get 0 + (get 1 lsl 8) + (get 2 lsl 16) + (get 3 lsl 24) -end -[@@if ocaml_version < (4, 8, 0)] + | Env.Env_constraints (summary, _) + | ((Env.Env_copy_types (summary, _)) [@if ocaml_version < (4, 10, 0)]) + | ((Env.Env_copy_types summary) [@if ocaml_version >= (4, 10, 0)]) + | Env.Env_persistent (summary, _) + | ((Env.Env_value_unbound (summary, _, _)) [@if ocaml_version >= (4, 10, 0)]) + | ((Env.Env_module_unbound (summary, _, _)) [@if ocaml_version >= (4, 10, 0)]) -> + find_loc_in_summary ident' summary module Symtable = struct (* Copied from ocaml/bytecomp/symtable.ml *) @@ -219,7 +109,6 @@ module Symtable = struct let get i = Char.code (Bytes.get buf i) in get 0 + (get 1 lsl 8) + (get 2 lsl 16) + (get 3 lsl 24) end -[@@if ocaml_version >= (4, 8, 0)] module Ident = struct [@@@ocaml.warning "-unused-field"] diff --git a/compiler/lib/ocaml_version.ml b/compiler/lib/ocaml_version.ml index e776906710..4d4738f36e 100644 --- a/compiler/lib/ocaml_version.ml +++ b/compiler/lib/ocaml_version.ml @@ -66,9 +66,6 @@ let rec compare v v' = let v = match current with - | 4 :: (4 | 5) :: _ -> `V4_04 - | 4 :: 6 :: _ -> `V4_06 - | 4 :: 7 :: _ -> `V4_07 | 4 :: 8 :: _ -> `V4_08 | 4 :: 9 :: _ -> `V4_09 | 4 :: 10 :: _ -> `V4_10 @@ -79,7 +76,7 @@ let v = | 5 :: 0 :: _ -> `V5_00 | _ -> if compare current [ 4; 4 ] < 0 - then failwith "OCaml version unsupported. Upgrade to OCaml 4.04 or newer." + then failwith "OCaml version unsupported. Upgrade to OCaml 4.08 or newer." else ( assert (compare current [ 5; 1 ] >= 0); failwith "OCaml version unsupported. Upgrade js_of_ocaml.") diff --git a/compiler/lib/ocaml_version.mli b/compiler/lib/ocaml_version.mli index 266ee3e116..fe4016d280 100644 --- a/compiler/lib/ocaml_version.mli +++ b/compiler/lib/ocaml_version.mli @@ -25,10 +25,7 @@ val compare : t -> t -> int val split : string -> t val v : - [ `V4_04 (* OCaml 4.04 / OCaml 4.05 *) - | `V4_06 (* OCaml 4.06 *) - | `V4_07 (* OCaml 4.07 *) - | `V4_08 (* OCaml 4.08 *) + [ `V4_08 (* OCaml 4.08 *) | `V4_09 (* OCaml 4.09 *) | `V4_10 (* OCaml 4.10 *) | `V4_11 (* OCaml 4.11 *) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 92c8f0c1d6..e8e771e70b 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -33,7 +33,7 @@ let predefined_exceptions = let new_closure_repr = match Ocaml_version.v with - | `V4_04 | `V4_06 | `V4_07 | `V4_08 | `V4_09 | `V4_10 | `V4_11 -> false + | `V4_08 | `V4_09 | `V4_10 | `V4_11 -> false | `V4_12 | `V4_13 | `V4_14 | `V5_00 -> true (* Read and manipulate debug section *) @@ -2241,7 +2241,7 @@ let parse_bytecode code globals debug_data = let override_global = match Ocaml_version.v with | `V4_13 | `V4_14 | `V5_00 -> [] - | `V4_04 | `V4_06 | `V4_07 | `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 -> + | `V4_08 | `V4_09 | `V4_10 | `V4_11 | `V4_12 -> let jsmodule name func = Prim (Extern "%overrideMod", [ Pc (NativeString name); Pc (NativeString func) ]) in diff --git a/compiler/ppx/ppx_optcomp_light.ml b/compiler/ppx/ppx_optcomp_light.ml index bcd170870d..47cf3f9112 100644 --- a/compiler/ppx/ppx_optcomp_light.ml +++ b/compiler/ppx/ppx_optcomp_light.ml @@ -20,7 +20,7 @@ (** Minimal version of ppx_optcomp It only support the following attribute {[ - [@if ocaml_version < (4,8,0)] + [@if ocaml_version < (4,12,0)] ]} on module (Pstr_module), toplevel bindings (Pstr_value, Pstr_primitive) diff --git a/compiler/tests-compiler/getenv.ml b/compiler/tests-compiler/getenv.ml index 33bea8e8e4..45fa5dc559 100644 --- a/compiler/tests-compiler/getenv.ml +++ b/compiler/tests-compiler/getenv.ml @@ -66,9 +66,7 @@ let%expect_test _ = compile_and_run ~flags:[ "--setenv"; "D=±" ] {| - (if Sys.ocaml_version >= "4.07" - then - match Sys.getenv "D" with + (match Sys.getenv "D" with | "\u{00b1}" -> () | _ -> print_endline "BUG")|}; [%expect {||}] diff --git a/dune-project b/dune-project index a4a96b1a34..dd5272f977 100644 --- a/dune-project +++ b/dune-project @@ -18,7 +18,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (and (>= 4.04) (< 5.1))) + (ocaml (and (>= 4.08) (< 5.1))) (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) (ppxlib (>= 0.15.0)) @@ -41,7 +41,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml (= :version)) (js_of_ocaml-ppx (= :version)) (lwt (>= 2.4.4)) @@ -60,7 +60,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml (= :version)) (ppxlib (>= 0.15)) (num :with-test) @@ -74,7 +74,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml (= :version)) (ppxlib (>= 0.15.0)) (num :with-test) @@ -88,7 +88,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml-compiler (= :version)) (ocamlfind (>= 1.5.1)) (cohttp-lwt-unix :with-test) @@ -105,7 +105,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml (= :version)) (js_of_ocaml-ppx (= :version)) (react (>= 1.2.1)) @@ -123,7 +123,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.04)) + (ocaml (>= 4.08)) (js_of_ocaml-compiler (= :version)) (ppxlib (>= 0.15)) (num :with-test) diff --git a/dune-workspace.dev b/dune-workspace.dev index d11898df0a..b6e4665da6 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -7,22 +7,6 @@ ;; ;; This will build js_of_ocaml against all these version of OCaml -(context - (opam - (switch 4.04.2))) - -(context - (opam - (switch 4.05.0))) - -(context - (opam - (switch 4.06.1))) - -(context - (opam - (switch 4.07.1))) - (context (opam (switch 4.08.1))) @@ -46,3 +30,11 @@ (context (opam (switch 4.13.1))) + +(context + (opam + (switch 4.14.0))) + +(context + (opam + (switch 5.0.0))) diff --git a/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index 900784156e..7e0db476a0 100644 --- a/js_of_ocaml-compiler.opam +++ b/js_of_ocaml-compiler.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04" & < "5.1"} + "ocaml" {>= "4.08" & < "5.1"} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "ppxlib" {>= "0.15.0"} diff --git a/js_of_ocaml-lwt.opam b/js_of_ocaml-lwt.opam index db456e5c47..064c6dedff 100644 --- a/js_of_ocaml-lwt.opam +++ b/js_of_ocaml-lwt.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} "lwt" {>= "2.4.4"} diff --git a/js_of_ocaml-ppx.opam b/js_of_ocaml-ppx.opam index 7afecc43fb..379f550b84 100644 --- a/js_of_ocaml-ppx.opam +++ b/js_of_ocaml-ppx.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "ppxlib" {>= "0.15.0"} "num" {with-test} diff --git a/js_of_ocaml-ppx_deriving_json.opam b/js_of_ocaml-ppx_deriving_json.opam index 24d3d1e506..49d4b0e2d2 100644 --- a/js_of_ocaml-ppx_deriving_json.opam +++ b/js_of_ocaml-ppx_deriving_json.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "ppxlib" {>= "0.15"} "num" {with-test} diff --git a/js_of_ocaml-toplevel.opam b/js_of_ocaml-toplevel.opam index 6c2145cd69..949356cc53 100644 --- a/js_of_ocaml-toplevel.opam +++ b/js_of_ocaml-toplevel.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml-compiler" {= version} "ocamlfind" {>= "1.5.1"} "cohttp-lwt-unix" {with-test} diff --git a/js_of_ocaml-tyxml.opam b/js_of_ocaml-tyxml.opam index 10cfb272dd..091061002e 100644 --- a/js_of_ocaml-tyxml.opam +++ b/js_of_ocaml-tyxml.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} "react" {>= "1.2.1"} diff --git a/js_of_ocaml.opam b/js_of_ocaml.opam index cba6ac622a..19a79d6852 100644 --- a/js_of_ocaml.opam +++ b/js_of_ocaml.opam @@ -12,7 +12,7 @@ doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ "dune" {>= "3.2"} - "ocaml" {>= "4.04"} + "ocaml" {>= "4.08"} "js_of_ocaml-compiler" {= version} "ppxlib" {>= "0.15"} "num" {with-test} diff --git a/manual/linker.wiki b/manual/linker.wiki index 619e29478a..344ff6b58e 100644 --- a/manual/linker.wiki +++ b/manual/linker.wiki @@ -35,6 +35,6 @@ function primitive_name(..){ the returned value of the primitive; when no annotation is provided, the linker assumes that the primitive may have side-effects. * **{{{//Requires}}}** is used if other primitives need to be loaded first - * **version_constraint** looks like "{{{< 4.07.0}}}" + * **version_constraint** looks like "{{{< 4.12.0}}}" * **{{{//Version}}}** is optional and is rarely used All JavaScript code following a **{{{//Provides}}}** annotation is associated to this annotation, until the next **{{{//Provides}}}** annotation. diff --git a/runtime/marshal.js b/runtime/marshal.js index 70e0c0f288..63bb2102db 100644 --- a/runtime/marshal.js +++ b/runtime/marshal.js @@ -446,20 +446,12 @@ MlObjectTable.prototype.recall = function(v) { ? undefined : this.objs.length - i; /* index is relative */ } -//Provides: caml_legacy_custom_code -//Version: >= 4.08 -var caml_legacy_custom_code = false - -//Provides: caml_legacy_custom_code -//Version: < 4.08 -var caml_legacy_custom_code = true - //Provides: caml_output_val //Requires: caml_int64_to_bytes, caml_failwith //Requires: caml_int64_bits_of_float //Requires: caml_is_ml_bytes, caml_ml_bytes_length, caml_bytes_unsafe_get //Requires: caml_is_ml_string, caml_ml_string_length, caml_string_unsafe_get -//Requires: MlObjectTable, caml_list_to_js_array, caml_legacy_custom_code, caml_custom_ops +//Requires: MlObjectTable, caml_list_to_js_array, caml_custom_ops //Requires: caml_invalid_argument,caml_string_of_jsbytes, caml_is_continuation_tag var caml_output_val = function (){ function Writer () { this.chunk = []; } @@ -525,13 +517,7 @@ var caml_output_val = function (){ var sz_32_64 = [0,0]; if(!ops.serialize) caml_invalid_argument("output_value: abstract value (Custom)"); - if(caml_legacy_custom_code) { - writer.write (8, 0x12 /*cst.CODE_CUSTOM*/); - for (var i = 0; i < name.length; i++) - writer.write (8, name.charCodeAt(i)); - writer.write(8, 0); - ops.serialize(writer, v, sz_32_64); - } else if(ops.fixed_length == undefined){ + if(ops.fixed_length == undefined){ writer.write (8, 0x18 /*cst.CODE_CUSTOM_LEN*/); for (var i = 0; i < name.length; i++) writer.write (8, name.charCodeAt(i)); diff --git a/runtime/toplevel.js b/runtime/toplevel.js index 27d634d658..45df287f3e 100644 --- a/runtime/toplevel.js +++ b/runtime/toplevel.js @@ -47,19 +47,8 @@ function caml_get_section_table () { return caml_global_data.toc; } - -//Provides: caml_reify_bytecode -//Requires: caml_failwith,caml_callback -//Version: < 4.08 -function caml_reify_bytecode (code, _sz) { - if(globalThis.toplevelCompile) - return caml_callback(globalThis.toplevelCompile, [[0,code], [0]]); - else caml_failwith("Toplevel not initialized (toplevelCompile)") -} - //Provides: caml_reify_bytecode //Requires: caml_failwith,caml_callback -//Version: >= 4.08 function caml_reify_bytecode (code, debug,_digest) { if(globalThis.toplevelCompile) return [0, 0, caml_callback(globalThis.toplevelCompile, [code,debug])]; diff --git a/tools/toplevel_expect/dune b/tools/toplevel_expect/dune index 35b44064fd..372664e168 100644 --- a/tools/toplevel_expect/dune +++ b/tools/toplevel_expect/dune @@ -6,8 +6,6 @@ (targets toplevel_expect_test.ml) (deps ../select/select.exe - toplevel_expect_test.ml-4.04 - toplevel_expect_test.ml-4.05 toplevel_expect_test.ml-4.08 toplevel_expect_test.ml-4.09 toplevel_expect_test.ml-4.10 diff --git a/tools/toplevel_expect/toplevel_expect_test.ml-4.04 b/tools/toplevel_expect/toplevel_expect_test.ml-4.04 deleted file mode 100644 index f7e0f94fc8..0000000000 --- a/tools/toplevel_expect/toplevel_expect_test.ml-4.04 +++ /dev/null @@ -1,381 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Execute a list of phrases from a .ml file and compare the result to the - expected output, written inside [%%expect ...] nodes. At the end, create - a .corrected file containing the corrected expectations. The test is - successful if there is no differences between the two files. - - An [%%expect] node always contains both the expected outcome with and - without -principal. When the two differ the expectation is written as - follows: - - {[ - [%%expect {| - output without -principal - |}, Principal{| - output with -principal - |}] - ]} -*) - -[@@@ocaml.warning "-40"] - -open StdLabels - -(* representation of: {tag|str|tag} *) -type string_constant = - { str : string - ; tag : string - } - -type expectation = - { extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *) - ; payload_loc : Location.t (* Location of the whole payload *) - ; normal : string_constant (* expectation without -principal *) - ; principal : string_constant (* expectation with -principal *) - } - -(* A list of phrases with the expected toplevel output *) -type chunk = - { phrases : Parsetree.toplevel_phrase list - ; expectation : expectation - } - -type correction = - { corrected_expectations : expectation list - ; trailing_output : string - } - -let match_expect_extension (ext : Parsetree.extension) = - match ext with - | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) -> - let invalid_payload () = - Location.raise_errorf ~loc:extid_loc - "invalid [%%%%expect payload]" - in - let string_constant (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_constant (Pconst_string (str, Some tag)) -> - { str; tag } - | _ -> invalid_payload () - in - let expectation = - match payload with - | PStr [{ pstr_desc = Pstr_eval (e, []); _ }] -> - let normal, principal = - match e.pexp_desc with - | Pexp_tuple - [ a - ; { pexp_desc = Pexp_construct - ({ txt = Lident "Principal"; _ }, Some b); _ } - ] -> - (string_constant a, string_constant b) - | _ -> let s = string_constant e in (s, s) - in - { extid_loc - ; payload_loc = e.pexp_loc - ; normal - ; principal - } - | PStr [] -> - let s = { tag = ""; str = "" } in - { extid_loc - ; payload_loc = { extid_loc with loc_start = extid_loc.loc_end } - ; normal = s - ; principal = s - } - | _ -> invalid_payload () - in - Some expectation - | _ -> - None - -(* Split a list of phrases from a .ml file *) -let split_chunks phrases = - let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc = - match phrases with - | [] -> - if code_acc = [] then - (List.rev acc, None) - else - (List.rev acc, Some (List.rev code_acc)) - | phrase :: phrases -> - match phrase with - | Ptop_def [] -> loop phrases code_acc acc - | Ptop_def [{pstr_desc = Pstr_extension(ext, []); _}] -> begin - match match_expect_extension ext with - | None -> loop phrases (phrase :: code_acc) acc - | Some expectation -> - let chunk = - { phrases = List.rev code_acc - ; expectation - } - in - loop phrases [] (chunk :: acc) - end - | _ -> loop phrases (phrase :: code_acc) acc - in - loop phrases [] [] - -module Compiler_messages = struct - let print_loc ppf (loc : Location.t) = - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - Format.fprintf ppf "Line _"; - if startchar >= 0 then - Format.fprintf ppf ", characters %d-%d" startchar endchar; - Format.fprintf ppf ":@." - - let error_prefix = "Error" - - - let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)= - print_loc ppf loc; - Format.fprintf ppf "@{%s@}: %s" error_prefix msg; - List.iter sub ~f:(fun err -> - Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err) - - let capture ppf ~f = - Misc.protect_refs - [ R (Location.formatter_for_warnings , ppf ) - ; R (Location.error_reporter , error_reporter ) - ] - f -end - -let collect_formatters buf pps ~f = - List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; - let save = - List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps - in - let restore () = - List.iter2 - ~f:(fun pp out_functions -> - Format.pp_print_flush pp (); - Format.pp_set_formatter_out_functions pp out_functions) - pps save - in - let out_string str ofs len = Buffer.add_substring buf str ofs len - and out_flush = ignore - and out_newline () = Buffer.add_char buf '\n' - and out_spaces n = for _i = 1 to n do Buffer.add_char buf ' ' done in - let out_functions = - { Format.out_string; out_flush; out_newline; out_spaces } - in - List.iter - ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) - pps; - match f () with - | x -> restore (); x - | exception exn -> restore (); raise exn - -(* Invariant: ppf = Format.formatter_of_buffer buf *) -let capture_everything buf ppf ~f = - collect_formatters buf [Format.std_formatter; Format.err_formatter] - ~f:(fun () -> Compiler_messages.capture ppf ~f) - -let exec_phrase ppf phrase = - if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase; - if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; - Toploop.execute_phrase true ppf phrase - -let parse_contents ~fname contents = - let lexbuf = Lexing.from_string contents in - Location.init lexbuf fname; - Location.input_name := fname; - Parse.use_file lexbuf - -let eval_expectation expectation ~output = - let s = - if !Clflags.principal then - expectation.principal - else - expectation.normal - in - if s.str = output then - None - else - let s = { s with str = output } in - Some ( - if !Clflags.principal then - { expectation with principal = s } - else - { expectation with normal = s } - ) - -let preprocess_structure mappers str = - let open Ast_mapper in - List.fold_right - ~f:(fun ppx_rewriter str -> - let mapper : Ast_mapper.mapper = ppx_rewriter [] in - mapper.structure mapper str) - mappers - ~init:str - -let preprocess_phrase mappers phrase = - let open Parsetree in - match phrase with - | Ptop_def str -> Ptop_def (preprocess_structure mappers str) - | Ptop_dir _ as x -> x - - -let shift_lines delta = - let position (pos : Lexing.position) = - { pos with pos_lnum = pos.pos_lnum + delta } - in - let location _this (loc : Location.t) = - { loc with - loc_start = position loc.loc_start - ; loc_end = position loc.loc_end - } - in - fun _ -> { Ast_mapper.default_mapper with location } - -let rec min_line_number : Parsetree.toplevel_phrase list -> int option = -function - | [] -> None - | (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l - | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum - -let eval_expect_file mapper fname ~file_contents = - Warnings.reset_fatal (); - let chunks, trailing_code = - parse_contents ~fname:fname file_contents |> split_chunks - in - let buf = Buffer.create 1024 in - let ppf = Format.formatter_of_buffer buf in - let out_fun = Format.pp_get_formatter_out_functions ppf () in - Format.pp_set_formatter_out_functions Format.std_formatter out_fun; - - let exec_phrases phrases = - - let mappers = - match min_line_number phrases with - | None -> [] - | Some lnum -> [shift_lines (1 - lnum)] - in - let mappers = mapper :: mappers in - let phrases = List.map ~f:(preprocess_phrase mappers) phrases in - - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let _ : bool = - List.fold_left phrases ~init:true ~f:(fun acc phrase -> - acc && - try - exec_phrase ppf phrase - with exn -> - Location.report_exception ppf exn; - false) - in - Format.pp_print_flush ppf (); - let len = Buffer.length buf in - if len > 0 && Buffer.nth buf (len - 1) <> '\n' then - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let s = Buffer.contents buf in - Buffer.clear buf; - Misc.delete_eol_spaces s - in - let corrected_expectations = - capture_everything buf ppf ~f:(fun () -> - List.fold_left chunks ~init:[] ~f:(fun acc chunk -> - let output = exec_phrases chunk.phrases in - match eval_expectation chunk.expectation ~output with - | None -> acc - | Some correction -> correction :: acc) - |> List.rev) - in - let trailing_output = - match trailing_code with - | None -> "" - | Some phrases -> - capture_everything buf ppf ~f:(fun () -> exec_phrases phrases) - in - { corrected_expectations; trailing_output } - -let output_slice oc s a b = - output_string oc (String.sub s ~pos:a ~len:(b - a)) - -let output_corrected oc ~file_contents correction = - let output_body oc { str; tag } = - Printf.fprintf oc "{%s|%s|%s}" tag str tag - in - let ofs = - List.fold_left correction.corrected_expectations ~init:0 - ~f:(fun ofs c -> - output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum; - output_body oc c.normal; - if !Clflags.principal && c.normal.str <> c.principal.str then begin - output_string oc ", Principal"; - output_body oc c.principal - end; - c.payload_loc.loc_end.pos_cnum) - in - output_slice oc file_contents ofs (String.length file_contents); - match correction.trailing_output with - | "" -> () - | s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s - -let write_corrected ~file ~file_contents correction = - let oc = open_out file in - output_corrected oc ~file_contents correction; - close_out oc - -let process_expect_file mapper fname = - let corrected_fname = fname ^ ".corrected" in - let file_contents = - let ic = open_in_bin fname in - match really_input_string ic (in_channel_length ic) with - | s -> close_in ic; Misc.normalise_eol s - | exception e -> close_in ic; raise e - in - let correction = eval_expect_file mapper fname ~file_contents in - write_corrected ~file:corrected_fname ~file_contents correction - -let repo_root = ref "" - -let main mapper fname = - Toploop.override_sys_argv - (Array.sub Sys.argv ~pos:!Arg.current - ~len:(Array.length Sys.argv - !Arg.current)); - (* Ignore OCAMLRUNPARAM=b to be reproducible *) - Printexc.record_backtrace false; - List.iter [ "stdlib" ] ~f:(fun s -> - Topdirs.dir_directory (Filename.concat !repo_root s)); - Toploop.initialize_toplevel_env (); - Sys.interactive := false; - process_expect_file mapper fname; - exit 0 - -let args = - Arg.align - [ "-repo-root", Set_string repo_root, - " root of the OCaml repository" - ; "-principal", Set Clflags.principal, - " Evaluate the file with -principal set" - ] - -let usage = "Usage: expect_test [script-file [arguments]]\n\ - options are:" - -let run mapper = - try - Arg.parse args (main mapper) usage; - Printf.eprintf "expect_test: no input file\n"; - exit 2 - with exn -> - Location.report_exception Format.err_formatter exn; - exit 2 diff --git a/tools/toplevel_expect/toplevel_expect_test.ml-4.05 b/tools/toplevel_expect/toplevel_expect_test.ml-4.05 deleted file mode 100644 index f7e0f94fc8..0000000000 --- a/tools/toplevel_expect/toplevel_expect_test.ml-4.05 +++ /dev/null @@ -1,381 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Execute a list of phrases from a .ml file and compare the result to the - expected output, written inside [%%expect ...] nodes. At the end, create - a .corrected file containing the corrected expectations. The test is - successful if there is no differences between the two files. - - An [%%expect] node always contains both the expected outcome with and - without -principal. When the two differ the expectation is written as - follows: - - {[ - [%%expect {| - output without -principal - |}, Principal{| - output with -principal - |}] - ]} -*) - -[@@@ocaml.warning "-40"] - -open StdLabels - -(* representation of: {tag|str|tag} *) -type string_constant = - { str : string - ; tag : string - } - -type expectation = - { extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *) - ; payload_loc : Location.t (* Location of the whole payload *) - ; normal : string_constant (* expectation without -principal *) - ; principal : string_constant (* expectation with -principal *) - } - -(* A list of phrases with the expected toplevel output *) -type chunk = - { phrases : Parsetree.toplevel_phrase list - ; expectation : expectation - } - -type correction = - { corrected_expectations : expectation list - ; trailing_output : string - } - -let match_expect_extension (ext : Parsetree.extension) = - match ext with - | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) -> - let invalid_payload () = - Location.raise_errorf ~loc:extid_loc - "invalid [%%%%expect payload]" - in - let string_constant (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_constant (Pconst_string (str, Some tag)) -> - { str; tag } - | _ -> invalid_payload () - in - let expectation = - match payload with - | PStr [{ pstr_desc = Pstr_eval (e, []); _ }] -> - let normal, principal = - match e.pexp_desc with - | Pexp_tuple - [ a - ; { pexp_desc = Pexp_construct - ({ txt = Lident "Principal"; _ }, Some b); _ } - ] -> - (string_constant a, string_constant b) - | _ -> let s = string_constant e in (s, s) - in - { extid_loc - ; payload_loc = e.pexp_loc - ; normal - ; principal - } - | PStr [] -> - let s = { tag = ""; str = "" } in - { extid_loc - ; payload_loc = { extid_loc with loc_start = extid_loc.loc_end } - ; normal = s - ; principal = s - } - | _ -> invalid_payload () - in - Some expectation - | _ -> - None - -(* Split a list of phrases from a .ml file *) -let split_chunks phrases = - let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc = - match phrases with - | [] -> - if code_acc = [] then - (List.rev acc, None) - else - (List.rev acc, Some (List.rev code_acc)) - | phrase :: phrases -> - match phrase with - | Ptop_def [] -> loop phrases code_acc acc - | Ptop_def [{pstr_desc = Pstr_extension(ext, []); _}] -> begin - match match_expect_extension ext with - | None -> loop phrases (phrase :: code_acc) acc - | Some expectation -> - let chunk = - { phrases = List.rev code_acc - ; expectation - } - in - loop phrases [] (chunk :: acc) - end - | _ -> loop phrases (phrase :: code_acc) acc - in - loop phrases [] [] - -module Compiler_messages = struct - let print_loc ppf (loc : Location.t) = - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - Format.fprintf ppf "Line _"; - if startchar >= 0 then - Format.fprintf ppf ", characters %d-%d" startchar endchar; - Format.fprintf ppf ":@." - - let error_prefix = "Error" - - - let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)= - print_loc ppf loc; - Format.fprintf ppf "@{%s@}: %s" error_prefix msg; - List.iter sub ~f:(fun err -> - Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err) - - let capture ppf ~f = - Misc.protect_refs - [ R (Location.formatter_for_warnings , ppf ) - ; R (Location.error_reporter , error_reporter ) - ] - f -end - -let collect_formatters buf pps ~f = - List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; - let save = - List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps - in - let restore () = - List.iter2 - ~f:(fun pp out_functions -> - Format.pp_print_flush pp (); - Format.pp_set_formatter_out_functions pp out_functions) - pps save - in - let out_string str ofs len = Buffer.add_substring buf str ofs len - and out_flush = ignore - and out_newline () = Buffer.add_char buf '\n' - and out_spaces n = for _i = 1 to n do Buffer.add_char buf ' ' done in - let out_functions = - { Format.out_string; out_flush; out_newline; out_spaces } - in - List.iter - ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) - pps; - match f () with - | x -> restore (); x - | exception exn -> restore (); raise exn - -(* Invariant: ppf = Format.formatter_of_buffer buf *) -let capture_everything buf ppf ~f = - collect_formatters buf [Format.std_formatter; Format.err_formatter] - ~f:(fun () -> Compiler_messages.capture ppf ~f) - -let exec_phrase ppf phrase = - if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase; - if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; - Toploop.execute_phrase true ppf phrase - -let parse_contents ~fname contents = - let lexbuf = Lexing.from_string contents in - Location.init lexbuf fname; - Location.input_name := fname; - Parse.use_file lexbuf - -let eval_expectation expectation ~output = - let s = - if !Clflags.principal then - expectation.principal - else - expectation.normal - in - if s.str = output then - None - else - let s = { s with str = output } in - Some ( - if !Clflags.principal then - { expectation with principal = s } - else - { expectation with normal = s } - ) - -let preprocess_structure mappers str = - let open Ast_mapper in - List.fold_right - ~f:(fun ppx_rewriter str -> - let mapper : Ast_mapper.mapper = ppx_rewriter [] in - mapper.structure mapper str) - mappers - ~init:str - -let preprocess_phrase mappers phrase = - let open Parsetree in - match phrase with - | Ptop_def str -> Ptop_def (preprocess_structure mappers str) - | Ptop_dir _ as x -> x - - -let shift_lines delta = - let position (pos : Lexing.position) = - { pos with pos_lnum = pos.pos_lnum + delta } - in - let location _this (loc : Location.t) = - { loc with - loc_start = position loc.loc_start - ; loc_end = position loc.loc_end - } - in - fun _ -> { Ast_mapper.default_mapper with location } - -let rec min_line_number : Parsetree.toplevel_phrase list -> int option = -function - | [] -> None - | (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l - | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum - -let eval_expect_file mapper fname ~file_contents = - Warnings.reset_fatal (); - let chunks, trailing_code = - parse_contents ~fname:fname file_contents |> split_chunks - in - let buf = Buffer.create 1024 in - let ppf = Format.formatter_of_buffer buf in - let out_fun = Format.pp_get_formatter_out_functions ppf () in - Format.pp_set_formatter_out_functions Format.std_formatter out_fun; - - let exec_phrases phrases = - - let mappers = - match min_line_number phrases with - | None -> [] - | Some lnum -> [shift_lines (1 - lnum)] - in - let mappers = mapper :: mappers in - let phrases = List.map ~f:(preprocess_phrase mappers) phrases in - - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let _ : bool = - List.fold_left phrases ~init:true ~f:(fun acc phrase -> - acc && - try - exec_phrase ppf phrase - with exn -> - Location.report_exception ppf exn; - false) - in - Format.pp_print_flush ppf (); - let len = Buffer.length buf in - if len > 0 && Buffer.nth buf (len - 1) <> '\n' then - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let s = Buffer.contents buf in - Buffer.clear buf; - Misc.delete_eol_spaces s - in - let corrected_expectations = - capture_everything buf ppf ~f:(fun () -> - List.fold_left chunks ~init:[] ~f:(fun acc chunk -> - let output = exec_phrases chunk.phrases in - match eval_expectation chunk.expectation ~output with - | None -> acc - | Some correction -> correction :: acc) - |> List.rev) - in - let trailing_output = - match trailing_code with - | None -> "" - | Some phrases -> - capture_everything buf ppf ~f:(fun () -> exec_phrases phrases) - in - { corrected_expectations; trailing_output } - -let output_slice oc s a b = - output_string oc (String.sub s ~pos:a ~len:(b - a)) - -let output_corrected oc ~file_contents correction = - let output_body oc { str; tag } = - Printf.fprintf oc "{%s|%s|%s}" tag str tag - in - let ofs = - List.fold_left correction.corrected_expectations ~init:0 - ~f:(fun ofs c -> - output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum; - output_body oc c.normal; - if !Clflags.principal && c.normal.str <> c.principal.str then begin - output_string oc ", Principal"; - output_body oc c.principal - end; - c.payload_loc.loc_end.pos_cnum) - in - output_slice oc file_contents ofs (String.length file_contents); - match correction.trailing_output with - | "" -> () - | s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s - -let write_corrected ~file ~file_contents correction = - let oc = open_out file in - output_corrected oc ~file_contents correction; - close_out oc - -let process_expect_file mapper fname = - let corrected_fname = fname ^ ".corrected" in - let file_contents = - let ic = open_in_bin fname in - match really_input_string ic (in_channel_length ic) with - | s -> close_in ic; Misc.normalise_eol s - | exception e -> close_in ic; raise e - in - let correction = eval_expect_file mapper fname ~file_contents in - write_corrected ~file:corrected_fname ~file_contents correction - -let repo_root = ref "" - -let main mapper fname = - Toploop.override_sys_argv - (Array.sub Sys.argv ~pos:!Arg.current - ~len:(Array.length Sys.argv - !Arg.current)); - (* Ignore OCAMLRUNPARAM=b to be reproducible *) - Printexc.record_backtrace false; - List.iter [ "stdlib" ] ~f:(fun s -> - Topdirs.dir_directory (Filename.concat !repo_root s)); - Toploop.initialize_toplevel_env (); - Sys.interactive := false; - process_expect_file mapper fname; - exit 0 - -let args = - Arg.align - [ "-repo-root", Set_string repo_root, - " root of the OCaml repository" - ; "-principal", Set Clflags.principal, - " Evaluate the file with -principal set" - ] - -let usage = "Usage: expect_test [script-file [arguments]]\n\ - options are:" - -let run mapper = - try - Arg.parse args (main mapper) usage; - Printf.eprintf "expect_test: no input file\n"; - exit 2 - with exn -> - Location.report_exception Format.err_formatter exn; - exit 2 diff --git a/tools/toplevel_expect/toplevel_expect_test.ml-4.06 b/tools/toplevel_expect/toplevel_expect_test.ml-4.06 deleted file mode 100644 index 8b73bcbde5..0000000000 --- a/tools/toplevel_expect/toplevel_expect_test.ml-4.06 +++ /dev/null @@ -1,382 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Execute a list of phrases from a .ml file and compare the result to the - expected output, written inside [%%expect ...] nodes. At the end, create - a .corrected file containing the corrected expectations. The test is - successful if there is no differences between the two files. - - An [%%expect] node always contains both the expected outcome with and - without -principal. When the two differ the expectation is written as - follows: - - {[ - [%%expect {| - output without -principal - |}, Principal{| - output with -principal - |}] - ]} -*) - -[@@@ocaml.warning "-40"] - -open StdLabels - -(* representation of: {tag|str|tag} *) -type string_constant = - { str : string - ; tag : string - } - -type expectation = - { extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *) - ; payload_loc : Location.t (* Location of the whole payload *) - ; normal : string_constant (* expectation without -principal *) - ; principal : string_constant (* expectation with -principal *) - } - -(* A list of phrases with the expected toplevel output *) -type chunk = - { phrases : Parsetree.toplevel_phrase list - ; expectation : expectation - } - -type correction = - { corrected_expectations : expectation list - ; trailing_output : string - } - -let match_expect_extension (ext : Parsetree.extension) = - match ext with - | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) -> - let invalid_payload () = - Location.raise_errorf ~loc:extid_loc - "invalid [%%%%expect payload]" - in - let string_constant (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_constant (Pconst_string (str, Some tag)) -> - { str; tag } - | _ -> invalid_payload () - in - let expectation = - match payload with - | PStr [{ pstr_desc = Pstr_eval (e, []); _ }] -> - let normal, principal = - match e.pexp_desc with - | Pexp_tuple - [ a - ; { pexp_desc = Pexp_construct - ({ txt = Lident "Principal"; _ }, Some b); _ } - ] -> - (string_constant a, string_constant b) - | _ -> let s = string_constant e in (s, s) - in - { extid_loc - ; payload_loc = e.pexp_loc - ; normal - ; principal - } - | PStr [] -> - let s = { tag = ""; str = "" } in - { extid_loc - ; payload_loc = { extid_loc with loc_start = extid_loc.loc_end } - ; normal = s - ; principal = s - } - | _ -> invalid_payload () - in - Some expectation - | _ -> - None - -(* Split a list of phrases from a .ml file *) -let split_chunks phrases = - let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc = - match phrases with - | [] -> - if code_acc = [] then - (List.rev acc, None) - else - (List.rev acc, Some (List.rev code_acc)) - | phrase :: phrases -> - match phrase with - | Ptop_def [] -> loop phrases code_acc acc - | Ptop_def [{pstr_desc = Pstr_extension(ext, []); _}] -> begin - match match_expect_extension ext with - | None -> loop phrases (phrase :: code_acc) acc - | Some expectation -> - let chunk = - { phrases = List.rev code_acc - ; expectation - } - in - loop phrases [] (chunk :: acc) - end - | _ -> loop phrases (phrase :: code_acc) acc - in - loop phrases [] [] - -module Compiler_messages = struct - let print_loc ppf (loc : Location.t) = - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - Format.fprintf ppf "Line _"; - if startchar >= 0 then - Format.fprintf ppf ", characters %d-%d" startchar endchar; - Format.fprintf ppf ":@." - - let error_prefix = "Error" - - - let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)= - print_loc ppf loc; - Format.fprintf ppf "@{%s@}: %s" error_prefix msg; - List.iter sub ~f:(fun err -> - Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err) - - let capture ppf ~f = - Misc.protect_refs - [ R (Location.formatter_for_warnings , ppf ) - ; R (Location.error_reporter , error_reporter ) - ] - f -end - -let collect_formatters buf pps ~f = - List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; - let save = - List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps - in - let restore () = - List.iter2 - ~f:(fun pp out_functions -> - Format.pp_print_flush pp (); - Format.pp_set_formatter_out_functions pp out_functions) - pps save - in - let out_string str ofs len = Buffer.add_substring buf str ofs len - and out_flush = ignore - and out_newline () = Buffer.add_char buf '\n' - and out_spaces n = for _i = 1 to n do Buffer.add_char buf ' ' done - and out_indent n = for _i = 1 to n do Buffer.add_char buf ' ' done in - let out_functions = - { Format.out_string; out_flush; out_newline; out_spaces; out_indent } - in - List.iter - ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) - pps; - match f () with - | x -> restore (); x - | exception exn -> restore (); raise exn - -(* Invariant: ppf = Format.formatter_of_buffer buf *) -let capture_everything buf ppf ~f = - collect_formatters buf [Format.std_formatter; Format.err_formatter] - ~f:(fun () -> Compiler_messages.capture ppf ~f) - -let exec_phrase ppf phrase = - if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase; - if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; - Toploop.execute_phrase true ppf phrase - -let parse_contents ~fname contents = - let lexbuf = Lexing.from_string contents in - Location.init lexbuf fname; - Location.input_name := fname; - Parse.use_file lexbuf - -let eval_expectation expectation ~output = - let s = - if !Clflags.principal then - expectation.principal - else - expectation.normal - in - if s.str = output then - None - else - let s = { s with str = output } in - Some ( - if !Clflags.principal then - { expectation with principal = s } - else - { expectation with normal = s } - ) - -let preprocess_structure mappers str = - let open Ast_mapper in - List.fold_right - ~f:(fun ppx_rewriter str -> - let mapper : Ast_mapper.mapper = ppx_rewriter [] in - mapper.structure mapper str) - mappers - ~init:str - -let preprocess_phrase mappers phrase = - let open Parsetree in - match phrase with - | Ptop_def str -> Ptop_def (preprocess_structure mappers str) - | Ptop_dir _ as x -> x - - -let shift_lines delta = - let position (pos : Lexing.position) = - { pos with pos_lnum = pos.pos_lnum + delta } - in - let location _this (loc : Location.t) = - { loc with - loc_start = position loc.loc_start - ; loc_end = position loc.loc_end - } - in - fun _ -> { Ast_mapper.default_mapper with location } - -let rec min_line_number : Parsetree.toplevel_phrase list -> int option = -function - | [] -> None - | (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l - | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum - -let eval_expect_file mapper fname ~file_contents = - Warnings.reset_fatal (); - let chunks, trailing_code = - parse_contents ~fname:fname file_contents |> split_chunks - in - let buf = Buffer.create 1024 in - let ppf = Format.formatter_of_buffer buf in - let out_fun = Format.pp_get_formatter_out_functions ppf () in - Format.pp_set_formatter_out_functions Format.std_formatter out_fun; - - let exec_phrases phrases = - - let mappers = - match min_line_number phrases with - | None -> [] - | Some lnum -> [shift_lines (1 - lnum)] - in - let mappers = mapper :: mappers in - let phrases = List.map ~f:(preprocess_phrase mappers) phrases in - - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let _ : bool = - List.fold_left phrases ~init:true ~f:(fun acc phrase -> - acc && - try - exec_phrase ppf phrase - with exn -> - Location.report_exception ppf exn; - false) - in - Format.pp_print_flush ppf (); - let len = Buffer.length buf in - if len > 0 && Buffer.nth buf (len - 1) <> '\n' then - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let s = Buffer.contents buf in - Buffer.clear buf; - Misc.delete_eol_spaces s - in - let corrected_expectations = - capture_everything buf ppf ~f:(fun () -> - List.fold_left chunks ~init:[] ~f:(fun acc chunk -> - let output = exec_phrases chunk.phrases in - match eval_expectation chunk.expectation ~output with - | None -> acc - | Some correction -> correction :: acc) - |> List.rev) - in - let trailing_output = - match trailing_code with - | None -> "" - | Some phrases -> - capture_everything buf ppf ~f:(fun () -> exec_phrases phrases) - in - { corrected_expectations; trailing_output } - -let output_slice oc s a b = - output_string oc (String.sub s ~pos:a ~len:(b - a)) - -let output_corrected oc ~file_contents correction = - let output_body oc { str; tag } = - Printf.fprintf oc "{%s|%s|%s}" tag str tag - in - let ofs = - List.fold_left correction.corrected_expectations ~init:0 - ~f:(fun ofs c -> - output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum; - output_body oc c.normal; - if !Clflags.principal && c.normal.str <> c.principal.str then begin - output_string oc ", Principal"; - output_body oc c.principal - end; - c.payload_loc.loc_end.pos_cnum) - in - output_slice oc file_contents ofs (String.length file_contents); - match correction.trailing_output with - | "" -> () - | s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s - -let write_corrected ~file ~file_contents correction = - let oc = open_out file in - output_corrected oc ~file_contents correction; - close_out oc - -let process_expect_file mapper fname = - let corrected_fname = fname ^ ".corrected" in - let file_contents = - let ic = open_in_bin fname in - match really_input_string ic (in_channel_length ic) with - | s -> close_in ic; Misc.normalise_eol s - | exception e -> close_in ic; raise e - in - let correction = eval_expect_file mapper fname ~file_contents in - write_corrected ~file:corrected_fname ~file_contents correction - -let repo_root = ref "" - -let main mapper fname = - Toploop.override_sys_argv - (Array.sub Sys.argv ~pos:!Arg.current - ~len:(Array.length Sys.argv - !Arg.current)); - (* Ignore OCAMLRUNPARAM=b to be reproducible *) - Printexc.record_backtrace false; - List.iter [ "stdlib" ] ~f:(fun s -> - Topdirs.dir_directory (Filename.concat !repo_root s)); - Toploop.initialize_toplevel_env (); - Sys.interactive := false; - process_expect_file mapper fname; - exit 0 - -let args = - Arg.align - [ "-repo-root", Set_string repo_root, - " root of the OCaml repository" - ; "-principal", Set Clflags.principal, - " Evaluate the file with -principal set" - ] - -let usage = "Usage: expect_test [script-file [arguments]]\n\ - options are:" - -let run mapper = - try - Arg.parse args (main mapper) usage; - Printf.eprintf "expect_test: no input file\n"; - exit 2 - with exn -> - Location.report_exception Format.err_formatter exn; - exit 2 diff --git a/tools/toplevel_expect/toplevel_expect_test.ml-4.07 b/tools/toplevel_expect/toplevel_expect_test.ml-4.07 deleted file mode 100644 index 8b73bcbde5..0000000000 --- a/tools/toplevel_expect/toplevel_expect_test.ml-4.07 +++ /dev/null @@ -1,382 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Jeremie Dimino, Jane Street Europe *) -(* *) -(* Copyright 2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Execute a list of phrases from a .ml file and compare the result to the - expected output, written inside [%%expect ...] nodes. At the end, create - a .corrected file containing the corrected expectations. The test is - successful if there is no differences between the two files. - - An [%%expect] node always contains both the expected outcome with and - without -principal. When the two differ the expectation is written as - follows: - - {[ - [%%expect {| - output without -principal - |}, Principal{| - output with -principal - |}] - ]} -*) - -[@@@ocaml.warning "-40"] - -open StdLabels - -(* representation of: {tag|str|tag} *) -type string_constant = - { str : string - ; tag : string - } - -type expectation = - { extid_loc : Location.t (* Location of "expect" in "[%%expect ...]" *) - ; payload_loc : Location.t (* Location of the whole payload *) - ; normal : string_constant (* expectation without -principal *) - ; principal : string_constant (* expectation with -principal *) - } - -(* A list of phrases with the expected toplevel output *) -type chunk = - { phrases : Parsetree.toplevel_phrase list - ; expectation : expectation - } - -type correction = - { corrected_expectations : expectation list - ; trailing_output : string - } - -let match_expect_extension (ext : Parsetree.extension) = - match ext with - | ({Asttypes.txt="expect"|"ocaml.expect"; loc = extid_loc}, payload) -> - let invalid_payload () = - Location.raise_errorf ~loc:extid_loc - "invalid [%%%%expect payload]" - in - let string_constant (e : Parsetree.expression) = - match e.pexp_desc with - | Pexp_constant (Pconst_string (str, Some tag)) -> - { str; tag } - | _ -> invalid_payload () - in - let expectation = - match payload with - | PStr [{ pstr_desc = Pstr_eval (e, []); _ }] -> - let normal, principal = - match e.pexp_desc with - | Pexp_tuple - [ a - ; { pexp_desc = Pexp_construct - ({ txt = Lident "Principal"; _ }, Some b); _ } - ] -> - (string_constant a, string_constant b) - | _ -> let s = string_constant e in (s, s) - in - { extid_loc - ; payload_loc = e.pexp_loc - ; normal - ; principal - } - | PStr [] -> - let s = { tag = ""; str = "" } in - { extid_loc - ; payload_loc = { extid_loc with loc_start = extid_loc.loc_end } - ; normal = s - ; principal = s - } - | _ -> invalid_payload () - in - Some expectation - | _ -> - None - -(* Split a list of phrases from a .ml file *) -let split_chunks phrases = - let rec loop (phrases : Parsetree.toplevel_phrase list) code_acc acc = - match phrases with - | [] -> - if code_acc = [] then - (List.rev acc, None) - else - (List.rev acc, Some (List.rev code_acc)) - | phrase :: phrases -> - match phrase with - | Ptop_def [] -> loop phrases code_acc acc - | Ptop_def [{pstr_desc = Pstr_extension(ext, []); _}] -> begin - match match_expect_extension ext with - | None -> loop phrases (phrase :: code_acc) acc - | Some expectation -> - let chunk = - { phrases = List.rev code_acc - ; expectation - } - in - loop phrases [] (chunk :: acc) - end - | _ -> loop phrases (phrase :: code_acc) acc - in - loop phrases [] [] - -module Compiler_messages = struct - let print_loc ppf (loc : Location.t) = - let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in - let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in - Format.fprintf ppf "Line _"; - if startchar >= 0 then - Format.fprintf ppf ", characters %d-%d" startchar endchar; - Format.fprintf ppf ":@." - - let error_prefix = "Error" - - - let rec error_reporter ppf ({loc; msg; sub; if_highlight=_} : Location.error)= - print_loc ppf loc; - Format.fprintf ppf "@{%s@}: %s" error_prefix msg; - List.iter sub ~f:(fun err -> - Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err) - - let capture ppf ~f = - Misc.protect_refs - [ R (Location.formatter_for_warnings , ppf ) - ; R (Location.error_reporter , error_reporter ) - ] - f -end - -let collect_formatters buf pps ~f = - List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; - let save = - List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps - in - let restore () = - List.iter2 - ~f:(fun pp out_functions -> - Format.pp_print_flush pp (); - Format.pp_set_formatter_out_functions pp out_functions) - pps save - in - let out_string str ofs len = Buffer.add_substring buf str ofs len - and out_flush = ignore - and out_newline () = Buffer.add_char buf '\n' - and out_spaces n = for _i = 1 to n do Buffer.add_char buf ' ' done - and out_indent n = for _i = 1 to n do Buffer.add_char buf ' ' done in - let out_functions = - { Format.out_string; out_flush; out_newline; out_spaces; out_indent } - in - List.iter - ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) - pps; - match f () with - | x -> restore (); x - | exception exn -> restore (); raise exn - -(* Invariant: ppf = Format.formatter_of_buffer buf *) -let capture_everything buf ppf ~f = - collect_formatters buf [Format.std_formatter; Format.err_formatter] - ~f:(fun () -> Compiler_messages.capture ppf ~f) - -let exec_phrase ppf phrase = - if !Clflags.dump_parsetree then Printast. top_phrase ppf phrase; - if !Clflags.dump_source then Pprintast.top_phrase ppf phrase; - Toploop.execute_phrase true ppf phrase - -let parse_contents ~fname contents = - let lexbuf = Lexing.from_string contents in - Location.init lexbuf fname; - Location.input_name := fname; - Parse.use_file lexbuf - -let eval_expectation expectation ~output = - let s = - if !Clflags.principal then - expectation.principal - else - expectation.normal - in - if s.str = output then - None - else - let s = { s with str = output } in - Some ( - if !Clflags.principal then - { expectation with principal = s } - else - { expectation with normal = s } - ) - -let preprocess_structure mappers str = - let open Ast_mapper in - List.fold_right - ~f:(fun ppx_rewriter str -> - let mapper : Ast_mapper.mapper = ppx_rewriter [] in - mapper.structure mapper str) - mappers - ~init:str - -let preprocess_phrase mappers phrase = - let open Parsetree in - match phrase with - | Ptop_def str -> Ptop_def (preprocess_structure mappers str) - | Ptop_dir _ as x -> x - - -let shift_lines delta = - let position (pos : Lexing.position) = - { pos with pos_lnum = pos.pos_lnum + delta } - in - let location _this (loc : Location.t) = - { loc with - loc_start = position loc.loc_start - ; loc_end = position loc.loc_end - } - in - fun _ -> { Ast_mapper.default_mapper with location } - -let rec min_line_number : Parsetree.toplevel_phrase list -> int option = -function - | [] -> None - | (Ptop_dir _ | Ptop_def []) :: l -> min_line_number l - | Ptop_def (st :: _) :: _ -> Some st.pstr_loc.loc_start.pos_lnum - -let eval_expect_file mapper fname ~file_contents = - Warnings.reset_fatal (); - let chunks, trailing_code = - parse_contents ~fname:fname file_contents |> split_chunks - in - let buf = Buffer.create 1024 in - let ppf = Format.formatter_of_buffer buf in - let out_fun = Format.pp_get_formatter_out_functions ppf () in - Format.pp_set_formatter_out_functions Format.std_formatter out_fun; - - let exec_phrases phrases = - - let mappers = - match min_line_number phrases with - | None -> [] - | Some lnum -> [shift_lines (1 - lnum)] - in - let mappers = mapper :: mappers in - let phrases = List.map ~f:(preprocess_phrase mappers) phrases in - - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let _ : bool = - List.fold_left phrases ~init:true ~f:(fun acc phrase -> - acc && - try - exec_phrase ppf phrase - with exn -> - Location.report_exception ppf exn; - false) - in - Format.pp_print_flush ppf (); - let len = Buffer.length buf in - if len > 0 && Buffer.nth buf (len - 1) <> '\n' then - (* For formatting purposes *) - Buffer.add_char buf '\n'; - let s = Buffer.contents buf in - Buffer.clear buf; - Misc.delete_eol_spaces s - in - let corrected_expectations = - capture_everything buf ppf ~f:(fun () -> - List.fold_left chunks ~init:[] ~f:(fun acc chunk -> - let output = exec_phrases chunk.phrases in - match eval_expectation chunk.expectation ~output with - | None -> acc - | Some correction -> correction :: acc) - |> List.rev) - in - let trailing_output = - match trailing_code with - | None -> "" - | Some phrases -> - capture_everything buf ppf ~f:(fun () -> exec_phrases phrases) - in - { corrected_expectations; trailing_output } - -let output_slice oc s a b = - output_string oc (String.sub s ~pos:a ~len:(b - a)) - -let output_corrected oc ~file_contents correction = - let output_body oc { str; tag } = - Printf.fprintf oc "{%s|%s|%s}" tag str tag - in - let ofs = - List.fold_left correction.corrected_expectations ~init:0 - ~f:(fun ofs c -> - output_slice oc file_contents ofs c.payload_loc.loc_start.pos_cnum; - output_body oc c.normal; - if !Clflags.principal && c.normal.str <> c.principal.str then begin - output_string oc ", Principal"; - output_body oc c.principal - end; - c.payload_loc.loc_end.pos_cnum) - in - output_slice oc file_contents ofs (String.length file_contents); - match correction.trailing_output with - | "" -> () - | s -> Printf.fprintf oc "\n[%%%%expect{|%s|}]\n" s - -let write_corrected ~file ~file_contents correction = - let oc = open_out file in - output_corrected oc ~file_contents correction; - close_out oc - -let process_expect_file mapper fname = - let corrected_fname = fname ^ ".corrected" in - let file_contents = - let ic = open_in_bin fname in - match really_input_string ic (in_channel_length ic) with - | s -> close_in ic; Misc.normalise_eol s - | exception e -> close_in ic; raise e - in - let correction = eval_expect_file mapper fname ~file_contents in - write_corrected ~file:corrected_fname ~file_contents correction - -let repo_root = ref "" - -let main mapper fname = - Toploop.override_sys_argv - (Array.sub Sys.argv ~pos:!Arg.current - ~len:(Array.length Sys.argv - !Arg.current)); - (* Ignore OCAMLRUNPARAM=b to be reproducible *) - Printexc.record_backtrace false; - List.iter [ "stdlib" ] ~f:(fun s -> - Topdirs.dir_directory (Filename.concat !repo_root s)); - Toploop.initialize_toplevel_env (); - Sys.interactive := false; - process_expect_file mapper fname; - exit 0 - -let args = - Arg.align - [ "-repo-root", Set_string repo_root, - " root of the OCaml repository" - ; "-principal", Set Clflags.principal, - " Evaluate the file with -principal set" - ] - -let usage = "Usage: expect_test [script-file [arguments]]\n\ - options are:" - -let run mapper = - try - Arg.parse args (main mapper) usage; - Printf.eprintf "expect_test: no input file\n"; - exit 2 - with exn -> - Location.report_exception Format.err_formatter exn; - exit 2