From d45e7e45aad8c4fd7d2ac27bcb168ea4259cec99 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Fri, 4 Aug 2023 17:21:36 +0200 Subject: [PATCH] WIP: fix for ocaml trunk --- .../js_of_ocaml_compiler_dynlink.ml | 6 +- compiler/lib-runtime-files/gen/gen.ml | 2 +- compiler/lib/linker.ml | 6 +- compiler/lib/ocaml_compiler.ml | 13 ++ compiler/lib/ocaml_compiler.mli | 2 +- compiler/lib/parse_bytecode.ml | 30 +++- compiler/tests-check-prim/unix-unix.output5 | 2 + .../tests-toplevel/test_toplevel.reference | 2 +- lib/tests/test_fun_call.ml | 22 ++- ppx/ppx_deriving_json/tests/gen.mlt | 161 +++++++++--------- runtime/domain.js | 26 ++- runtime/gc.js | 4 + runtime/io.js | 33 +++- .../toplevel_expect_test.ml-default | 1 + 14 files changed, 197 insertions(+), 113 deletions(-) diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 9bf10680d9..04b7535c23 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -20,9 +20,9 @@ let () = Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ()); Config.Flag.set "effects" (Jsoo_runtime.Sys.Config.effects ()); (* this needs to stay synchronized with toplevel.js *) - let toplevel_compile (s : bytes array) (debug : Instruct.debug_event list array) : - unit -> J.t = - let s = String.concat ~sep:"" (List.map ~f:Bytes.to_string (Array.to_list s)) in + let toplevel_compile (s : _ Bigarray.Array1.t) (debug : Instruct.debug_event list array) + : unit -> J.t = + let s = String.init (Bigarray.Array1.dim s) ~f:(fun i -> Bigarray.Array1.get s i) in let prims = split_primitives (Symtable.data_primitive_names ()) in let b = Buffer.create 100 in let fmt = Pretty_print.to_buffer b in diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index 0acc8b2821..c41325f20b 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -88,7 +88,7 @@ let () = let %s = Js_of_ocaml_compiler.Builtins.register ~name:%S ~content:{frag|%s|frag} - ~fragments:(Some {frag|%s|frag}) + ~fragments:(Some %S) |} (to_ident (Filename.chop_extension name)) name diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index a33687e5f2..8992e00f39 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -318,7 +318,11 @@ module Fragment = struct | None -> let lex = Parse_js.Lexer.of_string ~filename content in parse_from_lex ~filename lex - | Some fragments -> Marshal.from_string fragments 0 + | Some fragments -> ( + try Marshal.from_string fragments 0 + with e -> + Printf.eprintf "failed to unmarshall %S\n%S\n" filename (Printexc.to_string e); + raise e) let parse_string string = let filename = "" in diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 60b6923fc1..1aa919d5cf 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -194,6 +194,19 @@ module Symtable = struct let get i = Char.code (Bytes.get buf i) in let n = get 0 + (get 1 lsl 8) + (get 2 lsl 16) + (get 3 lsl 24) in n + [@@if ocaml_version < (5, 2, 0)] + + let reloc_ident name = + let buf = Bigarray.(Array1.create char c_layout 4) in + let () = + try Symtable.patch_object buf [ reloc_get_of_string name, 0 ] + with _ -> Symtable.patch_object buf [ reloc_set_of_string name, 0 ] + in + + let get i = Char.code (Bigarray.Array1.get buf i) in + let n = get 0 + (get 1 lsl 8) + (get 2 lsl 16) + (get 3 lsl 24) in + n + [@@if ocaml_version >= (5, 2, 0)] let current_state () : GlobalMap.t = let x : Symtable.global_map = Symtable.current_state () in diff --git a/compiler/lib/ocaml_compiler.mli b/compiler/lib/ocaml_compiler.mli index da83ac43f0..f7890eb36a 100644 --- a/compiler/lib/ocaml_compiler.mli +++ b/compiler/lib/ocaml_compiler.mli @@ -55,7 +55,7 @@ end module Ident : sig type 'a tbl = 'a Ident.tbl - val table_contents : int Ident.tbl -> (int * Ident.t) list + val table_contents : 'a Ident.tbl -> ('a * Ident.t) list end module Cmo_format : sig diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index de63754ad5..30414b4a75 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -267,11 +267,33 @@ end = struct let find_rec { events_by_pc; _ } pc = try let { event; _ } = Int_table.find events_by_pc pc in - Ocaml_compiler.Ident.table_contents event.ev_compenv.ce_rec - |> List.map ~f:(fun (i, ident) -> - (if new_closure_repr then i / 3 else i / 2), ident) - |> List.sort ~cmp:(fun (i, _) (j, _) -> compare i j) + let env = event.ev_compenv in + let names = + Ocaml_compiler.Ident.table_contents env.ce_rec + |> List.map ~f:(fun (i, ident) -> + (if new_closure_repr then i / 3 else i / 2), ident) + in + List.sort names ~cmp:(fun (i, _) (j, _) -> compare i j) + with Not_found -> [] + [@@if ocaml_version < (5, 2, 0)] + + let find_rec { events_by_pc; _ } pc = + try + let { event; _ } = Int_table.find events_by_pc pc in + let env = event.ev_compenv in + let names = + match env.ce_closure with + | Not_in_closure -> raise Not_found + | In_closure { entries; _ } -> + Ocaml_compiler.Ident.table_contents entries + |> List.filter_map ~f:(fun (ent, ident) -> + match ent with + | Function i -> Some (i / 3, ident) + | Free_variable _ -> None) + in + List.sort names ~cmp:(fun (i, _) (j, _) -> compare i j) with Not_found -> [] + [@@if ocaml_version >= (5, 2, 0)] let mem { events_by_pc; _ } pc = Int_table.mem events_by_pc pc diff --git a/compiler/tests-check-prim/unix-unix.output5 b/compiler/tests-check-prim/unix-unix.output5 index 7452e7d18c..38bab3f39a 100644 --- a/compiler/tests-check-prim/unix-unix.output5 +++ b/compiler/tests-check-prim/unix-unix.output5 @@ -99,6 +99,7 @@ caml_unix_outchannel_of_filedescr caml_unix_pipe caml_unix_putenv caml_unix_read +caml_unix_read_bigarray caml_unix_realpath caml_unix_recv caml_unix_recvfrom @@ -138,6 +139,7 @@ caml_unix_utimes caml_unix_wait caml_unix_waitpid caml_unix_write +caml_unix_write_bigarray debugger is_digit_normalized diff --git a/compiler/tests-toplevel/test_toplevel.reference b/compiler/tests-toplevel/test_toplevel.reference index 3ab394a970..7547e41707 100644 --- a/compiler/tests-toplevel/test_toplevel.reference +++ b/compiler/tests-toplevel/test_toplevel.reference @@ -2,4 +2,4 @@ hello Line 3, characters 2-4: Error: Syntax error Line 4, characters 0-16: -Error: Unbound module Missing_module +Error: Unbound module "Missing_module" diff --git a/lib/tests/test_fun_call.ml b/lib/tests/test_fun_call.ml index 888246dd20..7d0677e5c4 100644 --- a/lib/tests/test_fun_call.ml +++ b/lib/tests/test_fun_call.ml @@ -147,7 +147,7 @@ let%expect_test "wrap_callback_strict" = (Js.Unsafe.callback_with_arity 2 cb3) {| (function(f){ return f(1,2,3) }) |}; [%expect {| - Result: function#1#1 |}]; + Result: function#1#undefined |}]; call_and_log (Js.Unsafe.callback_with_arity 2 cb3) ~cont:(fun g -> g 4) @@ -164,7 +164,7 @@ let%expect_test "wrap_callback_strict" = Result: 0 |}]; call_and_log (Js.Unsafe.callback_with_arity 2 cb3) {| (function(f){ return f(1,2) }) |}; [%expect {| - Result: function#1#1 |}] + Result: function#1#undefined |}] let%expect_test "wrap_callback_strict" = call_and_log @@ -291,7 +291,7 @@ let%expect_test "wrap_meth_callback_strict" = (Js.Unsafe.meth_callback_with_arity 2 cb4) {| (function(f){ return f.apply("this",[1,2,3]) }) |}; [%expect {| - Result: function#1#1 |}]; + Result: function#1#undefined |}]; call_and_log (Js.Unsafe.meth_callback_with_arity 2 cb4) ~cont:(fun g -> g 4) @@ -309,7 +309,7 @@ let%expect_test "wrap_meth_callback_strict" = call_and_log (Js.Unsafe.meth_callback_with_arity 2 cb4) {| (function(f){ return f.apply("this",[1,2]) }) |}; - [%expect {| Result: function#1#1 |}] + [%expect {| Result: function#1#undefined |}] let%expect_test "wrap_meth_callback_strict" = call_and_log @@ -338,23 +338,21 @@ let%expect_test "over application, extra arguments are dropped" = (Js.Unsafe.meth_callback cb4) {| (function(f){ return f.apply("this",[1,2,3,4]) }) |}; [%expect {| - got this, 1, 2, 3, done - Result: 0 |}] + Result: function#1#undefined |}] let%expect_test "partial application, extra arguments set to undefined" = call_and_log (Js.Unsafe.meth_callback cb4) {| (function(f){ return f.apply("this",[1,2]) }) |}; [%expect {| - got this, 1, 2, undefined, done - Result: 0 |}] + Result: function#1#undefined |}] (* caml_call_gen *) let%expect_test _ = call_and_log cb3 ~cont:(fun g -> g 1) {| (function(f){ return f }) |}; [%expect {| - Result: function#2#2 |}] + Result: function#1#undefined |}] let%expect_test _ = call_and_log cb3 ~cont:(fun g -> g 1 2 3 4) {| (function(f){ return f }) |}; @@ -369,7 +367,7 @@ let%expect_test _ = | _ -> Printf.printf "Error: unknown" in f cb5; - [%expect {| Result: function#1#1 |}]; + [%expect {| Result: function#1#undefined |}]; f cb4; [%expect {| got 1, 1, 2, 3, done @@ -399,10 +397,10 @@ let%expect_test _ = Result: 0 |}]; f (Obj.magic cb4); [%expect {| - Result: function#1#1 |}]; + Result: function#1#undefined |}]; f (Obj.magic cb5); [%expect {| - Result: function#2#2 |}] + Result: function#1#undefined |}] let%expect_test _ = let open Js_of_ocaml in diff --git a/ppx/ppx_deriving_json/tests/gen.mlt b/ppx/ppx_deriving_json/tests/gen.mlt index 80a3abe287..07df9cfea5 100644 --- a/ppx/ppx_deriving_json/tests/gen.mlt +++ b/ppx/ppx_deriving_json/tests/gen.mlt @@ -180,7 +180,6 @@ type variant1 = [%%expect {| - type variant1 = | A | B @@ -203,14 +202,14 @@ include let _ = variant1_of_json let rec variant1_to_json : Buffer.t -> variant1 -> unit = fun buf -> - function - | D a -> - (Buffer.add_string buf "[0"; - (Buffer.add_string buf ","; variant1_to_json buf a); - Buffer.add_string buf "]") - | C -> Deriving_Json.Json_int.write buf 2 - | B -> Deriving_Json.Json_int.write buf 1 - | A -> Deriving_Json.Json_int.write buf 0 + (function + | D a -> + (Buffer.add_string buf "[0"; + (Buffer.add_string buf ","; variant1_to_json buf a); + Buffer.add_string buf "]") + | C -> Deriving_Json.Json_int.write buf 2 + | B -> Deriving_Json.Json_int.write buf 1 + | A -> Deriving_Json.Json_int.write buf 0) let _ = variant1_to_json let variant1_json : variant1 Deriving_Json.t = Deriving_Json.make variant1_to_json variant1_of_json @@ -229,7 +228,6 @@ type variant2 = [%%expect {| - type variant2 = | D of string | E of variant1 [@@deriving json] @@ -251,16 +249,16 @@ include let _ = variant2_of_json let rec variant2_to_json : Buffer.t -> variant2 -> unit = fun buf -> - function - | E a -> - (Buffer.add_string buf "[1"; - (Buffer.add_string buf ","; variant1_to_json buf a); - Buffer.add_string buf "]") - | D a -> - (Buffer.add_string buf "[0"; - (Buffer.add_string buf ","; - Deriving_Json.Json_string.write buf a); - Buffer.add_string buf "]") + (function + | E a -> + (Buffer.add_string buf "[1"; + (Buffer.add_string buf ","; variant1_to_json buf a); + Buffer.add_string buf "]") + | D a -> + (Buffer.add_string buf "[0"; + (Buffer.add_string buf ","; + Deriving_Json.Json_string.write buf a); + Buffer.add_string buf "]")) let _ = variant2_to_json let variant2_json : variant2 Deriving_Json.t = Deriving_Json.make variant2_to_json variant2_of_json @@ -330,7 +328,6 @@ type poly1 = [%%expect {| - type poly1 = [ `A | `B of string ][@@deriving json] include struct @@ -342,13 +339,13 @@ include Deriving_Json_lexer.lexbuf -> [ `NCst of int | `Cst of int ] -> poly1 = fun buf -> - function - | `Cst 65 -> `A - | `NCst 66 -> - (Deriving_Json_lexer.read_comma buf; - (let v = Deriving_Json.Json_string.read buf in - Deriving_Json_lexer.read_rbracket buf; `B v)) - | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf + (function + | `Cst 65 -> `A + | `NCst 66 -> + (Deriving_Json_lexer.read_comma buf; + (let v = Deriving_Json.Json_string.read buf in + Deriving_Json_lexer.read_rbracket buf; `B v)) + | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf) and poly1_of_json : Deriving_Json_lexer.lexbuf -> poly1 = fun buf -> poly1_of_json_with_tag buf (Deriving_Json_lexer.read_vcase buf) @@ -389,7 +386,6 @@ type poly2 = [%%expect {| - type poly2 = [ | poly1 | `C of int ][@@deriving json] include struct @@ -404,14 +400,14 @@ include Deriving_Json_lexer.lexbuf -> [ `NCst of int | `Cst of int ] -> poly2 = fun buf -> - function - | x when poly1_recognize x -> - (poly1_of_json_with_tag buf x :> [ | poly1 | `C of int ]) - | `NCst 67 -> - (Deriving_Json_lexer.read_comma buf; - (let v = Deriving_Json.Json_int.read buf in - Deriving_Json_lexer.read_rbracket buf; `C v)) - | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf + (function + | x when poly1_recognize x -> + (poly1_of_json_with_tag buf x :> [ | poly1 | `C of int ]) + | `NCst 67 -> + (Deriving_Json_lexer.read_comma buf; + (let v = Deriving_Json.Json_int.read buf in + Deriving_Json_lexer.read_rbracket buf; `C v)) + | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf) and poly2_of_json : Deriving_Json_lexer.lexbuf -> poly2 = fun buf -> poly2_of_json_with_tag buf (Deriving_Json_lexer.read_vcase buf) @@ -454,7 +450,6 @@ type inline_record = [%%expect {| - type inline_record = | I of { name: string ; @@ -482,19 +477,19 @@ include let _ = inline_record_of_json let rec inline_record_to_json : Buffer.t -> inline_record -> unit = fun buf -> - function - | J { empty } -> - (Buffer.add_string buf "[1"; - (Buffer.add_string buf ","; - Deriving_Json.Json_unit.write buf empty); - Buffer.add_string buf "]") - | I { name; age } -> - (Buffer.add_string buf "[0"; - ((Buffer.add_string buf ","; - Deriving_Json.Json_string.write buf name); - Buffer.add_string buf ","; - Deriving_Json.Json_int.write buf age); - Buffer.add_string buf "]") + (function + | J { empty } -> + (Buffer.add_string buf "[1"; + (Buffer.add_string buf ","; + Deriving_Json.Json_unit.write buf empty); + Buffer.add_string buf "]") + | I { name; age } -> + (Buffer.add_string buf "[0"; + ((Buffer.add_string buf ","; + Deriving_Json.Json_string.write buf name); + Buffer.add_string buf ","; + Deriving_Json.Json_int.write buf age); + Buffer.add_string buf "]")) let _ = inline_record_to_json let inline_record_json : inline_record Deriving_Json.t = Deriving_Json.make inline_record_to_json inline_record_of_json @@ -613,7 +608,6 @@ val json : type t = A | B [@@deriving json] [%%expect {| - type t = | A | B [@@deriving json] @@ -629,9 +623,9 @@ include let _ = of_json let rec to_json : Buffer.t -> t -> unit = fun buf -> - function - | B -> Deriving_Json.Json_int.write buf 1 - | A -> Deriving_Json.Json_int.write buf 0 + (function + | B -> Deriving_Json.Json_int.write buf 1 + | A -> Deriving_Json.Json_int.write buf 0) let _ = to_json let json : t Deriving_Json.t = Deriving_Json.make to_json of_json let _ = json @@ -726,7 +720,6 @@ type poly3 = [%%expect {| - type poly3 = [ | poly1 | `C of [ `p1 of poly1 | `p2 of poly2 | `p3 of poly3 ] ] [@@deriving json] @@ -743,34 +736,34 @@ include Deriving_Json_lexer.lexbuf -> [ `NCst of int | `Cst of int ] -> poly3 = fun buf -> - function - | x when poly1_recognize x -> - (poly1_of_json_with_tag buf x :> [ | poly1 - | `C of - [ `p1 of poly1 - | `p2 of poly2 - | `p3 of poly3 ] ]) - | `NCst 67 -> - (Deriving_Json_lexer.read_comma buf; - (let v = - (fun buf -> - function - | `NCst 25025 -> - (Deriving_Json_lexer.read_comma buf; - (let v = poly1_of_json buf in - Deriving_Json_lexer.read_rbracket buf; `p1 v)) - | `NCst 25026 -> - (Deriving_Json_lexer.read_comma buf; - (let v = poly2_of_json buf in - Deriving_Json_lexer.read_rbracket buf; `p2 v)) - | `NCst 25027 -> - (Deriving_Json_lexer.read_comma buf; - (let v = poly3_of_json buf in - Deriving_Json_lexer.read_rbracket buf; `p3 v)) - | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf) buf - (Deriving_Json_lexer.read_vcase buf) in - Deriving_Json_lexer.read_rbracket buf; `C v)) - | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf + (function + | x when poly1_recognize x -> + (poly1_of_json_with_tag buf x :> [ | poly1 + | `C of + [ `p1 of poly1 + | `p2 of poly2 + | `p3 of poly3 ] ]) + | `NCst 67 -> + (Deriving_Json_lexer.read_comma buf; + (let v = + (fun buf -> + (function + | `NCst 25025 -> + (Deriving_Json_lexer.read_comma buf; + (let v = poly1_of_json buf in + Deriving_Json_lexer.read_rbracket buf; `p1 v)) + | `NCst 25026 -> + (Deriving_Json_lexer.read_comma buf; + (let v = poly2_of_json buf in + Deriving_Json_lexer.read_rbracket buf; `p2 v)) + | `NCst 25027 -> + (Deriving_Json_lexer.read_comma buf; + (let v = poly3_of_json buf in + Deriving_Json_lexer.read_rbracket buf; `p3 v)) + | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf)) + buf (Deriving_Json_lexer.read_vcase buf) in + Deriving_Json_lexer.read_rbracket buf; `C v)) + | _ -> Deriving_Json_lexer.tag_error ~typename:"" buf) and poly3_of_json : Deriving_Json_lexer.lexbuf -> poly3 = fun buf -> poly3_of_json_with_tag buf (Deriving_Json_lexer.read_vcase buf) diff --git a/runtime/domain.js b/runtime/domain.js index b4c2921625..9ee76edd52 100644 --- a/runtime/domain.js +++ b/runtime/domain.js @@ -42,6 +42,11 @@ function caml_atomic_exchange(ref, v) { return r; } +//Provides: caml_atomic_make_contended +function caml_atomic_make_contended(a) { + return [0, a] +} + //Provides: caml_ml_domain_unique_token var caml_ml_domain_unique_token_ = [0] function caml_ml_domain_unique_token(unit) { @@ -65,12 +70,31 @@ var caml_domain_id = 0; //Requires: caml_ml_mutex_unlock //Requires: caml_domain_id //Requires: caml_callback +//Version: >= 5.2 +var caml_domain_latest_idx = 1 +function caml_domain_spawn(f,term_sync){ + var id = caml_domain_latest_idx++; + var old = caml_domain_id; + caml_domain_id = id; + var res = caml_callback(f,[0]); + caml_domain_id = old; + caml_ml_mutex_unlock(term_sync[2]); + //TODO: fix exn case + term_sync[1] = [0, [0, res]]; + return id; +} + +//Provides: caml_domain_spawn +//Requires: caml_ml_mutex_unlock +//Requires: caml_domain_id +//Requires: caml_callback +//Version: < 5.2 var caml_domain_latest_idx = 1 function caml_domain_spawn(f,mutex){ var id = caml_domain_latest_idx++; var old = caml_domain_id; caml_domain_id = id; - caml_callback(f,[0]); + var res = caml_callback(f,[0]); caml_domain_id = old; caml_ml_mutex_unlock(mutex); return id; diff --git a/runtime/gc.js b/runtime/gc.js index a38ed480e0..90161249f0 100644 --- a/runtime/gc.js +++ b/runtime/gc.js @@ -75,6 +75,9 @@ function caml_memprof_stop(unit) { return 0; } +//Provides: caml_memprof_discard +function caml_memprof_discard(t) { return 0 } + //Provides: caml_eventlog_resume function caml_eventlog_resume(unit) { return 0; } @@ -98,3 +101,4 @@ function caml_get_major_bucket(n) { return 0; } //Provides: caml_get_major_credit function caml_get_major_credit(n) { return 0; } + diff --git a/runtime/io.js b/runtime/io.js index d8ed88fcbf..0b07eb74bc 100644 --- a/runtime/io.js +++ b/runtime/io.js @@ -262,6 +262,14 @@ function caml_ml_input (chanid, b, i, l) { return caml_ml_input_block(chanid, ba, i, l) } +//Provides: caml_ml_input_bigarray +//Requires: caml_ml_input_block +//Requires: caml_ba_to_typed_array +function caml_ml_input_bigarray (chanid, b, i, l) { + var ba = caml_ba_to_typed_array(b); + return caml_ml_input_block(chanid, ba, i, l) +} + //Provides: caml_ml_input_block //Requires: caml_refill, caml_ml_channels function caml_ml_input_block (chanid, ba, i, l) { @@ -458,14 +466,12 @@ function caml_ml_flush (chanid) { //output to out_channel -//Provides: caml_ml_output_bytes +//Provides: caml_ml_output_ta //Requires: caml_ml_flush,caml_ml_bytes_length -//Requires: caml_create_bytes, caml_blit_bytes, caml_raise_sys_error, caml_ml_channels, caml_string_of_bytes -//Requires: caml_uint8_array_of_bytes -function caml_ml_output_bytes(chanid,buffer,offset,len) { +//Requires: caml_raise_sys_error, caml_ml_channels +function caml_ml_output_ta(chanid,buffer,offset,len) { var chan = caml_ml_channels[chanid]; if(! chan.opened) caml_raise_sys_error("Cannot output to a closed channel"); - var buffer = caml_uint8_array_of_bytes(buffer); buffer = buffer.subarray(offset, offset + len); if(chan.buffer_curr + buffer.length > chan.buffer.length) { var b = new Uint8Array(chan.buffer_curr + buffer.length); @@ -504,6 +510,23 @@ function caml_ml_output_bytes(chanid,buffer,offset,len) { return 0; } +//Provides: caml_ml_output_bytes +//Requires: caml_uint8_array_of_bytes, caml_ml_output_ta +function caml_ml_output_bytes(chanid,buffer,offset,len) { + var buffer = caml_uint8_array_of_bytes(buffer); + return caml_ml_output_ta(chanid,buffer,offset,len); +} + + +//Provides: caml_ml_output_bigarray +//Requires: caml_ba_to_typed_array, caml_ml_output_ta +function caml_ml_output_bigarray(chanid,buffer,offset,len) { + var buffer = caml_ba_to_typed_array(buffer); + return caml_ml_output_ta(chanid,buffer,offset,len); +} + + + //Provides: caml_ml_output //Requires: caml_ml_output_bytes, caml_bytes_of_string function caml_ml_output(chanid,buffer,offset,len){ diff --git a/tools/toplevel_expect/toplevel_expect_test.ml-default b/tools/toplevel_expect/toplevel_expect_test.ml-default index 702e512a96..303a969fe5 100644 --- a/tools/toplevel_expect/toplevel_expect_test.ml-default +++ b/tools/toplevel_expect/toplevel_expect_test.ml-default @@ -279,6 +279,7 @@ let eval_expect_file mapper fname ~file_contents = List.fold_left phrases ~init:true ~f:(fun acc phrase -> acc && try + Location.reset (); exec_phrase ppf phrase with exn -> Location.report_exception ppf exn;