diff --git a/testsuite/tests/typing-poly/poly.ml.principal.reference b/testsuite/tests/typing-poly/poly.ml.principal.reference index 55bfd0f4c..b5b4518ff 100644 --- a/testsuite/tests/typing-poly/poly.ml.principal.reference +++ b/testsuite/tests/typing-poly/poly.ml.principal.reference @@ -300,7 +300,7 @@ and 'a v = 'a u t constraint 'a = int Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g -and 'a v = 'a u t constraint 'a = int +and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ diff --git a/testsuite/tests/typing-poly/poly.ml.reference b/testsuite/tests/typing-poly/poly.ml.reference index 89d050b37..50b4117d6 100644 --- a/testsuite/tests/typing-poly/poly.ml.reference +++ b/testsuite/tests/typing-poly/poly.ml.reference @@ -283,7 +283,7 @@ and 'a v = 'a u t constraint 'a = int Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t # type 'a u = 'a constraint 'a = g -and 'a v = 'a u t constraint 'a = int +and 'a v = 'a u t constraint 'a = g # Characters 38-58: type 'a u = < m : 'a v > and 'a v = 'a list u;; ^^^^^^^^^^^^^^^^^^^^ @@ -441,12 +441,7 @@ Error: Type < m : 'a. 'a -> ('a * (< m : 'c. 'c -> 'b as 'e > as 'd) as 'b) > = struct let f (x : as 'foo) = () end;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Signature mismatch: - Modules do not match: - sig val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit end - is not included in - sig - val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit - end + ... Values do not match: val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit is not included in diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index f3b585188..a058dc4dd 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -220,8 +220,8 @@ let execute_phrase print_outcome ppf phr = Typecore.reset_delayed_checks (); let (str, sg, newenv) = Typemod.type_structure oldenv sstr Location.none in - let _ = - Includemod.compunit "//toplevel//" sg "(inferred signature)" sg in + let sg' = Typemod.simplify_signature sg in + ignore (Includemod.signatures oldenv sg sg'); Typecore.force_delayed_checks (); let lam = Translmod.transl_toplevel_definition str in Warnings.check_fatal (); @@ -238,8 +238,7 @@ let execute_phrase print_outcome ppf phr = let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (item_list newenv - (Typemod.simplify_signature sg)) + | _ -> Ophr_signature (item_list newenv sg') else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/typing/ctype.ml b/typing/ctype.ml index 86d744ac9..41fa5f02f 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -690,12 +690,11 @@ let forward_try_expand_once = (* Forward declaration *) let get_level env p = try match (Env.find_type p env).type_newtype_level with - | None -> Path.binding_time p - | Some (x, _) -> x - with - | _ -> - (* no newtypes in predef *) - Path.binding_time p + | None -> Path.binding_time p + | Some (x, _) -> x + with Not_found -> + (* no newtypes in predef *) + Path.binding_time p let rec update_level env level ty = let ty = repr ty in @@ -1437,10 +1436,13 @@ let expand_head_opt env ty = let enforce_constraints env ty = match ty with {desc = Tconstr (path, args, abbrev); level = level} -> - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) + begin try + let decl = Env.find_type path env in + ignore + (subst env level Public (ref Mnil) None decl.type_params args + (newvar2 level)) + with Not_found -> () + end | _ -> assert false @@ -1490,7 +1492,7 @@ let rec non_recursive_abbrev env ty0 ty = with Cannot_expand -> if !Clflags.recursive_types && (in_current_module p || in_pervasives p || - is_datatype (Env.find_type p env)) + try is_datatype (Env.find_type p env) with Not_found -> false) then () else iter_type_expr (non_recursive_abbrev env ty0) ty end @@ -1832,11 +1834,13 @@ let reify env t = in iterator t -let is_abstract_newtype env p = - let decl = Env.find_type p env in - not (decl.type_newtype_level = None) && - decl.type_manifest = None && - decl.type_kind = Type_abstract +let is_abstract_newtype env p = + try + let decl = Env.find_type p env in + not (decl.type_newtype_level = None) && + decl.type_manifest = None && + decl.type_kind = Type_abstract + with Not_found -> false (* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually @@ -1957,22 +1961,24 @@ and mcomp_type_decl type_pairs subst env p1 p2 tl1 tl2 = in_pervasives p || in_current_module p && decl.type_newtype_level = None in - let decl = Env.find_type p1 env in - let decl' = Env.find_type p2 env in - if Path.same p1 p2 then - if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2 else () - else match decl.type_kind, decl'.type_kind with - | Type_record (lst,r), Type_record (lst',r') when r = r' -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_record_description type_pairs subst env lst lst' - | Type_variant v1, Type_variant v2 -> - mcomp_list type_pairs subst env tl1 tl2; - mcomp_variant_description type_pairs subst env v1 v2 - | Type_variant _, Type_record _ - | Type_record _, Type_variant _ -> raise (Unify []) - | _ -> - if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl') - || is_datatype decl && non_aliased p2 decl' then raise (Unify []) + try + let decl = Env.find_type p1 env in + let decl' = Env.find_type p2 env in + if Path.same p1 p2 then + (if non_aliased p1 decl then mcomp_list type_pairs subst env tl1 tl2) + else match decl.type_kind, decl'.type_kind with + | Type_record (lst,r), Type_record (lst',r') when r = r' -> + mcomp_list type_pairs subst env tl1 tl2; + mcomp_record_description type_pairs subst env lst lst' + | Type_variant v1, Type_variant v2 -> + mcomp_list type_pairs subst env tl1 tl2; + mcomp_variant_description type_pairs subst env v1 v2 + | Type_variant _, Type_record _ + | Type_record _, Type_variant _ -> raise (Unify []) + | _ -> + if non_aliased p1 decl && (non_aliased p2 decl' || is_datatype decl') + || is_datatype decl && non_aliased p2 decl' then raise (Unify []) + with Not_found -> () and mcomp_type_option type_pairs subst env t t' = match t, t' with @@ -2022,10 +2028,11 @@ let find_lowest_level ty = end in find ty; unmark_type ty; !lowest -let find_newtype_level env path = - match (Env.find_type path env).type_newtype_level with - Some x -> x +let find_newtype_level env path = + try match (Env.find_type path env).type_newtype_level with + | Some x -> x | None -> assert false + with Not_found -> assert false let add_gadt_equation env source destination = let destination = duplicate_type destination in @@ -2179,7 +2186,7 @@ and unify3 env t1 t1' t2 t2' = | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> if !umode = Expression || not !generate_equations || in_current_module p1 || in_pervasives p1 - || is_datatype (Env.find_type p1 !env) + || try is_datatype (Env.find_type p1 !env) with Not_found -> false then unify_list env tl1 tl2 else