Merge 5.2.0minus-19

src/analysis/ptyp_of_type.ml

@@ -163,7 +163,7 @@ and value_description id
     { val_type; val_kind = _; val_loc; val_attributes; val_modalities; _ } =
   let type_ = core_type val_type in
   let snap = Btype.snapshot () in
-  let modalities = Mode.Modality.Value.zap_to_id val_modalities in
+  let modalities = Mode.Modality.zap_to_id val_modalities in
   Btype.backtrack snap;
   { Parsetree.pval_name = var_of_id id;
     pval_type = type_;

src/analysis/stack_or_heap_enclosing.ml

@@ -43,7 +43,7 @@ let from_nodes ~lsp_compat ~pos ~path =
          value binding. However, the LSP hover at this point will describe just the
          pattern, so we don't override the location in the [lsp_compat] regime. *)
       let loc = if lsp_compat then None else Some vb_loc in
-      ret ?loc (Alloc_mode alloc_mode.mode)
+      ret ?loc (Alloc_mode alloc_mode)
     | Expression { exp_desc; _ }, _ -> (
       match exp_desc with
       | Texp_function { alloc_mode; body; _ } -> (
@@ -76,8 +76,8 @@ let from_nodes ~lsp_compat ~pos ~path =
         in
         match body_loc with
         | Some loc when cursor_is_inside loc -> None
-        | _ -> ret (Alloc_mode alloc_mode.mode))
-      | Texp_array (_, _, _, alloc_mode) -> ret (Alloc_mode alloc_mode.mode)
+        | _ -> ret (Alloc_mode alloc_mode))
+      | Texp_array (_, _, _, alloc_mode) -> ret (Alloc_mode alloc_mode)
       | Texp_construct
           ({ loc; txt = _lident }, { cstr_repr; _ }, args, maybe_alloc_mode)
         -> (
@@ -89,7 +89,7 @@ let from_nodes ~lsp_compat ~pos ~path =
           if lsp_compat && cursor_is_inside loc then Some loc else None
         in
         match maybe_alloc_mode with
-        | Some alloc_mode -> ret ?loc (Alloc_mode alloc_mode.mode)
+        | Some alloc_mode -> ret ?loc (Alloc_mode alloc_mode)
         | None -> (
           match args with
           | [] -> ret_no_alloc ?loc "constructor without arguments"
@@ -102,18 +102,18 @@ let from_nodes ~lsp_compat ~pos ~path =
       | Texp_record { representation; alloc_mode = maybe_alloc_mode; _ } -> (
         match (maybe_alloc_mode, representation) with
         | _, Record_inlined _ -> None
-        | Some alloc_mode, _ -> ret_alloc alloc_mode.mode
+        | Some alloc_mode, _ -> ret_alloc alloc_mode
         | None, Record_unboxed -> ret_no_alloc "unboxed record"
         | None, (Record_boxed _ | Record_float | Record_ufloat | Record_mixed _)
           -> ret Unexpected_no_alloc)
       | Texp_field (_, _, _, _, boxed_or_unboxed, _) -> (
         match boxed_or_unboxed with
-        | Boxing (alloc_mode, _) -> ret_alloc alloc_mode.mode
+        | Boxing (alloc_mode, _) -> ret_alloc alloc_mode
         | Non_boxing _ -> None)
       | Texp_variant (_, maybe_exp_and_alloc_mode) ->
         maybe_exp_and_alloc_mode
         |> Option.map ~f:(fun (_, (alloc_mode : Typedtree.alloc_mode)) ->
-               alloc_mode.mode)
+               alloc_mode)
         |> ret_maybe_alloc "variant without argument"
       | _ -> None)
     | _ -> None

src/kernel/mtyper.ml

@@ -40,7 +40,7 @@ type typedtree_items =
   | Interface_items of
       { items : (Parsetree.signature_item, Typedtree.signature_item) item list;
         psig_modalities : Parsetree.modalities;
-        sig_modalities : Mode.Modality.Value.Const.t;
+        sig_modalities : Mode.Modality.Const.t;
         sig_sloc : Location.t
       }
   | Implementation_items of

src/ocaml/typing/mode.ml

@@ -15,6 +15,13 @@
 (* warn on fragile matches *)
 [@@@warning "+4"]
 
+(* Merlin-specific: change some module paths to match the compiler *)
+module Misc = struct
+  include Misc
+  module Stdlib = Misc_stdlib
+  include Misc_stdlib
+end
+
 open Allowance
 open Solver
 open Mode_intf
@@ -166,11 +173,6 @@ module Hint_for_solver (* : Solver_intf.Hint *) = struct
   end
 end
 
-module Misc = struct
-  let fatal_error = Misc.fatal_error
-  include Misc_stdlib
-end
-
 type nonrec allowed = allowed
 
 type nonrec disallowed = disallowed

src/ocaml/typing/shape.ml

@@ -13,6 +13,13 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* Merlin-specific: change some module paths to match the compiler *)
+module Misc = struct
+  include Misc
+  module Stdlib = Misc_stdlib
+  include Misc_stdlib
+end
+
 module Layout = Jkind_types.Sort.Const
 type base_layout = Jkind_types.Sort.base
 

