summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--debugger/loadprinter.ml15
-rw-r--r--testsuite/tests/typing-objects/class_2.ml15
-rw-r--r--toplevel/topdirs.ml60
-rw-r--r--typing/ctype.ml59
-rw-r--r--typing/ctype.mli41
-rw-r--r--typing/typeclass.ml225
-rw-r--r--typing/typecore.ml1288
-rw-r--r--typing/typecore.mli1
-rw-r--r--typing/typedecl.ml270
-rw-r--r--typing/typemod.ml28
-rw-r--r--typing/typetexp.ml112
-rw-r--r--typing/typetexp.mli3
12 files changed, 1136 insertions, 981 deletions
diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml
index 5009623a89..ff2eed190b 100644
--- a/debugger/loadprinter.ml
+++ b/debugger/loadprinter.ml
@@ -90,14 +90,13 @@ let eval_value_path env path =
(* Install, remove a printer (as in toplevel/topdirs) *)
let match_printer_type desc make_printer_type =
- Ctype.begin_def();
- let ty_arg = Ctype.newvar() in
- Ctype.unify Env.empty
- (make_printer_type ty_arg)
- (Ctype.instance desc.val_type);
- Ctype.end_def();
- Ctype.generalize ty_arg;
- ty_arg
+ Ctype.wrap_def ~post:Ctype.generalize begin fun () ->
+ let ty_arg = Ctype.newvar() in
+ Ctype.unify Env.empty
+ (make_printer_type ty_arg)
+ (Ctype.instance desc.val_type);
+ ty_arg
+ end
let find_printer_type lid =
match Env.find_value_by_name lid Env.empty with
diff --git a/testsuite/tests/typing-objects/class_2.ml b/testsuite/tests/typing-objects/class_2.ml
new file mode 100644
index 0000000000..2d70884cdd
--- /dev/null
+++ b/testsuite/tests/typing-objects/class_2.ml
@@ -0,0 +1,15 @@
+(* TEST
+ * expect
+*)
+
+(* class expressions may also contain local recursive bindings *)
+class test =
+ let rec f = fun x -> g x
+ and g = fun x -> f x in
+object
+ method f : 'a 'b. 'a -> 'b = f
+ method g : 'a 'b. 'a -> 'b = g
+end
+[%%expect{|
+class test : object method f : 'a -> 'b method g : 'a -> 'b end
+|}]
diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml
index 1d92cb65dd..4529a1cf00 100644
--- a/toplevel/topdirs.ml
+++ b/toplevel/topdirs.ml
@@ -231,43 +231,43 @@ let match_simple_printer_type desc ~is_old_style =
then Topprinters.printer_type_old
else Topprinters.printer_type_new
in
- Ctype.begin_def();
- let ty_arg = Ctype.newvar() in
- match
- Ctype.unify !toplevel_env
- (make_printer_type ty_arg)
- (Ctype.instance desc.val_type);
- with
- | exception Ctype.Unify _ -> None
- | () ->
- Ctype.end_def();
- Ctype.generalize ty_arg;
- if is_old_style
- then Some (Printer.Old ty_arg)
- else Some (Printer.Simple ty_arg)
+ match
+ Ctype.wrap_def ~post:Ctype.generalize begin fun () ->
+ let ty_arg = Ctype.newvar() in
+ Ctype.unify !toplevel_env
+ (make_printer_type ty_arg)
+ (Ctype.instance desc.val_type);
+ ty_arg
+ end
+ with
+ | exception Ctype.Unify _ -> None
+ | ty_arg ->
+ if is_old_style
+ then Some (Printer.Old ty_arg)
+ else Some (Printer.Simple ty_arg)
let match_generic_printer_type desc ty_path args =
let make_printer_type = Topprinters.printer_type_new in
- Ctype.begin_def();
- let args = List.map (fun _ -> Ctype.newvar ()) args in
- let ty_target = Ctype.newty (Tconstr (ty_path, args, ref Mnil)) in
- let printer_args_ty =
- List.map (fun ty_var -> make_printer_type ty_var) args in
- let ty_expected =
- List.fold_right Topprinters.type_arrow
- printer_args_ty (make_printer_type ty_target) in
match
- Ctype.unify !toplevel_env
+ Ctype.wrap_def ~post:generalize begin fun () ->
+ let args = List.map (fun _ -> Ctype.newvar ()) args in
+ let ty_target = Ctype.newty (Tconstr (ty_path, args, ref Mnil)) in
+ let printer_args_ty =
+ List.map (fun ty_var -> make_printer_type ty_var) args in
+ let ty_expected =
+ List.fold_right Topprinters.type_arrow
+ printer_args_ty (make_printer_type ty_target) in
+ Ctype.unify !toplevel_env
+ ty_expected
+ (Ctype.instance desc.val_type);
ty_expected
- (Ctype.instance desc.val_type);
+ end
with
| exception Ctype.Unify _ -> None
- | _ ->
- Ctype.end_def();
- Ctype.generalize ty_expected;
- if Ctype.all_distinct_vars !toplevel_env args
- then Some ()
- else None
+ | ty_expected ->
+ if Ctype.all_distinct_vars !toplevel_env args
+ then Some ()
+ else None
let match_printer_type desc =
match match_simple_printer_type desc ~is_old_style:false with
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 67593ae1d4..de0b0e4e5c 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -182,6 +182,52 @@ let end_def () =
let create_scope () =
init_def (!current_level + 1);
!current_level
+let wrap_def ?post f =
+ begin_def ();
+ let result = f () in
+ end_def ();
+ Option.iter (fun g -> g result) post;
+ result
+let wrap_def_process_if cond f ~proc =
+ if cond then begin_def ();
+ let result, l = f () in
+ if cond then begin
+ end_def ();
+ List.iter proc l;
+ end;
+ result
+let wrap_def_process f ~proc = wrap_def_process_if true f ~proc
+let wrap_def_if cond f ~post =
+ if cond then begin_def ();
+ let result = f () in
+ if cond then begin
+ end_def ();
+ post result;
+ end;
+ result
+let wrap_def_principal f ~post = wrap_def_if !Clflags.principal f ~post
+let wrap_def_process_principal f ~proc =
+ wrap_def_process_if !Clflags.principal f ~proc
+let wrap_init_def_if cond ~level f =
+ if cond then (begin_def (); init_def level);
+ let result = f () in
+ if cond then end_def ();
+ result
+let wrap_init_def ~level f = wrap_init_def_if true ~level f
+
+let wrap_class_def ?post f =
+ begin_class_def ();
+ let result = f () in
+ end_def ();
+ Option.iter (fun g -> g result) post;
+ result
+
+let wrap_raise_nongen_level f =
+ raise_nongen_level ();
+ let result = f () in
+ end_def ();
+ result
+
let reset_global_level () =
global_level := !current_level + 1
@@ -1671,16 +1717,13 @@ let full_expand ~may_forget_scope env ty =
if may_forget_scope then
try expand_head_unif env ty with Unify_trace _ ->
(* #10277: forget scopes when printing trace *)
- begin_def ();
- init_def (get_level ty);
- let ty =
+ wrap_def begin fun () ->
+ init_def (get_level ty);
(* The same as [expand_head], except in the failing case we return the
- *original* type, not [correct_levels ty].*)
+ *original* type, not [correct_levels ty].*)
try try_expand_head try_expand_safe env (correct_levels ty) with
| Cannot_expand -> ty
- in
- end_def ();
- ty
+ end
else expand_head env ty
in
match get_desc ty with
@@ -3166,6 +3209,8 @@ let unify_pairs env ty1 ty2 pairs =
let unify env ty1 ty2 =
unify_pairs (ref env) ty1 ty2 []
+(* Lower the level of a type to the current level *)
+let enforce_current_level env ty = unify_var env (newvar ()) ty
(**** Special cases of unification ****)
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 86c46d1ee8..ad19acb4c3 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -33,14 +33,49 @@ exception Matches_failure of Env.t * Errortrace.unification_error
exception Incompatible
(* Raised from [mcomp] *)
+(* Old API
val init_def: int -> unit
(* Set the initial variable level *)
val begin_def: unit -> unit
(* Raise the variable level by one at the beginning of a definition. *)
-val end_def: unit -> unit
- (* Lower the variable level by one at the end of a definition *)
val begin_class_def: unit -> unit
+ (* Raise the current level not touching the nongen level *)
val raise_nongen_level: unit -> unit
+ (* Raise the nongen level to the current level *)
+val end_def: unit -> unit
+ (* Lower the variable level by one at the end of a definition *)
+*)
+
+val wrap_def: ?post:('a -> unit) -> (unit -> 'a) -> 'a
+ (* [wrap_def (fun () -> cmd) ~post] evaluates [cmd] at a raised level.
+ If given, [post] is applied to the result, at the original level.
+ It is expected to contain only level related post-processing. *)
+val wrap_def_if: bool -> (unit -> 'a) -> post:('a -> unit) -> 'a
+ (* Same as [wrap_init_def], but only raise the level conditionally.
+ [post] also is only called if the level is raised. *)
+val wrap_def_process: (unit -> 'a * 'b list) -> proc:('b -> unit) -> 'a
+ (* Variant of [wrap_def], where [proc] is iterated on the returned
+ list. *)
+val wrap_def_process_if:
+ bool -> (unit -> 'a * 'b list) -> proc:('b -> unit) -> 'a
+ (* Conditional variant of [wrap_def_process] *)
+val wrap_init_def: level: int -> (unit -> 'a) -> 'a
+ (* [wrap_init_def ~level (fun () -> cmd)] evaluates [cmd] with
+ [current_level] set to [level] *)
+val wrap_init_def_if: bool -> level: int -> (unit -> 'a) -> 'a
+ (* Conditional variant of [wrap_init_def] *)
+val wrap_def_principal: (unit -> 'a) -> post:('a -> unit) -> 'a
+val wrap_def_process_principal:
+ (unit -> 'a * 'b list) -> proc:('b -> unit) -> 'a
+ (* Applications of [wrap_def_if] and [wrap_def_process_if] to
+ [!Clflags.principal] *)
+
+val wrap_class_def: ?post:('a -> unit) -> (unit -> 'a) -> 'a
+ (* Variant of [wrap_def], where the current level is raised but
+ the nongen level is not touched *)
+val wrap_raise_nongen_level: (unit -> 'a) -> 'a
+ (* Variant of [wrap_def], raises the nongen level to the current level *)
+
val reset_global_level: unit -> unit
(* Reset the global level before typing an expression *)
val increase_global_level: unit -> int
@@ -115,6 +150,8 @@ val lower_contravariant: Env.t -> type_expr -> unit
to be used before generalize for expansive expressions *)
val lower_variables_only: Env.t -> int -> type_expr -> unit
(* Lower all variables to the given level *)
+val enforce_current_level: Env.t -> type_expr -> unit
+ (* Lower whole type to !current_level *)
val generalize_structure: type_expr -> unit
(* Generalize the structure of a type, lowering variables
to !current_level *)
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 2d0c3d1085..336d09401b 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -643,15 +643,13 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
| Pcf_val (label, mut, Cfk_virtual styp) ->
with_attrs
(fun () ->
- if !Clflags.principal then Ctype.begin_def ();
- let cty = Typetexp.transl_simple_type val_env false styp in
- let ty = cty.ctyp_type in
- if !Clflags.principal then begin
- Ctype.end_def ();
- Ctype.generalize_structure ty
- end;
+ let cty =
+ Ctype.wrap_def_principal
+ (fun () -> Typetexp.transl_simple_type val_env false styp)
+ ~post:(fun cty -> Ctype.generalize_structure cty.ctyp_type)
+ in
add_instance_variable ~strict:true loc val_env
- label.txt mut Virtual ty sign;
+ label.txt mut Virtual cty.ctyp_type sign;
let already_declared, val_env, par_env, id, vars =
match Vars.find label.txt vars with
| id -> true, val_env, par_env, id, vars
@@ -684,12 +682,10 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
raise(Error(loc, val_env,
No_overriding ("instance variable", label.txt)))
end;
- if !Clflags.principal then Ctype.begin_def ();
- let definition = type_exp val_env sdefinition in
- if !Clflags.principal then begin
- Ctype.end_def ();
- Ctype.generalize_structure definition.exp_type
- end;
+ let definition =
+ Ctype.wrap_def_principal ~post:Typecore.generalize_structure_exp
+ (fun () -> type_exp val_env sdefinition)
+ in
add_instance_variable ~strict:true loc val_env
label.txt mut Concrete definition.exp_type sign;
let already_declared, val_env, par_env, id, vars =
@@ -907,9 +903,9 @@ and class_field_second_pass cl_num sign met_env field =
mk_expected
(Btype.newgenty (Tarrow(Nolabel, self_type, ty, commu_ok)))
in
- Ctype.raise_nongen_level ();
- let texp = type_expect met_env sdefinition meth_type in
- Ctype.end_def ();
+ let texp =
+ Ctype.wrap_raise_nongen_level
+ (fun () -> type_expect met_env sdefinition meth_type) in
let kind = Tcfk_concrete (override, texp) in
let desc = Tcf_method(label, priv, kind) in
met_env, mkcf desc loc attributes)
@@ -919,15 +915,15 @@ and class_field_second_pass cl_num sign met_env field =
| Initializer { sexpr; warning_state; loc; attributes } ->
Warnings.with_state warning_state
(fun () ->
- Ctype.raise_nongen_level ();
let unit_type = Ctype.instance Predef.type_unit in
let self_type = sign.Types.csig_self in
let meth_type =
mk_expected
(Ctype.newty (Tarrow (Nolabel, self_type, unit_type, commu_ok)))
in
- let texp = type_expect met_env sexpr meth_type in
- Ctype.end_def ();
+ let texp =
+ Ctype.wrap_raise_nongen_level
+ (fun () -> type_expect met_env sexpr meth_type) in
let desc = Tcf_initializer texp in
met_env, mkcf desc loc attributes)
| Attribute { attribute; loc; attributes; } ->
@@ -1142,15 +1138,15 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
in
class_expr cl_num val_env met_env virt self_scope sfun
| Pcl_fun (l, None, spat, scl') ->
- if !Clflags.principal then Ctype.begin_def ();
let (pat, pv, val_env', met_env) =
- Typecore.type_class_arg_pattern cl_num val_env met_env l spat
+ Ctype.wrap_def_principal
+ (fun () ->
+ Typecore.type_class_arg_pattern cl_num val_env met_env l spat)
+ ~post: begin fun (pat, _, _, _) ->
+ let gen {pat_type = ty} = Ctype.generalize_structure ty in
+ iter_pattern gen pat
+ end
in
- if !Clflags.principal then begin
- Ctype.end_def ();
- let gen {pat_type = ty} = Ctype.generalize_structure ty in
- iter_pattern gen pat
- end;
let pv =
List.map
begin fun (id, id', _ty) ->
@@ -1177,9 +1173,9 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
Typecore.check_partial val_env pat.pat_type pat.pat_loc
[{c_lhs = pat; c_guard = None; c_rhs = dummy}]
in
- Ctype.raise_nongen_level ();
- let cl = class_expr cl_num val_env' met_env virt self_scope scl' in
- Ctype.end_def ();
+ let cl =
+ Ctype.wrap_raise_nongen_level
+ (fun () -> class_expr cl_num val_env' met_env virt self_scope scl') in
if Btype.is_optional l && not_nolabel_function cl.cl_type then
Location.prerr_warning pat.pat_loc
Warnings.Unerasable_optional_argument;
@@ -1192,12 +1188,11 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
}
| Pcl_apply (scl', sargs) ->
assert (sargs <> []);
- if !Clflags.principal then Ctype.begin_def ();
- let cl = class_expr cl_num val_env met_env virt self_scope scl' in
- if !Clflags.principal then begin
- Ctype.end_def ();
- Ctype.generalize_class_type_structure cl.cl_type;
- end;
+ let cl =
+ Ctype.wrap_def_principal
+ (fun () -> class_expr cl_num val_env met_env virt self_scope scl')
+ ~post:(fun cl -> Ctype.generalize_class_type_structure cl.cl_type)
+ in
let rec nonopt_labels ls ty_fun =
match ty_fun with
| Cty_arrow (l, _, ty_res) ->
@@ -1306,18 +1301,19 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
let path = Pident id in
(* do not mark the value as used *)
let vd = Env.find_value path val_env in
- Ctype.begin_def ();
let expr =
- {exp_desc =
- Texp_ident(path, mknoloc(Longident.Lident (Ident.name id)),vd);
- exp_loc = Location.none; exp_extra = [];
- exp_type = Ctype.instance vd.val_type;
- exp_attributes = [];
- exp_env = val_env;
- }
+ Ctype.wrap_def begin fun () ->
+ {exp_desc =
+ Texp_ident(path,
+ mknoloc(Longident.Lident (Ident.name id)),vd);
+ exp_loc = Location.none; exp_extra = [];
+ exp_type = Ctype.instance vd.val_type;
+ exp_attributes = [];
+ exp_env = val_env;
+ }
+ end
+ ~post:(fun exp -> Ctype.generalize exp.exp_type)
in
- Ctype.end_def ();
- Ctype.generalize expr.exp_type;
let desc =
{val_type = expr.exp_type; val_kind = Val_ivar (Immutable,
cl_num);
@@ -1344,22 +1340,29 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
cl_attributes = scl.pcl_attributes;
}
| Pcl_constraint (scl', scty) ->
- Ctype.begin_class_def ();
- let context = Typetexp.narrow () in
- let cl = class_expr cl_num val_env met_env virt self_scope scl' in
- complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
- Typetexp.widen context;
- let context = Typetexp.narrow () in
- let clty = class_type val_env virt self_scope scty in
- complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
- Typetexp.widen context;
- Ctype.end_def ();
-
- Ctype.limited_generalize_class_type
- (Btype.self_type_row cl.cl_type) cl.cl_type;
- Ctype.limited_generalize_class_type
- (Btype.self_type_row clty.cltyp_type) clty.cltyp_type;
-
+ let cl, clty =
+ Ctype.wrap_class_def begin fun () ->
+ let cl =
+ Typetexp.wrap_type_variable_scope begin fun () ->
+ let cl = class_expr cl_num val_env met_env virt self_scope scl' in
+ complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
+ cl
+ end
+ and clty =
+ Typetexp.wrap_type_variable_scope begin fun () ->
+ let clty = class_type val_env virt self_scope scty in
+ complete_class_type
+ clty.cltyp_loc val_env virt Class clty.cltyp_type;
+ clty
+ end
+ in
+ cl, clty
+ end
+ ~post: begin fun ({cl_type=cl}, {cltyp_type=clty}) ->
+ Ctype.limited_generalize_class_type (Btype.self_type_row cl) cl;
+ Ctype.limited_generalize_class_type (Btype.self_type_row clty) clty;
+ end
+ in
begin match
Includeclass.class_types val_env cl.cl_type clty.cltyp_type
with
@@ -1457,12 +1460,10 @@ let initial_env define_class approx
let (cl_params, cl_ty, cl_td) = temp_abbrev cl.pci_loc arity uid in
(* Temporary type for the class constructor *)
- if !Clflags.principal then Ctype.begin_def ();
- let constr_type = approx cl.pci_expr in
- if !Clflags.principal then begin
- Ctype.end_def ();
- Ctype.generalize_structure constr_type;
- end;
+ let constr_type =
+ Ctype.wrap_def_principal (fun () -> approx cl.pci_expr)
+ ~post:Ctype.generalize_structure
+ in
let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in
let dummy_class =
{Types.cty_params = []; (* Dummy value *)
@@ -1513,42 +1514,43 @@ let class_infos define_class kind
(res, env) =
reset_type_variables ();
- Ctype.begin_class_def ();
-
- (* Introduce class parameters *)
- let ci_params =
- let make_param (sty, v) =
- try
- (transl_type_param env sty, v)
- with Already_bound ->
- raise(Error(sty.ptyp_loc, env, Repeated_parameter))
- in
- List.map make_param cl.pci_params
- in
- let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
-
- (* Allow self coercions (only for class declarations) *)
- let coercion_locs = ref [] in
-
- (* Type the class expression *)
- let (expr, typ) =
- try
- Typecore.self_coercion :=
- (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
- let res = kind env cl.pci_virt cl.pci_expr in
- Typecore.self_coercion := List.tl !Typecore.self_coercion;
- res
- with exn ->
- Typecore.self_coercion := []; raise exn
+ let ci_params, params, coercion_locs, expr, typ, sign =
+ Ctype.wrap_class_def begin fun () ->
+ (* Introduce class parameters *)
+ let ci_params =
+ let make_param (sty, v) =
+ try
+ (transl_type_param env sty, v)
+ with Already_bound ->
+ raise(Error(sty.ptyp_loc, env, Repeated_parameter))
+ in
+ List.map make_param cl.pci_params
+ in
+ let params = List.map (fun (cty, _) -> cty.ctyp_type) ci_params in
+
+ (* Allow self coercions (only for class declarations) *)
+ let coercion_locs = ref [] in
+
+ (* Type the class expression *)
+ let (expr, typ) =
+ try
+ Typecore.self_coercion :=
+ (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion;
+ let res = kind env cl.pci_virt cl.pci_expr in
+ Typecore.self_coercion := List.tl !Typecore.self_coercion;
+ res
+ with exn ->
+ Typecore.self_coercion := []; raise exn
+ in
+ let sign = Btype.signature_of_class_type typ in
+ (ci_params, params, coercion_locs, expr, typ, sign)
+ end
+ ~post: begin fun (_, params, _, _, typ, sign) ->
+ (* Generalize the row variable *)
+ List.iter (Ctype.limited_generalize sign.csig_self_row) params;
+ Ctype.limited_generalize_class_type sign.csig_self_row typ;
+ end
in
- let sign = Btype.signature_of_class_type typ in
-
- Ctype.end_def ();
-
- (* Generalize the row variable *)
- List.iter (Ctype.limited_generalize sign.csig_self_row) params;
- Ctype.limited_generalize_class_type sign.csig_self_row typ;
-
(* Check the abbreviation for the object type *)
let (obj_params', obj_type) = Ctype.instance_class params typ in
let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
@@ -1833,14 +1835,17 @@ let type_classes define_class approx kind env cls =
))
cls
in
- Ctype.begin_class_def ();
- let (res, env) =
- List.fold_left (initial_env define_class approx) ([], env) cls
- in
- let (res, env) =
- List.fold_right (class_infos define_class kind) res ([], env)
+ let res, env =
+ Ctype.wrap_class_def begin fun () ->
+ let (res, env) =
+ List.fold_left (initial_env define_class approx) ([], env) cls
+ in
+ let (res, env) =
+ List.fold_right (class_infos define_class kind) res ([], env)
+ in
+ res, env
+ end
in
- Ctype.end_def ();
let res = List.rev_map (final_decl env define_class) res in
let decls = List.fold_right extract_type_decls res [] in
let decls =
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 156209491c..d03f47ab09 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -544,10 +544,9 @@ let rec build_as_type ~refine (env : Env.t ref) p =
here.
If we used [generic_instance] we would lose the sharing between
[instance ty] and [ty]. *)
- begin_def ();
- let ty = instance cty.ctyp_type in
- end_def ();
- generalize_structure ty;
+ let ty =
+ wrap_def ~post:generalize_structure (fun () -> instance cty.ctyp_type)
+ in
(* This call to unify can't fail since the pattern is well typed. *)
unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty);
ty
@@ -621,19 +620,15 @@ let solve_Ppat_poly_constraint ~refine env loc sty expected_ty =
pattern_force := force :: !pattern_force;
match get_desc ty with
| Tpoly (body, tyl) ->
- begin_def ();
- init_def generic_level;
- let _, ty' = instance_poly ~keep_names:true false tyl body in
- end_def ();
+ let _, ty' =
+ wrap_init_def ~level:generic_level
+ (fun () -> instance_poly ~keep_names:true false tyl body)
+ in
(cty, ty, ty')
| _ -> assert false
let solve_Ppat_alias ~refine env pat =
- begin_def ();
- let ty_var = build_as_type ~refine env pat in
- end_def ();
- generalize ty_var;
- ty_var
+ wrap_def ~post:generalize (fun () -> build_as_type ~refine env pat)
let solve_Ppat_tuple (type a) ~refine loc env (args : a list) expected_ty =
let vars = List.map (fun _ -> newgenvar ()) args in
@@ -654,10 +649,10 @@ let solve_constructor_annotation env name_list sty ty_args ty_ex =
{name with txt = id})
name_list
in
- begin_def ();
- let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
- end_def ();
- generalize_structure ty;
+ let cty, ty, force =
+ wrap_def ~post:(fun (_,ty,_) -> generalize_structure ty)
+ (fun () -> Typetexp.transl_simple_type_delayed !env sty)
+ in
pattern_force := force :: !pattern_force;
let ty_args =
let ty1 = instance ty and ty2 = instance ty in
@@ -697,10 +692,9 @@ let solve_Ppat_construct ~refine env loc constr no_existentials
correct head *)
if constr.cstr_generalized then
unify_head_only ~refine loc env (instance expected_ty) constr;
- begin_def ();
- let expected_ty = instance expected_ty in
+
(* PR#7214: do not use gadt unification for toplevel lets *)
- let unify_res ty_res =
+ let unify_res ty_res expected_ty =
let refine =
match refine, no_existentials with
| None, None when constr.cstr_generalized -> Some false
@@ -708,38 +702,43 @@ let solve_Ppat_construct ~refine env loc constr no_existentials
in
unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty
in
- let expansion_scope = get_gadt_equations_level () in
- let ty_args, ty_res, equated_types, existential_ctyp =
- match existential_styp with
- None ->
- let ty_args, ty_res, _ =
- instance_constructor
- (Make_existentials_abstract { env; scope = expansion_scope }) constr
- in
- ty_args, ty_res, unify_res ty_res, None
- | Some (name_list, sty) ->
- let existential_treatment =
- if name_list = [] then
- Make_existentials_abstract { env; scope = expansion_scope }
- else
- (* we will unify them (in solve_constructor_annotation) with the
- local types provided by the user *)
- Keep_existentials_flexible
- in
- let ty_args, ty_res, ty_ex =
- instance_constructor existential_treatment constr
- in
- let equated_types = unify_res ty_res in
- let ty_args, existential_ctyp =
- solve_constructor_annotation env name_list sty ty_args ty_ex in
- ty_args, ty_res, equated_types, existential_ctyp
+
+ let ty_args, equated_types, existential_ctyp =
+ wrap_def_process ~proc: generalize_structure begin fun () ->
+ let expected_ty = instance expected_ty in
+ let expansion_scope = get_gadt_equations_level () in
+ let ty_args, ty_res, equated_types, existential_ctyp =
+ match existential_styp with
+ None ->
+ let ty_args, ty_res, _ =
+ instance_constructor
+ (Make_existentials_abstract { env; scope = expansion_scope })
+ constr
+ in
+ ty_args, ty_res, unify_res ty_res expected_ty, None
+ | Some (name_list, sty) ->
+ let existential_treatment =
+ if name_list = [] then
+ Make_existentials_abstract { env; scope = expansion_scope }
+ else
+ (* we will unify them (in solve_constructor_annotation) with the
+ local types provided by the user *)
+ Keep_existentials_flexible
+ in
+ let ty_args, ty_res, ty_ex =
+ instance_constructor existential_treatment constr
+ in
+ let equated_types = unify_res ty_res expected_ty in
+ let ty_args, existential_ctyp =
+ solve_constructor_annotation env name_list sty ty_args ty_ex in
+ ty_args, ty_res, equated_types, existential_ctyp
+ in
+ if constr.cstr_existentials <> [] then
+ lower_variables_only !env expansion_scope ty_res;
+ ((ty_args, equated_types, existential_ctyp),
+ expected_ty :: ty_res :: ty_args)
+ end
in
- if constr.cstr_existentials <> [] then
- lower_variables_only !env expansion_scope ty_res;
- end_def ();
- generalize_structure expected_ty;
- generalize_structure ty_res;
- List.iter generalize_structure ty_args;
if !Clflags.principal && refine = None then begin
(* Do not warn for counter-examples *)
let exception Warn_only_once in
@@ -765,18 +764,16 @@ let solve_Ppat_construct ~refine env loc constr no_existentials
(ty_args, existential_ctyp)
let solve_Ppat_record_field ~refine loc env label label_lid record_ty =
- begin_def ();
- let (_, ty_arg, ty_res) = instance_label false label in
- begin try
- unify_pat_types ~refine loc env ty_res (instance record_ty)
- with Error(_loc, _env, Pattern_type_clash(err, _)) ->
- raise(Error(label_lid.loc, !env,
- Label_mismatch(label_lid.txt, err)))
- end;
- end_def ();
- generalize_structure ty_res;
- generalize_structure ty_arg;
- ty_arg
+ wrap_def_process ~proc:generalize_structure begin fun () ->
+ let (_, ty_arg, ty_res) = instance_label false label in
+ begin try
+ unify_pat_types ~refine loc env ty_res (instance record_ty)
+ with Error(_loc, _env, Pattern_type_clash(err, _)) ->
+ raise(Error(label_lid.loc, !env,
+ Label_mismatch(label_lid.txt, err)))
+ end;
+ (ty_arg, [ty_res; ty_arg])
+ end
let solve_Ppat_array ~refine loc env expected_ty =
let ty_elt = newgenvar() in
@@ -792,11 +789,11 @@ let solve_Ppat_lazy ~refine loc env expected_ty =
nv
let solve_Ppat_constraint ~refine loc env sty expected_ty =
- begin_def();
- let cty, ty, force = Typetexp.transl_simple_type_delayed !env sty in
- end_def();
+ let cty, ty, force =
+ wrap_def ~post:(fun (_, ty, _) -> generalize_structure ty)
+ (fun () -> Typetexp.transl_simple_type_delayed !env sty)
+ in
pattern_force := force :: !pattern_force;
- generalize_structure ty;
let ty, expected_ty' = instance ty, ty in
unify_pat_types ~refine loc env ty (instance expected_ty);
(cty, ty, expected_ty')
@@ -1723,20 +1720,23 @@ and type_pat_aux
let initial_module_variables = !module_variables in
let equation_level = !gadt_equations_level in
let outter_lev = get_current_level () in
- (* introduce a new scope *)
- begin_def ();
- let lev = get_current_level () in
- gadt_equations_level := Some lev;
- let type_pat_rec env sp = type_pat category sp expected_ty ~env in
- let env1 = ref !env in
- let p1 = type_pat_rec env1 sp1 in
- let p1_variables = !pattern_variables in
- let p1_module_variables = !module_variables in
- pattern_variables := initial_pattern_variables;
- module_variables := initial_module_variables;
- let env2 = ref !env in
- let p2 = type_pat_rec env2 sp2 in
- end_def ();
+ (* Introduce a new scope; wrap_def without generalizations *)
+ let env1, p1, p1_variables, p1_module_variables, env2, p2 =
+ wrap_def begin fun () ->
+ let lev = get_current_level () in
+ gadt_equations_level := Some lev;
+ let type_pat_rec env sp = type_pat category sp expected_ty ~env in
+ let env1 = ref !env in
+ let p1 = type_pat_rec env1 sp1 in
+ let p1_variables = !pattern_variables in
+ let p1_module_variables = !module_variables in
+ pattern_variables := initial_pattern_variables;
+ module_variables := initial_module_variables;
+ let env2 = ref !env in
+ let p2 = type_pat_rec env2 sp2 in
+ (env1, p1, p1_variables, p1_module_variables, env2, p2)
+ end
+ in
gadt_equations_level := equation_level;
let p2_variables = !pattern_variables in
(* Make sure no variable with an ambiguous type gets added to the
@@ -2517,22 +2517,20 @@ let list_labels env ty =
ty_expected should already be generalized. *)
let check_univars env kind exp ty_expected vars =
let pty = instance ty_expected in
- begin_def ();
let exp_ty, vars =
- match get_desc pty with
- Tpoly (body, tl) ->
- (* Enforce scoping for type_let:
- since body is not generic, instance_poly only makes
- copies of nodes that have a Tvar as descendant *)
- let _, ty' = instance_poly true tl body in
- let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
- unify_exp_types exp.exp_loc env exp_ty ty';
- exp_ty, vars
- | _ -> assert false
+ wrap_def_process ~proc:generalize begin fun () ->
+ match get_desc pty with
+ Tpoly (body, tl) ->
+ (* Enforce scoping for type_let:
+ since body is not generic, instance_poly only makes
+ copies of nodes that have a Tvar as descendant *)
+ let _, ty' = instance_poly true tl body in
+ let vars, exp_ty = instance_parameterized_type vars exp.exp_type in
+ unify_exp_types exp.exp_loc env exp_ty ty';
+ ((exp_ty, vars), exp_ty::vars)
+ | _ -> assert false
+ end
in
- end_def ();
- generalize exp_ty;
- List.iter generalize vars;
let ty, complete = polyfy env exp_ty vars in
if not complete then
let ty_expected = instance ty_expected in
@@ -2848,6 +2846,12 @@ let with_explanation explanation f =
let err = Expr_type_clash(err', Some explanation, exp') in
raise (Error (loc', env', err))
+(* Generalize expressions *)
+let generalize_structure_exp exp = generalize_structure exp.exp_type
+let may_lower_contravariant_then_generalize env exp =
+ if maybe_expansive exp then lower_contravariant env exp.exp_type;
+ generalize exp.exp_type
+
let rec type_exp ?recarg env sexp =
(* We now delegate everything to type_expect *)
type_expect ?recarg env sexp (mk_expected (newvar ()))
@@ -2855,7 +2859,8 @@ let rec type_exp ?recarg env sexp =
(* Typing of an expression with an expected type.
This provide better error messages, and allows controlled
propagation of return type information.
- In the principal case, [type_expected'] may be at generic_level.
+ In the principal case, structural nodes of [type_expected_explained] may be
+ at [generic_level] (but its variables no higher than [!current_level]).
*)
and type_expect ?in_function ?recarg env sexp ty_expected_explained =
@@ -2878,6 +2883,7 @@ and type_expect_
let desc = sexp.pexp_desc in
(* Record the expression type before unifying it with the expected type *)
let with_explanation = with_explanation explanation in
+ (* Unify the result with [ty_expected], enforcing the current level *)
let rue exp =
with_explanation (fun () ->
unify_exp ~sdesc_for_hint:desc env (re exp) (instance ty_expected));
@@ -3021,23 +3027,23 @@ and type_expect_
if TypeSet.mem ty seen then () else
match get_desc ty with
Tarrow (_l, ty_arg, ty_fun, _com) ->
- (try unify_var env (newvar()) ty_arg
+ (try enforce_current_level env ty_arg
with Unify _ -> assert false);
lower_args (TypeSet.add ty seen) ty_fun
| _ -> ()
in
let type_sfunct sfunct =
- begin_def (); (* one more level for non-returning functions *)
- if !Clflags.principal then begin_def ();
- let funct = type_exp env sfunct in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure funct.exp_type
- end;
- let ty = instance funct.exp_type in
- end_def ();
- wrap_trace_gadt_instances env (lower_args TypeSet.empty) ty;
- funct
+ (* one more level for warning on non-returning functions *)
+ wrap_def_process
+ begin fun () ->
+ let funct =
+ wrap_def_principal (fun () -> type_exp env sfunct)
+ ~post: generalize_structure_exp
+ in
+ let ty = instance funct.exp_type in
+ (funct, [ty])
+ end
+ ~proc:(wrap_trace_gadt_instances env (lower_args TypeSet.empty))
in
let funct, sargs =
let funct = type_sfunct sfunct in
@@ -3056,10 +3062,7 @@ and type_expect_
| _ ->
funct, sargs
in
- begin_def ();
let (args, ty_res) = type_application env funct sargs in
- end_def ();
- unify_var env (newvar()) funct.exp_type;
rue {
exp_desc = Texp_apply(funct, args);
exp_loc = loc; exp_extra = [];
@@ -3067,11 +3070,10 @@ and type_expect_
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_match(sarg, caselist) ->
- begin_def ();
- let arg = type_exp env sarg in
- end_def ();
- if maybe_expansive arg then lower_contravariant env arg.exp_type;
- generalize arg.exp_type;
+ let arg =
+ wrap_def (fun () -> type_exp env sarg)
+ ~post:(may_lower_contravariant_then_generalize env)
+ in
let cases, partial =
type_cases Computation env
arg.exp_type ty_expected_explained true loc caselist in
@@ -3158,12 +3160,10 @@ and type_expect_
match opt_sexp with
None -> None
| Some sexp ->
- if !Clflags.principal then begin_def ();
- let exp = type_exp ~recarg env sexp in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure exp.exp_type
- end;
+ let exp =
+ wrap_def_principal (fun () -> type_exp ~recarg env sexp)
+ ~post: generalize_structure_exp
+ in
Some exp
in
let ty_record, expected_type =
@@ -3194,10 +3194,10 @@ and type_expect_
| Some(_, _, true), Some _ -> ty_expected, expected_opath
| (None | Some (_, _, false)), Some (_, p', _) ->
let decl = Env.find_type p' env in
- begin_def ();
- let ty = newconstr p' (instance_list decl.type_params) in
- end_def ();
- generalize_structure ty;
+ let ty =
+ wrap_def ~post:generalize_structure
+ (fun () -> newconstr p' (instance_list decl.type_params))
+ in
ty, opt_exp_opath
in
let closed = (opt_sexp = None) in
@@ -3411,11 +3411,11 @@ and type_expect_
exp_env = env }
| Pexp_constraint (sarg, sty) ->
(* Pretend separate = true, 1% slowdown for lablgtk *)
- begin_def ();
- let cty = Typetexp.transl_simple_type env false sty in
+ let cty =
+ wrap_def (fun () -> Typetexp.transl_simple_type env false sty)
+ ~post:(fun cty -> generalize_structure cty.ctyp_type)
+ in
let ty = cty.ctyp_type in
- end_def ();
- generalize_structure ty;
let (arg, ty') = (type_argument env sarg ty (instance ty), instance ty) in
rue {
exp_desc = arg.exp_desc;
@@ -3436,12 +3436,14 @@ and type_expect_
let (cty', ty', force) =
Typetexp.transl_simple_type_delayed env sty'
in
- begin_def ();
- let arg = type_exp env sarg in
- end_def ();
- let tv = newvar () in
- let gen = generalizable (get_level tv) arg.exp_type in
- unify_var env tv arg.exp_type;
+ let arg, gen =
+ let lv = get_current_level () in
+ wrap_def begin fun () ->
+ let arg = type_exp env sarg in
+ (arg, generalizable lv arg.exp_type)
+ end
+ ~post:(fun (arg,_) -> enforce_current_level env arg.exp_type)
+ in
begin match arg.exp_desc, !self_coercion, get_desc ty' with
Texp_ident(_, _, {val_kind=Val_self _}), (path,r) :: _,
Tconstr(path',_,_) when Path.same path path' ->
@@ -3479,15 +3481,17 @@ and type_expect_
end;
(arg, ty', None, cty')
| Some sty ->
- begin_def ();
- let (cty, ty, force) =
- Typetexp.transl_simple_type_delayed env sty
- and (cty', ty', force') =
- Typetexp.transl_simple_type_delayed env sty'
+ let cty, ty, force, cty', ty', force' =
+ wrap_def_process ~proc:generalize_structure begin fun () ->
+ let (cty, ty, force) =
+ Typetexp.transl_simple_type_delayed env sty
+ and (cty', ty', force') =
+ Typetexp.transl_simple_type_delayed env sty'
+ in
+ ((cty, ty, force, cty', ty', force'),
+ [ty; ty'])
+ end
in
- end_def ();
- generalize_structure ty;
- generalize_structure ty';
begin try
let force'' = subtype env (instance ty) (instance ty') in
force (); force' (); force'' ()
@@ -3507,13 +3511,10 @@ and type_expect_
arg.exp_extra;
}
| Pexp_send (e, {txt=met}) ->
- if !Clflags.principal then begin_def ();
- let (obj,meth,typ) = type_send env loc explanation e met
+ let (obj,meth,typ) =
+ wrap_def_principal (fun () -> type_send env loc explanation e met)
+ ~post:(fun (_,_,typ) -> generalize_structure typ)
in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure typ;
- end;
let typ =
match get_desc typ with
| Tpoly (ty, []) ->
@@ -3614,44 +3615,55 @@ and type_expect_
assert false
end
| Pexp_letmodule(name, smodl, sbody) ->
- let ty = newvar() in
- (* remember original level *)
- begin_def ();
- let context = Typetexp.narrow () in
- let modl, md_shape = !type_module env smodl in
- Mtype.lower_nongen (get_level ty) modl.mod_type;
- let pres =
- match modl.mod_type with
- | Mty_alias _ -> Mp_absent
- | _ -> Mp_present
- in
- let scope = create_scope () in
- let md =
- { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
- md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
- in
- let (id, new_env) =
- match name.txt with
- | None -> None, env
- | Some name ->
- let id, env =
- Env.enter_module_declaration ~scope ~shape:md_shape name pres md env
+ let lv = get_current_level () in
+ let (id, name, pres, modl, _, body) =
+ wrap_def begin fun () ->
+ let modl, pres, id, new_env =
+ Typetexp.wrap_type_variable_scope begin fun () ->
+ let modl, md_shape = !type_module env smodl in
+ Mtype.lower_nongen lv modl.mod_type;
+ let pres =
+ match modl.mod_type with
+ | Mty_alias _ -> Mp_absent
+ | _ -> Mp_present
+ in
+ let scope = create_scope () in
+ let md =
+ { md_type = modl.mod_type; md_attributes = [];
+ md_loc = name.loc;
+ md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+ in
+ let (id, new_env) =
+ match name.txt with
+ | None -> None, env
+ | Some name ->
+ let id, env =
+ Env.enter_module_declaration
+ ~scope ~shape:md_shape name pres md env
+ in
+ Some id, env
+ in
+ modl, pres, id, new_env
+ end
in
- Some id, env
+ (* Ideally, we should catch Expr_type_clash errors
+ in type_expect triggered by escaping identifiers
+ from the local module and refine them into
+ Scoping_let_module errors
+ *)
+ let body = type_expect new_env sbody ty_expected_explained in
+ (id, name, pres, modl, new_env, body)
+ end
+ ~post: begin fun (_,_,_,_,new_env,body) ->
+ (* Ensure that local definitions do not leak. *)
+ (* required for implicit unpack *)
+ enforce_current_level new_env body.exp_type
+ end
in
- Typetexp.widen context;
- (* ideally, we should catch Expr_type_clash errors
- in type_expect triggered by escaping identifiers from the local module
- and refine them into Scoping_let_module errors
- *)
- let body = type_expect new_env sbody ty_expected_explained in
- (* go back to original level *)
- end_def ();
- Ctype.unify_var new_env ty body.exp_type;
re {
exp_desc = Texp_letmodule(id, name, pres, modl, body);
exp_loc = loc; exp_extra = [];
- exp_type = ty;
+ exp_type = body.exp_type;
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_letexception(cd, sbody) ->
@@ -3710,18 +3722,16 @@ and type_expect_
exp_env = env;
}
| Pexp_poly(sbody, sty) ->
- if !Clflags.principal then begin_def ();
let ty, cty =
- match sty with None -> protect_expansion env ty_expected, None
- | Some sty ->
- let sty = Ast_helper.Typ.force_poly sty in
- let cty = Typetexp.transl_simple_type env false sty in
- cty.ctyp_type, Some cty
+ wrap_def_principal ~post:(fun (ty,_) -> generalize_structure ty)
+ begin fun () ->
+ match sty with None -> protect_expansion env ty_expected, None
+ | Some sty ->
+ let sty = Ast_helper.Typ.force_poly sty in
+ let cty = Typetexp.transl_simple_type env false sty in
+ cty.ctyp_type, Some cty
+ end
in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty
- end;
if sty <> None then
with_explanation (fun () ->
unify_exp_types loc env (instance ty) (instance ty_expected));
@@ -3732,16 +3742,19 @@ and type_expect_
{ exp with exp_type = instance ty }
| Tpoly (ty', tl) ->
(* One more level to generalize locally *)
- begin_def ();
- if !Clflags.principal then begin_def ();
- let vars, ty'' = instance_poly true tl ty' in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty''
- end;
- let exp = type_expect env sbody (mk_expected ty'') in
- end_def ();
- generalize_and_check_univars env "method" exp ty_expected vars;
+ let (exp,_) =
+ wrap_def begin fun () ->
+ let vars, ty'' =
+ wrap_def_principal (fun () -> instance_poly true tl ty')
+ ~post:(fun (_,ty'') -> generalize_structure ty'')
+ in
+ let exp = type_expect env sbody (mk_expected ty'') in
+ (exp, vars)
+ end
+ ~post: begin fun (exp,vars) ->
+ generalize_and_check_univars env "method" exp ty_expected vars
+ end
+ in
{ exp with exp_type = instance ty }
| Tvar _ ->
let exp = type_exp env sbody in
@@ -3759,33 +3772,31 @@ and type_expect_
else
newvar ()
in
- (* remember original level *)
- begin_def ();
- (* Create a fake abstract type declaration for name. *)
- let decl = new_local_type ~loc () in
- let scope = create_scope () in
- let (id, new_env) = Env.enter_type ~scope name decl env in
-
- let body = type_exp new_env sbody in
- (* Replace every instance of this type constructor in the resulting
- type. *)
- let seen = Hashtbl.create 8 in
- let rec replace t =
- if Hashtbl.mem seen (get_id t) then ()
- else begin
- Hashtbl.add seen (get_id t) ();
- match get_desc t with
- | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
- | _ -> Btype.iter_type_expr replace t
- end
+ (* Use [wrap_def] just for scoping *)
+ let body, ety = wrap_def begin fun () ->
+ (* Create a fake abstract type declaration for [name]. *)
+ let decl = new_local_type ~loc () in
+ let scope = create_scope () in
+ let (id, new_env) = Env.enter_type ~scope name decl env in
+
+ let body = type_exp new_env sbody in
+ (* Replace every instance of this type constructor in the resulting
+ type. *)
+ let seen = Hashtbl.create 8 in
+ let rec replace t =
+ if Hashtbl.mem seen (get_id t) then ()
+ else begin
+ Hashtbl.add seen (get_id t) ();
+ match get_desc t with
+ | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty
+ | _ -> Btype.iter_type_expr replace t
+ end
+ in
+ let ety = Subst.type_expr Subst.identity body.exp_type in
+ replace ety;
+ (body, ety)
+ end
in
- let ety = Subst.type_expr Subst.identity body.exp_type in
- replace ety;
- (* back to original level *)
- end_def ();
- (* lower the levels of the result type *)
- (* unify_var env ty ety; *)
-
(* non-expansive if the body is non-expansive, so we don't introduce
any new extra node in the typed AST. *)
rue { body with exp_loc = loc; exp_type = ety;
@@ -3841,32 +3852,32 @@ and type_expect_
let ty_acc = newty (Ttuple [ty_acc; ty]) in
loop spat_acc ty_acc rest
in
- if !Clflags.principal then begin_def ();
- let let_loc = slet.pbop_op.loc in
- let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
- let op_type = instance op_desc.val_type in
- let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
- let ty_func_result = newvar () in
- let ty_func =
- newty (Tarrow(Nolabel, ty_params, ty_func_result, commu_ok)) in
- let ty_result = newvar () in
- let ty_andops = newvar () in
- let ty_op =
- newty (Tarrow(Nolabel, ty_andops,
- newty (Tarrow(Nolabel, ty_func, ty_result, commu_ok)), commu_ok))
+ let op_path, op_desc, op_type, spat_params, ty_params,
+ ty_func_result, ty_result, ty_andops =
+ wrap_def_process_principal ~proc:generalize_structure begin fun () ->
+ let let_loc = slet.pbop_op.loc in
+ let op_path, op_desc = type_binding_op_ident env slet.pbop_op in
+ let op_type = instance op_desc.val_type in
+ let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in
+ let ty_func_result = newvar () in
+ let ty_func =
+ newty (Tarrow(Nolabel, ty_params, ty_func_result, commu_ok)) in
+ let ty_result = newvar () in
+ let ty_andops = newvar () in
+ let ty_op =
+ newty (Tarrow(Nolabel, ty_andops,
+ newty (Tarrow(Nolabel, ty_func, ty_result, commu_ok)), commu_ok))
+ in
+ begin try
+ unify env op_type ty_op
+ with Unify err ->
+ raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err)))
+ end;
+ ((op_path, op_desc, op_type, spat_params, ty_params,
+ ty_func_result, ty_result, ty_andops),
+ [ty_andops; ty_params; ty_func_result; ty_result])
+ end
in
- begin try
- unify env op_type ty_op
- with Unify err ->
- raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err)))
- end;
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty_andops;
- generalize_structure ty_params;
- generalize_structure ty_func_result;
- generalize_structure ty_result
- end;
let exp, ands = type_andops env slet.pbop_exp sands ty_andops in
let scase = Ast_helper.Exp.case spat_params sbody in
let cases, partial =
@@ -3974,38 +3985,37 @@ and type_function ?(in_function : (Location.t * type_expr) option)
| None -> (loc, instance ty_expected)
in
let separate = !Clflags.principal || Env.has_local_constraints env in
- if separate then begin_def ();
- let (ty_arg, ty_res) =
- try filter_arrow env (instance ty_expected) arg_label
- with Filter_arrow_failed err ->
- let err = match err with
- | Unification_error unif_err ->
- Expr_type_clash(unif_err, explanation, None)
- | Label_mismatch { got; expected; expected_type} ->
- Abstract_wrong_label { got; expected; expected_type; explanation }
- | Not_a_function -> begin
- match in_function with
- | Some _ -> Too_many_arguments(ty_fun, explanation)
- | None -> Not_a_function(ty_fun, explanation)
+ let ty_arg, ty_res =
+ wrap_def_process_if separate ~proc:generalize_structure begin fun () ->
+ let (ty_arg, ty_res) =
+ try filter_arrow env (instance ty_expected) arg_label
+ with Filter_arrow_failed err ->
+ let err = match err with
+ | Unification_error unif_err ->
+ Expr_type_clash(unif_err, explanation, None)
+ | Label_mismatch { got; expected; expected_type} ->
+ Abstract_wrong_label { got; expected; expected_type; explanation }
+ | Not_a_function -> begin
+ match in_function with
+ | Some _ -> Too_many_arguments(ty_fun, explanation)
+ | None -> Not_a_function(ty_fun, explanation)
end
+ in
+ raise (Error(loc_fun, env, err))
in
- raise (Error(loc_fun, env, err))
- in
- let ty_arg =
- if is_optional arg_label then
- let tv = newvar() in
- begin
- try unify env ty_arg (type_option tv)
- with Unify _ -> assert false
- end;
- type_option tv
- else ty_arg
+ let ty_arg =
+ if is_optional arg_label then
+ let tv = newvar() in
+ begin
+ try unify env ty_arg (type_option tv)
+ with Unify _ -> assert false
+ end;
+ type_option tv
+ else ty_arg
+ in
+ ((ty_arg, ty_res), [ty_arg; ty_res])
+ end
in
- if separate then begin
- end_def ();
- generalize_structure ty_arg;
- generalize_structure ty_res
- end;
let cases, partial =
type_cases Value ~in_function:(loc_fun,ty_fun) env
ty_arg (mk_expected ty_res) true loc caselist in
@@ -4027,12 +4037,10 @@ and type_function ?(in_function : (Location.t * type_expr) option)
and type_label_access env srecord usage lid =
- if !Clflags.principal then begin_def ();
- let record = type_exp ~recarg:Allowed env srecord in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure record.exp_type
- end;
+ let record =
+ wrap_def_principal ~post:generalize_structure_exp
+ (fun () -> type_exp ~recarg:Allowed env srecord)
+ in
let ty_exp = record.exp_type in
let expected_type =
match extract_concrete_record env ty_exp with
@@ -4298,37 +4306,40 @@ and type_format loc str env =
and type_label_exp create env loc ty_expected
(lid, label, sarg) =
(* Here also ty_expected may be at generic_level *)
- begin_def ();
let separate = !Clflags.principal || Env.has_local_constraints env in
- if separate then (begin_def (); begin_def ());
- let (vars, ty_arg, ty_res) = instance_label true label in
- if separate then begin
- end_def ();
- (* Generalize label information *)
- generalize_structure ty_arg;
- generalize_structure ty_res
- end;
- begin try
- unify env (instance ty_res) (instance ty_expected)
- with Unify err ->
- raise (Error(lid.loc, env, Label_mismatch(lid.txt, err)))
- end;
- (* Instantiate so that we can generalize internal nodes *)
- let ty_arg = instance ty_arg in
- if separate then begin
- end_def ();
- (* Generalize information merged from ty_expected *)
- generalize_structure ty_arg
- end;
- if label.lbl_private = Private then
- if create then
- raise (Error(loc, env, Private_type ty_expected))
- else
- raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+ let (vars, ty_arg, snap, arg) =
+ wrap_def begin fun () ->
+ let (vars, ty_arg) =
+ wrap_def_process_if separate ~proc:generalize_structure begin fun () ->
+ let (vars, ty_arg, ty_res) =
+ wrap_def_process_if separate ~proc:generalize_structure
+ begin fun () ->
+ let ((_, ty_arg, ty_res) as r) = instance_label true label in
+ (r, [ty_arg; ty_res])
+ end
+ in
+ begin try
+ unify env (instance ty_res) (instance ty_expected)
+ with Unify err ->
+ raise (Error(lid.loc, env, Label_mismatch(lid.txt, err)))
+ end;
+ (* Instantiate so that we can generalize internal nodes *)
+ let ty_arg = instance ty_arg in
+ ((vars, ty_arg), [ty_arg])
+ end
+ in
+
+ if label.lbl_private = Private then
+ if create then
+ raise (Error(loc, env, Private_type ty_expected))
+ else
+ raise (Error(lid.loc, env, Private_label(lid.txt, ty_expected)));
+ let snap = if vars = [] then None else Some (Btype.snapshot ()) in
+ let arg = type_argument env sarg ty_arg (instance ty_arg) in
+ (vars, ty_arg, snap, arg)
+ end
+ in
let arg =
- let snap = if vars = [] then None else Some (Btype.snapshot ()) in
- let arg = type_argument env sarg ty_arg (instance ty_arg) in
- end_def ();
try
if (vars = []) then arg
else begin
@@ -4340,15 +4351,19 @@ and type_label_exp create env loc ty_expected
with exn when maybe_expansive arg -> try
(* Try to retype without propagating ty_arg, cf PR#4862 *)
Option.iter Btype.backtrack snap;
- begin_def ();
- let arg = type_exp env sarg in
- end_def ();
- lower_contravariant env arg.exp_type;
- begin_def ();
- let arg = {arg with exp_type = instance arg.exp_type} in
- unify_exp env arg (instance ty_arg);
- end_def ();
- generalize_and_check_univars env "field value" arg label.lbl_arg vars;
+ let arg = wrap_def (fun () -> type_exp env sarg)
+ ~post:(fun arg -> lower_contravariant env arg.exp_type)
+ in
+ let arg =
+ wrap_def begin fun () ->
+ let arg = {arg with exp_type = instance arg.exp_type} in
+ unify_exp env arg (instance ty_arg);
+ arg
+ end
+ ~post: begin fun arg ->
+ generalize_and_check_univars env "field value" arg label.lbl_arg vars
+ end
+ in
{arg with exp_type = instance arg.exp_type}
with Error (_, _, Less_general _) as e -> raise e
| _ -> raise exn (* In case of failure return the first error *)
@@ -4380,12 +4395,10 @@ and type_argument ?explanation ?recarg env sarg ty_expected' ty_expected =
Some (safe_expect, lv) ->
(* apply optional arguments when expected type is "" *)
(* we must be very careful about not breaking the semantics *)
- if !Clflags.principal then begin_def ();
- let texp = type_exp env sarg in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure texp.exp_type
- end;
+ let texp =
+ wrap_def_principal ~post:generalize_structure_exp
+ (fun () -> type_exp env sarg)
+ in
let rec make_args args ty_fun =
match get_desc (expand_head env ty_fun) with
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
@@ -4646,16 +4659,20 @@ and type_application env funct sargs =
(try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true
with Filter_arrow_failed _ -> false)
in
- match sargs with
- | (* Special case for ignore: avoid discarding warning *)
- [Nolabel, sarg] when is_ignore funct ->
- let ty_arg, ty_res = filter_arrow env (instance funct.exp_type) Nolabel in
- let exp = type_expect env sarg (mk_expected ty_arg) in
- check_partial_application ~statement:false exp;
- ([Nolabel, Some exp], ty_res)
- | _ ->
- let ty = funct.exp_type in
- type_args [] ty (instance ty) sargs
+ (* Extra scope to check for non-returning functions *)
+ wrap_def begin fun () ->
+ match sargs with
+ | (* Special case for ignore: avoid discarding warning *)
+ [Nolabel, sarg] when is_ignore funct ->
+ let ty_arg, ty_res =
+ filter_arrow env (instance funct.exp_type) Nolabel in
+ let exp = type_expect env sarg (mk_expected ty_arg) in
+ check_partial_application ~statement:false exp;
+ ([Nolabel, Some exp], ty_res)
+ | _ ->
+ let ty = funct.exp_type in
+ type_args [] ty (instance ty) sargs
+ end
and type_construct env loc lid sarg ty_expected_explained attrs =
let { ty = ty_expected; explanation } = ty_expected_explained in
@@ -4689,27 +4706,32 @@ and type_construct env loc lid sarg ty_expected_explained attrs =
raise(Error(loc, env, Constructor_arity_mismatch
(lid.txt, constr.cstr_arity, List.length sargs)));
let separate = !Clflags.principal || Env.has_local_constraints env in
- if separate then (begin_def (); begin_def ());
- let (ty_args, ty_res, _) =
- instance_constructor Keep_existentials_flexible constr
+ let ty_args, ty_res, texp =
+ wrap_def_process_if separate ~proc:generalize_structure begin fun () ->
+ let ty_args, ty_res, texp =
+ wrap_def_if separate begin fun () ->
+ let (ty_args, ty_res, _) =
+ instance_constructor Keep_existentials_flexible constr
+ in
+ let texp =
+ re {
+ exp_desc = Texp_construct(lid, constr, []);
+ exp_loc = loc; exp_extra = [];
+ exp_type = ty_res;
+ exp_attributes = attrs;
+ exp_env = env } in
+ (ty_args, ty_res, texp)
+ end
+ ~post: begin fun (_, ty_res, texp) ->
+ generalize_structure ty_res;
+ with_explanation explanation (fun () ->
+ unify_exp env {texp with exp_type = instance ty_res}
+ (instance ty_expected));
+ end
+ in
+ ((ty_args, ty_res, texp), ty_res::ty_args)
+ end
in
- let texp =
- re {
- exp_desc = Texp_construct(lid, constr, []);
- exp_loc = loc; exp_extra = [];
- exp_type = ty_res;
- exp_attributes = attrs;
- exp_env = env } in
- if separate then begin
- end_def ();
- generalize_structure ty_res;
- with_explanation explanation (fun () ->
- unify_exp env {texp with exp_type = instance ty_res}
- (instance ty_expected));
- end_def ();
- List.iter generalize_structure ty_args;
- generalize_structure ty_res;
- end;
let ty_args0, ty_res =
match instance_list (ty_res :: ty_args) with
t :: tl -> tl, t
@@ -4747,11 +4769,10 @@ and type_construct env loc lid sarg ty_expected_explained attrs =
(* Typing of statements (expressions whose values are discarded) *)
and type_statement ?explanation env sexp =
- begin_def();
- let exp = type_exp env sexp in
- end_def();
- let ty = expand_head env exp.exp_type and tv = newvar() in
- if is_Tvar ty && get_level ty > get_level tv then
+ (* Raise the current level to detect non-returning functions *)
+ let exp = wrap_def (fun () -> type_exp env sexp) in
+ let ty = expand_head env exp.exp_type in
+ if is_Tvar ty && get_level ty > get_current_level () then
Location.prerr_warning
(final_subexpression exp).exp_loc
Warnings.Nonreturning_statement;
@@ -4762,7 +4783,7 @@ and type_statement ?explanation env sexp =
exp
else begin
check_partial_application ~statement:true exp;
- unify_var env tv ty;
+ enforce_current_level env ty;
exp
end
@@ -4780,45 +4801,47 @@ and type_unpacks ?(in_function : (Location.t * type_expr) option)
*)
type_expect ?in_function env sbody expected_ty
| unpack :: rem ->
- begin_def ();
- let context = Typetexp.narrow () in
- let name = unpack.tu_name in
- let modl, md_shape =
- !type_module env
- Ast_helper.(
- Mod.unpack ~loc:unpack.tu_loc
- (Exp.ident ~loc:name.loc
- (mkloc (Longident.Lident name.txt) name.loc)))
- in
- Mtype.lower_nongen (get_level ty) modl.mod_type;
- let pres =
- match modl.mod_type with
- | Mty_alias _ -> Mp_absent
- | _ -> Mp_present
- in
- let scope = create_scope () in
- let md =
- { md_type = modl.mod_type; md_attributes = [];
- md_loc = name.loc;
- md_uid = unpack.tu_uid; }
- in
- let (id, extended_env) =
- Env.enter_module_declaration ~scope ~shape:md_shape
- name.txt pres md env
- in
- Typetexp.widen context;
- let body = fold_unpacks extended_env rem in
- (* go back to parent level *)
- end_def ();
- Ctype.unify_var extended_env ty body.exp_type;
- re {
- exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
- pres, modl, body);
- exp_loc;
- exp_attributes;
- exp_extra = [];
- exp_type = ty;
- exp_env = env }
+ wrap_def begin fun () ->
+ let name, modl, pres, id, extended_env =
+ Typetexp.wrap_type_variable_scope begin fun () ->
+ let name = unpack.tu_name in
+ let modl, md_shape =
+ !type_module env
+ Ast_helper.(
+ Mod.unpack ~loc:unpack.tu_loc
+ (Exp.ident ~loc:name.loc
+ (mkloc (Longident.Lident name.txt) name.loc)))
+ in
+ Mtype.lower_nongen (get_level ty) modl.mod_type;
+ let pres =
+ match modl.mod_type with
+ | Mty_alias _ -> Mp_absent
+ | _ -> Mp_present
+ in
+ let scope = create_scope () in
+ let md =
+ { md_type = modl.mod_type; md_attributes = [];
+ md_loc = name.loc;
+ md_uid = unpack.tu_uid; }
+ in
+ let (id, extended_env) =
+ Env.enter_module_declaration ~scope ~shape:md_shape
+ name.txt pres md env
+ in
+ name, modl, pres, id, extended_env
+ end
+ in
+ let body = fold_unpacks extended_env rem in
+ Ctype.unify_var extended_env ty body.exp_type;
+ re {
+ exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
+ pres, modl, body);
+ exp_loc;
+ exp_attributes;
+ exp_extra = [];
+ exp_type = ty;
+ exp_env = env }
+ end
in
fold_unpacks env unpacks
@@ -4851,87 +4874,97 @@ and type_cases
| _ -> true
in
let outer_level = get_current_level () in
- let lev =
- if may_contain_gadts then begin_def ();
- get_current_level ()
- in
+ wrap_def_process_if may_contain_gadts begin fun () ->
+ let lev = get_current_level () in
let take_partial_instance =
if erase_either
then Some false else None
in
- begin_def (); (* propagation of the argument *)
- let pattern_force = ref [] in
-(* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
- Printtyp.raw_type_expr ty_arg; *)
- let half_typed_cases =
- List.map
- (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) ->
- if !Clflags.principal then begin_def (); (* propagation of pattern *)
- begin_def ();
- let ty_arg = instance ?partial:take_partial_instance ty_arg in
- end_def ();
- generalize_structure ty_arg;
- let (pat, ext_env, force, pvs, unpacks) =
- type_pattern category ~lev env pc_lhs ty_arg
- in
- pattern_force := force @ !pattern_force;
- let pat =
- if !Clflags.principal then begin
- end_def ();
- iter_pattern_variables_type generalize_structure pvs;
- { pat with pat_type = instance pat.pat_type }
- end else pat
- in
- (* Ensure that no ambivalent pattern type escapes its branch *)
- check_scope_escape pat.pat_loc env outer_level ty_arg;
- { typed_pat = pat;
- pat_type_for_unif = ty_arg;
- untyped_case = case;
- branch_env = ext_env;
- pat_vars = pvs;
- unpacks;
- contains_gadt = contains_gadt (as_comp_pattern category pat); }
+ let half_typed_cases, ty_res, do_copy_types, ty_arg' =
+ (* propagation of the argument *)
+ wrap_def begin fun () ->
+ let pattern_force = ref [] in
+ (* Format.printf "@[%i %i@ %a@]@." lev (get_current_level())
+ Printtyp.raw_type_expr ty_arg; *)
+ let half_typed_cases =
+ List.map
+ (fun ({pc_lhs; pc_guard = _; pc_rhs = _} as case) ->
+ let htc =
+ wrap_def_principal begin fun () ->
+ let ty_arg =
+ (* propagation of pattern *)
+ wrap_def ~post:generalize_structure
+ (fun () -> instance ?partial:take_partial_instance ty_arg)
+ in
+ let (pat, ext_env, force, pvs, unpacks) =
+ type_pattern category ~lev env pc_lhs ty_arg
+ in
+ pattern_force := force @ !pattern_force;
+ { typed_pat = pat;
+ pat_type_for_unif = ty_arg;
+ untyped_case = case;
+ branch_env = ext_env;
+ pat_vars = pvs;
+ unpacks;
+ contains_gadt = contains_gadt (as_comp_pattern category pat); }
+ end
+ ~post: begin fun htc ->
+ iter_pattern_variables_type generalize_structure htc.pat_vars;
+ end
+ in
+ (* Ensure that no ambivalent pattern type escapes its branch *)
+ check_scope_escape htc.typed_pat.pat_loc env outer_level
+ htc.pat_type_for_unif;
+ if !Clflags.principal then (* XXX find a bettery way? *)
+ let pat = htc.typed_pat in
+ {htc with typed_pat = { pat with pat_type = instance pat.pat_type }}
+ else htc
)
- caselist in
- let patl = List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
- let does_contain_gadt =
- List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
- in
- let ty_res, do_copy_types =
- if does_contain_gadt && not !Clflags.principal then
- correct_levels ty_res, Env.make_copy_of_types env
- else ty_res, (fun env -> env)
- in
- (* Unify all cases (delayed to keep it order-free) *)
- let ty_arg' = newvar () in
- let unify_pats ty =
- List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
- unify_pat_types pat.pat_loc (ref env) pat_ty ty
- ) half_typed_cases
+ caselist in
+ let patl =
+ List.map (fun { typed_pat; _ } -> typed_pat) half_typed_cases in
+ let does_contain_gadt =
+ List.exists (fun { contains_gadt; _ } -> contains_gadt) half_typed_cases
+ in
+ let ty_res, do_copy_types =
+ if does_contain_gadt && not !Clflags.principal then
+ correct_levels ty_res, Env.make_copy_of_types env
+ else ty_res, (fun env -> env)
+ in
+ (* Unify all cases (delayed to keep it order-free) *)
+ let ty_arg' = newvar () in
+ let unify_pats ty =
+ List.iter (fun { typed_pat = pat; pat_type_for_unif = pat_ty; _ } ->
+ unify_pat_types pat.pat_loc (ref env) pat_ty ty
+ ) half_typed_cases
+ in
+ unify_pats ty_arg';
+ (* Check for polymorphic variants to close *)
+ if List.exists has_variants patl then begin
+ Parmatch.pressure_variants_in_computation_pattern env
+ (List.map (as_comp_pattern category) patl);
+ List.iter finalize_variants patl
+ end;
+ (* `Contaminating' unifications start here *)
+ List.iter (fun f -> f()) !pattern_force;
+ (* Post-processing and generalization *)
+ if take_partial_instance <> None then unify_pats (instance ty_arg);
+ List.iter (fun { pat_vars; _ } ->
+ iter_pattern_variables_type
+ (fun t -> unify_var env (newvar()) t) pat_vars
+ ) half_typed_cases;
+ (half_typed_cases, ty_res, do_copy_types, ty_arg')
+ end
+ ~post: begin fun (half_typed_cases, _, _, ty_arg') ->
+ generalize ty_arg';
+ List.iter (fun { pat_vars; _ } ->
+ iter_pattern_variables_type generalize pat_vars
+ ) half_typed_cases
+ end
in
- unify_pats ty_arg';
- (* Check for polymorphic variants to close *)
- if List.exists has_variants patl then begin
- Parmatch.pressure_variants_in_computation_pattern env
- (List.map (as_comp_pattern category) patl);
- List.iter finalize_variants patl
- end;
- (* `Contaminating' unifications start here *)
- List.iter (fun f -> f()) !pattern_force;
- (* Post-processing and generalization *)
- if take_partial_instance <> None then unify_pats (instance ty_arg);
- List.iter (fun { pat_vars; _ } ->
- iter_pattern_variables_type (fun t -> unify_var env (newvar()) t) pat_vars
- ) half_typed_cases;
- end_def ();
- generalize ty_arg';
- List.iter (fun { pat_vars; _ } ->
- iter_pattern_variables_type generalize pat_vars
- ) half_typed_cases;
(* type bodies *)
let in_function = if List.length caselist = 1 then in_function else None in
let ty_res' = instance ty_res in
- if !Clflags.principal then begin_def ();
let cases =
List.map
(fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
@@ -4956,7 +4989,8 @@ and type_cases
in
let ty_expected =
if contains_gadt && not !Clflags.principal then
- (* allow propagation from preceding branches *)
+ (* Take a generic copy of [ty_res] again to allow propagation of
+ type information from preceding branches *)
correct_levels ty_res
else ty_res in
let guard =
@@ -4979,7 +5013,6 @@ and type_cases
)
half_typed_cases
in
- if !Clflags.principal then end_def ();
let do_init = may_contain_gadts || needs_exhaust_check in
let ty_arg_check =
if do_init then
@@ -5003,10 +5036,10 @@ and type_cases
List.iter (fun { typed_pat; branch_env; _ } ->
check_absent_variant branch_env (as_comp_pattern category typed_pat)
) half_typed_cases;
- if delayed then (begin_def (); init_def lev);
- check_unused ~lev env ty_arg_check val_cases ;
- check_unused ~lev env Predef.type_exn exn_cases ;
- if delayed then end_def ();
+ wrap_init_def_if delayed ~level:lev begin fun () ->
+ check_unused ~lev env ty_arg_check val_cases ;
+ check_unused ~lev env Predef.type_exn exn_cases ;
+ end;
Parmatch.check_ambiguous_bindings val_cases ;
Parmatch.check_ambiguous_bindings exn_cases
in
@@ -5015,12 +5048,10 @@ and type_cases
else
(* Check for unused cases, do not delay because of gadts *)
unused_check false;
- if may_contain_gadts then begin
- end_def ();
- (* Ensure that existential types do not escape *)
- unify_exp_types loc env ty_res' (newvar ()) ;
- end;
- cases, partial
+ ((cases, partial), [ty_res'])
+ end
+ (* Ensure that existential types do not escape *)
+ ~proc:(fun ty_res' -> unify_exp_types loc env ty_res' (newvar ()))
(* Typing of let bindings *)
@@ -5042,118 +5073,126 @@ and type_let ?check ?check_strict
sty
| _ -> spat)
spat_sexp_list in
-
- begin_def();
- if !Clflags.principal then begin_def ();
- let nvs = List.map (fun _ -> newvar ()) spatl in
- let (pat_list, new_env, force, pvs, unpacks) =
- type_pattern_list Value existential_context env spatl nvs allow in
let attrs_list = List.map fst spatl in
let is_recursive = (rec_flag = Recursive) in
- (* If recursive, first unify with an approximation of the expression *)
- if is_recursive then
- List.iter2
- (fun pat binding ->
- let pat =
- match get_desc pat.pat_type with
- | Tpoly (ty, tl) ->
- {pat with pat_type =
- snd (instance_poly ~keep_names:true false tl ty)}
- | _ -> pat
- in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
- pat_list spat_sexp_list;
- (* Polymorphic variant processing *)
- List.iter
- (fun pat ->
- if has_variants pat then begin
- Parmatch.pressure_variants env [pat];
- finalize_variants pat
- end)
- pat_list;
- (* Generalize the structure *)
- let pat_list =
- if !Clflags.principal then begin
- end_def ();
- iter_pattern_variables_type generalize_structure pvs;
- List.map (fun pat ->
- generalize_structure pat.pat_type;
- {pat with pat_type = instance pat.pat_type}
- ) pat_list
- end else
- pat_list
- in
- (* Only bind pattern variables after generalizing *)
- List.iter (fun f -> f()) force;
- let exp_list =
- let exp_env = if is_recursive then new_env else env in
- type_let_def_wrap_warnings ?check ?check_strict ~is_recursive
- ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs
- (fun exp_env {pvb_expr=sexp; pvb_attributes; _} pat ->
- match get_desc pat.pat_type with
- | Tpoly (ty, tl) ->
- if !Clflags.principal then begin_def ();
- let vars, ty' = instance_poly ~keep_names:true true tl ty in
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty'
- end;
- let exp =
- Builtin_attributes.warning_scope pvb_attributes (fun () ->
- if rec_flag = Recursive then
- type_unpacks exp_env unpacks sexp (mk_expected ty')
- else
- type_expect exp_env sexp (mk_expected ty')
- )
- in
- exp, Some vars
- | _ ->
- let exp =
- Builtin_attributes.warning_scope pvb_attributes (fun () ->
- if rec_flag = Recursive then
- type_unpacks exp_env unpacks sexp (mk_expected pat.pat_type)
- else
- type_expect exp_env sexp (mk_expected pat.pat_type))
- in
- exp, None)
+ let (pat_list, exp_list, new_env, unpacks, _pvs) =
+ wrap_def begin fun () ->
+ let (pat_list, new_env, force, pvs, unpacks) =
+ wrap_def_principal begin fun () ->
+ let nvs = List.map (fun _ -> newvar ()) spatl in
+ let (pat_list, _new_env, _force, _pvs, _unpacks as res) =
+ type_pattern_list Value existential_context env spatl nvs allow in
+ (* If recursive, first unify with an approximation of the
+ expression *)
+ if is_recursive then
+ List.iter2
+ (fun pat binding ->
+ let pat =
+ match get_desc pat.pat_type with
+ | Tpoly (ty, tl) ->
+ {pat with pat_type =
+ snd (instance_poly ~keep_names:true false tl ty)}
+ | _ -> pat
+ in unify_pat (ref env) pat (type_approx env binding.pvb_expr))
+ pat_list spat_sexp_list;
+ (* Polymorphic variant processing *)
+ List.iter
+ (fun pat ->
+ if has_variants pat then begin
+ Parmatch.pressure_variants env [pat];
+ finalize_variants pat
+ end)
+ pat_list;
+ res
+ end
+ ~post: begin fun (pat_list, _, _, pvs, _) ->
+ (* Generalize the structure *)
+ iter_pattern_variables_type generalize_structure pvs;
+ List.iter (fun pat -> generalize_structure pat.pat_type) pat_list
+ end
+ in
+ let pat_list =
+ List.map
+ (fun pat -> {pat with pat_type = instance pat.pat_type})
+ pat_list
+ in
+ (* Only bind pattern variables after generalizing *)
+ List.iter (fun f -> f()) force;
+
+ let exp_list =
+ let exp_env = if is_recursive then new_env else env in
+ type_let_def_wrap_warnings ?check ?check_strict ~is_recursive
+ ~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs
+ (fun exp_env {pvb_expr=sexp; pvb_attributes; _} pat ->
+ match get_desc pat.pat_type with
+ | Tpoly (ty, tl) ->
+ let vars, ty' =
+ wrap_def_principal
+ ~post:(fun (_,ty') -> generalize_structure ty')
+ (fun () -> instance_poly ~keep_names:true true tl ty)
+ in
+ let exp =
+ Builtin_attributes.warning_scope pvb_attributes (fun () ->
+ if rec_flag = Recursive then
+ type_unpacks exp_env unpacks sexp (mk_expected ty')
+ else
+ type_expect exp_env sexp (mk_expected ty')
+ )
+ in
+ exp, Some vars
+ | _ ->
+ let exp =
+ Builtin_attributes.warning_scope pvb_attributes (fun () ->
+ if rec_flag = Recursive then
+ type_unpacks exp_env unpacks sexp
+ (mk_expected pat.pat_type)
+ else
+ type_expect exp_env sexp (mk_expected pat.pat_type))
+ in
+ exp, None)
+ in
+ List.iter2
+ (fun pat (attrs, exp) ->
+ Builtin_attributes.warning_scope ~ppwarning:false attrs
+ (fun () ->
+ ignore(check_partial env pat.pat_type pat.pat_loc
+ [case pat exp])
+ )
+ )
+ pat_list
+ (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
+ (pat_list, exp_list, new_env, unpacks,
+ List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs)
+ end
+ ~post: begin fun (pat_list, exp_list, _, _, pvs) ->
+ List.iter2
+ (fun pat (exp, _) ->
+ if maybe_expansive exp then lower_contravariant env pat.pat_type)
+ pat_list exp_list;
+ iter_pattern_variables_type generalize pvs;
+ List.iter2
+ (fun pat (exp, vars) ->
+ match vars with
+ | None ->
+ (* We generalize expressions even if they are not bound to a variable
+ and do not have an expliclit polymorphic type annotation. This is
+ not needed in general, however those types may be shown by the
+ interactive toplevel, for example:
+ {[
+ let _ = Array.get;;
+ - : 'a array -> int -> 'a = <fun>
+ ]}
+ so we do it anyway. *)
+ generalize exp.exp_type
+ | Some vars ->
+ if maybe_expansive exp then
+ lower_contravariant env exp.exp_type;
+ generalize_and_check_univars env "definition"
+ exp pat.pat_type vars)
+ pat_list exp_list
+ end
in
- List.iter2
- (fun pat (attrs, exp) ->
- Builtin_attributes.warning_scope ~ppwarning:false attrs
- (fun () ->
- ignore(check_partial env pat.pat_type pat.pat_loc
- [case pat exp])
- )
- )
- pat_list
- (List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
- let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in
- end_def();
- List.iter2
- (fun pat (exp, _) ->
- if maybe_expansive exp then
- lower_contravariant env pat.pat_type)
- pat_list exp_list;
- iter_pattern_variables_type generalize pvs;
- List.iter2
- (fun pat (exp, vars) ->
- match vars with
- | None ->
- (* We generalize expressions even if they are not bound to a variable
- and do not have an expliclit polymorphic type annotation. This is
- not needed in general, however those types may be shown by the
- interactive toplevel, for example:
- {[
- let _ = Array.get;;
- - : 'a array -> int -> 'a = <fun>
- ]}
- so we do it anyway. *)
- generalize exp.exp_type
- | Some vars ->
- if maybe_expansive exp then
- lower_contravariant env exp.exp_type;
- generalize_and_check_univars env "definition" exp pat.pat_type vars)
- pat_list exp_list;
let l = List.combine pat_list exp_list in
let l =
List.map2
@@ -5306,26 +5345,26 @@ and type_andops env sarg sands expected_ty =
match rev_sands with
| [] -> type_expect env let_sarg (mk_expected expected_ty), []
| { pbop_op = sop; pbop_exp = sexp; pbop_loc = loc; _ } :: rest ->
- if !Clflags.principal then begin_def ();
- let op_path, op_desc = type_binding_op_ident env sop in
- let op_type = instance op_desc.val_type in
- let ty_arg = newvar () in
- let ty_rest = newvar () in
- let ty_result = newvar() in
- let ty_rest_fun =
- newty (Tarrow(Nolabel, ty_arg, ty_result, commu_ok)) in
- let ty_op = newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in
- begin try
- unify env op_type ty_op
- with Unify err ->
- raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err)))
- end;
- if !Clflags.principal then begin
- end_def ();
- generalize_structure ty_rest;
- generalize_structure ty_arg;
- generalize_structure ty_result
- end;
+ let op_path, op_desc, op_type, ty_arg, ty_rest, ty_result =
+ wrap_def_process_principal ~proc:generalize_structure begin fun () ->
+ let op_path, op_desc = type_binding_op_ident env sop in
+ let op_type = instance op_desc.val_type in
+ let ty_arg = newvar () in
+ let ty_rest = newvar () in
+ let ty_result = newvar() in
+ let ty_rest_fun =
+ newty (Tarrow(Nolabel, ty_arg, ty_result, commu_ok)) in
+ let ty_op =
+ newty (Tarrow(Nolabel, ty_rest, ty_rest_fun, commu_ok)) in
+ begin try
+ unify env op_type ty_op
+ with Unify err ->
+ raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err)))
+ end;
+ ((op_path, op_desc, op_type, ty_arg, ty_rest, ty_result),
+ [ty_rest; ty_arg; ty_result])
+ end
+ in
let let_arg, rest = loop env let_sarg rest ty_rest in
let exp = type_expect env sexp (mk_expected ty_arg) in
begin try
@@ -5451,11 +5490,10 @@ let type_let existential_ctx env rec_flag spat_sexp_list =
let type_expression env sexp =
Typetexp.reset_type_variables();
- begin_def();
- let exp = type_exp env sexp in
- end_def();
- if maybe_expansive exp then lower_contravariant env exp.exp_type;
- generalize exp.exp_type;
+ let exp =
+ wrap_def (fun () -> type_exp env sexp)
+ ~post:(may_lower_contravariant_then_generalize env)
+ in
match sexp.pexp_desc with
Pexp_ident lid ->
let loc = sexp.pexp_loc in
diff --git a/typing/typecore.mli b/typing/typecore.mli
index c1da384df1..2095d3b3e5 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -134,6 +134,7 @@ val option_some: Env.t -> Typedtree.expression -> Typedtree.expression
val option_none: Env.t -> type_expr -> Location.t -> Typedtree.expression
val extract_option_type: Env.t -> type_expr -> type_expr
val generalizable: int -> type_expr -> bool
+val generalize_structure_exp: Typedtree.expression -> unit
val reset_delayed_checks: unit -> unit
val force_delayed_checks: unit -> unit
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 5d5bebd917..7d87c0fb5b 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -263,54 +263,54 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
| Some sret_type ->
(* if it's a generalized constructor we must first narrow and
then widen so as to not introduce any new constraints *)
- let z = narrow () in
+ (* narrow and widen are now invoked through wrap_type_variable_scope *)
+ wrap_type_variable_scope begin fun () ->
reset_type_variables ();
- let univars, closed =
- match svars with
- | [] -> None, false
- | vs ->
- Ctype.begin_def();
- Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true
- in
- let args, targs =
- transl_constructor_arguments env univars closed sargs
- in
- let tret_type = transl_simple_type env ?univars closed sret_type in
- let ret_type = tret_type.ctyp_type in
- (* TODO add back type_path as a parameter ? *)
- begin match get_desc ret_type with
- | Tconstr (p', _, _) when Path.same type_path p' -> ()
- | _ ->
- let trace =
- (* Expansion is not helpful here -- the restriction on GADT return
- types is purely syntactic. (In the worst case, expansion
- produces gibberish.) *)
- [Ctype.unexpanded_diff
- ~got:ret_type
- ~expected:(Ctype.newconstr type_path type_params)]
+ let closed = svars <> [] in
+ let targs, tret_type, args, ret_type, _univars =
+ Ctype.wrap_def_if closed begin fun () ->
+ let univar_list =
+ make_poly_univars (List.map (fun v -> v.txt) svars) in
+ let univars = if closed then Some univar_list else None in
+ let args, targs =
+ transl_constructor_arguments env univars closed sargs
in
- raise (Error(sret_type.ptyp_loc,
- Constraint_failed(env,
- Errortrace.unification_error ~trace)))
- end;
- begin match univars with
- | None -> ()
- | Some univars ->
- Ctype.end_def();
- Btype.iter_type_expr_cstr_args Ctype.generalize args;
- Ctype.generalize ret_type;
- let _vars = instance_poly_univars env loc univars in
- let set_level t = Ctype.unify_var env (Ctype.newvar()) t in
- Btype.iter_type_expr_cstr_args set_level args;
- set_level ret_type;
- end;
- widen z;
+ let tret_type = transl_simple_type env ?univars closed sret_type in
+ let ret_type = tret_type.ctyp_type in
+ (* TODO add back type_path as a parameter ? *)
+ begin match get_desc ret_type with
+ | Tconstr (p', _, _) when Path.same type_path p' -> ()
+ | _ ->
+ let trace =
+ (* Expansion is not helpful here -- the restriction on GADT
+ return types is purely syntactic. (In the worst case,
+ expansion produces gibberish.) *)
+ [Ctype.unexpanded_diff
+ ~got:ret_type
+ ~expected:(Ctype.newconstr type_path type_params)]
+ in
+ raise (Error(sret_type.ptyp_loc,
+ Constraint_failed(
+ env, Errortrace.unification_error ~trace)))
+ end;
+ (targs, tret_type, args, ret_type, univar_list)
+ end
+ ~post: begin fun (_, _, args, ret_type, univars) ->
+ Btype.iter_type_expr_cstr_args Ctype.generalize args;
+ Ctype.generalize ret_type;
+ let _vars = instance_poly_univars env loc univars in
+ let set_level t = Ctype.enforce_current_level env t in
+ Btype.iter_type_expr_cstr_args set_level args;
+ set_level ret_type;
+ end
+ in
targs, Some tret_type, args, Some ret_type
+ end
let transl_declaration env sdecl (id, uid) =
(* Bind type parameters *)
reset_type_variables();
- Ctype.begin_def ();
+ Ctype.wrap_def begin fun () ->
let tparams = make_params env sdecl.ptype_params in
let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
let cstrs = List.map
@@ -460,7 +460,6 @@ let transl_declaration env sdecl (id, uid) =
try Ctype.unify env ty ty' with Ctype.Unify err ->
raise(Error(loc, Inconsistent_constraint (env, err))))
cstrs;
- Ctype.end_def ();
(* Add abstract row *)
if is_fixed_type sdecl then begin
let p, _ =
@@ -482,6 +481,7 @@ let transl_declaration env sdecl (id, uid) =
typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
}
+ end
(* Generalize a type declaration *)
@@ -886,59 +886,62 @@ let transl_type_decl env rec_flag sdecl_list =
Uid.mk ~current_unit:(Env.get_unit_name ())
) sdecl_list
in
- Ctype.begin_def();
- (* Enter types. *)
- let temp_env =
- List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
- (* Translate each declaration. *)
- let current_slot = ref None in
- let warn_unused = Warnings.is_active (Warnings.Unused_type_declaration "") in
- let ids_slots (id, _uid as ids) =
- match rec_flag with
- | Asttypes.Recursive when warn_unused ->
- (* See typecore.ml for a description of the algorithm used
- to detect unused declarations in a set of recursive definitions. *)
- let slot = ref [] in
- let td = Env.find_type (Path.Pident id) temp_env in
- Env.set_type_used_callback
- td
- (fun old_callback ->
- match !current_slot with
- | Some slot -> slot := td.type_uid :: !slot
- | None ->
- List.iter Env.mark_type_used (get_ref slot);
- old_callback ()
- );
- ids, Some slot
- | Asttypes.Recursive | Asttypes.Nonrecursive ->
- ids, None
- in
- let transl_declaration name_sdecl (id, slot) =
- current_slot := slot;
- Builtin_attributes.warning_scope
- name_sdecl.ptype_attributes
- (fun () -> transl_declaration temp_env name_sdecl id)
+ let tdecls, decls, new_env =
+ Ctype.wrap_def_process ~proc:generalize_decl begin fun () ->
+ (* Enter types. *)
+ let temp_env =
+ List.fold_left2 (enter_type rec_flag) env sdecl_list ids_list in
+ (* Translate each declaration. *)
+ let current_slot = ref None in
+ let warn_unused =
+ Warnings.is_active (Warnings.Unused_type_declaration "") in
+ let ids_slots (id, _uid as ids) =
+ match rec_flag with
+ | Asttypes.Recursive when warn_unused ->
+ (* See typecore.ml for a description of the algorithm used to
+ detect unused declarations in a set of recursive definitions. *)
+ let slot = ref [] in
+ let td = Env.find_type (Path.Pident id) temp_env in
+ Env.set_type_used_callback
+ td
+ (fun old_callback ->
+ match !current_slot with
+ | Some slot -> slot := td.type_uid :: !slot
+ | None ->
+ List.iter Env.mark_type_used (get_ref slot);
+ old_callback ()
+ );
+ ids, Some slot
+ | Asttypes.Recursive | Asttypes.Nonrecursive ->
+ ids, None
+ in
+ let transl_declaration name_sdecl (id, slot) =
+ current_slot := slot;
+ Builtin_attributes.warning_scope
+ name_sdecl.ptype_attributes
+ (fun () -> transl_declaration temp_env name_sdecl id)
+ in
+ let tdecls =
+ List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
+ let decls =
+ List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
+ current_slot := None;
+ (* Check for duplicates *)
+ check_duplicates sdecl_list;
+ (* Build the final env. *)
+ let new_env = add_types_to_env decls env in
+ (* Update stubs *)
+ begin match rec_flag with
+ | Asttypes.Nonrecursive -> ()
+ | Asttypes.Recursive ->
+ List.iter2
+ (fun (id, _) sdecl ->
+ update_type temp_env new_env id sdecl.ptype_loc)
+ ids_list sdecl_list
+ end;
+ ((tdecls, decls, new_env), List.map snd decls)
+ end
in
- let tdecls =
- List.map2 transl_declaration sdecl_list (List.map ids_slots ids_list) in
- let decls =
- List.map (fun tdecl -> (tdecl.typ_id, tdecl.typ_type)) tdecls in
- current_slot := None;
- (* Check for duplicates *)
- check_duplicates sdecl_list;
- (* Build the final env. *)
- let new_env = add_types_to_env decls env in
- (* Update stubs *)
- begin match rec_flag with
- | Asttypes.Nonrecursive -> ()
- | Asttypes.Recursive ->
- List.iter2
- (fun (id, _) sdecl -> update_type temp_env new_env id sdecl.ptype_loc)
- ids_list sdecl_list
- end;
- (* Generalize type declarations. *)
- Ctype.end_def();
- List.iter (fun (_, decl) -> generalize_decl decl) decls;
(* Check for ill-formed abbrevs *)
let id_loc_list =
List.map2 (fun (id, _) sdecl -> (id, sdecl.ptype_loc))
@@ -1124,11 +1127,6 @@ let is_rebind ext =
| Text_decl _ -> false
let transl_type_extension extend env loc styext =
- (* Note: it would be incorrect to call [create_scope] *after*
- [reset_type_variables] or after [begin_def] (see #10010). *)
- let scope = Ctype.create_scope () in
- reset_type_variables();
- Ctype.begin_def();
let type_path, type_decl =
let lid = styext.ptyext_path in
Env.lookup_type ~loc:lid.loc lid.txt env
@@ -1173,24 +1171,34 @@ let transl_type_extension extend env loc styext =
| None -> ()
| Some err -> raise (Error(loc, Extension_mismatch (type_path, env, err)))
end;
- let ttype_params = make_params env styext.ptyext_params in
- let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
- List.iter2 (Ctype.unify_var env)
- (Ctype.instance_list type_decl.type_params)
- type_params;
- let constructors =
- List.map (transl_extension_constructor ~scope env type_path
- type_decl.type_params type_params styext.ptyext_private)
- styext.ptyext_constructors
+ (* Note: it would be incorrect to call [create_scope] *after*
+ [reset_type_variables] or after [wrap_def] (see #10010). *)
+ let scope = Ctype.create_scope () in
+ reset_type_variables();
+ let ttype_params, _type_params, constructors =
+ Ctype.wrap_def begin fun () ->
+ let ttype_params = make_params env styext.ptyext_params in
+ let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in
+ List.iter2 (Ctype.unify_var env)
+ (Ctype.instance_list type_decl.type_params)
+ type_params;
+ let constructors =
+ List.map (transl_extension_constructor ~scope env type_path
+ type_decl.type_params type_params styext.ptyext_private)
+ styext.ptyext_constructors
+ in
+ (ttype_params, type_params, constructors)
+ end
+ ~post: begin fun (_, type_params, constructors) ->
+ (* Generalize types *)
+ List.iter Ctype.generalize type_params;
+ List.iter
+ (fun ext ->
+ Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+ Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
+ constructors;
+ end
in
- Ctype.end_def();
- (* Generalize types *)
- List.iter Ctype.generalize type_params;
- List.iter
- (fun ext ->
- Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
- Option.iter Ctype.generalize ext.ext_type.ext_ret_type)
- constructors;
(* Check that all type variables are closed *)
List.iter
(fun ext ->
@@ -1237,15 +1245,16 @@ let transl_type_extension extend env loc styext =
let transl_exception env sext =
let scope = Ctype.create_scope () in
reset_type_variables();
- Ctype.begin_def();
let ext =
- transl_extension_constructor ~scope env
- Predef.path_exn [] [] Asttypes.Public sext
+ Ctype.wrap_def
+ (fun () ->
+ transl_extension_constructor ~scope env
+ Predef.path_exn [] [] Asttypes.Public sext)
+ ~post: begin fun ext ->
+ Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
+ Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
+ end
in
- Ctype.end_def();
- (* Generalize types *)
- Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args;
- Option.iter Ctype.generalize ext.ext_type.ext_ret_type;
(* Check that all type variables are closed *)
begin match Ctype.closed_extension_constructor ext.ext_type with
Some ty ->
@@ -1452,7 +1461,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
sdecl =
Env.mark_type_used sig_decl.type_uid;
reset_type_variables();
- Ctype.begin_def();
+ Ctype.wrap_def begin fun () ->
(* In the first part of this function, we typecheck the syntactic
declaration [sdecl] in the outer environment [outer_env]. *)
let env = outer_env in
@@ -1572,8 +1581,6 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
type_immediate = new_type_immediate;
type_separability = new_type_separability;
} in
- Ctype.end_def();
- generalize_decl new_sig_decl;
{
typ_id = id;
typ_name = sdecl.ptype_name;
@@ -1586,14 +1593,15 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
typ_private = sdecl.ptype_private;
typ_attributes = sdecl.ptype_attributes;
}
+ end
+ ~post:(fun ttyp -> generalize_decl ttyp.typ_type)
(* Approximate a type declaration: just make all types abstract *)
let abstract_type_decl ~injective arity =
let rec make_params n =
if n <= 0 then [] else Ctype.newvar() :: make_params (n-1) in
- Ctype.begin_def();
- let decl =
+ Ctype.wrap_def ~post:generalize_decl begin fun () ->
{ type_params = make_params arity;
type_arity = arity;
type_kind = Type_abstract;
@@ -1608,10 +1616,8 @@ let abstract_type_decl ~injective arity =
type_immediate = Unknown;
type_unboxed_default = false;
type_uid = Uid.internal_not_actually_unique;
- } in
- Ctype.end_def();
- generalize_decl decl;
- decl
+ }
+ end
let approx_type_decl sdecl_list =
let scope = Ctype.create_scope () in
diff --git a/typing/typemod.ml b/typing/typemod.ml
index ebdeb97bbe..2037f30059 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -2223,12 +2223,10 @@ and type_module_aux ~alias sttn funct_body anchor env smod =
},
final_shape
| Pmod_unpack sexp ->
- if !Clflags.principal then Ctype.begin_def ();
- let exp = Typecore.type_exp env sexp in
- if !Clflags.principal then begin
- Ctype.end_def ();
- Ctype.generalize_structure exp.exp_type
- end;
+ let exp =
+ Ctype.wrap_def_principal (fun () -> Typecore.type_exp env sexp)
+ ~post:Typecore.generalize_structure_exp
+ in
let mty =
match get_desc (Ctype.expand_head env exp.exp_type) with
Tpackage (p, fl) ->
@@ -2886,12 +2884,16 @@ let lookup_type_in_sig sg =
let type_package env m p fl =
(* Same as Pexp_letmodule *)
- (* remember original level *)
- Ctype.begin_def ();
- let context = Typetexp.narrow () in
- let modl, _mod_shape = type_module env m in
- let scope = Ctype.create_scope () in
- Typetexp.widen context;
+ let modl, scope =
+ Typetexp.wrap_type_variable_scope begin fun () ->
+ (* type the module and create a scope in a raised level *)
+ Ctype.wrap_def begin fun () ->
+ let modl, _mod_shape = type_module env m in
+ let scope = Ctype.create_scope () in
+ modl, scope
+ end
+ end
+ in
let fl', env =
match fl with
| [] -> [], env
@@ -2932,8 +2934,6 @@ let type_package env m p fl =
in
fl', env
in
- (* go back to original level *)
- Ctype.end_def ();
let mty =
if fl = [] then (Mty_ident p)
else modtype_of_package env modl.mod_loc p fl'
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index f70c0645bf..2f474a388d 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -105,6 +105,14 @@ let widen (gl, tv) =
restore_global_level gl;
type_variables := tv
+let wrap_type_variable_scope f =
+ let context = narrow () in
+ let r = f () in
+ widen context;
+ r
+
+let generalize_ctyp typ = generalize typ.ctyp_type
+
let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
let validate_name = function
@@ -316,19 +324,20 @@ and transl_type_aux env policy styp =
end;
ty
with Not_found ->
- if !Clflags.principal then begin_def ();
- let t = newvar () in
- used_variables :=
- TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
- let ty = transl_type env policy st in
- begin try unify_var env t ty.ctyp_type with Unify err ->
- let err = Errortrace.swap_unification_error err in
- raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err))
- end;
- if !Clflags.principal then begin
- end_def ();
- generalize_structure t;
- end;
+ let t, ty =
+ wrap_def_principal begin fun () ->
+ let t = newvar () in
+ used_variables :=
+ TyVarMap.add alias (t, styp.ptyp_loc) !used_variables;
+ let ty = transl_type env policy st in
+ begin try unify_var env t ty.ctyp_type with Unify err ->
+ let err = Errortrace.swap_unification_error err in
+ raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err))
+ end;
+ (t, ty)
+ end
+ ~post: (fun (t, _) -> generalize_structure t)
+ in
let t = instance t in
let px = Btype.proxy t in
begin match get_desc px with
@@ -436,15 +445,18 @@ and transl_type_aux env policy styp =
ctyp (Ttyp_variant (tfields, closed, present)) ty
| Ptyp_poly(vars, st) ->
let vars = List.map (fun v -> v.txt) vars in
- begin_def();
- let new_univars = make_poly_univars vars in
- let old_univars = !univars in
- univars := new_univars @ !univars;
- let cty = transl_type env policy st in
+ let new_univars, cty =
+ wrap_def begin fun () ->
+ let new_univars = make_poly_univars vars in
+ let old_univars = !univars in
+ univars := new_univars @ !univars;
+ let cty = transl_type env policy st in
+ univars := old_univars;
+ (new_univars, cty)
+ end
+ ~post:(fun (_,cty) -> generalize_ctyp cty)
+ in
let ty = cty.ctyp_type in
- univars := old_univars;
- end_def();
- generalize ty;
let ty_list = check_poly_univars env styp.ptyp_loc new_univars in
let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in
let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in
@@ -452,9 +464,7 @@ and transl_type_aux env policy styp =
ctyp (Ttyp_poly (vars, cty)) ty'
| Ptyp_package (p, l) ->
let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
- let z = narrow () in
- let mty = !transl_modtype env mty in
- widen z;
+ let mty = wrap_type_variable_scope (fun () -> !transl_modtype env mty) in
let ptys = List.map (fun (s, pty) ->
s, transl_type env policy pty
) l in
@@ -600,19 +610,21 @@ let transl_simple_type env ?univars:(uvs=[]) fixed styp =
let transl_simple_type_univars env styp =
univars := []; used_variables := TyVarMap.empty; pre_univars := [];
- begin_def ();
- let typ = transl_type env Univars styp in
- (* Only keep already global variables in used_variables *)
- let new_variables = !used_variables in
- used_variables := TyVarMap.empty;
- TyVarMap.iter
- (fun name p ->
- if TyVarMap.mem name !type_variables then
- used_variables := TyVarMap.add name p !used_variables)
- new_variables;
- globalize_used_variables env false ();
- end_def ();
- generalize typ.ctyp_type;
+ let typ =
+ wrap_def ~post:generalize_ctyp begin fun () ->
+ let typ = transl_type env Univars styp in
+ (* Only keep already global variables in used_variables *)
+ let new_variables = !used_variables in
+ used_variables := TyVarMap.empty;
+ TyVarMap.iter
+ (fun name p ->
+ if TyVarMap.mem name !type_variables then
+ used_variables := TyVarMap.add name p !used_variables)
+ new_variables;
+ globalize_used_variables env false ();
+ typ
+ end
+ in
let univs =
List.fold_left
(fun acc v ->
@@ -628,28 +640,29 @@ let transl_simple_type_univars env styp =
let transl_simple_type_delayed env styp =
univars := []; used_variables := TyVarMap.empty;
- begin_def ();
- let typ = transl_type env Extensible styp in
- end_def ();
+ let typ = wrap_def (fun () -> transl_type env Extensible styp) in
make_fixed_univars typ.ctyp_type;
(* This brings the used variables to the global level, but doesn't link them
to their other occurrences just yet. This will be done when [force] is
called. *)
let force = globalize_used_variables env false in
(* Generalizes everything except the variables that were just globalized. *)
- generalize typ.ctyp_type;
+ generalize_ctyp typ; (* XXX: should be post-processed by [wrap_def] *)
(typ, instance typ.ctyp_type, force)
let transl_type_scheme env styp =
reset_type_variables();
match styp.ptyp_desc with
| Ptyp_poly (vars, st) ->
- begin_def();
let vars = List.map (fun v -> v.txt) vars in
- let univars = make_poly_univars vars in
- let typ = transl_simple_type env ~univars true st in
- end_def();
- generalize typ.ctyp_type;
+ let univars, typ =
+ wrap_def begin fun () ->
+ let univars = make_poly_univars vars in
+ let typ = transl_simple_type env ~univars true st in
+ (univars, typ)
+ end
+ ~post:(fun (_,typ) -> generalize_ctyp typ)
+ in
let _ = instance_poly_univars env styp.ptyp_loc univars in
{ ctyp_desc = Ttyp_poly (vars, typ);
ctyp_type = typ.ctyp_type;
@@ -657,11 +670,8 @@ let transl_type_scheme env styp =
ctyp_loc = styp.ptyp_loc;
ctyp_attributes = styp.ptyp_attributes }
| _ ->
- begin_def();
- let typ = transl_simple_type env false styp in
- end_def();
- generalize typ.ctyp_type;
- typ
+ wrap_def (fun () -> transl_simple_type env false styp)
+ ~post:generalize_ctyp
(* Error report *)
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index c264ab599a..786cf503e7 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -52,8 +52,7 @@ val transl_type_param:
Env.t -> Parsetree.core_type -> Typedtree.core_type
type variable_context
-val narrow: unit -> variable_context
-val widen: variable_context -> unit
+val wrap_type_variable_scope: (unit -> 'a) -> 'a
exception Already_bound
View Lorry Controller Status