summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/ctype.ml68
-rw-r--r--typing/env.ml32
-rw-r--r--typing/includemod.ml50
-rw-r--r--typing/mtype.ml75
-rw-r--r--typing/mtype.mli4
-rw-r--r--typing/oprint.ml31
-rw-r--r--typing/outcometree.mli14
-rw-r--r--typing/printtyp.ml144
-rw-r--r--typing/printtyp.mli8
-rw-r--r--typing/subst.ml28
-rw-r--r--typing/typeclass.ml96
-rw-r--r--typing/typecore.ml420
-rw-r--r--typing/typemod.ml134
-rw-r--r--typing/typemod.mli2
-rw-r--r--typing/types.ml16
-rw-r--r--typing/types.mli16
16 files changed, 639 insertions, 499 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
index bc430b3771..da37d93184 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -825,7 +825,9 @@ let instance_class params cty =
{cty_self = copy sign.cty_self;
cty_vars =
Vars.map (function (mut, ty) -> (mut, copy ty)) sign.cty_vars;
- cty_concr = sign.cty_concr}
+ cty_concr = sign.cty_concr;
+ cty_inher =
+ List.map (fun (p,tl) -> (p, List.map copy tl)) sign.cty_inher}
| Tcty_fun (l, ty, cty) ->
Tcty_fun (l, copy ty, copy_class_type cty)
in
@@ -1227,21 +1229,21 @@ let occur env ty0 ty =
be done at meta-level, using bindings in univar_pairs *)
let rec unify_univar t1 t2 = function
(cl1, cl2) :: rem ->
- let repr_univ = List.map (fun (t,o) -> repr t, o) in
- let cl1 = repr_univ cl1 and cl2 = repr_univ cl2 in
- begin try
- let r1 = List.assq t1 cl1 in
- match !r1 with
- Some t -> if t2 != repr t then raise (Unify [])
- | None ->
- try
- let r2 = List.assq t2 cl2 in
- if !r2 <> None then raise (Unify []);
- set_univar r1 t2; set_univar r2 t1
- with Not_found ->
- raise (Unify [])
- with Not_found ->
- unify_univar t1 t2 rem
+ let find_univ t cl =
+ try
+ let (_, r) = List.find (fun (t',_) -> t == repr t') cl in
+ Some r
+ with Not_found -> None
+ in
+ begin match find_univ t1 cl1, find_univ t2 cl2 with
+ Some {contents=Some t'2}, Some _ when t2 == repr t'2 ->
+ ()
+ | Some({contents=None} as r1), Some({contents=None} as r2) ->
+ set_univar r1 t2; set_univar r2 t1
+ | None, None ->
+ unify_univar t1 t2 rem
+ | _ ->
+ raise (Unify [])
end
| [] -> raise (Unify [])
@@ -1303,6 +1305,13 @@ let expand_trace env trace =
(repr t1, full_expand env t1)::(repr t2, full_expand env t2)::rem)
trace []
+(* build a dummy variant type *)
+let mkvariant fields closed =
+ newgenty
+ (Tvariant
+ {row_fields = fields; row_closed = closed; row_more = newvar();
+ row_bound = []; row_fixed = false; row_name = None })
+
(**** Unification ****)
(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
@@ -1460,9 +1469,9 @@ and unify3 env t1 t1' t2 t2' =
unify_row env row1 row2
| (Tfield _, Tfield _) -> (* Actually unused *)
unify_fields env t1' t2'
- | (Tfield(_,kind,_,rem), Tnil) | (Tnil, Tfield(_,kind,_,rem)) ->
+ | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) ->
begin match field_kind_repr kind with
- Fvar r -> r := Some Fabsent
+ Fvar r when f <> dummy_method -> set_kind r Fabsent
| _ -> raise (Unify [])
end
| (Tnil, Tnil) ->
@@ -1544,15 +1553,16 @@ and unify_fields env ty1 ty2 = (* Optimization *)
let (fields1, rest1) = flatten_fields ty1
and (fields2, rest2) = flatten_fields ty2 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
+ let l1 = (repr ty1).level and l2 = (repr ty2).level in
let va =
if miss1 = [] then rest2
else if miss2 = [] then rest1
- else newvar ()
+ else newty2 (min l1 l2) Tvar
in
let d1 = rest1.desc and d2 = rest2.desc in
try
- unify env (build_fields (repr ty1).level miss1 va) rest2;
- unify env rest1 (build_fields (repr ty2).level miss2 va);
+ unify env (build_fields l1 miss1 va) rest2;
+ unify env rest1 (build_fields l2 miss2 va);
List.iter
(fun (n, k1, t1, k2, t2) ->
unify_kind k1 k2;
@@ -1604,11 +1614,6 @@ and unify_row env row1 row2 =
row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
pairs
in
- let mkvariant fields closed =
- newgenty
- (Tvariant
- {row_fields = fields; row_closed = closed; row_more = newvar();
- row_bound = []; row_fixed = false; row_name = None }) in
let empty fields =
List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
(* Check whether we are going to build an empty type *)
@@ -1657,7 +1662,10 @@ and unify_row env row1 row2 =
let undo = ref [] in
List.iter
(fun (l,f1,f2) ->
- unify_row_field env row1.row_fixed row2.row_fixed undo l f1 f2)
+ try unify_row_field env row1.row_fixed row2.row_fixed undo l f1 f2
+ with Unify trace ->
+ raise (Unify ((mkvariant [l,f1] true,
+ mkvariant [l,f2] true) :: trace)))
pairs;
(* Special case when there is only one field left *)
if row0.row_closed then begin
@@ -1728,6 +1736,7 @@ and unify_row_field env fixed1 fixed2 undo l f1 f2 =
| Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
set_row_field e2 f1
| _ -> raise (Unify [])
+
let unify env ty1 ty2 =
try
@@ -3191,7 +3200,10 @@ let nondep_class_signature env id sign =
cty_vars =
Vars.map (function (m, t) -> (m, nondep_type_rec env id t))
sign.cty_vars;
- cty_concr = sign.cty_concr }
+ cty_concr = sign.cty_concr;
+ cty_inher =
+ List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl))
+ sign.cty_inher }
let rec nondep_class_type env id =
function
diff --git a/typing/env.ml b/typing/env.ml
index 85379b041b..b71c6bb581 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -420,7 +420,7 @@ let rec prefix_idents root pos sub = function
let nextpos = match decl.val_kind with Val_prim _ -> pos | _ -> pos+1 in
let (pl, final_sub) = prefix_idents root nextpos sub rem in
(p::pl, final_sub)
- | Tsig_type(id, decl) :: rem ->
+ | Tsig_type(id, decl, _) :: rem ->
(* types bind their own values *)
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) =
@@ -430,7 +430,7 @@ let rec prefix_idents root pos sub = function
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) = prefix_idents root (pos+1) sub rem in
(p::pl, final_sub)
- | Tsig_module(id, mty) :: rem ->
+ | Tsig_module(id, mty, _) :: rem ->
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) =
prefix_idents root (pos+1) (Subst.add_module id p sub) rem in
@@ -441,11 +441,11 @@ let rec prefix_idents root pos sub = function
prefix_idents root pos
(Subst.add_modtype id (Tmty_ident p) sub) rem in
(p::pl, final_sub)
- | Tsig_class(id, decl) :: rem ->
+ | Tsig_class(id, decl, _) :: rem ->
let p = Pdot(root, Ident.name id, pos) in
let (pl, final_sub) = prefix_idents root (pos + 1) sub rem in
(p::pl, final_sub)
- | Tsig_cltype(id, decl) :: rem ->
+ | Tsig_cltype(id, decl, _) :: rem ->
let p = Pdot(root, Ident.name id, nopos) in
let (pl, final_sub) = prefix_idents root pos sub rem in
(p::pl, final_sub)
@@ -473,7 +473,7 @@ let rec components_of_module env sub path mty =
begin match decl.val_kind with
Val_prim _ -> () | _ -> incr pos
end
- | Tsig_type(id, decl) ->
+ | Tsig_type(id, decl, _) ->
let decl' = Subst.type_declaration sub decl in
c.comp_types <-
Tbl.add (Ident.name id) (decl', !pos) c.comp_types;
@@ -493,7 +493,7 @@ let rec components_of_module env sub path mty =
c.comp_constrs <-
Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs;
incr pos
- | Tsig_module(id, mty) ->
+ | Tsig_module(id, mty, _) ->
let mty' = Subst.modtype sub mty in
c.comp_modules <-
Tbl.add (Ident.name id) (mty', !pos) c.comp_modules;
@@ -507,12 +507,12 @@ let rec components_of_module env sub path mty =
c.comp_modtypes <-
Tbl.add (Ident.name id) (decl', nopos) c.comp_modtypes;
env := store_modtype id path decl !env
- | Tsig_class(id, decl) ->
+ | Tsig_class(id, decl, _) ->
let decl' = Subst.class_declaration sub decl in
c.comp_classes <-
Tbl.add (Ident.name id) (decl', !pos) c.comp_classes;
incr pos
- | Tsig_cltype(id, decl) ->
+ | Tsig_cltype(id, decl, _) ->
let decl' = Subst.cltype_declaration sub decl in
c.comp_cltypes <-
Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes)
@@ -654,12 +654,12 @@ and enter_cltype = enter store_cltype
let add_item comp env =
match comp with
Tsig_value(id, decl) -> add_value id decl env
- | Tsig_type(id, decl) -> add_type id decl env
+ | Tsig_type(id, decl, _) -> add_type id decl env
| Tsig_exception(id, decl) -> add_exception id decl env
- | Tsig_module(id, mty) -> add_module id mty env
+ | Tsig_module(id, mty, _) -> add_module id mty env
| Tsig_modtype(id, decl) -> add_modtype id decl env
- | Tsig_class(id, decl) -> add_class id decl env
- | Tsig_cltype(id, decl) -> add_cltype id decl env
+ | Tsig_class(id, decl, _) -> add_class id decl env
+ | Tsig_cltype(id, decl, _) -> add_cltype id decl env
let rec add_signature sg env =
match sg with
@@ -679,21 +679,21 @@ let open_signature root sg env =
Tsig_value(id, decl) ->
store_value (Ident.hide id) p
(Subst.value_description sub decl) env
- | Tsig_type(id, decl) ->
+ | Tsig_type(id, decl, _) ->
store_type (Ident.hide id) p
(Subst.type_declaration sub decl) env
| Tsig_exception(id, decl) ->
store_exception (Ident.hide id) p
(Subst.exception_declaration sub decl) env
- | Tsig_module(id, mty) ->
+ | Tsig_module(id, mty, _) ->
store_module (Ident.hide id) p (Subst.modtype sub mty) env
| Tsig_modtype(id, decl) ->
store_modtype (Ident.hide id) p
(Subst.modtype_declaration sub decl) env
- | Tsig_class(id, decl) ->
+ | Tsig_class(id, decl, _) ->
store_class (Ident.hide id) p
(Subst.class_declaration sub decl) env
- | Tsig_cltype(id, decl) ->
+ | Tsig_cltype(id, decl, _) ->
store_cltype (Ident.hide id) p
(Subst.cltype_declaration sub decl) env)
env sg pl in
diff --git a/typing/includemod.ml b/typing/includemod.ml
index ab035ece8d..8cf6d5ee8b 100644
--- a/typing/includemod.ml
+++ b/typing/includemod.ml
@@ -104,26 +104,24 @@ type field_desc =
let item_ident_name = function
Tsig_value(id, _) -> (id, Field_value(Ident.name id))
- | Tsig_type(id, _) -> (id, Field_type(Ident.name id))
+ | Tsig_type(id, _, _) -> (id, Field_type(Ident.name id))
| Tsig_exception(id, _) -> (id, Field_exception(Ident.name id))
- | Tsig_module(id, _) -> (id, Field_module(Ident.name id))
+ | Tsig_module(id, _, _) -> (id, Field_module(Ident.name id))
| Tsig_modtype(id, _) -> (id, Field_modtype(Ident.name id))
- | Tsig_class(id, _) -> (id, Field_class(Ident.name id))
- | Tsig_cltype(id, _) -> (id, Field_classtype(Ident.name id))
+ | Tsig_class(id, _, _) -> (id, Field_class(Ident.name id))
+ | Tsig_cltype(id, _, _) -> (id, Field_classtype(Ident.name id))
(* Simplify a structure coercion *)
-let simplify_structure_coercion cc =
- let pos = ref 0 in
- try
- List.iter
- (fun (n, c) ->
- if n <> !pos || c <> Tcoerce_none then raise Exit;
- incr pos)
- cc;
- Tcoerce_none
- with Exit ->
- Tcoerce_structure cc
+let simplify_structure_coercion init_size cc =
+ let rec is_identity_coercion pos = function
+ | [] ->
+ pos = init_size
+ | (n, c) :: rem ->
+ n = pos && c = Tcoerce_none && is_identity_coercion (pos + 1) rem in
+ if is_identity_coercion 0 cc
+ then Tcoerce_none
+ else Tcoerce_structure cc
(* Inclusion between module types.
Return the restriction that transforms a value of the smaller type
@@ -178,22 +176,22 @@ and signatures env subst sig1 sig2 =
(* Build a table of the components of sig1, along with their positions.
The table is indexed by kind and name of component *)
let rec build_component_table pos tbl = function
- [] -> tbl
+ [] -> (tbl, pos)
| item :: rem ->
let (id, name) = item_ident_name item in
let nextpos =
match item with
Tsig_value(_,{val_kind = Val_prim _})
| Tsig_modtype(_,_)
- | Tsig_cltype(_,_) -> pos
+ | Tsig_cltype(_,_,_) -> pos
| Tsig_value(_,_)
- | Tsig_type(_,_)
+ | Tsig_type(_,_,_)
| Tsig_exception(_,_)
- | Tsig_module(_,_)
- | Tsig_class(_, _) -> pos+1 in
+ | Tsig_module(_,_,_)
+ | Tsig_class(_, _,_) -> pos+1 in
build_component_table nextpos
(Tbl.add name (id, item, pos) tbl) rem in
- let comps1 =
+ let (comps1, size1) =
build_component_table 0 Tbl.empty sig1 in
(* Pair each component of sig2 with a component of sig1,
identifying the names along the way.
@@ -227,7 +225,7 @@ and signatures env subst sig1 sig2 =
pair_components subst paired (Missing_field id2 :: unpaired) rem
end in
(* Do the pairing and checking, and return the final coercion *)
- simplify_structure_coercion(pair_components subst [] [] sig2)
+ simplify_structure_coercion size1 (pair_components subst [] [] sig2)
(* Inclusion between signature components *)
@@ -239,24 +237,24 @@ and signature_components env subst = function
Val_prim p -> signature_components env subst rem
| _ -> (pos, cc) :: signature_components env subst rem
end
- | (Tsig_type(id1, tydecl1), Tsig_type(id2, tydecl2), pos) :: rem ->
+ | (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
type_declarations env subst id1 tydecl1 tydecl2;
(pos, Tcoerce_none) :: signature_components env subst rem
| (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
:: rem ->
exception_declarations env subst id1 excdecl1 excdecl2;
(pos, Tcoerce_none) :: signature_components env subst rem
- | (Tsig_module(id1, mty1), Tsig_module(id2, mty2), pos) :: rem ->
+ | (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
let cc =
modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
(pos, cc) :: signature_components env subst rem
| (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
modtype_infos env subst id1 info1 info2;
signature_components env subst rem
- | (Tsig_class(id1, decl1), Tsig_class(id2, decl2), pos) :: rem ->
+ | (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
class_declarations env subst id1 decl1 decl2;
(pos, Tcoerce_none) :: signature_components env subst rem
- | (Tsig_cltype(id1, info1), Tsig_cltype(id2, info2), pos) :: rem ->
+ | (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
class_type_declarations env subst id1 info1 info2;
signature_components env subst rem
| _ ->
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 46c0348a25..b18c0a11c9 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -45,7 +45,7 @@ and strengthen_sig env sg p =
[] -> []
| (Tsig_value(id, desc) as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p
- | Tsig_type(id, decl) :: rem ->
+ | Tsig_type(id, decl, rs) :: rem ->
let newdecl =
match decl.type_manifest with
None ->
@@ -53,12 +53,12 @@ and strengthen_sig env sg p =
Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
decl.type_params, ref Mnil))) }
| _ -> decl in
- Tsig_type(id, newdecl) :: strengthen_sig env rem p
+ Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p
| (Tsig_exception(id, d) as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p
- | Tsig_module(id, mty) :: rem ->
- Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos))) ::
- strengthen_sig (Env.add_module id mty env) rem p
+ | Tsig_module(id, mty, rs) :: rem ->
+ Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs)
+ :: strengthen_sig (Env.add_module id mty env) rem p
(* Need to add the module in case it defines manifest module types *)
| Tsig_modtype(id, decl) :: rem ->
let newdecl =
@@ -70,9 +70,9 @@ and strengthen_sig env sg p =
Tsig_modtype(id, newdecl) ::
strengthen_sig (Env.add_modtype id decl env) rem p
(* Need to add the module type in case it is manifest *)
- | (Tsig_class(id, decl) as sigelt) :: rem ->
+ | (Tsig_class(id, decl, rs) as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p
- | (Tsig_cltype(id, decl) as sigelt) :: rem ->
+ | (Tsig_cltype(id, decl, rs) as sigelt) :: rem ->
sigelt :: strengthen_sig env rem p
(* In nondep_supertype, env is only used for the type it assigns to id.
@@ -102,16 +102,15 @@ let nondep_supertype env mid mty =
let rem' = nondep_sig va rem in
match item with
Tsig_value(id, d) ->
- let t = Ctype.nondep_type env mid d.val_type in
- Tsig_value(id, {val_type = t;
- val_kind = d.val_kind }) ::
- rem'
- | Tsig_type(id, d) ->
- Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d) :: rem'
+ Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
+ val_kind = d.val_kind}) :: rem'
+ | Tsig_type(id, d, rs) ->
+ Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
+ :: rem'
| Tsig_exception(id, d) ->
Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
- | Tsig_module(id, mty) ->
- Tsig_module(id, nondep_mty va mty) :: rem'
+ | Tsig_module(id, mty, rs) ->
+ Tsig_module(id, nondep_mty va mty, rs) :: rem'
| Tsig_modtype(id, d) ->
begin try
Tsig_modtype(id, nondep_modtype_decl d) :: rem'
@@ -120,10 +119,12 @@ let nondep_supertype env mid mty =
Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem'
| _ -> raise Not_found
end
- | Tsig_class(id, d) ->
- Tsig_class(id, Ctype.nondep_class_declaration env mid d) :: rem'
- | Tsig_cltype(id, d) ->
- Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d) :: rem'
+ | Tsig_class(id, d, rs) ->
+ Tsig_class(id, Ctype.nondep_class_declaration env mid d, rs)
+ :: rem'
+ | Tsig_cltype(id, d, rs) ->
+ Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d, rs)
+ :: rem'
and nondep_modtype_decl = function
Tmodtype_abstract -> Tmodtype_abstract
@@ -153,10 +154,12 @@ let rec enrich_modtype env p mty =
mty
and enrich_item env p = function
- Tsig_type(id, decl) ->
- Tsig_type(id, enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl)
- | Tsig_module(id, mty) ->
- Tsig_module(id, enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty)
+ Tsig_type(id, decl, rs) ->
+ Tsig_type(id,
+ enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
+ | Tsig_module(id, mty, rs) ->
+ Tsig_module(id,
+ enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs)
| item -> item
let rec type_paths env p mty =
@@ -171,10 +174,10 @@ and type_paths_sig env p pos sg =
| Tsig_value(id, decl) :: rem ->
let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
type_paths_sig env p pos' rem
- | Tsig_type(id, decl) :: rem ->
+ | Tsig_type(id, decl, _) :: rem ->
let pos' = pos + 1 in
Pdot(p, Ident.name id, pos) :: type_paths_sig env p pos' rem
- | Tsig_module(id, mty) :: rem ->
+ | Tsig_module(id, mty, _) :: rem ->
type_paths env (Pdot(p, Ident.name id, pos)) mty @
type_paths_sig (Env.add_module id mty env) p (pos+1) rem
| Tsig_modtype(id, decl) :: rem ->
@@ -183,3 +186,25 @@ and type_paths_sig env p pos sg =
type_paths_sig env p (pos+1) rem
| (Tsig_cltype _) :: rem ->
type_paths_sig env p pos rem
+
+let rec no_code_needed env mty =
+ match scrape env mty with
+ Tmty_ident p -> false
+ | Tmty_signature sg -> no_code_needed_sig env sg
+ | Tmty_functor(_, _, _) -> false
+
+and no_code_needed_sig env sg =
+ match sg with
+ [] -> true
+ | Tsig_value(id, decl) :: rem ->
+ begin match decl.val_kind with
+ | Val_prim _ -> no_code_needed_sig env rem
+ | _ -> false
+ end
+ | Tsig_module(id, mty, _) :: rem ->
+ no_code_needed env mty &&
+ no_code_needed_sig (Env.add_module id mty env) rem
+ | (Tsig_type _ | Tsig_modtype _ | Tsig_cltype _) :: rem ->
+ no_code_needed_sig env rem
+ | (Tsig_exception _ | Tsig_class _) :: rem ->
+ false
diff --git a/typing/mtype.mli b/typing/mtype.mli
index abb66b9696..b15b09ec9c 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -30,6 +30,10 @@ val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
(* Return the smallest supertype of the given type
in which the given ident does not appear.
Raise [Not_found] if no such type exists. *)
+val no_code_needed: Env.t -> module_type -> bool
+val no_code_needed_sig: Env.t -> signature -> bool
+ (* Determine whether a module needs no implementation code,
+ i.e. consists only of type definitions. *)
val enrich_modtype: Env.t -> Path.t -> module_type -> module_type
val enrich_typedecl: Env.t -> Path.t -> type_declaration -> type_declaration
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
diff --git a/typing/oprint.ml b/typing/oprint.ml
index dc0447f008..9808979bb5 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -328,12 +328,14 @@ and print_out_signature ppf =
fprintf ppf "%a@ %a" !out_sig_item item print_out_signature items
and print_out_sig_item ppf =
function
- Osig_class (vir_flag, name, params, clt) ->
- fprintf ppf "@[<2>class%s@ %a%s@ :@ %a@]"
+ Osig_class (vir_flag, name, params, clt, rs) ->
+ fprintf ppf "@[<2>%s%s@ %a%s@ :@ %a@]"
+ (if rs = Orec_next then "and" else "class")
(if vir_flag then " virtual" else "") print_out_class_params params
name !out_class_type clt
- | Osig_class_type (vir_flag, name, params, clt) ->
- fprintf ppf "@[<2>class type%s@ %a%s@ =@ %a@]"
+ | Osig_class_type (vir_flag, name, params, clt, rs) ->
+ fprintf ppf "@[<2>%s%s@ %a%s@ =@ %a@]"
+ (if rs = Orec_next then "and" else "class type")
(if vir_flag then " virtual" else "") print_out_class_params params
name !out_class_type clt
| Osig_exception (id, tyl) ->
@@ -342,9 +344,16 @@ and print_out_sig_item ppf =
fprintf ppf "@[<2>module type %s@]" name
| Osig_modtype (name, mty) ->
fprintf ppf "@[<2>module type %s =@ %a@]" name !out_module_type mty
- | Osig_module (name, mty) ->
- fprintf ppf "@[<2>module %s :@ %a@]" name !out_module_type mty
- | Osig_type tdl -> print_out_type_decl_list ppf tdl
+ | Osig_module (name, mty, rs) ->
+ fprintf ppf "@[<2>%s %s :@ %a@]"
+ (match rs with Orec_not -> "module"
+ | Orec_first -> "module rec"
+ | Orec_next -> "and")
+ name !out_module_type mty
+ | Osig_type(td, rs) ->
+ print_out_type_decl
+ (if rs = Orec_next then "and" else "type")
+ ppf td
| Osig_value (name, ty, prims) ->
let kwd = if prims = [] then "val" else "external" in
let pr_prims ppf =
@@ -356,13 +365,7 @@ and print_out_sig_item ppf =
in
fprintf ppf "@[<2>%s %a :@ %a%a@]" kwd value_ident name !out_type
ty pr_prims prims
-and print_out_type_decl_list ppf =
- function
- [] -> ()
- | [x] -> print_out_type_decl "type" ppf x
- | x :: l ->
- print_out_type_decl "type" ppf x;
- List.iter (fun x -> fprintf ppf "@ %a" (print_out_type_decl "and") x) l
+
and print_out_type_decl kwd ppf (name, args, ty, constraints) =
let print_constraints ppf params =
List.iter
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index bb001f91ba..765e074617 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -82,16 +82,22 @@ type out_module_type =
| Omty_ident of out_ident
| Omty_signature of out_sig_item list
and out_sig_item =
- | Osig_class of bool * string * string list * out_class_type
- | Osig_class_type of bool * string * string list * out_class_type
+ | Osig_class of
+ bool * string * string list * out_class_type * out_rec_status
+ | Osig_class_type of
+ bool * string * string list * out_class_type * out_rec_status
| Osig_exception of string * out_type list
| Osig_modtype of string * out_module_type
- | Osig_module of string * out_module_type
- | Osig_type of out_type_decl list
+ | Osig_module of string * out_module_type * out_rec_status
+ | Osig_type of out_type_decl * out_rec_status
| Osig_value of string * out_type * string list
and out_type_decl =
string * (string * (bool * bool)) list * out_type *
(out_type * out_type) list
+and out_rec_status =
+ | Orec_not
+ | Orec_first
+ | Orec_next
type out_phrase =
| Ophr_eval of out_value * out_type
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index d5561eb16a..4ff107fe32 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -69,6 +69,13 @@ let rec path ppf = function
| Papply(p1, p2) ->
fprintf ppf "%a(%a)" path p1 path p2
+(* Print a recursive annotation *)
+
+let tree_of_rec = function
+ | Trec_not -> Orec_not
+ | Trec_first -> Orec_first
+ | Trec_next -> Orec_next
+
(* Print a raw type expression, with sharing *)
let raw_list pr ppf = function
@@ -603,11 +610,11 @@ and tree_of_constructor (name, args) =
and tree_of_label (name, mut, arg) =
(name, mut = Mutable, tree_of_typexp false arg)
-let tree_of_type_declaration id decl =
- Osig_type [tree_of_type_decl id decl]
+let tree_of_type_declaration id decl rs =
+ Osig_type (tree_of_type_decl id decl, tree_of_rec rs)
let type_declaration id ppf decl =
- !Oprint.out_sig_item ppf (tree_of_type_declaration id decl)
+ !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first)
(* Print an exception declaration *)
@@ -737,7 +744,7 @@ let tree_of_class_params = function
let tyl = tree_of_typlist true params in
List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
-let tree_of_class_declaration id cl =
+let tree_of_class_declaration id cl rs =
let params = filter_params cl.cty_params in
reset ();
@@ -752,12 +759,13 @@ let tree_of_class_declaration id cl =
let vir_flag = cl.cty_new = None in
Osig_class
(vir_flag, Ident.name id, tree_of_class_params params,
- tree_of_class_type true params cl.cty_type)
+ tree_of_class_type true params cl.cty_type,
+ tree_of_rec rs)
let class_declaration id ppf cl =
- !Oprint.out_sig_item ppf (tree_of_class_declaration id cl)
+ !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first)
-let tree_of_cltype_declaration id cl =
+let tree_of_cltype_declaration id cl rs =
let params = List.map repr cl.clty_params in
reset ();
@@ -781,10 +789,11 @@ let tree_of_cltype_declaration id cl =
Osig_class_type
(virt, Ident.name id, tree_of_class_params params,
- tree_of_class_type true params cl.clty_type)
+ tree_of_class_type true params cl.clty_type,
+ tree_of_rec rs)
let cltype_declaration id ppf cl =
- !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl)
+ !Oprint.out_sig_item ppf (tree_of_cltype_declaration id cl Trec_first)
(* Print a module type *)
@@ -799,48 +808,25 @@ let rec tree_of_modtype = function
and tree_of_signature = function
| [] -> []
- | item :: rem ->
- match item with
- | Tsig_value(id, decl) ->
- tree_of_value_description id decl :: tree_of_signature rem
- | Tsig_type(id, decl) ->
- let (type_decl_list, rem) =
- let rec more_type_declarations = function
- | Tsig_type(id, decl) :: rem ->
- let (type_decl_list, rem) = more_type_declarations rem in
- (id, decl) :: type_decl_list, rem
- | rem -> [], rem in
- more_type_declarations rem
- in
- let type_decl_list =
- List.map (fun (id, decl) -> tree_of_type_decl id decl)
- ((id, decl) :: type_decl_list)
- in
- Osig_type type_decl_list
- ::
- tree_of_signature rem
- | Tsig_exception(id, decl) ->
- Osig_exception (Ident.name id, tree_of_typlist false decl) ::
- tree_of_signature rem
- | Tsig_module(id, mty) ->
- Osig_module (Ident.name id, tree_of_modtype mty) ::
- tree_of_signature rem
- | Tsig_modtype(id, decl) ->
- tree_of_modtype_declaration id decl :: tree_of_signature rem
- | Tsig_class(id, decl) ->
- let rem =
- match rem with
- | ctydecl :: tydecl1 :: tydecl2 :: rem -> rem
- | _ -> []
- in
- tree_of_class_declaration id decl :: tree_of_signature rem
- | Tsig_cltype(id, decl) ->
- let rem =
- match rem with
- | tydecl1 :: tydecl2 :: rem -> rem
- | _ -> []
- in
- tree_of_cltype_declaration id decl :: tree_of_signature rem
+ | Tsig_value(id, decl) :: rem ->
+ tree_of_value_description id decl :: tree_of_signature rem
+ | Tsig_type(id, decl, rs) :: rem ->
+ Osig_type(tree_of_type_decl id decl, tree_of_rec rs) ::
+ tree_of_signature rem
+ | Tsig_exception(id, decl) :: rem ->
+ Osig_exception (Ident.name id, tree_of_typlist false decl) ::
+ tree_of_signature rem
+ | Tsig_module(id, mty, rs) :: rem ->
+ Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) ::
+ tree_of_signature rem
+ | Tsig_modtype(id, decl) :: rem ->
+ tree_of_modtype_declaration id decl :: tree_of_signature rem
+ | Tsig_class(id, decl, rs) :: ctydecl :: tydecl1 :: tydecl2 :: rem ->
+ tree_of_class_declaration id decl rs :: tree_of_signature rem
+ | Tsig_cltype(id, decl, rs) :: tydecl1 :: tydecl2 :: rem ->
+ tree_of_cltype_declaration id decl rs :: tree_of_signature rem
+ | _ ->
+ assert false
and tree_of_modtype_declaration id decl =
let mty =
@@ -850,7 +836,8 @@ and tree_of_modtype_declaration id decl =
in
Osig_modtype (Ident.name id, mty)
-let tree_of_module id mty = Osig_module (Ident.name id, tree_of_modtype mty)
+let tree_of_module id mty rs =
+ Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs)
let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty)
let modtype_declaration id ppf decl =
@@ -879,11 +866,6 @@ let rec trace fst txt ppf = function
(trace false txt) rem
| _ -> ()
-let rec mismatch = function
- | [(_, t); (_, t')] -> (t, t')
- | _ :: _ :: rem -> mismatch rem
- | _ -> assert false
-
let rec filter_trace = function
| (t1, t1') :: (t2, t2') :: rem ->
let rem' = filter_trace rem in
@@ -906,12 +888,37 @@ let prepare_expansion (t, t') =
mark_loops t; if t != t' then mark_loops t';
(t, t')
+let may_prepare_expansion compact (t, t') =
+ match (repr t').desc with
+ Tvariant _ | Tobject _ when compact ->
+ mark_loops t; (t, t)
+ | _ -> prepare_expansion (t, t')
+
let print_tags ppf fields =
match fields with [] -> ()
| (t, _) :: fields ->
fprintf ppf "`%s" t;
List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
+let has_explanation unif t3 t4 =
+ match t3.desc, t4.desc with
+ Tfield _, _ | _, Tfield _
+ | Tunivar, Tvar | Tvar, Tunivar
+ | Tvariant _, Tvariant _ -> true
+ | Tconstr (p, _, _), Tvar | Tvar, Tconstr (p, _, _) ->
+ unif && min t3.level t4.level < Path.binding_time p
+ | _ -> false
+
+let rec mismatch unif = function
+ (_, t) :: (_, t') :: rem ->
+ begin match mismatch unif rem with
+ Some _ as m -> m
+ | None ->
+ if has_explanation unif t t' then Some(t,t') else None
+ end
+ | [] -> None
+ | _ -> assert false
+
let explanation unif t3 t4 ppf =
match t3.desc, t4.desc with
| Tfield _, Tvar | Tvar, Tfield _ ->
@@ -933,6 +940,8 @@ let explanation unif t3 t4 ppf =
| _, Tfield (lab, _, _, _) when lab = dummy_method ->
fprintf ppf
"@,Self type cannot be unified with a closed object type"
+ | Tfield (l, _, _, _), Tfield (l', _, _, _) when l = l' ->
+ fprintf ppf "@,Types for method %s are incompatible" l
| Tfield (l, _, _, _), _ ->
fprintf ppf
"@,@[Only the first object type has a method %s@]" l
@@ -953,22 +962,29 @@ let explanation unif t3 t4 ppf =
fprintf ppf
"@,@[The second variant type does not allow tag(s)@ @[<hov>%a@]@]"
print_tags fields
+ | [l1,_], true, [l2,_], true when l1 = l2 ->
+ fprintf ppf "@,Types for tag `%s are incompatible" l1
| _ -> ()
end
| _ -> ()
+let explanation unif mis ppf =
+ match mis with
+ None -> ()
+ | Some (t3, t4) -> explanation unif t3 t4 ppf
+
let unification_error unif tr txt1 ppf txt2 =
reset ();
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
- let (t3, t4) = mismatch tr in
+ let mis = mismatch unif tr in
match tr with
| [] | _ :: [] -> assert false
| t1 :: t2 :: tr ->
try
- let t1, t1' = prepare_expansion t1
- and t2, t2' = prepare_expansion t2 in
- print_labels := not !Clflags.classic;
let tr = filter_trace tr in
+ let t1, t1' = may_prepare_expansion (tr = []) t1
+ and t2, t2' = may_prepare_expansion (tr = []) t2 in
+ print_labels := not !Clflags.classic;
let tr = List.map prepare_expansion tr in
fprintf ppf
"@[<v>\
@@ -979,7 +995,7 @@ let unification_error unif tr txt1 ppf txt2 =
txt1 (type_expansion t1) t1'
txt2 (type_expansion t2) t2'
(trace false "is not compatible with type") tr
- (explanation unif t3 t4);
+ (explanation unif mis);
print_labels := true
with exn ->
print_labels := true;
@@ -1006,6 +1022,6 @@ let report_subtyping_error ppf tr1 txt1 tr2 =
and tr2 = List.map prepare_expansion tr2 in
trace true txt1 ppf tr1;
if tr2 = [] then () else
- let t3, t4 = mismatch tr2 in
+ let mis = mismatch true tr2 in
trace false "is not compatible with type" ppf tr2;
- explanation true t3 t4 ppf
+ explanation true mis ppf
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index c02c13f0df..d645d15c08 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -37,19 +37,19 @@ val type_scheme_max: ?b_reset_names: bool ->
(* Fin Maxence *)
val tree_of_value_description: Ident.t -> value_description -> out_sig_item
val value_description: Ident.t -> formatter -> value_description -> unit
-val tree_of_type_declaration: Ident.t -> type_declaration -> out_sig_item
+val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item
val type_declaration: Ident.t -> formatter -> type_declaration -> unit
val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item
val exception_declaration: Ident.t -> formatter -> exception_declaration -> unit
-val tree_of_module: Ident.t -> module_type -> out_sig_item
+val tree_of_module: Ident.t -> module_type -> rec_status -> out_sig_item
val modtype: formatter -> module_type -> unit
val signature: formatter -> signature -> unit
val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item
val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit
val class_type: formatter -> class_type -> unit
-val tree_of_class_declaration: Ident.t -> class_declaration -> out_sig_item
+val tree_of_class_declaration: Ident.t -> class_declaration -> rec_status -> out_sig_item
val class_declaration: Ident.t -> formatter -> class_declaration -> unit
-val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> out_sig_item
+val tree_of_cltype_declaration: Ident.t -> cltype_declaration -> rec_status -> out_sig_item
val cltype_declaration: Ident.t -> formatter -> cltype_declaration -> unit
val type_expansion: type_expr -> Format.formatter -> type_expr -> unit
val prepare_expansion: type_expr * type_expr -> type_expr * type_expr
diff --git a/typing/subst.ml b/typing/subst.ml
index 4a2ffa1773..62e282a886 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -183,7 +183,11 @@ let type_declaration s decl =
let class_signature s sign =
{ cty_self = typexp s sign.cty_self;
cty_vars = Vars.map (function (m, t) -> (m, typexp s t)) sign.cty_vars;
- cty_concr = sign.cty_concr }
+ cty_concr = sign.cty_concr;
+ cty_inher =
+ List.map (fun (p, tl) -> (type_path s p, List.map (typexp s) tl))
+ sign.cty_inher
+ }
let rec class_type s =
function
@@ -234,10 +238,10 @@ let exception_declaration s tyl =
let rec rename_bound_idents s idents = function
[] -> (List.rev idents, s)
- | Tsig_type(id, d) :: sg ->
+ | Tsig_type(id, d, _) :: sg ->
let id' = Ident.rename id in
rename_bound_idents (add_type id (Pident id') s) (id' :: idents) sg
- | Tsig_module(id, mty) :: sg ->
+ | Tsig_module(id, mty, _) :: sg ->
let id' = Ident.rename id in
rename_bound_idents (add_module id (Pident id') s) (id' :: idents) sg
| Tsig_modtype(id, d) :: sg ->
@@ -245,7 +249,7 @@ let rec rename_bound_idents s idents = function
rename_bound_idents (add_modtype id (Tmty_ident(Pident id')) s)
(id' :: idents) sg
| (Tsig_value(id, _) | Tsig_exception(id, _) |
- Tsig_class(id, _) | Tsig_cltype(id, _)) :: sg ->
+ Tsig_class(id, _, _) | Tsig_cltype(id, _, _)) :: sg ->
let id' = Ident.rename id in
rename_bound_idents s (id' :: idents) sg
@@ -278,18 +282,18 @@ and signature_component s comp newid =
match comp with
Tsig_value(id, d) ->
Tsig_value(newid, value_description s d)
- | Tsig_type(id, d) ->
- Tsig_type(newid, type_declaration s d)
+ | Tsig_type(id, d, rs) ->
+ Tsig_type(newid, type_declaration s d, rs)
| Tsig_exception(id, d) ->
Tsig_exception(newid, exception_declaration s d)
- | Tsig_module(id, mty) ->
- Tsig_module(newid, modtype s mty)
+ | Tsig_module(id, mty, rs) ->
+ Tsig_module(newid, modtype s mty, rs)
| Tsig_modtype(id, d) ->
Tsig_modtype(newid, modtype_declaration s d)
- | Tsig_class(id, d) ->
- Tsig_class(newid, class_declaration s d)
- | Tsig_cltype(id, d) ->
- Tsig_cltype(newid, cltype_declaration s d)
+ | Tsig_class(id, d, rs) ->
+ Tsig_class(newid, class_declaration s d, rs)
+ | Tsig_cltype(id, d, rs) ->
+ Tsig_cltype(newid, cltype_declaration s d, rs)
and modtype_declaration s = function
Tmodtype_abstract -> Tmodtype_abstract
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 81f36b30ac..503a1098b5 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -88,9 +88,10 @@ let rec generalize_class_type =
Tcty_constr (_, params, cty) ->
List.iter Ctype.generalize params;
generalize_class_type cty
- | Tcty_signature {cty_self = sty; cty_vars = vars } ->
+ | Tcty_signature {cty_self = sty; cty_vars = vars; cty_inher = inher} ->
Ctype.generalize sty;
- Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars
+ Vars.iter (fun _ (_, ty) -> Ctype.generalize ty) vars;
+ List.iter (fun (_,tl) -> List.iter Ctype.generalize tl) inher
| Tcty_fun (_, ty, cty) ->
Ctype.generalize ty;
generalize_class_type cty
@@ -172,7 +173,9 @@ let rec limited_generalize rv =
| Tcty_signature sign ->
Ctype.limited_generalize rv sign.cty_self;
Vars.iter (fun _ (_, ty) -> Ctype.limited_generalize rv ty)
- sign.cty_vars
+ sign.cty_vars;
+ List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl)
+ sign.cty_inher
| Tcty_fun (_, ty, cty) ->
Ctype.limited_generalize rv ty;
limited_generalize rv cty
@@ -272,10 +275,15 @@ let make_method cl_num expr =
(*******************************)
-let rec class_type_field env self_type meths (val_sig, concr_meths) =
+let rec class_type_field env self_type meths (val_sig, concr_meths, inher) =
function
Pctf_inher sparent ->
let parent = class_type env sparent in
+ let inher =
+ match parent with
+ Tcty_constr (p, tl, _) -> (p, tl) :: inher
+ | _ -> inher
+ in
let (cl_sig, concr_meths, _) =
inheritance self_type env concr_meths Concr.empty sparent.pcty_loc
parent
@@ -285,7 +293,7 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
(fun lab (mut, ty) val_sig -> Vars.add lab (mut, ty) val_sig)
cl_sig.cty_vars val_sig
in
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
| Pctf_val (lab, mut, sty_opt, loc) ->
let (mut, ty) =
@@ -299,19 +307,19 @@ let rec class_type_field env self_type meths (val_sig, concr_meths) =
| Some sty ->
mut, transl_simple_type env false sty
in
- (Vars.add lab (mut, ty) val_sig, concr_meths)
+ (Vars.add lab (mut, ty) val_sig, concr_meths, inher)
| Pctf_virt (lab, priv, sty, loc) ->
declare_method env meths self_type lab priv sty loc;
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
| Pctf_meth (lab, priv, sty, loc) ->
declare_method env meths self_type lab priv sty loc;
- (val_sig, Concr.add lab concr_meths)
+ (val_sig, Concr.add lab concr_meths, inher)
| Pctf_cstr (sty, sty', loc) ->
type_constraint env sty sty' loc;
- (val_sig, concr_meths)
+ (val_sig, concr_meths, inher)
and class_signature env sty sign =
let meths = ref Meths.empty in
@@ -328,15 +336,16 @@ and class_signature env sty sign =
end;
(* Class type fields *)
- let (val_sig, concr_meths) =
+ let (val_sig, concr_meths, inher) =
List.fold_left (class_type_field env self_type meths)
- (Vars.empty, Concr.empty)
+ (Vars.empty, Concr.empty, [])
sign
in
{cty_self = self_type;
cty_vars = val_sig;
- cty_concr = concr_meths }
+ cty_concr = concr_meths;
+ cty_inher = inher}
and class_type env scty =
match scty.pcty_desc with
@@ -376,10 +385,16 @@ and class_type env scty =
module StringSet = Set.Make(struct type t = string let compare = compare end)
let rec class_field cl_num self_type meths vars
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals) =
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher) =
function
Pcf_inher (sparent, super) ->
let parent = class_expr cl_num val_env par_env sparent in
+ let inher =
+ match parent.cl_type with
+ Tcty_constr (p, tl, _) -> (p, tl) :: inher
+ | _ -> inher
+ in
let (cl_sig, concr_meths, warn_meths) =
inheritance self_type val_env concr_meths warn_meths sparent.pcl_loc
parent.cl_type
@@ -417,7 +432,7 @@ let rec class_field cl_num self_type meths vars
in
(val_env, met_env, par_env,
lazy(Cf_inher (parent, inh_vars, inh_meths))::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_val (lab, mut, sexp, loc) ->
if StringSet.mem lab inh_vals then
@@ -435,12 +450,13 @@ let rec class_field cl_num self_type meths vars
enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env
in
(val_env, met_env, par_env, lazy(Cf_val (lab, id, exp)) :: fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_virt (lab, priv, sty, loc) ->
virtual_method val_env meths self_type lab priv sty loc;
let warn_meths = Concr.remove lab warn_meths in
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher)
| Pcf_meth (lab, priv, expr, loc) ->
let (_, ty) =
@@ -483,11 +499,12 @@ let rec class_field cl_num self_type meths vars
Cf_meth (lab, texp)
end in
(val_env, met_env, par_env, field::fields,
- Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals)
+ Concr.add lab concr_meths, Concr.add lab warn_meths, inh_vals, inher)
| Pcf_cstr (sty, sty', loc) ->
type_constraint val_env sty sty' loc;
- (val_env, met_env, par_env, fields, concr_meths, warn_meths, inh_vals)
+ (val_env, met_env, par_env, fields, concr_meths, warn_meths,
+ inh_vals, inher)
| Pcf_let (rec_flag, sdefs, loc) ->
let kset = Kset.empty () in (* FIXME *)
@@ -518,7 +535,7 @@ let rec class_field cl_num self_type meths vars
([], met_env, par_env)
in
(val_env, met_env, par_env, lazy(Cf_let(rec_flag, defs, vals))::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
| Pcf_init expr ->
let expr = make_method cl_num expr in
@@ -535,22 +552,24 @@ let rec class_field cl_num self_type meths vars
Cf_init texp
end in
(val_env, met_env, par_env, field::fields,
- concr_meths, warn_meths, inh_vals)
+ concr_meths, warn_meths, inh_vals, inher)
and class_structure cl_num final val_env met_env loc (spat, str) =
(* Environment for substructures *)
let par_env = met_env in
- (* Private self type more method access, with a dummy method preventing
- it from being closed/escaped. *)
+ (* Self type, with a dummy method preventing it from being closed/escaped. *)
let self_type = Ctype.newvar () in
Ctype.unify val_env
(Ctype.filter_method val_env dummy_method Private self_type)
(Ctype.newty (Ttuple []));
+ (* Private self is used for private method calls *)
+ let private_self = if final then Ctype.newvar () else self_type in
+
(* Self binder *)
let (pat, meths, vars, val_env, meth_env, par_env) =
- type_self_pattern cl_num self_type val_env met_env par_env spat
+ type_self_pattern cl_num private_self val_env met_env par_env spat
in
let public_self = pat.pat_type in
@@ -569,30 +588,33 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
(* Copy known information to still empty self_type *)
List.iter
(fun (lab,kind,ty) ->
+ let k =
+ if Btype.field_kind_repr kind = Fpresent then Public else Private in
try Ctype.unify val_env ty
- (Ctype.filter_method val_env lab Public self_type)
+ (Ctype.filter_method val_env lab k self_type)
with _ -> assert false)
(get_methods public_self)
end;
(* Typing of class fields *)
- let (_, _, _, fields, concr_meths, _, _) =
+ let (_, _, _, fields, concr_meths, _, _, inher) =
List.fold_left (class_field cl_num self_type meths vars)
(val_env, meth_env, par_env, [], Concr.empty, Concr.empty,
- StringSet.empty)
+ StringSet.empty, [])
str
in
Ctype.unify val_env self_type (Ctype.newvar ());
let sign =
{cty_self = public_self;
cty_vars = Vars.map (function (id, mut, ty) -> (mut, ty)) !vars;
- cty_concr = concr_meths } in
+ cty_concr = concr_meths;
+ cty_inher = inher} in
let methods = get_methods self_type in
let priv_meths =
List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
methods in
if final then begin
- (* Unify public_self and a copy of self_type. self_type will not
+ (* Unify private_self and a copy of self_type. self_type will not
be modified after this point *)
Ctype.close_object self_type;
let mets = virtual_methods {sign with cty_self = self_type} in
@@ -600,11 +622,18 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
let self_methods =
List.fold_right
(fun (lab,kind,ty) rem ->
- if lab = dummy_method then rem else
- Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
+ if lab = dummy_method then
+ (* allow public self and private self to be unified *)
+ match Btype.field_kind_repr kind with
+ Fvar r -> Btype.set_kind r Fabsent; rem
+ | _ -> rem
+ else
+ Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem)))
methods (Ctype.newty Tnil) in
- begin try Ctype.unify val_env public_self
- (Ctype.newty (Tobject(self_methods, ref None)))
+ begin try
+ Ctype.unify val_env private_self
+ (Ctype.newty (Tobject(self_methods, ref None)));
+ Ctype.unify val_env public_self self_type
with Ctype.Unify trace -> raise(Error(loc, Final_self_clash trace))
end;
end;
@@ -951,7 +980,8 @@ let rec initial_env define_class approx
Tcty_signature
{ cty_self = Ctype.newvar ();
cty_vars = Vars.empty;
- cty_concr = Concr.empty }
+ cty_concr = Concr.empty;
+ cty_inher = [] }
in
let dummy_class =
{cty_params = []; (* Dummy value *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index ffc59e72f8..7cdbab5015 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -339,200 +339,194 @@ let build_or_pat env loc lid =
pat pats in
rp { r with pat_loc = loc }
-let type_pat ?(nonlinear=false) env sp =
- let rec type_pat0 env sp =
- match sp.ppat_desc with
- Ppat_any ->
- rp {
- pat_desc = Tpat_any;
- pat_loc = sp.ppat_loc;
- pat_type = newvar();
- pat_env = env },
- []
- | Ppat_var name ->
- let ty = newvar() in
- let id = enter_variable sp.ppat_loc name ty in
- rp {
- pat_desc = Tpat_var id;
- pat_loc = sp.ppat_loc;
- pat_type = ty;
- pat_env = env },
- []
- | Ppat_alias(sq, name) ->
- let q, nonlinears = type_pat0 env sq in
- begin_def ();
- let ty_var = build_as_type env q in
- end_def ();
- generalize ty_var;
- let id = enter_variable sp.ppat_loc name ty_var in
- rp {
- pat_desc = Tpat_alias(q, id);
- pat_loc = sp.ppat_loc;
- pat_type = q.pat_type;
- pat_env = env },
- nonlinears
- | Ppat_constant cst ->
- rp {
- pat_desc = Tpat_constant cst;
- pat_loc = sp.ppat_loc;
- pat_type = type_constant cst;
- pat_env = env },
- []
- | Ppat_tuple spl ->
- let pl,nonlinearsl =
- let pnonlinearsl = List.map (type_pat0 env) spl in
- List.map fst pnonlinearsl,
- List.map snd pnonlinearsl
- in
- rp {
- pat_desc = Tpat_tuple pl;
- pat_loc = sp.ppat_loc;
- pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
- pat_env = env },
- List.flatten nonlinearsl
- | Ppat_construct(lid, sarg, explicit_arity) ->
- let constr =
+let rec find_record_qual = function
+ | [] -> None
+ | (Longident.Ldot (modname, _), _) :: _ -> Some modname
+ | _ :: rest -> find_record_qual rest
+
+let type_label_a_list type_lid_a lid_a_list =
+ match find_record_qual lid_a_list with
+ | None -> List.map type_lid_a lid_a_list
+ | Some modname ->
+ List.map
+ (function
+ | (Longident.Lident id), sarg ->
+ type_lid_a (Longident.Ldot (modname, id), sarg)
+ | lid_a -> type_lid_a lid_a)
+ lid_a_list
+
+let nonlinear_variables = ref []
+let reset_nonlinear_variables () = nonlinear_variables := []
+
+let rec type_pat ?(nonlinear=false) env sp =
+ match sp.ppat_desc with
+ Ppat_any ->
+ rp {
+ pat_desc = Tpat_any;
+ pat_loc = sp.ppat_loc;
+ pat_type = newvar();
+ pat_env = env }
+ | Ppat_var name ->
+ let ty = newvar() in
+ let id = enter_variable sp.ppat_loc name ty in
+ rp {
+ pat_desc = Tpat_var id;
+ pat_loc = sp.ppat_loc;
+ pat_type = ty;
+ pat_env = env }
+ | Ppat_alias(sq, name) ->
+ let q = type_pat env sq in
+ begin_def ();
+ let ty_var = build_as_type env q in
+ end_def ();
+ generalize ty_var;
+ let id = enter_variable sp.ppat_loc name ty_var in
+ rp {
+ pat_desc = Tpat_alias(q, id);
+ pat_loc = sp.ppat_loc;
+ pat_type = q.pat_type;
+ pat_env = env }
+ | Ppat_constant cst ->
+ rp {
+ pat_desc = Tpat_constant cst;
+ pat_loc = sp.ppat_loc;
+ pat_type = type_constant cst;
+ pat_env = env }
+ | Ppat_tuple spl ->
+ let pl = List.map (type_pat env) spl in
+ rp {
+ pat_desc = Tpat_tuple pl;
+ pat_loc = sp.ppat_loc;
+ pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+ pat_env = env }
+ | Ppat_construct(lid, sarg, explicit_arity) ->
+ let constr =
+ try
+ Env.lookup_constructor lid env
+ with Not_found ->
+ raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
+ let sargs =
+ match sarg with
+ None -> []
+ | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
+ | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
+ | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
+ replicate_list sp constr.cstr_arity
+ | Some sp -> [sp] in
+ if List.length sargs <> constr.cstr_arity then
+ raise(Error(sp.ppat_loc, Constructor_arity_mismatch(lid,
+ constr.cstr_arity, List.length sargs)));
+ let args = List.map (type_pat env) sargs in
+ let (ty_args, ty_res) = instance_constructor constr in
+ List.iter2 (unify_pat env) args ty_args;
+ rp {
+ pat_desc = Tpat_construct(constr, args);
+ pat_loc = sp.ppat_loc;
+ pat_type = ty_res;
+ pat_env = env }
+ | Ppat_variant(l, sarg) ->
+ let arg = may_map (type_pat env) sarg in
+ let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
+ let row = { row_fields =
+ [l, Reither(arg = None, arg_type, true, ref None)];
+ row_bound = arg_type;
+ row_closed = false;
+ row_more = newvar ();
+ row_fixed = false;
+ row_name = None } in
+ rp {
+ pat_desc = Tpat_variant(l, arg, row);
+ pat_loc = sp.ppat_loc;
+ pat_type = newty (Tvariant row);
+ pat_env = env }
+ | Ppat_record lid_sp_list ->
+ let rec check_duplicates = function
+ [] -> ()
+ | (lid, sarg) :: remainder ->
+ if List.mem_assoc lid remainder
+ then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
+ else check_duplicates remainder in
+ check_duplicates lid_sp_list;
+ let ty = newvar() in
+ let type_label_pat (lid, sarg) =
+ let label =
try
- Env.lookup_constructor lid env
+ Env.lookup_label lid env
with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_constructor lid)) in
- let sargs =
- match sarg with
- None -> []
- | Some {ppat_desc = Ppat_tuple spl} when explicit_arity -> spl
- | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 -> spl
- | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 ->
- replicate_list sp constr.cstr_arity
- | Some sp -> [sp] in
- if List.length sargs <> constr.cstr_arity then
- raise(Error(sp.ppat_loc, Constructor_arity_mismatch(lid,
- constr.cstr_arity, List.length sargs)));
- let args, nonlinearsl =
- let argnonlinearsl = List.map (type_pat0 env) sargs in
- List.map fst argnonlinearsl,
- List.map snd argnonlinearsl
- in
- let (ty_args, ty_res) = instance_constructor constr in
- List.iter2 (unify_pat env) args ty_args;
- rp {
- pat_desc = Tpat_construct(constr, args);
- pat_loc = sp.ppat_loc;
- pat_type = ty_res;
- pat_env = env },
- List.flatten nonlinearsl
- | Ppat_variant(l, sarg) ->
- let arg, nonlinears =
- match may_map (type_pat0 env) sarg with
- | None -> None, []
- | Some (arg, nonlinears) -> Some arg, nonlinears
- in
- let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
- let row = { row_fields =
- [l, Reither(arg = None, arg_type, true, ref None)];
- row_bound = arg_type;
- row_closed = false;
- row_more = newvar ();
- row_fixed = false;
- row_name = None } in
- rp {
- pat_desc = Tpat_variant(l, arg, row);
- pat_loc = sp.ppat_loc;
- pat_type = newty (Tvariant row);
- pat_env = env },
- nonlinears
- | Ppat_record lid_sp_list ->
- let rec check_duplicates = function
- [] -> ()
- | (lid, sarg) :: remainder ->
- if List.mem_assoc lid remainder
- then raise(Error(sp.ppat_loc, Label_multiply_defined lid))
- else check_duplicates remainder in
- check_duplicates lid_sp_list;
- let ty = newvar() in
- let type_label_pat (lid, sarg) =
- let label =
- try
- Env.lookup_label lid env
- with Not_found ->
- raise(Error(sp.ppat_loc, Unbound_label lid)) in
- let (_, ty_arg, ty_res) = instance_label false label in
- begin try
- unify env ty_res ty
- with Unify trace ->
- raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
- end;
- let arg, nonlinears = type_pat0 env sarg in
- unify_pat env arg ty_arg;
- (label, arg), nonlinears
- in
- let label_pat_list, nonlinearsl =
- let l = List.map type_label_pat lid_sp_list in
- List.map fst l, List.map snd l
- in
- rp {
- pat_desc = Tpat_record label_pat_list;
- pat_loc = sp.ppat_loc;
- pat_type = ty;
- pat_env = env },
- List.flatten nonlinearsl
- | Ppat_array spl ->
- let pl, nonlinearsl =
- let l = List.map (type_pat0 env) spl in
- List.map fst l, List.map snd l
- in
- let ty_elt = newvar() in
- List.iter (fun p -> unify_pat env p ty_elt) pl;
- rp {
- pat_desc = Tpat_array pl;
- pat_loc = sp.ppat_loc;
- pat_type = instance (Predef.type_array ty_elt);
- pat_env = env },
- List.flatten nonlinearsl
- | Ppat_or(sp1, sp2) ->
- let implicit_when_empty_check loc nonlinears =
- match nonlinears with
- | {Typertype.varinfo_name=n} :: _ ->
- raise (Error(loc, Orpat_with_non_linear_tvar n))
- | _ -> ()
- in
- let initial_pattern_variables = !pattern_variables in
- let p1,nonlinears1 = type_pat0 env sp1 in
- implicit_when_empty_check sp1.ppat_loc nonlinears1;
- let p1_variables = !pattern_variables in
- pattern_variables := initial_pattern_variables ;
- let p2,nonlinears2 = type_pat0 env sp2 in
- implicit_when_empty_check sp2.ppat_loc nonlinears2;
- let p2_variables = !pattern_variables in
- unify_pat env p2 p1.pat_type;
- let alpha_env =
- enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
- pattern_variables := p1_variables ;
- rp {
- pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
- pat_loc = sp.ppat_loc;
- pat_type = p1.pat_type;
- pat_env = env },
- [] (* must be empty! *)
- | Ppat_constraint(sp, sty) ->
- let p, nonlinears = type_pat0 env sp in
- let ty, force = Typetexp.transl_simple_type_delayed env sty in
- unify_pat env p ty;
- pattern_force := force :: !pattern_force;
- p, nonlinears
- | Ppat_type lid ->
- build_or_pat env sp.ppat_loc lid, []
- | Ppat_rtype sty ->
- (* translate pattern *)
- let sp, nonlinears =
- Typertype.pattern_of_type nonlinear
- (fun lid -> fst (Env.lookup_type lid env)) sty
- in
- let pat, internal_nonlinears = type_pat0 env sp in
- assert (internal_nonlinears=[]);
- unify_pat env pat (Typertype.get_rtype_type ());
- pat, nonlinears
- in
- type_pat0 env sp
+ raise(Error(sp.ppat_loc, Unbound_label lid)) in
+ let (_, ty_arg, ty_res) = instance_label false label in
+ begin try
+ unify env ty_res ty
+ with Unify trace ->
+ raise(Error(sp.ppat_loc, Label_mismatch(lid, trace)))
+ end;
+ let arg = type_pat env sarg in
+ unify_pat env arg ty_arg;
+ (label, arg)
+ in
+ rp {
+ pat_desc = Tpat_record(type_label_a_list type_label_pat lid_sp_list);
+ pat_loc = sp.ppat_loc;
+ pat_type = ty;
+ pat_env = env }
+ | Ppat_array spl ->
+ let pl = List.map (type_pat env) spl in
+ let ty_elt = newvar() in
+ List.iter (fun p -> unify_pat env p ty_elt) pl;
+ rp {
+ pat_desc = Tpat_array pl;
+ pat_loc = sp.ppat_loc;
+ pat_type = instance (Predef.type_array ty_elt);
+ pat_env = env }
+ | Ppat_or(sp1, sp2) ->
+ let initial_pattern_variables = !pattern_variables in
+ let p1 = type_pat env sp1 in
+ let p1_variables = !pattern_variables in
+ pattern_variables := initial_pattern_variables ;
+ let p2 = type_pat env sp2 in
+ let p2_variables = !pattern_variables in
+ unify_pat env p2 p1.pat_type;
+ let alpha_env =
+ enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
+ pattern_variables := p1_variables ;
+ rp {
+ pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
+ pat_loc = sp.ppat_loc;
+ pat_type = p1.pat_type;
+ pat_env = env }
+ | Ppat_constraint(sp, sty) ->
+ let p = type_pat env sp in
+ let ty, force = Typetexp.transl_simple_type_delayed env sty in
+ unify_pat env p ty;
+ pattern_force := force :: !pattern_force;
+ p
+ | Ppat_type lid ->
+ build_or_pat env sp.ppat_loc lid
+ | Ppat_rtype sty ->
+ (* translate pattern *)
+ let sp, nonlinears =
+ Typertype.pattern_of_type nonlinear
+ (fun lid -> fst (Env.lookup_type lid env)) sty
+ in
+ (* typing of the produced pattern. it must not contain
+ nonlinear things! *)
+ (* escape and reset the nonlinear variable information *)
+ let escaped_nonlinear_variables = !nonlinear_variables in
+ reset_nonlinear_variables ();
+ (* type the produced pattern *)
+ let pat = type_pat env sp in
+ (* check it has no nonlinear variables *)
+ assert (!nonlinear_variables=[]);
+ (* recover the original nonlinear_variable information *)
+ nonlinear_variables := escaped_nonlinear_variables;
+ unify_pat env pat (Typertype.get_rtype_type ());
+ nonlinear_variables := nonlinears @ !nonlinear_variables;
+ pat
+
+let type_pat ?nonlinear env sp =
+ reset_nonlinear_variables ();
+ let p = type_pat ?nonlinear env sp in
+ p, !nonlinear_variables
let get_ref r =
let v = !r in r := []; v
@@ -678,9 +672,10 @@ let type_format loc fmt =
and ty_result = newvar ()
and ty_aresult = newvar () in
let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
- let bad_format i len =
- raise (Error (loc, Bad_format (String.sub fmt i len))) in
- let incomplete i = bad_format i (len - i) in
+
+ let invalid_fmt s = raise (Error (loc, Bad_format s)) in
+ let incomplete i = invalid_fmt (String.sub fmt i (len - i)) in
+ let invalid i j = invalid_fmt (String.sub fmt i (j - i + 1)) in
let rec scan_format i =
if i >= len then ty_aresult, ty_result else
@@ -742,8 +737,7 @@ let type_format loc fmt =
| '%' | '!' -> scan_format (j + 1)
| 's' | 'S' | '[' -> conversion j Predef.type_string
| 'c' | 'C' -> conversion j Predef.type_char
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
- conversion j Predef.type_int
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' -> conversion j Predef.type_int
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
| 'B' | 'b' -> conversion j Predef.type_bool
| 'a' ->
@@ -752,24 +746,24 @@ let type_format loc fmt =
let ty_aresult, ty_result = conversion j ty_arg in
ty_aresult, ty_arrow ty_a ty_result
| 't' -> conversion j (ty_arrow ty_input ty_aresult)
- | 'n' when j + 1 = len -> conversion j Predef.type_int
- | 'l' | 'n' | 'L' as conv ->
+ | 'n' | 'l' when j + 1 = len -> conversion j Predef.type_int
+ | 'n' | 'l' | 'L' as c ->
let j = j + 1 in
if j >= len then incomplete i else begin
- match fmt.[j] with
- | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
- let ty_arg =
- match conv with
- | 'l' -> Predef.type_int32
- | 'n' -> Predef.type_nativeint
- | _ -> Predef.type_int64 in
- conversion j ty_arg
- | c ->
- if conv = 'l' || conv = 'n'
- then conversion (j - 1) Predef.type_int
- else bad_format i (j - i)
+ match fmt.[j] with
+ | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' ->
+ let ty_arg =
+ match c with
+ | 'l' -> Predef.type_int32
+ | 'n' -> Predef.type_nativeint
+ | _ -> Predef.type_int64 in
+ conversion j ty_arg
+ | _ ->
+ if c = 'l' || c = 'n'
+ then conversion (j - 1) Predef.type_int
+ else invalid i (j - i)
end
- | c -> bad_format i (j - i + 1) in
+ | c -> invalid i j in
scan_width i j in
let ty_ares, ty_res = scan_format 0 in
@@ -1038,7 +1032,7 @@ Format.fprintf Format.err_formatter "funct=%a@."
if label.lbl_private = Private then
raise(Error(sexp.pexp_loc, Private_type ty));
(label, {arg with exp_type = instance arg.exp_type}) in
- let lbl_exp_list = List.map type_label_exp lid_sexp_list in
+ let lbl_exp_list = type_label_a_list type_label_exp lid_sexp_list in
let rec check_duplicates seen_pos lid_sexp lbl_exp =
match (lid_sexp, lbl_exp) with
((lid, _) :: rem1, (lbl, _) :: rem2) ->
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 390d1ed6d5..384156dddc 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -36,6 +36,8 @@ type error =
| Non_generalizable of type_expr
| Non_generalizable_class of Ident.t * class_declaration
| Non_generalizable_module of module_type
+ | Implementation_is_required of string
+ | Interface_not_compiled of string
exception Error of Location.t * error
@@ -71,20 +73,21 @@ let merge_constraint initial_env loc sg lid constr =
match (sg, namelist, constr) with
([], _, _) ->
raise(Error(loc, With_no_component lid))
- | (Tsig_type(id, decl) :: rem, [s], Pwith_type sdecl)
+ | (Tsig_type(id, decl, rs) :: rem, [s], Pwith_type sdecl)
when Ident.name id = s ->
let newdecl = Typedecl.transl_with_constraint initial_env sdecl in
Includemod.type_declarations env id newdecl decl;
- Tsig_type(id, newdecl) :: rem
- | (Tsig_module(id, mty) :: rem, [s], Pwith_module lid)
+ Tsig_type(id, newdecl, rs) :: rem
+ | (Tsig_module(id, mty, rs) :: rem, [s], Pwith_module lid)
when Ident.name id = s ->
let (path, mty') = type_module_path initial_env loc lid in
let newmty = Mtype.strengthen env mty' path in
ignore(Includemod.modtypes env newmty mty);
- Tsig_module(id, newmty) :: rem
- | (Tsig_module(id, mty) :: rem, s :: namelist, _) when Ident.name id = s ->
+ Tsig_module(id, newmty, rs) :: rem
+ | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
+ when Ident.name id = s ->
let newsg = merge env (extract_sig env loc mty) namelist in
- Tsig_module(id, Tmty_signature newsg) :: rem
+ Tsig_module(id, Tmty_signature newsg, rs) :: rem
| (item :: rem, _, _) ->
item :: merge (Env.add_item item env) rem namelist in
try
@@ -92,6 +95,14 @@ let merge_constraint initial_env loc sg lid constr =
with Includemod.Error explanation ->
raise(Error(loc, With_mismatch(lid, explanation)))
+(* Add recursion flags on declarations arising from a mutually recursive
+ block. *)
+
+let map_rec fn decls rem =
+ match decls with
+ | [] -> rem
+ | d1 :: dl -> fn Trec_first d1 :: map_end (fn Trec_next) dl rem
+
(* Auxiliary for translating recursively-defined module types.
Return a module type that approximates the shape of the given module
type AST. Retain only module, type, and module type
@@ -127,11 +138,11 @@ let approx_modtype transl_mty init_env smty =
| Psig_type sdecls ->
let decls = Typedecl.approx_type_decl env sdecls in
let rem = approx_sig env srem in
- map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
+ map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
| Psig_module(name, smty) ->
let mty = approx_mty env smty in
let (id, newenv) = Env.enter_module name mty env in
- Tsig_module(id, mty) :: approx_sig newenv srem
+ Tsig_module(id, mty, Trec_not) :: approx_sig newenv srem
| Psig_recmodule sdecls ->
let decls =
List.map
@@ -141,7 +152,7 @@ let approx_modtype transl_mty init_env smty =
let newenv =
List.fold_left (fun env (id, mty) -> Env.add_module id mty env)
env decls in
- map_end (fun (id, mty) -> Tsig_module(id, mty)) decls
+ map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls
(approx_sig newenv srem)
| Psig_modtype(name, sinfo) ->
let info = approx_mty_info env sinfo in
@@ -162,11 +173,12 @@ let approx_modtype transl_mty init_env smty =
let decls = Typeclass.approx_class_declarations env sdecls in
let rem = approx_sig env srem in
List.flatten
- (List.map
- (fun (i1, d1, i2, d2, i3, d3) ->
- [Tsig_cltype(i1, d1); Tsig_type(i2, d2); Tsig_type(i3, d3)])
- decls)
- @ rem
+ (map_rec
+ (fun rs (i1, d1, i2, d2, i3, d3) ->
+ [Tsig_cltype(i1, d1, rs);
+ Tsig_type(i2, d2, rs);
+ Tsig_type(i3, d3, rs)])
+ decls [rem])
| _ ->
approx_sig env srem
@@ -203,9 +215,9 @@ let check cl loc set_ref name =
else set_ref := StringSet.add name !set_ref
let check_sig_item type_names module_names modtype_names loc = function
- Tsig_type(id, _) ->
+ Tsig_type(id, _, _) ->
check "type" loc type_names (Ident.name id)
- | Tsig_module(id, _) ->
+ | Tsig_module(id, _, _) ->
check "module" loc module_names (Ident.name id)
| Tsig_modtype(id, _) ->
check "module type" loc modtype_names (Ident.name id)
@@ -260,7 +272,7 @@ and transl_signature env sg =
sdecls;
let (decls, newenv) = Typedecl.transl_type_decl env sdecls in
let rem = transl_sig newenv srem in
- map_end (fun (id, info) -> Tsig_type(id, info)) decls rem
+ map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls rem
| Psig_exception(name, sarg) ->
let arg = Typedecl.transl_exception env sarg in
let (id, newenv) = Env.enter_exception name arg env in
@@ -271,7 +283,7 @@ and transl_signature env sg =
let mty = transl_modtype env smty in
let (id, newenv) = Env.enter_module name mty env in
let rem = transl_sig newenv srem in
- Tsig_module(id, mty) :: rem
+ Tsig_module(id, mty, Trec_not) :: rem
| Psig_recmodule sdecls ->
List.iter
(fun (name, smty) ->
@@ -280,7 +292,7 @@ and transl_signature env sg =
let (decls, newenv) =
transl_recmodule_modtypes item.psig_loc env sdecls in
let rem = transl_sig newenv srem in
- map_end (fun (id, mty) -> Tsig_module(id, mty)) decls rem
+ map_rec (fun rs (id, mty) -> Tsig_module(id, mty, rs)) decls rem
| Psig_modtype(name, sinfo) ->
check "module type" item.psig_loc modtype_names name;
let info = transl_modtype_info env sinfo in
@@ -311,10 +323,12 @@ and transl_signature env sg =
let (classes, newenv) = Typeclass.class_descriptions env cl in
let rem = transl_sig newenv srem in
List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
- [Tsig_class(i, d); Tsig_cltype(i', d');
- Tsig_type(i'', d''); Tsig_type(i''', d''')])
+ (map_rec
+ (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
+ [Tsig_class(i, d, rs);
+ Tsig_cltype(i', d', rs);
+ Tsig_type(i'', d'', rs);
+ Tsig_type(i''', d''', rs)])
classes [rem])
| Psig_class_type cl ->
List.iter
@@ -324,10 +338,11 @@ and transl_signature env sg =
let (classes, newenv) = Typeclass.class_type_declarations env cl in
let rem = transl_sig newenv srem in
List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'') ->
- [Tsig_cltype(i, d);
- Tsig_type(i', d'); Tsig_type(i'', d'')])
+ (map_rec
+ (fun rs (i, d, i', d', i'', d'') ->
+ [Tsig_cltype(i, d, rs);
+ Tsig_type(i', d', rs);
+ Tsig_type(i'', d'', rs)])
classes [rem])
in transl_sig env sg
@@ -378,7 +393,7 @@ let rec closed_modtype = function
and closed_signature_item = function
Tsig_value(id, desc) -> Ctype.closed_schema desc.val_type
- | Tsig_module(id, mty) -> closed_modtype mty
+ | Tsig_module(id, mty, _) -> closed_modtype mty
| _ -> true
let check_nongen_scheme env = function
@@ -406,8 +421,8 @@ let rec bound_value_identifiers = function
| Tsig_value(id, {val_kind = Val_reg}) :: rem ->
id :: bound_value_identifiers rem
| Tsig_exception(id, decl) :: rem -> id :: bound_value_identifiers rem
- | Tsig_module(id, mty) :: rem -> id :: bound_value_identifiers rem
- | Tsig_class(id, decl) :: rem -> id :: bound_value_identifiers rem
+ | Tsig_module(id, mty, _) :: rem -> id :: bound_value_identifiers rem
+ | Tsig_class(id, decl, _) :: rem -> id :: bound_value_identifiers rem
| _ :: rem -> bound_value_identifiers rem
(* Helpers for typing recursive modules *)
@@ -550,7 +565,7 @@ and type_structure anchor env kset sstr =
enrich_type_decls anchor decls env newenv in
let (str_rem, sig_rem, final_env) = type_struct newenv' srem in
(Tstr_type decls :: str_rem,
- map_end (fun (id, info) -> Tsig_type(id, info)) decls sig_rem,
+ map_rec (fun rs (id, info) -> Tsig_type(id, info, rs)) decls sig_rem,
final_env)
| {pstr_desc = Pstr_exception(name, sarg)} :: srem ->
let arg = Typedecl.transl_exception env sarg in
@@ -573,7 +588,7 @@ and type_structure anchor env kset sstr =
let (id, newenv) = Env.enter_module name mty env in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(Tstr_module(id, modl) :: str_rem,
- Tsig_module(id, modl.mod_type) :: sig_rem,
+ Tsig_module(id, modl.mod_type, Trec_not) :: sig_rem,
final_env)
| {pstr_desc = Pstr_recmodule sbind; pstr_loc = loc} :: srem ->
List.iter
@@ -601,7 +616,7 @@ and type_structure anchor env kset sstr =
let bind = List.map2 type_recmodule_binding decls sbind in
let (str_rem, sig_rem, final_env) = type_struct newenv srem in
(Tstr_recmodule bind :: str_rem,
- map_end (fun (id, modl) -> Tsig_module(id, modl.mod_type))
+ map_rec (fun rs (id, modl) -> Tsig_module(id, modl.mod_type, rs))
bind sig_rem,
final_env)
| {pstr_desc = Pstr_modtype(name, smty); pstr_loc = loc} :: srem ->
@@ -633,10 +648,12 @@ and type_structure anchor env kset sstr =
(List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) ::
str_rem,
List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
- [Tsig_class(i, d); Tsig_cltype(i', d');
- Tsig_type(i'', d''); Tsig_type(i''', d''')])
+ (map_rec
+ (fun rs (i, d, i', d', i'', d'', i''', d''', _, _, _) ->
+ [Tsig_class(i, d, rs);
+ Tsig_cltype(i', d', rs);
+ Tsig_type(i'', d'', rs);
+ Tsig_type(i''', d''', rs)])
classes [sig_rem]),
final_env)
| {pstr_desc = Pstr_class_type cl; pstr_loc = loc} :: srem ->
@@ -653,9 +670,11 @@ and type_structure anchor env kset sstr =
(List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) ::
str_rem,
List.flatten
- (map_end
- (fun (i, d, i', d', i'', d'') ->
- [Tsig_cltype(i, d); Tsig_type(i', d'); Tsig_type(i'', d'')])
+ (map_rec
+ (fun rs (i, d, i', d', i'', d'') ->
+ [Tsig_cltype(i, d, rs);
+ Tsig_type(i', d', rs);
+ Tsig_type(i'', d'', rs)])
classes [sig_rem]),
final_env)
| {pstr_desc = Pstr_include smodl; pstr_loc = loc} :: srem ->
@@ -693,7 +712,7 @@ and normalize_signature env = List.iter (normalize_signature_item env)
and normalize_signature_item env = function
Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type
- | Tsig_module(id, mty) -> normalize_modtype env mty
+ | Tsig_module(id, mty, _) -> normalize_modtype env mty
| _ -> ()
(* Simplify multiple specifications of a value or an exception in a signature.
@@ -720,9 +739,9 @@ and simplify_signature sg =
simplif val_names (StringSet.add name exn_names)
(if StringSet.mem name exn_names then res else component :: res)
sg
- | Tsig_module(id, mty) :: sg ->
+ | Tsig_module(id, mty, rs) :: sg ->
simplif val_names exn_names
- (Tsig_module(id, simplify_modtype mty) :: res) sg
+ (Tsig_module(id, simplify_modtype mty, rs) :: res) sg
| component :: sg ->
simplif val_names exn_names (component :: res) sg
in
@@ -730,12 +749,12 @@ and simplify_signature sg =
(* Typecheck an implementation file *)
-let type_implementation sourcefile prefixname modulename initial_env ast =
+let type_implementation sourcefile outputprefix modulename initial_env ast =
Typecore.reset_delayed_checks ();
let kset = Kset.empty () in
let (str, sg, finalenv) =
Misc.try_finally (fun () -> type_structure initial_env kset ast)
- (fun () -> Stypes.dump (prefixname ^ ".annot"))
+ (fun () -> Stypes.dump (outputprefix ^ ".annot"))
in
Typecore.force_delayed_checks (); (* We check kset emptyness here? *)
if !Clflags.print_types then begin
@@ -743,17 +762,21 @@ let type_implementation sourcefile prefixname modulename initial_env ast =
(str, Tcoerce_none)
end else begin
let coercion =
- if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
+ let sourceintf =
+ Misc.chop_extension_if_any sourcefile ^ !Config.interface_suffix in
+ if Sys.file_exists sourceintf then begin
let intf_file =
- try find_in_path !Config.load_path (prefixname ^ ".cmi")
- with Not_found -> prefixname ^ ".cmi" in
+ try
+ find_in_path_uncap !Config.load_path (modulename ^ ".cmi")
+ with Not_found ->
+ raise(Error(Location.none, Interface_not_compiled sourceintf)) in
let dclsig = Env.read_signature modulename intf_file in
Includemod.compunit sourcefile sg intf_file dclsig
end else begin
check_nongen_schemes finalenv str;
normalize_signature finalenv sg;
if not !Clflags.dont_write_files then
- Env.save_signature sg modulename (prefixname ^ ".cmi");
+ Env.save_signature sg modulename (outputprefix ^ ".cmi");
Tcoerce_none
end in
(str, coercion)
@@ -768,7 +791,7 @@ let rec package_signatures subst = function
let sg' = Subst.signature subst sg in
let oldid = Ident.create_persistent name
and newid = Ident.create name in
- Tsig_module(newid, Tmty_signature sg') ::
+ Tsig_module(newid, Tmty_signature sg', Trec_not) ::
package_signatures (Subst.add_module oldid (Pident newid) subst) rem
let package_units objfiles cmifile modulename =
@@ -778,6 +801,10 @@ let package_units objfiles cmifile modulename =
(fun f ->
let pref = chop_extension_if_any f in
let modname = String.capitalize(Filename.basename pref) in
+ let sg = Env.read_signature modname (pref ^ ".cmi") in
+ if Filename.check_suffix f ".cmi" &&
+ not(Mtype.no_code_needed_sig Env.initial sg)
+ then raise(Error(Location.none, Implementation_is_required f));
(modname, Env.read_signature modname (pref ^ ".cmi")))
objfiles in
(* Compute signature of packaged unit *)
@@ -852,3 +879,10 @@ let report_error ppf = function
fprintf ppf
"@[The type of this module,@ %a,@ \
contains type variables that cannot be generalized@]" modtype mty
+ | Implementation_is_required intf_name ->
+ fprintf ppf
+ "@[The interface %s@ declares values, not just types.@ \
+ An implementation must be provided.@]" intf_name
+ | Interface_not_compiled intf_name ->
+ fprintf ppf
+ "@[Could not find the .cmi file for interface@ %s.@]" intf_name
diff --git a/typing/typemod.mli b/typing/typemod.mli
index b0f5de65ab..d43f490242 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -48,6 +48,8 @@ type error =
| Non_generalizable of type_expr
| Non_generalizable_class of Ident.t * class_declaration
| Non_generalizable_module of module_type
+ | Implementation_is_required of string
+ | Interface_not_compiled of string
exception Error of Location.t * error
diff --git a/typing/types.ml b/typing/types.ml
index c5a179d099..4e8cc9083c 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -165,7 +165,8 @@ type class_type =
and class_signature =
{ cty_self: type_expr;
cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
- cty_concr: Concr.t }
+ cty_concr: Concr.t;
+ cty_inher: (Path.t * type_expr list) list }
type class_declaration =
{ cty_params: type_expr list;
@@ -189,13 +190,18 @@ and signature = signature_item list
and signature_item =
Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
+ | Tsig_type of Ident.t * type_declaration * rec_status
| Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
+ | Tsig_module of Ident.t * module_type * rec_status
| Tsig_modtype of Ident.t * modtype_declaration
- | Tsig_class of Ident.t * class_declaration
- | Tsig_cltype of Ident.t * cltype_declaration
+ | Tsig_class of Ident.t * class_declaration * rec_status
+ | Tsig_cltype of Ident.t * cltype_declaration * rec_status
and modtype_declaration =
Tmodtype_abstract
| Tmodtype_manifest of module_type
+
+and rec_status =
+ Trec_not
+ | Trec_first
+ | Trec_next
diff --git a/typing/types.mli b/typing/types.mli
index 93ca3079c0..8d3408bf86 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -167,7 +167,8 @@ type class_type =
and class_signature =
{ cty_self: type_expr;
cty_vars: (Asttypes.mutable_flag * type_expr) Vars.t;
- cty_concr: Concr.t }
+ cty_concr: Concr.t;
+ cty_inher: (Path.t * type_expr list) list }
type class_declaration =
{ cty_params: type_expr list;
@@ -191,13 +192,18 @@ and signature = signature_item list
and signature_item =
Tsig_value of Ident.t * value_description
- | Tsig_type of Ident.t * type_declaration
+ | Tsig_type of Ident.t * type_declaration * rec_status
| Tsig_exception of Ident.t * exception_declaration
- | Tsig_module of Ident.t * module_type
+ | Tsig_module of Ident.t * module_type * rec_status
| Tsig_modtype of Ident.t * modtype_declaration
- | Tsig_class of Ident.t * class_declaration
- | Tsig_cltype of Ident.t * cltype_declaration
+ | Tsig_class of Ident.t * class_declaration * rec_status
+ | Tsig_cltype of Ident.t * cltype_declaration * rec_status
and modtype_declaration =
Tmodtype_abstract
| Tmodtype_manifest of module_type
+
+and rec_status =
+ Trec_not (* not recursive *)
+ | Trec_first (* first in a recursive group *)
+ | Trec_next (* not first in a recursive group *)
View Lorry Controller Status