src/ocaml/typing/shape_reduce.ml

@@ -15,6 +15,13 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(* Merlin-specific: change some module paths to match the compiler *)
+module Misc = struct
+  include Misc
+  module Stdlib = Misc_stdlib
+  include Misc_stdlib
+end
+
 open Shape
 
 module MB = Misc.Maybe_bounded

src/ocaml/typing/shape_reduce.mli

@@ -73,15 +73,15 @@ end
     compilation unit to prevent conflicting entries in these memoization tables.
 *)
 module Make(_ : sig
-    val fuel : unit -> Misc.Maybe_bounded.t
+    val fuel : unit -> Misc_stdlib.Maybe_bounded.t
 
     val projection_rules_for_merlin_enabled : bool
 
-    val fuel_for_compilation_units : unit -> Misc.Maybe_bounded.t
+    val fuel_for_compilation_units : unit -> Misc_stdlib.Maybe_bounded.t
 
-    val max_shape_reduce_steps_per_variable : unit -> Misc.Maybe_bounded.t
+    val max_shape_reduce_steps_per_variable : unit -> Misc_stdlib.Maybe_bounded.t
 
-    val max_compilation_unit_depth : unit -> Misc.Maybe_bounded.t
+    val max_compilation_unit_depth : unit -> Misc_stdlib.Maybe_bounded.t
 
     val read_unit_shape :
       diagnostics:Diagnostics.t -> unit_name:string -> Shape.t option

src/ocaml/typing/typecore.ml

@@ -5757,7 +5757,7 @@ let create_merlin_type_error_node loc env ty_expected ~attributes =
               val_attributes = [];
               val_uid = Uid.internal_not_actually_unique;
               val_zero_alloc = Zero_alloc.default;
-              val_modalities = Modality.Value.id;
+              val_modalities = Modality.id;
             },
             Id_value,
             (Uniqueness.disallow_left Uniqueness.legacy,
@@ -8100,10 +8100,7 @@ and type_function_
                     body;
                     ret_mode;
                     ret_sort;
-                    alloc_mode =
-                      { mode = alloc_mode;
-                        locality_context = expected_mode.locality_context
-                      };
+                    alloc_mode;
                     zero_alloc=Zero_alloc.default
                   });
               exp_loc = loc;
@@ -8294,11 +8291,8 @@ and type_function_
                 in
                 Texp_function
                   { params; body; ret_mode; ret_sort;
-                    alloc_mode = {
-                      mode = Alloc.disallow_left alloc_mode;
-                      locality_context = expected_mode.locality_context
-                    };
-                    zero_alloc=Zero_alloc.default });
+                    alloc_mode = Alloc.disallow_left alloc_mode;
+                    zero_alloc = Zero_alloc.default });
               exp_loc = loc;
               exp_extra = [];
               exp_type;
@@ -8498,7 +8492,7 @@ and type_label_access
         lbl_res = ty_exp;
         lbl_arg = newvar arg_kind;
         lbl_mut = Mutable { mode = Mode.Value.Comonadic.legacy; atomic = Nonatomic };
-        lbl_modalities = Mode.Modality.Value.Const.id;
+        lbl_modalities = Mode.Modality.Const.id;
         lbl_pos = 0;
         lbl_all = [||];
         lbl_repres =
@@ -10048,10 +10042,7 @@ and type_function_cases_expect
                   body = Tfunction_cases cases;
                   ret_mode = Alloc.disallow_right ret_mode;
                   ret_sort;
-                  alloc_mode = {
-                    mode = Alloc.disallow_left alloc_mode;
-                    locality_context = expected_mode.locality_context
-                  };
+                  alloc_mode = Alloc.disallow_left alloc_mode;
                   zero_alloc = Zero_alloc.default;
                 };
             exp_loc = loc;

src/ocaml/utils/misc_stdlib.ml

@@ -457,3 +457,48 @@ module Nonempty_list = struct
   let (@) (x :: xs) (y :: ys) =
     x :: List.(xs @ (y :: ys))
 end
