+OCaml 4.07.1 (4 October 2018)
+-----------------------------
+
+### Bug fixes:
+
+- MPR#7815, GPR#1896: major GC crash with first-fit policy
+ (Stephen Dolan and Damien Doligez, report by Joris Giovannangeli)
+
+* MPR#7818, GPR#2051: Remove local aliases in functor argument types,
+ to prevent the aliasing of their target.
+ (Jacques Garrigue, report by mandrykin, review by Leo White)
+
+- MPR#7820, GPR#1897: Fix Array.of_seq. This function used to apply a circular
+ permutation of one cell to the right on the sequence.
+ (Thierry Martinez, review by Nicolás Ojeda Bär)
+
+- MPR#7821, GPR#1908: make sure that the compilation of extension
+ constructors doesn't cause the compiler to load more cmi files
+ (Jérémie Dimino)
+
+- MPR#7824, GPR#1914: subtype_row: filter out absent fields when row is closed
+ (Leo White and Thomas Refis, report by talex, review by Jacques Garrigue)
+
+- GPR#1915: rec_check.ml is too permissive for certain class declarations.
+ (Alban Reynaud with Gabriel Scherer, review by Jeremy Yallop)
+
+- MPR#7833, MPR#7835, MPR#7822, GPR#1997: Track newtype level again
+ (Leo White, reports by Jerome Simeon, Thomas Refis and Florian
+ Angeletti, review by Jacques Garrigue)
+
+- MPR#7838: -principal causes assertion failure in type checker
+ (Jacques Garrigue, report by Markus Mottl, review by Thomas Refis)
+
OCaml 4.07.0 (10 July 2018)
---------------------------
-4.07.0
+4.07.1
# The version string is the first line of this file.
# It must be in the format described in stdlib/sys.mli
let transl_extension_constructor env path ext =
let path =
- Stdlib.Option.map (Printtyp.rewrite_double_underscore_paths env) path
+ Printtyp.wrap_printing_env env ~error:true (fun () ->
+ Stdlib.Option.map (Printtyp.rewrite_double_underscore_paths env) path)
in
let name =
match path, !Clflags.for_package with
mlsize_t oldsz = sz;
prev = flp[i];
- while (prev != flp[i+1]){
+ while (prev != flp[i+1] && j < FLP_MAX - i){
cur = Next (prev);
sz = Wosize_bp (cur);
if (sz > prevsz){
[] -> a
| hd::tl -> unsafe_set a i hd; fill (i-1) tl
in
- fill (len-1) tl
+ fill (len-2) tl
let of_seq i =
let l = Seq.fold_left (fun acc x -> x::acc) [] i in
()
;;
+(* MPR 7820 *)
+let () =
+ assert
+ ([| 1;2;3 |] =
+ (Array.to_seq [| 1;2;3 |]
+ |> Array.of_seq));
+ ()
+;;
+
let () = print_endline "OK";;
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module M : sig
+ type 'a t
+
+ type _ typ =
+ | Foo : 'a -> [`Foo of 'a] typ
+ | Bar : string -> [`Bar] typ
+
+ val use_bar : [`Bar] t -> int
+
+ val foo : [`Foo of int] t
+
+end = struct
+ type 'a t = string
+
+ type _ typ =
+ | Foo : 'a -> [`Foo of 'a] typ
+ | Bar : string -> [`Bar] typ
+
+ let foo = "foo"
+
+ let use_bar _ = 0
+end;;
+[%%expect {|
+module M :
+ sig
+ type 'a t
+ type _ typ =
+ Foo : 'a -> [ `Foo of 'a ] typ
+ | Bar : string -> [ `Bar ] typ
+ val use_bar : [ `Bar ] t -> int
+ val foo : [ `Foo of int ] t
+ end
+|}];;
+
+let go (type a) (typ : a M.typ) (msg : a M.t) =
+ match typ with
+ | Bar s ->
+ (match M.use_bar msg with _ -> ())
+;;
+[%%expect {|
+Line _, characters 2-68:
+ ..match typ with
+ | Bar s ->
+ (match M.use_bar msg with _ -> ())
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+Foo _
+val go : 'a M.typ -> 'a M.t -> unit = <fun>
+|}];;
unify_mb.ml
variables_in_mcomp.ml
yallop_bugs.ml
+gpr1997.ml
let Cons(Elt dim, _) = sh in ()
^^^^^^^^^^^^^^^^
Error: This pattern matches values of type ('a -> $0 -> nil) t
- but a pattern was expected which matches values of type
- ('a -> 'b -> nil) t
+ but a pattern was expected which matches values of type 'b
The type constructor $0 would escape its scope
|}];;
is not included in
type t = int * bool
|}];;
+
+
+(* PR#7838 *)
+
+module Make (X : sig val f : [ `A ] -> unit end) = struct
+ let make f1 f2 arg = match arg with `A -> f1 arg; f2 arg
+ let f = make X.f (fun _ -> ())
+end;;
+[%%expect{|
+module Make :
+ functor (X : sig val f : [ `A ] -> unit end) ->
+ sig
+ val make : (([< `A ] as 'a) -> 'b) -> ('a -> 'c) -> 'a -> 'c
+ val f : [ `A ] -> unit
+ end
+|}]
pr7207.ml
pr7348.ml
pr7787.ml
+pr7818.ml
printing.ml
recursive.ml
Test.ml
--- /dev/null
+(* TEST
+ * expect
+*)
+
+(* cannot_alias.ml *)
+module Termsig = struct
+ module Term0 = struct
+ module type S = sig
+ module Id : sig end
+ end
+ end
+ module Term = struct
+ module type S = sig
+ module Term0 : Term0.S
+ module T = Term0
+ end
+ end
+end;;
+[%%expect{|
+module Termsig :
+ sig
+ module Term0 : sig module type S = sig module Id : sig end end end
+ module Term :
+ sig module type S = sig module Term0 : Term0.S module T = Term0 end end
+ end
+|}]
+
+module Make1 (T' : Termsig.Term.S) = struct
+ module T = struct
+ include T'.T
+ let u = 1
+ end
+end;;
+[%%expect{|
+module Make1 :
+ functor
+ (T' : sig
+ module Term0 : Termsig.Term0.S
+ module T : sig module Id : sig end end
+ end) ->
+ sig module T : sig module Id : sig end val u : int end end
+|}]
+
+module Make2 (T' : Termsig.Term.S) = struct
+ module T = struct
+ include T'.T
+ module Id2 = Id
+ let u = 1
+ end
+end;;
+[%%expect{|
+module Make2 :
+ functor
+ (T' : sig
+ module Term0 : Termsig.Term0.S
+ module T : sig module Id : sig end end
+ end) ->
+ sig
+ module T : sig module Id : sig end module Id2 = Id val u : int end
+ end
+|}]
+
+module Make3 (T' : Termsig.Term.S) = struct
+ module T = struct
+ include T'.T
+ module Id2 = Id
+ let u = 1
+ let u = 1
+ end
+end;;
+[%%expect{|
+module Make3 :
+ functor
+ (T' : sig
+ module Term0 : Termsig.Term0.S
+ module T : sig module Id : sig end end
+ end) ->
+ sig
+ module T : sig module Id : sig end module Id2 = Id val u : int end
+ end
+|}]
+
+(* cannot_alias2.ml *)
+module type S = sig
+ module Term0 : sig module Id : sig end end
+ module T = Term0
+end;;
+
+module Make1 (T' : S) = struct
+ module Id = T'.T.Id
+ module Id2 = Id
+end;;
+[%%expect{|
+module type S =
+ sig module Term0 : sig module Id : sig end end module T = Term0 end
+module Make1 :
+ functor
+ (T' : sig
+ module Term0 : sig module Id : sig end end
+ module T : sig module Id : sig end end
+ end) ->
+ sig module Id : sig end module Id2 = Id end
+|}]
+
+module Make2 (T' : S) : sig module Id : sig end module Id2 = Id end
+ with module Id := T'.Term0.Id = struct
+ module Id = T'.T.Id
+ module Id2 = Id
+end;;
+[%%expect{|
+Line _, characters 57-107:
+ .........................................................struct
+ module Id = T'.T.Id
+ module Id2 = Id
+ end..
+Error: Signature mismatch:
+ Modules do not match:
+ sig module Id : sig end module Id2 = Id end
+ is not included in
+ sig module Id2 = T'.Term0.Id end
+ In module Id2:
+ Module T'.Term0.Id cannot be aliased
+|}]
+
+module Make3 (T' : S) = struct
+ module T = struct
+ module Id = T'.T.Id
+ module Id2 = Id
+ let u = 1
+ let u = 1
+ end
+end;;
+[%%expect{|
+module Make3 :
+ functor
+ (T' : sig
+ module Term0 : sig module Id : sig end end
+ module T : sig module Id : sig end end
+ end) ->
+ sig
+ module T : sig module Id : sig end module Id2 = Id val u : int end
+ end
+|}]
+
+(* unsoundness if Make1 returned an Id.x field *)
+module M = Make1 (struct module Term0 =
+ struct module Id = struct let x = "a" end end module T = Term0 end);;
+M.Id.x;;
+[%%expect{|
+module M : sig module Id : sig end module Id2 = Id end
+Line _, characters 0-6:
+ M.Id.x;;
+ ^^^^^^
+Error: Unbound value M.Id.x
+|}]
+
+
+(* cannot_alias3.ml *)
+module MkT(X : sig end) = struct type t end
+module type S = sig
+ module Term0 : sig module Id : sig end end
+ module T = Term0
+ type t = MkT(T).t
+end;;
+
+module Make1 (T' : S) = struct
+ module Id = T'.T.Id
+ module Id2 = Id
+ type t = T'.t
+end;;
+
+module IS = struct
+ module Term0 = struct module Id = struct let x = "a" end end
+ module T = Term0
+ type t = MkT(T).t
+end;;
+
+module M = Make1(IS);;
+[%%expect{|
+module MkT : functor (X : sig end) -> sig type t end
+module type S =
+ sig
+ module Term0 : sig module Id : sig end end
+ module T = Term0
+ type t = MkT(T).t
+ end
+module Make1 :
+ functor
+ (T' : sig
+ module Term0 : sig module Id : sig end end
+ module T : sig module Id : sig end end
+ type t = MkT(T).t
+ end) ->
+ sig module Id : sig end module Id2 = Id type t = T'.t end
+module IS :
+ sig
+ module Term0 : sig module Id : sig val x : string end end
+ module T = Term0
+ type t = MkT(T).t
+ end
+module M : sig module Id : sig end module Id2 = Id type t = IS.t end
+|}]
+
+
+(* cannot_alias4.ml *)
+(* Can be used to break module abstraction *)
+(* Still sound ? *)
+(* It seems to only work if Term0 and Term contain identical types *)
+(* It may also be possible to do the same thing using
+ Mtype.nondep_supertype anyway *)
+type (_,_) eq = Eq : ('a,'a) eq
+module MkT(X : Set.OrderedType) = Set.Make(X)
+module type S = sig
+ module Term0 : Set.OrderedType with type t = int
+ module T = Term0
+ type t = E of (MkT(T).t,MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t,MkT(T).t) eq
+end;;
+module F(X:S) = X;;
+module rec M : S = M;;
+module M' = F(M);;
+module type S' = module type of M';;
+module Asc = struct type t = int let compare x y = x - y end;;
+module Desc = struct type t = int let compare x y = y - x end;;
+module rec M1 : S' with module Term0 := Asc and module T := Desc = M1;;
+(* And now we have a witness of MkT(Asc).t = MkT(Desc).t ... *)
+let (E eq : M1.u) = (E Eq : M1.t);;
+[%%expect{|
+type (_, _) eq = Eq : ('a, 'a) eq
+module MkT :
+ functor (X : Set.OrderedType) ->
+ sig
+ type elt = X.t
+ type t = Set.Make(X).t
+ val empty : t
+ val is_empty : t -> bool
+ val mem : elt -> t -> bool
+ val add : elt -> t -> t
+ val singleton : elt -> t
+ val remove : elt -> t -> t
+ val union : t -> t -> t
+ val inter : t -> t -> t
+ val diff : t -> t -> t
+ val compare : t -> t -> int
+ val equal : t -> t -> bool
+ val subset : t -> t -> bool
+ val iter : (elt -> unit) -> t -> unit
+ val map : (elt -> elt) -> t -> t
+ val fold : (elt -> 'a -> 'a) -> t -> 'a -> 'a
+ val for_all : (elt -> bool) -> t -> bool
+ val exists : (elt -> bool) -> t -> bool
+ val filter : (elt -> bool) -> t -> t
+ val partition : (elt -> bool) -> t -> t * t
+ val cardinal : t -> int
+ val elements : t -> elt list
+ val min_elt : t -> elt
+ val min_elt_opt : t -> elt option
+ val max_elt : t -> elt
+ val max_elt_opt : t -> elt option
+ val choose : t -> elt
+ val choose_opt : t -> elt option
+ val split : elt -> t -> t * bool * t
+ val find : elt -> t -> elt
+ val find_opt : elt -> t -> elt option
+ val find_first : (elt -> bool) -> t -> elt
+ val find_first_opt : (elt -> bool) -> t -> elt option
+ val find_last : (elt -> bool) -> t -> elt
+ val find_last_opt : (elt -> bool) -> t -> elt option
+ val of_list : elt list -> t
+ val to_seq_from : elt -> t -> elt Seq.t
+ val to_seq : t -> elt Seq.t
+ val add_seq : elt Seq.t -> t -> t
+ val of_seq : elt Seq.t -> t
+ end
+module type S =
+ sig
+ module Term0 : sig type t = int val compare : t -> t -> int end
+ module T = Term0
+ type t = E of (MkT(T).t, MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t, MkT(T).t) eq
+ end
+module F :
+ functor
+ (X : sig
+ module Term0 : sig type t = int val compare : t -> t -> int end
+ module T : sig type t = int val compare : t -> t -> int end
+ type t = E of (MkT(T).t, MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t, MkT(T).t) eq
+ end) ->
+ sig
+ module Term0 : sig type t = int val compare : t -> t -> int end
+ module T : sig type t = int val compare : t -> t -> int end
+ type t = X.t = E of (MkT(T).t, MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t, MkT(T).t) eq
+ end
+module rec M : S
+module M' :
+ sig
+ module Term0 : sig type t = int val compare : t -> t -> int end
+ module T : sig type t = int val compare : t -> t -> int end
+ type t = M.t = E of (MkT(T).t, MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t, MkT(T).t) eq
+ end
+module type S' =
+ sig
+ module Term0 : sig type t = int val compare : t -> t -> int end
+ module T : sig type t = int val compare : t -> t -> int end
+ type t = M.t = E of (MkT(T).t, MkT(T).t) eq
+ type u = t = E of (MkT(Term0).t, MkT(T).t) eq
+ end
+module Asc : sig type t = int val compare : int -> int -> int end
+module Desc : sig type t = int val compare : int -> int -> int end
+module rec M1 :
+ sig
+ type t = M.t = E of (MkT(Desc).t, MkT(Desc).t) eq
+ type u = t = E of (MkT(Asc).t, MkT(Desc).t) eq
+ end
+val eq : (MkT(Asc).t, MkT(Desc).t) eq = Eq
+|}]
^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: This kind of recursive class expression is not allowed
|}];;
+
+(* More tests about recursion in class declarations *)
+class a = let _x() = new a in object end;;
+[%%expect{|
+class a : object end
+|}];;
+
+class a = object end
+and b = let _x() = new a in object end;;
+[%%expect{|
+class a : object end
+and b : object end
+|}];;
+
+class a = let x() = new a in let y = x() in object end;;
+[%%expect{|
+Line _, characters 10-54:
+ class a = let x() = new a in let y = x() in object end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+|}];;
+
+class a = object end
+and b = let x() = new a in let y = x() in object end;;
+[%%expect{|
+Line _, characters 8-52:
+ and b = let x() = new a in let y = x() in object end;;
+ ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: This kind of recursive class expression is not allowed
+|}];;
pr5057_ok.ml
pr5057a_bad.ml
pr7199_ok.ml
+pr7824.ml
privrowsabate_ok.ml
--- /dev/null
+(* TEST
+ * expect
+*)
+
+module Element : sig
+ type +'a t
+
+ val from_a : [`A] t -> unit
+ val from_ab : [< `A | `B] t -> unit
+
+ val to_a : unit -> [`A] t
+ val to_ab : unit -> [< `A | `B] t
+end = struct
+ type +'a t
+
+ let from_a x = assert false
+ let from_ab x = assert false
+
+ let to_a x = assert false
+ let to_ab x = assert false
+end ;;
+[%%expect{|
+module Element :
+ sig
+ type +'a t
+ val from_a : [ `A ] t -> unit
+ val from_ab : [< `A | `B ] t -> unit
+ val to_a : unit -> [ `A ] t
+ val to_ab : unit -> [< `A | `B ] t
+ end
+|}];;
+
+let f x =
+ Element.from_a x;
+ Element.from_ab x;
+ match [] with
+ | _::_ -> (x :> [`A | `C] Element.t)
+;;
+[%%expect{|
+Line _, characters 2-54:
+ ..match [] with
+ | _::_ -> (x :> [`A | `C] Element.t)
+Warning 8: this pattern-matching is not exhaustive.
+Here is an example of a case that is not matched:
+[]
+val f : [ `A ] Element.t -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+type _ t = T : 'a -> 'a t
+
+let f x =
+ Element.from_a x;
+ Element.from_ab x;
+ match T () with
+ | T _ -> (x :> [`A | `C] Element.t)
+;;
+[%%expect{|
+type _ t = T : 'a -> 'a t
+val f : [ `A ] Element.t -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+let f () =
+ let open Element in
+ let x = if true then to_ab () else to_a () in
+ (x :> [ `A | `C ] Element.t)
+;;
+[%%expect{|
+val f : unit -> [ `A | `C ] Element.t = <fun>
+|}];;
+
+let f () =
+ let open Element in
+ let x = if true then to_a () else to_ab () in
+ (x :> [ `A | `C ] Element.t)
+;;
+[%%expect{|
+val f : unit -> [ `A | `C ] Element.t = <fun>
+|}];;
module M = struct type t let _ = (x : t list ref) end
(without this constraint, the type system would actually be unsound.)
*)
-let get_path_scope p =
- Path.binding_time p
+let get_path_scope env p =
+ try
+ match (Env.find_type p env).type_newtype_level with
+ | None -> Path.binding_time p
+ | Some (x, _) -> x
+ with
+ | Not_found ->
+ (* no newtypes in predef *)
+ Path.binding_time p
let rec normalize_package_path env p =
let t =
| None -> ()
end;
match ty.desc with
- Tconstr(p, _tl, _abbrev) when level < get_path_scope p ->
+ Tconstr(p, _tl, _abbrev) when level < get_path_scope env p ->
(* Try first to replace an abbreviation by its expansion. *)
begin try
link_type ty (!forward_try_expand_once env ty);
log_type ty; ty.desc <- Tpackage (p', nl, tl);
update_level env level expand ty
| Tobject(_, ({contents=Some(p, _tl)} as nm))
- when level < get_path_scope p ->
+ when level < get_path_scope env p ->
set_name nm None;
update_level env level expand ty
| Tvariant row ->
let row = row_repr row in
begin match row.row_name with
- | Some (p, _tl) when level < get_path_scope p ->
+ | Some (p, _tl) when level < get_path_scope env p ->
log_type ty;
ty.desc <- Tvariant {row with row_name = None}
| _ -> ()
match more.desc with
Tsubst ty -> ty
| Tconstr _ | Tnil ->
- if keep then save_desc more more.desc;
+ save_desc more more.desc;
copy more
| Tvar _ | Tunivar _ ->
save_desc more more.desc;
if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
Printf.sprintf "%s%d" s index
-let new_declaration expansion_scope manifest =
+let new_declaration newtype manifest =
{
type_params = [];
type_arity = 0;
type_private = Public;
type_manifest = manifest;
type_variance = [];
- type_is_newtype = true;
- type_expansion_scope = expansion_scope;
+ type_newtype_level = newtype;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
let instance_constructor ?in_pattern cstr =
begin match in_pattern with
| None -> ()
- | Some (env, expansion_scope) ->
+ | Some (env, newtype_lev) ->
let process existential =
- let decl = new_declaration (Some expansion_scope) None in
+ let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
let name =
match repr existential with
{desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name
information is indeed lost, but it probably does not worth it.
*)
+let newtype_level = ref None
+
+let get_newtype_level () =
+ match !newtype_level with
+ | None -> assert false
+ | Some x -> x
+
(* a local constraint can be added only if the rhs
of the constraint does not contain any Tvars.
They need to be removed using this function *)
let reify env t =
+ let newtype_level = get_newtype_level () in
let create_fresh_constr lev name =
+ let decl = new_declaration (Some (newtype_level, newtype_level)) None in
let name = match name with Some s -> "$'"^s | _ -> "$" in
let path = Path.Pident (Ident.create (get_new_abstract_name name)) in
- let binding_time = Ident.current_time () in
- let decl = new_declaration (Some binding_time) None in
let new_env = Env.add_local_type path decl !env in
let t = newty2 lev (Tconstr (path,[],ref Mnil)) in
env := new_env;
- t, binding_time
+ t
in
let visited = ref TypeSet.empty in
let rec iterator ty =
visited := TypeSet.add ty !visited;
match ty.desc with
Tvar o ->
- let t, binding_time = create_fresh_constr ty.level o in
+ let t = create_fresh_constr ty.level o in
link_type ty t;
- if ty.level < binding_time then
+ if ty.level < newtype_level then
raise (Unify [t, newvar2 ty.level])
| Tvariant r ->
let r = row_repr r in
let m = r.row_more in
match m.desc with
Tvar o ->
- let t, binding_time = create_fresh_constr m.level o in
+ let t = create_fresh_constr m.level o in
let row =
{r with row_fields=[]; row_fixed=true; row_more = t} in
link_type m (newty2 m.level (Tvariant row));
- if m.level < binding_time then
+ if m.level < newtype_level then
raise (Unify [t, newvar2 m.level])
| _ -> assert false
end;
let is_newtype env p =
try
let decl = Env.find_type p env in
- decl.type_expansion_scope <> None &&
+ decl.type_newtype_level <> None &&
decl.type_kind = Type_abstract &&
decl.type_private = Public
with Not_found -> false
let non_aliasable p decl =
(* in_pervasives p || (subsumed by in_current_module) *)
- in_current_module p && not decl.type_is_newtype
+ in_current_module p && decl.type_newtype_level = None
let is_instantiable env p =
try
end
in find ty; unmark_type ty; !lowest
-let find_expansion_scope env path =
- match (Env.find_type path env).type_expansion_scope with
- | Some x -> x
- | None -> assert false
-
-let gadt_equations_level = ref None
-
-let get_gadt_equations_level () =
- match !gadt_equations_level with
+let find_expansion_level env path =
+ (* always guarded by a call to [is_newtype], so we *always* have a newtype
+ level. *)
+ match (Env.find_type path env).type_newtype_level with
+ | Some (_, x) -> x
| None -> assert false
- | Some x -> x
let add_gadt_equation env source destination =
(* Format.eprintf "@[add_gadt_equation %s %a@]@."
(Path.name source) !Btype.print_raw destination; *)
if local_non_recursive_abbrev !env source destination then begin
let destination = duplicate_type destination in
- let expansion_scope =
- max (Path.binding_time source) (get_gadt_equations_level ())
+ let source_lev = get_path_scope !env source in
+ let decl =
+ new_declaration (Some (source_lev, get_newtype_level ())) (Some destination)
in
- let decl = new_declaration (Some expansion_scope) (Some destination) in
env := Env.add_local_type source decl !env;
cleanup_abbrev ()
end
&& is_newtype !env p1 && is_newtype !env p2 ->
(* Do not use local constraints more than necessary *)
begin try
- if find_expansion_scope !env p1 > find_expansion_scope !env p2 then
+ if find_expansion_level !env p1 > find_expansion_level !env p2 then
unify env t1 (try_expand_once !env t2)
else
unify env (try_expand_once !env t1) t2
when is_instantiable !env path && is_instantiable !env path'
&& !generate_equations ->
let source, destination =
- if get_path_scope path > get_path_scope path'
+ if get_path_scope !env path > get_path_scope !env path'
then path , t2'
else path', t1'
in
undo_compress snap;
raise (Unification_recursive_abbrev (expand_trace !env [(ty1,ty2)]))
-let unify_gadt ~equations_level:lev (env:Env.t ref) ty1 ty2 =
+let unify_gadt ~newtype_level:lev (env:Env.t ref) ty1 ty2 =
try
univar_pairs := [];
- gadt_equations_level := Some lev;
+ newtype_level := Some lev;
set_mode_pattern ~generate:true ~injective:true
(fun () -> unify env ty1 ty2);
- gadt_equations_level := None;
+ newtype_level := None;
TypePairs.clear unify_eq_set;
with e ->
- gadt_equations_level := None;
+ newtype_level := None;
TypePairs.clear unify_eq_set;
raise e
let row1 = row_repr row1 and row2 = row_repr row2 in
let r1, r2, pairs =
merge_row_fields row1.row_fields row2.row_fields in
+ let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in
+ let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in
let more1 = repr row1.row_more
and more2 = repr row2.row_more in
match more1.desc, more2.desc with
type_manifest = tm;
type_private = priv;
type_variance = decl.type_variance;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = decl.type_loc;
type_attributes = decl.type_attributes;
type_immediate = decl.type_immediate;
val unify: Env.t -> type_expr -> type_expr -> unit
(* Unify the two types given. Raise [Unify] if not possible. *)
-val unify_gadt: equations_level:int -> Env.t ref -> type_expr -> type_expr -> unit
+val unify_gadt: newtype_level:int -> Env.t ref -> type_expr -> type_expr -> unit
(* Unify the two types given and update the environment with the
local constraints. Raise [Unify] if not possible. *)
val unify_var: Env.t -> type_expr -> type_expr -> unit
type_private = priv;
type_manifest = None;
type_variance = List.map (fun _ -> Variance.full) type_params;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
| Some body when decl.type_private = Public
|| decl.type_kind <> Type_abstract
|| Btype.has_constr_row body ->
- (decl.type_params, body, decl.type_expansion_scope)
+ (decl.type_params, body, may_map snd decl.type_newtype_level)
(* The manifest type of Private abstract data types without
private row are still considered unknown to the type system.
Hence, this case is caught by the following clause that also handles
match decl.type_manifest with
(* The manifest type of Private abstract data types can still get
an approximation using their manifest type. *)
- | Some body ->
- (decl.type_params, body, decl.type_expansion_scope)
+ | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
| _ -> raise Not_found
let find_modtype_expansion path env =
PathSet.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
!paths Ident.Set.empty
-let rec remove_aliases_mty env excl mty =
- match mty with
- Mty_signature sg ->
- Mty_signature (remove_aliases_sig env excl sg)
- | Mty_alias _ ->
- let mty' = Env.scrape_alias env mty in
- if mty' = mty then mty else
- remove_aliases_mty env excl mty'
- | mty ->
- mty
+type remove_alias_args =
+ { mutable modified: bool;
+ exclude: Ident.t -> Path.t -> bool;
+ scrape: Env.t -> module_type -> module_type }
+
+let rec remove_aliases_mty env args mty =
+ let args' = {args with modified = false} in
+ let mty' =
+ match args.scrape env mty with
+ Mty_signature sg ->
+ Mty_signature (remove_aliases_sig env args' sg)
+ | Mty_alias _ ->
+ let mty' = Env.scrape_alias env mty in
+ if mty' = mty then mty else
+ (args'.modified <- true; remove_aliases_mty env args' mty')
+ | mty ->
+ mty
+ in
+ if args'.modified then (args.modified <- true; mty') else mty
-and remove_aliases_sig env excl sg =
+and remove_aliases_sig env args sg =
match sg with
[] -> []
| Sig_module(id, md, rs) :: rem ->
let mty =
match md.md_type with
- Mty_alias _ when Ident.Set.mem id excl ->
+ Mty_alias (_, p) when args.exclude id p ->
md.md_type
| mty ->
- remove_aliases_mty env excl mty
+ remove_aliases_mty env args mty
in
Sig_module(id, {md with md_type = mty} , rs) ::
- remove_aliases_sig (Env.add_module id mty env) excl rem
+ remove_aliases_sig (Env.add_module id mty env) args rem
| Sig_modtype(id, mtd) :: rem ->
Sig_modtype(id, mtd) ::
- remove_aliases_sig (Env.add_modtype id mtd env) excl rem
+ remove_aliases_sig (Env.add_modtype id mtd env) args rem
| it :: rem ->
- it :: remove_aliases_sig env excl rem
+ it :: remove_aliases_sig env args rem
+let scrape_for_functor_arg env mty =
+ let exclude _id p =
+ try ignore (Env.find_module p env); true with Not_found -> false
+ in
+ remove_aliases_mty env {modified=false; exclude; scrape} mty
let scrape_for_type_of ~remove_aliases env mty =
if remove_aliases then begin
let excl = collect_arg_paths mty in
- remove_aliases_mty env excl mty
+ let exclude id _p = Ident.Set.mem id excl in
+ let scrape _ mty = mty in
+ remove_aliases_mty env {modified=false; exclude; scrape} mty
end else begin
scrape_for_type_of env mty
end
(* Expand toplevel module type abbreviations
till hitting a "hard" module type (signature, functor,
or abstract module type ident. *)
+val scrape_for_functor_arg: Env.t -> module_type -> module_type
+ (* Remove aliases in a functor argument type *)
val scrape_for_type_of:
remove_aliases:bool -> Env.t -> module_type -> module_type
- (* Expand module aliases *)
+ (* Process type for module type of *)
val freshen: module_type -> module_type
(* Return an alpha-equivalent copy of the given module type
where bound identifiers are fresh. *)
type_private = Asttypes.Public;
type_manifest = None;
type_variance = [];
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
let dummy =
{ type_params = []; type_arity = 0; type_kind = Type_abstract;
type_private = Public; type_manifest = None; type_variance = [];
- type_is_newtype = false; type_expansion_scope = None;
- type_loc = Location.none;
+ type_newtype_level = None; type_loc = Location.none;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
end;
type_private = decl.type_private;
type_variance = decl.type_variance;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = loc s decl.type_loc;
type_attributes = attrs s decl.type_attributes;
type_immediate = decl.type_immediate;
type_private = Public;
type_manifest = Some ty;
type_variance = Misc.replicate_list Variance.full arity;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = loc;
type_attributes = []; (* or keep attrs from the class decl? *)
type_immediate = false;
type_private = Public;
type_manifest = Some obj_ty;
type_variance = List.map (fun _ -> Variance.full) obj_params;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = cl.pci_loc;
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = false;
type_private = Public;
type_manifest = Some cl_ty;
type_variance = List.map (fun _ -> Variance.full) cl_params;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = cl.pci_loc;
type_attributes = []; (* or keep attrs from cl? *)
type_immediate = false;
raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2)))
(* level at which to create the local type declarations *)
-let gadt_equations_level = ref None
-let get_gadt_equations_level () =
- match !gadt_equations_level with
+let newtype_level = ref None
+let get_newtype_level () =
+ match !newtype_level with
Some y -> y
| None -> assert false
let unify_pat_types_gadt loc env ty ty' =
- try unify_gadt ~equations_level:(get_gadt_equations_level ()) env ty ty'
+ let newtype_level =
+ match !newtype_level with
+ | None -> assert false
+ | Some x -> x
+ in
+ try
+ unify_gadt ~newtype_level env ty ty'
with
- | Unify trace ->
+ Unify trace ->
raise(Error(loc, !env, Pattern_type_clash(trace)))
| Tags(l1,l2) ->
raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2)))
raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt,
constr.cstr_arity, List.length sargs)));
let (ty_args, ty_res) =
- instance_constructor ~in_pattern:(env, get_gadt_equations_level ())
- constr
+ instance_constructor ~in_pattern:(env, get_newtype_level ()) constr
in
(* PR#7214: do not use gadt unification for toplevel lets *)
if not constr.cstr_generalized || mode = Inside_or || no_existentials
let type_pat ?(allow_existentials=false) ?constrs ?labels ?(mode=Normal)
?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
- gadt_equations_level := Some lev;
+ newtype_level := Some lev;
try
let r =
type_pat ~no_existentials:(not allow_existentials) ~constrs ~labels
~mode ~explode ~env sp expected_ty (fun x -> x) in
iter_pattern (fun p -> p.pat_env <- !env) r;
- gadt_equations_level := None;
+ newtype_level := None;
r
with e ->
- gadt_equations_level := None;
+ newtype_level := None;
raise e
Use.inspect (Use.join (class_expr env ce)
(list arg env args))
| Tcl_let (rec_flag, valbinds, _, ce) ->
- let _, ty = value_bindings rec_flag env valbinds in
- Use.(inspect (join ty (class_expr env ce)))
+ let env', ty = value_bindings rec_flag env valbinds in
+ Use.(inspect (join ty (class_expr env' ce)))
| Tcl_constraint (ce, _, _, _, _) ->
class_expr env ce
| Tcl_open (_, _, _, _, ce) ->
| Tcl_fun (_, _, _, _, _) -> Use.empty
| Tcl_apply (_, _) -> Use.empty
| Tcl_let (rec_flag, valbinds, _, ce) ->
- let _, ty = value_bindings rec_flag env valbinds in
- Use.join ty (class_expr env ce)
+ (* This rule looks like the `Texp_let` rule in the `expression`
+ function. There is no `Use.discard` here because the
+ occurrences of the variables in [idlist] are only of the form
+ [new id], so they are either absent, Dereferenced, or Guarded
+ (under a delay), never Unguarded, and `discard` would be a no-op.
+ *)
+ let env', ty = value_bindings rec_flag env valbinds in
+ Use.join ty (class_expr env' ce)
| Tcl_constraint (ce, _, _, _, _) ->
class_expr env ce
| Tcl_open (_, _, _, _, ce) ->
(* remember original level *)
begin_def ();
(* Create a fake abstract type declaration for name. *)
+ let level = get_current_level () in
let decl = {
type_params = [];
type_arity = 0;
type_private = Public;
type_manifest = None;
type_variance = [];
- type_is_newtype = true;
- type_expansion_scope = None;
+ type_newtype_level = Some (level, level);
type_loc = loc;
type_attributes = [];
type_immediate = false;
| _ -> true
in
let outer_level = get_current_level () in
- let init_env () =
- (* raise level for existentials *)
- begin_def ();
- Ident.set_current_time (get_current_level ());
- let lev = Ident.current_time () in
- Ctype.init_def (lev+100000); (* up to 1000 existentials *)
- lev
- in
- let lev =
- if may_contain_gadts then init_env () else get_current_level ()
- in
+ if may_contain_gadts then begin_def ();
+ let lev = get_current_level () in
(* Do we need to propagate polymorphism *)
let propagate =
!Clflags.principal || may_contain_gadts || (repr ty_arg).level = generic_level ||
if take_partial_instance <> None then unify_pats (instance ty_arg);
if propagate then begin
List.iter
- (iter_pattern (fun {pat_type=t} -> unify_var env t (newvar()))) patl;
+ (fun (pat, _, (env, _)) ->
+ iter_pattern (fun {pat_type=t} -> unify_var env (newvar()) t) pat)
+ pat_env_list;
end_def ();
generalize ty_arg';
List.iter (iter_pattern (fun {pat_type=t} -> generalize t)) patl;
(* We could check whether there actually is a GADT here instead of reusing
[has_constructor], but I'm not sure it's worth it. *)
let do_init = may_contain_gadts || needs_exhaust_check in
- let lev =
- if do_init && not may_contain_gadts then init_env () else lev in
+ if do_init && not may_contain_gadts then begin_def ();
+ let lev = get_current_level () in
let ty_arg_check =
if do_init then
(* Hack: use for_saving to copy variables too *)
else
Partial
in
- let unused_check do_init =
- let lev =
- if do_init then init_env () else get_current_level ()
- in
+ let unused_check () =
+ begin_def ();
+ init_def lev;
List.iter (fun (pat, _, (env, _)) -> check_absent_variant env pat)
pat_env_list;
- check_unused ~lev env (instance ty_arg_check) cases ;
- if do_init then end_def ();
- Parmatch.check_ambiguous_bindings cases
+ check_unused ~lev env (instance ty_arg_check) cases;
+ Parmatch.check_ambiguous_bindings cases;
+ end_def ()
in
if contains_polyvars || do_init then
- add_delayed_check (fun () -> unused_check do_init)
+ add_delayed_check unused_check
else
- unused_check false;
+ unused_check ();
(* Check for unused cases, do not delay because of gadts *)
if do_init then begin
end_def ();
begin match sdecl.ptype_manifest with None -> None
| Some _ -> Some(Ctype.newvar ()) end;
type_variance = List.map (fun _ -> Variance.full) sdecl.ptype_params;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
type_private = sdecl.ptype_private;
type_manifest = man;
type_variance = List.map (fun _ -> Variance.full) params;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
type_private = priv;
type_manifest = man;
type_variance = [];
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = sdecl.ptype_loc;
type_attributes = sdecl.ptype_attributes;
type_immediate = false;
type_private = Public;
type_manifest = None;
type_variance = replicate_list Variance.full arity;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_loc = Location.none;
type_attributes = [];
type_immediate = false;
)
sdecl.ptype_params;
type_loc = sdecl.ptype_loc;
- type_is_newtype = false;
- type_expansion_scope = None;
+ type_newtype_level = None;
type_attributes = [];
type_immediate = false;
type_unboxed = unboxed_false_default_false;
Mty_signature(approx_sig env ssg)
| Pmty_functor(param, sarg, sres) ->
let arg = may_map (approx_modtype env) sarg in
- let (id, newenv) =
- Env.enter_module ~arg:true param.txt (Btype.default_mty arg) env in
+ let rarg = Mtype.scrape_for_functor_arg env (Btype.default_mty arg) in
+ let (id, newenv) = Env.enter_module ~arg:true param.txt rarg env in
let res = approx_modtype newenv sres in
Mty_functor(id, arg, res)
| Pmty_with(sbody, _constraints) ->
Builtin_attributes.warning_scope smty.pmty_attributes
(fun () -> transl_modtype_aux env smty)
+and transl_modtype_functor_arg env sarg =
+ let mty = transl_modtype env sarg in
+ {mty with mty_type = Mtype.scrape_for_functor_arg env mty.mty_type}
+
and transl_modtype_aux env smty =
let loc = smty.pmty_loc in
match smty.pmty_desc with
mkmty (Tmty_signature sg) (Mty_signature sg.sig_type) env loc
smty.pmty_attributes
| Pmty_functor(param, sarg, sres) ->
- let arg = Misc.may_map (transl_modtype env) sarg in
+ let arg = Misc.may_map (transl_modtype_functor_arg env) sarg in
let ty_arg = Misc.may_map (fun m -> m.mty_type) arg in
let (id, newenv) =
Env.enter_module ~arg:true param.txt (Btype.default_mty ty_arg) env in
wrap_constraint env false md (Mty_signature sg')
Tmodtype_implicit
| Pmod_functor(name, smty, sbody) ->
- let mty = may_map (transl_modtype env) smty in
- let ty_arg = may_map (fun m -> m.mty_type) mty in
+ let mty = may_map (transl_modtype_functor_arg env) smty in
+ let ty_arg = Misc.may_map (fun m -> m.mty_type) mty in
let (id, newenv), funct_body =
match ty_arg with None -> (Ident.create "*", env), false
| Some mty -> Env.enter_module ~arg:true name.txt mty env, true in
mod_loc = smod.pmod_loc }
| _ -> type_module env smod
in
- let mty = tmty.mod_type in
- let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
+ let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
(* PR#5036: must not contain non-generalized type variables *)
if not (closed_modtype env mty) then
raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
type_private: private_flag;
type_manifest: type_expr option;
type_variance: Variance.t list;
- type_is_newtype: bool;
- type_expansion_scope: int option;
+ type_newtype_level: (int * int) option;
type_loc: Location.t;
type_attributes: Parsetree.attributes;
type_immediate: bool;
type_manifest: type_expr option;
type_variance: Variance.t list;
(* covariant, contravariant, weakly contravariant, injective *)
- type_is_newtype: bool;
- type_expansion_scope: int option;
+ type_newtype_level: (int * int) option;
+ (* definition level * expansion level *)
type_loc: Location.t;
type_attributes: Parsetree.attributes;
type_immediate: bool; (* true iff type should not be a pointer *)
let exec_magic_number = "Caml1999X023"
(* exec_magic_number is duplicated in byterun/caml/exec.h *)
-and cmi_magic_number = "Caml1999I023"
+and cmi_magic_number = "Caml1999I024"
and cmo_magic_number = "Caml1999O023"
and cma_magic_number = "Caml1999A023"
and cmx_magic_number =
and ast_intf_magic_number = "Caml1999N023"
and cmxs_magic_number = "Caml1999D023"
(* cmxs_magic_number is duplicated in otherlibs/dynlink/natdynlink.ml *)
-and cmt_magic_number = "Caml1999T023"
+and cmt_magic_number = "Caml1999T024"
let load_path = ref ([] : string list)
projects / ocaml.git / commitdiff