From: Stephane Glondu Date: Wed, 10 Jul 2019 12:50:03 +0000 (+0200) Subject: New upstream version 4.07.1 X-Git-Tag: archive/raspbian/4.08.1-4+rpi1~2^2~17^2~5^2~2 X-Git-Url: https://dgit.raspbian.org/?a=commitdiff_plain;h=1dff8a2f0f8dae311ae15ca8fa2596b737450ba6;p=ocaml.git New upstream version 4.07.1 --- diff --git a/Changes b/Changes index 25976617..584fa9a9 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,36 @@ +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) --------------------------- diff --git a/VERSION b/VERSION index 6d514477..0e48c0f1 100644 --- a/VERSION +++ b/VERSION @@ -1,4 +1,4 @@ -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 diff --git a/boot/ocamlc b/boot/ocamlc index beac6097..4529ffc3 100755 Binary files a/boot/ocamlc and b/boot/ocamlc differ diff --git a/boot/ocamllex b/boot/ocamllex index 1b3e201e..cd31e4c6 100755 Binary files a/boot/ocamllex and b/boot/ocamllex differ diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index fa1ddbeb..0da506f8 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -48,7 +48,8 @@ let prim_fresh_oo_id = 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 diff --git a/byterun/freelist.c b/byterun/freelist.c index 915eb9f9..4782800e 100644 --- a/byterun/freelist.c +++ b/byterun/freelist.c @@ -338,7 +338,7 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) 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){ diff --git a/stdlib/array.ml b/stdlib/array.ml index d29a04fa..a693f4a7 100644 --- a/stdlib/array.ml +++ b/stdlib/array.ml @@ -334,7 +334,7 @@ let of_rev_list = function [] -> 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 diff --git a/testsuite/tests/lib-seq/test.ml b/testsuite/tests/lib-seq/test.ml index 934a001e..ca38d466 100644 --- a/testsuite/tests/lib-seq/test.ml +++ b/testsuite/tests/lib-seq/test.ml @@ -13,6 +13,15 @@ let () = () ;; +(* MPR 7820 *) +let () = + assert + ([| 1;2;3 |] = + (Array.to_seq [| 1;2;3 |] + |> Array.of_seq)); + () +;; + let () = print_endline "OK";; diff --git a/testsuite/tests/typing-gadts/gpr1997.ml b/testsuite/tests/typing-gadts/gpr1997.ml new file mode 100644 index 00000000..8a9b6c95 --- /dev/null +++ b/testsuite/tests/typing-gadts/gpr1997.ml @@ -0,0 +1,53 @@ +(* 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 = +|}];; diff --git a/testsuite/tests/typing-gadts/ocamltests b/testsuite/tests/typing-gadts/ocamltests index ace6ac47..908c01f5 100644 --- a/testsuite/tests/typing-gadts/ocamltests +++ b/testsuite/tests/typing-gadts/ocamltests @@ -46,3 +46,4 @@ test.ml unify_mb.ml variables_in_mcomp.ml yallop_bugs.ml +gpr1997.ml diff --git a/testsuite/tests/typing-gadts/pr7222.ml b/testsuite/tests/typing-gadts/pr7222.ml index 290f4448..4316e10e 100644 --- a/testsuite/tests/typing-gadts/pr7222.ml +++ b/testsuite/tests/typing-gadts/pr7222.ml @@ -38,7 +38,6 @@ Line _, characters 6-22: 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 |}];; diff --git a/testsuite/tests/typing-misc/variant.ml b/testsuite/tests/typing-misc/variant.ml index 00ad4ea3..9564f36a 100644 --- a/testsuite/tests/typing-misc/variant.ml +++ b/testsuite/tests/typing-misc/variant.ml @@ -26,3 +26,19 @@ Error: Signature mismatch: 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 +|}] diff --git a/testsuite/tests/typing-modules/ocamltests b/testsuite/tests/typing-modules/ocamltests index 24dd8694..1b548b20 100644 --- a/testsuite/tests/typing-modules/ocamltests +++ b/testsuite/tests/typing-modules/ocamltests @@ -7,6 +7,7 @@ pr6394.ml pr7207.ml pr7348.ml pr7787.ml +pr7818.ml printing.ml recursive.ml Test.ml diff --git a/testsuite/tests/typing-modules/pr7818.ml b/testsuite/tests/typing-modules/pr7818.ml new file mode 100644 index 00000000..166faf8e --- /dev/null +++ b/testsuite/tests/typing-modules/pr7818.ml @@ -0,0 +1,319 @@ +(* 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 +|}] diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml index 0777d1d4..e187c566 100644 --- a/testsuite/tests/typing-objects/Tests.ml +++ b/testsuite/tests/typing-objects/Tests.ml @@ -886,3 +886,33 @@ Line _, characters 10-37: ^^^^^^^^^^^^^^^^^^^^^^^^^^^ 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 +|}];; diff --git a/testsuite/tests/typing-polyvariants-bugs/ocamltests b/testsuite/tests/typing-polyvariants-bugs/ocamltests index d589e6c1..5ea661d0 100644 --- a/testsuite/tests/typing-polyvariants-bugs/ocamltests +++ b/testsuite/tests/typing-polyvariants-bugs/ocamltests @@ -3,4 +3,5 @@ pr4933_ok.ml pr5057_ok.ml pr5057a_bad.ml pr7199_ok.ml +pr7824.ml privrowsabate_ok.ml diff --git a/testsuite/tests/typing-polyvariants-bugs/pr7824.ml b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml new file mode 100644 index 00000000..2592b4b5 --- /dev/null +++ b/testsuite/tests/typing-polyvariants-bugs/pr7824.ml @@ -0,0 +1,78 @@ +(* 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 = +|}];; + +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 = +|}];; + +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 = +|}];; + +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 = +|}];; diff --git a/typing/ctype.ml b/typing/ctype.ml index f24e46d1..ce4e584e 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -684,8 +684,15 @@ let forward_try_expand_once = (* Forward declaration *) 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 = @@ -745,7 +752,7 @@ let rec update_level env level expand ty = | 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); @@ -767,13 +774,13 @@ let rec update_level env level expand 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} | _ -> () @@ -1027,7 +1034,7 @@ let rec copy ?partial ?keep_names ty = 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; @@ -1129,7 +1136,7 @@ let get_new_abstract_name s = 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; @@ -1137,8 +1144,7 @@ let new_declaration expansion_scope manifest = 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; @@ -1148,9 +1154,9 @@ let new_declaration expansion_scope manifest = 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 @@ -1943,19 +1949,26 @@ let deep_occur t0 ty = 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 = @@ -1964,9 +1977,9 @@ let reify env t = 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 @@ -1975,11 +1988,11 @@ let reify env t = 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; @@ -1995,14 +2008,14 @@ let reify env t = 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 @@ -2245,27 +2258,22 @@ let find_lowest_level ty = 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 @@ -2412,7 +2420,7 @@ let rec unify (env:Env.t ref) t1 t2 = && 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 @@ -2532,7 +2540,7 @@ and unify3 env t1 t1' t2 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 @@ -2860,16 +2868,16 @@ let unify env ty1 ty2 = 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 @@ -4132,6 +4140,8 @@ and subtype_row env trace row1 row2 cstrs = 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 @@ -4483,8 +4493,7 @@ let nondep_type_decl env mid id is_covariant decl = 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; diff --git a/typing/ctype.mli b/typing/ctype.mli index e22d2694..c4d1e55f 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -169,7 +169,7 @@ val enforce_constraints: Env.t -> type_expr -> unit 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 diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 7bef64c9..052e7417 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -85,8 +85,7 @@ let constructor_args priv cd_args cd_res path rep = 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; diff --git a/typing/env.ml b/typing/env.ml index cf5207ee..f49a8478 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1051,7 +1051,7 @@ let find_type_expansion path env = | 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 @@ -1067,8 +1067,7 @@ let find_type_expansion_opt path env = 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 = diff --git a/typing/mtype.ml b/typing/mtype.ml index c923fd33..f22ac743 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -423,41 +423,57 @@ let collect_arg_paths mty = 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 diff --git a/typing/mtype.mli b/typing/mtype.mli index a2cfadfd..30d13ec6 100644 --- a/typing/mtype.mli +++ b/typing/mtype.mli @@ -21,9 +21,11 @@ val scrape: Env.t -> module_type -> module_type (* 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. *) diff --git a/typing/predef.ml b/typing/predef.ml index 2989d426..a7688ccc 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -125,8 +125,7 @@ let decl_abstr = 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; diff --git a/typing/printtyp.ml b/typing/printtyp.ml index f2e6f196..efb2ed09 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -1284,8 +1284,7 @@ let filter_rem_sig item rem = 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; diff --git a/typing/subst.ml b/typing/subst.ml index ad9d8d68..5ac528e1 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -299,8 +299,7 @@ let type_declaration s decl = 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; diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 53542c5c..e03c2cd3 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1291,8 +1291,7 @@ let temp_abbrev loc env id arity = 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; @@ -1542,8 +1541,7 @@ let class_infos define_class kind 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; @@ -1562,8 +1560,7 @@ let class_infos define_class kind 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; diff --git a/typing/typecore.ml b/typing/typecore.ml index c6a40713..cd3df704 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -390,16 +390,22 @@ let unify_exp_types loc env ty expected_ty = 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))) @@ -1185,8 +1191,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env 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 @@ -1409,16 +1414,16 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env 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 @@ -2317,8 +2322,8 @@ struct 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) -> @@ -2417,8 +2422,14 @@ struct | 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) -> @@ -3736,6 +3747,7 @@ and type_expect_ (* 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; @@ -3743,8 +3755,7 @@ and type_expect_ 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; @@ -4650,17 +4661,8 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = | _ -> 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 || @@ -4726,7 +4728,9 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = 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; @@ -4773,8 +4777,8 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = (* 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 *) @@ -4787,20 +4791,19 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist = 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 (); diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 5e4b9d5a..18e56e87 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -104,8 +104,7 @@ let enter_type rec_flag env sdecl id = 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; @@ -518,8 +517,7 @@ let transl_declaration env sdecl id = 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; @@ -1850,8 +1848,7 @@ let transl_with_constraint env id row_path orig_decl sdecl = 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; @@ -1899,8 +1896,7 @@ let abstract_type_decl arity = 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; diff --git a/typing/typemod.ml b/typing/typemod.ml index 1812e089..c251f57f 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -359,8 +359,7 @@ let merge_constraint initial_env remove_aliases loc sg constr = ) 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; @@ -542,8 +541,8 @@ let rec approx_modtype env smty = 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) -> @@ -747,6 +746,10 @@ let rec transl_modtype env smty = 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 @@ -763,7 +766,7 @@ and transl_modtype_aux env smty = 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 @@ -1343,8 +1346,8 @@ and type_module_aux ~alias sttn funct_body anchor env smod = 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 @@ -1763,8 +1766,7 @@ let type_module_type_of env smod = 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)); diff --git a/typing/types.ml b/typing/types.ml index 3003fc98..94b41a16 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -146,8 +146,7 @@ type type_declaration = 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; diff --git a/typing/types.mli b/typing/types.mli index b88c87ee..1ca92c12 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -291,8 +291,8 @@ type type_declaration = 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 *) diff --git a/utils/config.mlp b/utils/config.mlp index 22750c4e..729e1378 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -84,7 +84,7 @@ let afl_instrument = %%AFL_INSTRUMENT%% 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 = @@ -101,7 +101,7 @@ and ast_impl_magic_number = "Caml1999M023" 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)