5.0 support

shadow-stdlib/gen/mapper.mll

@@ -2,15 +2,6 @@
 open StdLabels
 open Printf
 
-module String = struct
-  [@@@warning "-32-3"]
-  let capitalize_ascii   = String.capitalize
-  let uncapitalize_ascii = String.uncapitalize
-  let uppercase_ascii    = String.uppercase
-  let lowercase_ascii    = String.lowercase
-  include String
-end
-
 let deprecated_msg ~is_exn what =
   sprintf
     "[%sdeprecated \"\\\n\

src/bytes0.ml

@@ -21,8 +21,8 @@ module Primitives = struct
   external get : bytes -> int -> char = "%bytes_safe_get"
   external length : bytes -> int = "%bytes_length"
   external unsafe_get : bytes -> int -> char = "%bytes_unsafe_get"
-
-  include Bytes_set_primitives
+  external set        : bytes -> int -> char -> unit = "%bytes_safe_set"
+  external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 
   (* [unsafe_blit_string] is not exported in the [stdlib] so we export it here *)
   external unsafe_blit_string

src/dune

@@ -1,5 +1,5 @@
-(rule (targets bytes_set_primitives.ml)
- (deps (:first_dep select-bytes-set-primitives/select.ml))
+(rule (targets random_repr.ml)
+ (deps (:first_dep select-random-repr/select.ml))
  (action
   (run %{ocaml} %{first_dep} -ocaml-version %{ocaml_version} -o %{targets})))
 

src/import0.ml

@@ -45,6 +45,8 @@ type 'a ref = 'a Caml.ref = { mutable contents : 'a }
 (* Reshuffle [Caml] so that we choose the modules using labels when available. *)
 module Caml = struct
 
+  include Caml
+
   module Arg = Caml.Arg (** @canonical Caml.Arg *)
 
   module Array = Caml.StdLabels.Array (** @canonical Caml.StdLabels.Array *)
@@ -109,8 +111,6 @@ module Caml = struct
 
   module Stack = Caml.Stack (** @canonical Caml.Stack *)
 
-  module Stream = Caml.Stream [@ocaml.warning "-3"] (** @canonical Caml.Stream *)
-
   module String = Caml.StdLabels.String (** @canonical Caml.StdLabels.String *)
 
   module Sys = Caml.Sys (** @canonical Caml.Sys *)
@@ -119,8 +119,6 @@ module Caml = struct
 
   module Unit = Caml.Unit (** @canonical Caml.Unit *)
 
-  include Pervasives [@ocaml.warning "-3"]
-
   exception Not_found = Caml.Not_found
 end
 

src/random.ml

@@ -1,5 +1,4 @@
 open! Import
-module Array = Array0
 module Int = Int0
 module Char = Char0
 
@@ -55,21 +54,7 @@ module State = struct
     Lazy.from_val (Caml.Random.State.make_self_init ())
   ;;
 
-  module Repr = struct
-    type t =
-      { st : int array
-      ; mutable idx : int
-      }
-
-    let of_state : Caml.Random.State.t -> t = Caml.Obj.magic
-  end
-
-  let assign t1 t2 =
-    let t1 = Repr.of_state (Lazy.force t1) in
-    let t2 = Repr.of_state (Lazy.force t2) in
-    Array.blit ~src:t2.st ~src_pos:0 ~dst:t1.st ~dst_pos:0 ~len:(Array.length t1.st);
-    t1.idx <- t2.idx
-  ;;
+  let assign = Random_repr.assign
 
   let full_init t seed = assign t (make seed)
 
@@ -249,22 +234,23 @@ module State = struct
   ;;
 end
 
-let default = State.default
-let bits () = State.bits default
-let int x = State.int default x
-let int32 x = State.int32 default x
-let nativeint x = State.nativeint default x
-let int64 x = State.int64 default x
-let float x = State.float default x
-let int_incl x y = State.int_incl default x y
-let int32_incl x y = State.int32_incl default x y
-let nativeint_incl x y = State.nativeint_incl default x y
-let int64_incl x y = State.int64_incl default x y
-let float_range x y = State.float_range default x y
-let bool () = State.bool default
-let char () = State.char default
-let ascii () = State.ascii default
-let full_init seed = State.full_init default seed
+let default = Random_repr.make_default State.default
+
+let bits () = State.bits (Random_repr.get_state default)
+let int x = State.int (Random_repr.get_state default) x
+let int32 x = State.int32 (Random_repr.get_state default) x
+let nativeint x = State.nativeint (Random_repr.get_state default) x
+let int64 x = State.int64 (Random_repr.get_state default) x
+let float x = State.float (Random_repr.get_state default) x
+let int_incl x y = State.int_incl (Random_repr.get_state default) x y
+let int32_incl x y = State.int32_incl (Random_repr.get_state default) x y
+let nativeint_incl x y = State.nativeint_incl (Random_repr.get_state default) x y
+let int64_incl x y = State.int64_incl (Random_repr.get_state default) x y
+let float_range x y = State.float_range (Random_repr.get_state default) x y
+let bool () = State.bool (Random_repr.get_state default)
+let char () = State.char (Random_repr.get_state default)
+let ascii () = State.ascii (Random_repr.get_state default)
+let full_init seed = State.full_init (Random_repr.get_state default) seed
 let init seed = full_init [| seed |]
 let self_init ?allow_in_tests () = full_init (random_seed ?allow_in_tests ())
-let set_state s = State.assign default s
+let set_state s = State.assign (Random_repr.get_state default) s

src/select-random-repr/select.ml

@@ -0,0 +1,59 @@
+let () =
+  let ver, output =
+    try
+      match Sys.argv with
+      | [|_; "-ocaml-version"; v; "-o"; fn|] ->
+        (Scanf.sscanf v "%d.%d" (fun major minor -> (major, minor)),
+         fn)
+      | _ -> raise Exit
+    with _ ->
+      failwith "bad command line arguments"
+  in
+  let oc = open_out output in
+  if ver >= (5, 0) then
+    Printf.fprintf oc {|
+module Repr = struct
+  open Caml.Bigarray
+
+  type t = (int64, int64_elt, c_layout) Array1.t
+
+  let of_state : Caml.Random.State.t -> t = Caml.Obj.magic
+end
+
+let assign dst src =
+  let dst = Repr.of_state (Lazy.force dst) in
+  let src = Repr.of_state (Lazy.force src) in
+  Caml.Bigarray.Array1.blit src dst
+
+let make_default default =
+  let split_from_parent v =
+    Caml.Lazy.map_val Caml.Random.State.split v
+  in
+  Caml.Domain.DLS.new_key ~split_from_parent (fun () -> default)
+
+let get_state random_key = Caml.Domain.DLS.get random_key
+|}
+  else
+    Printf.fprintf oc {|
+module Array = Array0
+
+module Repr = struct
+  type t =
+    { st : int array
+    ; mutable idx : int
+    }
+
+  let of_state : Caml.Random.State.t -> t = Caml.Obj.magic
+end
+
+let assign t1 t2 =
+  let t1 = Repr.of_state (Lazy.force t1) in
+  let t2 = Repr.of_state (Lazy.force t2) in
+  Array.blit ~src:t2.st ~src_pos:0 ~dst:t1.st ~dst_pos:0 ~len:(Array.length t1.st);
+  t1.idx <- t2.idx
+
+let make_default default = default
+
+let[@inline always] get_state state = state
+|};
+  close_out oc

src/string.ml

@@ -1,7 +1,9 @@
 open! Import
 module Array = Array0
-module Bytes = Bytes0
 include String0
+module Bytes = Bytes0
+(* This alias is necessary despite [String0] defining [Bytes = Bytes0], in order to
+   convince ocamldep that this file doesn't depend on bytes.ml. *)
 
 let invalid_argf = Printf.invalid_argf
 let raise_s = Error.raise_s

src/string0.ml

@@ -16,14 +16,15 @@
    ocamldep from mistakenly causing a file to depend on [Base.String]. *)
 
 open! Import0
+module Bytes = Bytes0
 module Sys = Sys0
 
 module String = struct
   external get : string -> int -> char = "%string_safe_get"
   external length : string -> int = "%string_length"
   external unsafe_get : string -> int -> char = "%string_unsafe_get"
-
-  include Bytes_set_primitives
+  external set        : bytes -> int -> char -> unit = "%bytes_safe_set"
+  external unsafe_set : bytes -> int -> char -> unit = "%bytes_unsafe_set"
 end
 
 include String
@@ -32,7 +33,13 @@ let max_length = Sys.max_string_length
 let ( ^ ) = ( ^ )
 let capitalize = Caml.String.capitalize_ascii
 let compare = Caml.String.compare
-let[@warning "-3"] copy = Caml.String.copy
+
+let copy x =
+  Bytes.unsafe_to_string
+    ~no_mutation_while_string_reachable:
+      (Bytes.of_string x)
+;;
+
 let escaped = Caml.String.escaped
 let lowercase = Caml.String.lowercase_ascii
 let make = Caml.String.make

src/type_equal.ml

@@ -74,15 +74,6 @@ module Composition_preserves_injectivity (M1 : Injective) (M2 : Injective) = str
   let strip e = M1.strip (M2.strip e)
 end
 
-module Obj = struct
-  module Extension_constructor = struct
-    [@@@ocaml.warning "-3"]
-
-    let id = Caml.Obj.extension_id
-    let of_val = Caml.Obj.extension_constructor
-  end
-end
-
 module Id = struct
   module Uid = Int
 
@@ -100,7 +91,8 @@ module Id = struct
       [@@@end]
 
       let sexp_of_t _sexp_of_a t =
-        `type_witness (Obj.Extension_constructor.id (Obj.Extension_constructor.of_val t))
+        `type_witness
+          (Caml.Obj.Extension_constructor.id (Caml.Obj.Extension_constructor.of_val t))
         |> sexp_of_type_witness_int
       ;;
     end
@@ -126,7 +118,7 @@ module Id = struct
     ;;
 
     let uid (type a) (module M : S with type t = a) =
-      Obj.Extension_constructor.id (Obj.Extension_constructor.of_val M.Key)
+      Caml.Obj.Extension_constructor.id (Caml.Obj.Extension_constructor.of_val M.Key)
     ;;
 
     (* We want a constant allocated once that [same] can return whenever it gets the same