WIP: fix for ocaml trunk

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

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

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 = "<string>" in

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

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

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
 

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
 

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"

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