+
+module Maybe_bounded = struct
+  type t =
+    | Unbounded
+    | Bounded of { mutable bound: int }
+
+  let decr = function
+    | Unbounded -> ()
+    | Bounded r when r.bound > 0 -> r.bound <- r.bound - 1
+    | Bounded _ -> ()
+
+  let incr = function
+    | Unbounded -> ()
+    | Bounded r ->
+      if Int.equal r.bound Int.max_int
+      then
+        let msg = Format.asprintf "incr called with max_int (%d)" Int.max_int in
+        raise (Invalid_argument msg)
+      else
+        r.bound <- r.bound + 1
+
+  let is_depleted = function
+    | Unbounded -> false
+    | Bounded r -> r.bound <= 0
+
+  let is_in_bounds n t =
+    if n < 0 then false
+    else
+      match t with
+      | Unbounded -> true
+      | Bounded r -> n < r.bound
+
+  let is_out_of_bounds n t =
+    if n < 0 then true
+    else
+      match t with
+      | Unbounded -> false
+      | Bounded r -> n >= r.bound
+
+  let of_int n = if n < 0 then Bounded { bound = 0 } else Bounded { bound = n }
+
+  let of_option = function
+    | None -> Unbounded
+    | Some n -> of_int n
+end

src/ocaml/utils/misc_stdlib.mli

@@ -298,3 +298,41 @@ module Nonempty_list : sig
 
   val (@) : 'a t -> 'a t -> 'a t
 end
+
+(** A bounded non-negative integer. The possible ranges are [0 ..< n],
+    represented by [Bounded { bound = n}] and [0 ..< ∞] represented by
+    [Unbounded]. *)
+module Maybe_bounded : sig
+  type t =
+    | Unbounded
+    | Bounded of { mutable bound: int }
+    (** The [bound] is not included. *)
+
+  (** [decr] decreases the current bound and truncates at zero. As such, [decr]
+      and then [incr] is not always a no-op. *)
+  val decr : t -> unit
+
+  (** [incr] increases the current bound. Raises an exception when attempting
+      to increment [max_int]. *)
+  val incr : t -> unit
+
+  val is_depleted : t -> bool
+
+  (** [is_in_bounds n t] returns [true] if [n] is in bounds.
+      A number counts as in bounds if it is non-negative and strictly smaller
+      than the bound. For [Unbounded], returns [true] if [n >= 0]. *)
+  val is_in_bounds : int -> t -> bool
+
+  (** [is_out_of_bounds n t] returns [true] if [n] is out of bounds. A number is
+      out of bounds if it is negative or greater than or equal to the bound. For
+      [Unbounded], returns [false] if [n < 0] and [true] otherwise. *)
+  val is_out_of_bounds : int -> t -> bool
+
+  (** [of_option opt] maps [None] to no bound and [Some n] to the bound [n]
+      (not inclusive). *)
+  val of_option : int option -> t
+
+  (** [of_int n] creates a bounded integer with bound [n] (not inclusive). *)
+  val of_int : int -> t
+end
+

src/utils/misc.ml

@@ -412,6 +412,46 @@ module Int_literal_converter = struct
   let int32 s = cvt_int_aux s Int32.neg Int32.of_string
   let int64 s = cvt_int_aux s Int64.neg Int64.of_string
   let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string
+
+  (* Follows "parse_sign_and_base" in runtime/ints.c *)
+  let parse_signedness s =
+    let char_at i =
+      if String.length s > i
+      then Some s.[i]
+      else None
+    in
+    let p =
+      match char_at 0 with
+      | Some ('-' | '+') -> 1
+      | Some _ | None -> 0
+    in
+    match char_at p with
+    | Some '0' ->
+      begin match char_at (p+1) with
+      | Some ('x' | 'X' | 'o' | 'O' | 'b' | 'B' | 'u' | 'U') -> false
+      | Some _ | None -> true
+      end
+    | Some _ | None -> true
+
+  let cvt_small_int str ~bits =
+    let i = int_of_string str in
+    let max_int = (1 lsl (bits-1)) - 1 in
+    let min_int = -(1 lsl (bits-1)) in
+    let max_uint = (1 lsl bits) - 1 in
+    let lower_limit, upper_limit =
+      if parse_signedness str
+      then min_int, max_int + 1
+      else -max_uint, max_uint
+    in
+    if i < lower_limit || i > upper_limit
+    then failwith "small int overflow";
+    (* handle overflow *)
+    if i > max_int then i - (max_uint + 1)
+    else if i < min_int then i + (max_uint + 1)
+    else i
+
+  let int8 s = cvt_small_int s ~bits:8
+  let int16 s = cvt_small_int s ~bits:16
 end
 
 (* [find_first_mono p] assumes that there exists a natural number

src/utils/misc.mli

@@ -201,6 +201,8 @@ val letter_of_int : int -> string
 
 module Int_literal_converter : sig
   val int : string -> int
+  val int8 : string -> int
+  val int16 : string -> int
   val int32 : string -> int32
   val int64 : string -> int64
   val nativeint : string -> nativeint