summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2004-12-11 06:58:14 +0000
committerJacques Garrigue <garrigue at math.nagoya-u.ac.jp>2004-12-11 06:58:14 +0000
commit2f766eea9177a45ce3fe8dab3dbf23de253cbba8 (patch)
tree11ef6beef6a391147b73835cd00a705ee7f045c0
parent385c6be7897735bc701a33b612df17d05ba9279d (diff)
downloadocaml-objvariants.tar.gz
merge from 2004-12-10objvariants
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/objvariants@6735 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
Diffstat
-rw-r--r--typing/ctype.ml242
-rw-r--r--typing/ctype.mli1
-rw-r--r--typing/env.ml32
-rw-r--r--typing/includemod.ml44
-rw-r--r--typing/mtype.ml72
-rw-r--r--typing/mtype.mli7
-rw-r--r--typing/oprint.ml42
-rw-r--r--typing/outcometree.mli16
-rw-r--r--typing/parmatch.ml14
-rw-r--r--typing/printtyp.ml189
-rw-r--r--typing/printtyp.mli8
-rw-r--r--typing/subst.ml30
-rw-r--r--typing/typeclass.ml126
-rw-r--r--typing/typecore.ml290
-rw-r--r--typing/typecore.mli1
-rw-r--r--typing/typedecl.ml104
-rw-r--r--typing/typedecl.mli6
-rw-r--r--typing/typemod.ml136
-rw-r--r--typing/typemod.mli2
-rw-r--r--typing/types.ml22
-rw-r--r--typing/types.mli22
-rw-r--r--typing/typetexp.ml2
22 files changed, 859 insertions, 549 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
index ac39a1d0df..0bb89c5061 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -224,6 +224,7 @@ let rec opened_object ty =
Tobject (t, _) -> opened_object t
| Tfield(_, _, _, t) -> opened_object t
| Tvar -> true
+ | Tunivar -> true
| _ -> false
(**** Close an object ****)
@@ -404,6 +405,11 @@ let free_vars ty =
free_variables := [];
res
+let free_variables ty =
+ let tl = List.map fst (free_vars ty) in
+ unmark_type ty;
+ tl
+
let rec closed_type ty =
match free_vars ty with
[] -> ()
@@ -677,7 +683,13 @@ let limited_generalize ty0 ty =
let idx = ty.level in
if idx <> generic_level then begin
set_level ty generic_level;
- List.iter generalize_parents !(snd (Hashtbl.find graph idx))
+ List.iter generalize_parents !(snd (Hashtbl.find graph idx));
+ (* Special case for rows: must generalize the row variable *)
+ match ty.desc with
+ Tvariant row ->
+ let more = row_more row in
+ if more.level <> generic_level then generalize_parents more
+ | _ -> ()
end
in
@@ -821,7 +833,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
@@ -867,12 +881,11 @@ let compute_univars ty =
TypeHash.add node_univars inv.inv_type (ref(TypeSet.singleton univ));
List.iter (add_univar univ) inv.inv_parents
in
- TypeHash.iter
- (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
+ TypeHash.iter (fun ty inv -> if ty.desc = Tunivar then add_univar ty inv)
inverted;
fun ty ->
try !(TypeHash.find node_univars ty) with Not_found -> TypeSet.empty
-
+
let rec diff_list l1 l2 =
if l1 == l2 then [] else
match l1 with [] -> invalid_arg "Ctype.diff_list"
@@ -1140,7 +1153,6 @@ let rec non_recursive_abbrev env ty0 ty =
let ty = repr ty in
if ty == repr ty0 then raise Recursive_abbrev;
if not (List.memq ty !visited) then begin
- let level = ty.level in
visited := ty :: !visited;
match ty.desc with
Tconstr(p, args, abbrev) ->
@@ -1223,21 +1235,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 [])
@@ -1245,7 +1257,7 @@ module TypeMap = Map.Make (TypeOps)
(* Test the occurence of free univars in a type *)
(* that's way too expansive. Must do some kind of cacheing *)
-let occur_univar ty =
+let occur_univar env ty =
let visited = ref TypeMap.empty in
let rec occur_rec bound ty =
let ty = repr ty in
@@ -1268,6 +1280,16 @@ let occur_univar ty =
| Tpoly (ty, tyl) ->
let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in
occur_rec bound ty
+ | Tconstr (_, [], _) -> ()
+ | Tconstr (p, tl, _) ->
+ begin try
+ let td = Env.find_type p env in
+ List.iter2
+ (fun t (pos,neg,_) -> if pos || neg then occur_rec bound t)
+ tl td.type_variance
+ with Not_found ->
+ List.iter (occur_rec bound) tl
+ end
| _ -> iter_type_expr (occur_rec bound) ty
in
try
@@ -1275,6 +1297,70 @@ let occur_univar ty =
with exn ->
unmark_type ty; raise exn
+(* Grouping univars by families according to their binders *)
+let add_univars =
+ List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s)
+
+let get_univar_family univar_pairs univars =
+ if univars = [] then TypeSet.empty else
+ let rec insert s = function
+ cl1, (_::_ as cl2) ->
+ if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then
+ add_univars s cl2
+ else s
+ | _ -> s
+ in
+ let s =
+ List.fold_left (fun s t -> TypeSet.add (repr t) s) TypeSet.empty univars
+ in List.fold_left insert s univar_pairs
+
+(* Whether a family of univars escapes from a type *)
+let univars_escape env univar_pairs vl ty =
+ let family = get_univar_family univar_pairs vl in
+ let visited = ref TypeSet.empty in
+ let rec occur t =
+ let t = repr t in
+ if TypeSet.mem t !visited then () else begin
+ visited := TypeSet.add t !visited;
+ match t.desc with
+ Tpoly (t, tl) ->
+ if List.exists (fun t -> TypeSet.mem (repr t) family) tl then ()
+ else occur t
+ | Tunivar ->
+ if TypeSet.mem t family then raise Occur
+ | Tconstr (_, [], _) -> ()
+ | Tconstr (p, tl, _) ->
+ begin try
+ let td = Env.find_type p env in
+ List.iter2 (fun t (pos,neg,_) -> if pos || neg then occur t)
+ tl td.type_variance
+ with Not_found ->
+ List.iter occur tl
+ end
+ | _ ->
+ iter_type_expr occur t
+ end
+ in
+ try occur ty; false with Occur -> true
+
+(* Wrapper checking that no variable escapes and updating univar_pairs *)
+let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
+ let old_univars = !univar_pairs in
+ let known_univars =
+ List.fold_left (fun s (cl,_) -> add_univars s cl)
+ TypeSet.empty old_univars
+ in
+ if tl1 <> [] && TypeSet.mem (List.hd tl1) known_univars &&
+ univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2)))
+ || tl2 <> [] && TypeSet.mem (List.hd tl2) known_univars &&
+ univars_escape env old_univars tl2 (newty(Tpoly(t1,tl1)))
+ then raise (Unify []);
+ let cl1 = List.map (fun t -> t, ref None) tl1
+ and cl2 = List.map (fun t -> t, ref None) tl2 in
+ univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
+ try let res = f t1 t2 in univar_pairs := old_univars; res
+ with exn -> univar_pairs := old_univars; raise exn
+
let univar_pairs = ref []
@@ -1299,6 +1385,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; row_object=[]})
+
(**** Unification ****)
(* Return whether [t0] occurs in [ty]. Objects are also traversed. *)
@@ -1354,11 +1447,11 @@ let rec unify env t1 t2 =
| (Tconstr _, Tvar) when deep_occur t2 t1 ->
unify2 env t1 t2
| (Tvar, _) ->
- occur env t1 t2; occur_univar t2;
+ occur env t1 t2; occur_univar env t2;
update_level env t1.level t2;
link_type t1 t2
| (_, Tvar) ->
- occur env t2 t1; occur_univar t1;
+ occur env t2 t1; occur_univar env t1;
update_level env t2.level t1;
link_type t2 t1
| (Tunivar, Tunivar) ->
@@ -1411,11 +1504,11 @@ and unify3 env t1 t1' t2 t2' =
try
begin match (d1, d2) with
(Tvar, _) ->
- occur_univar t2
+ occur_univar env t2
| (_, Tvar) ->
let td1 = newgenty d1 in
occur env t2' td1;
- occur_univar td1;
+ occur_univar env td1;
if t1 == t1' then begin
(* The variable must be instantiated... *)
let ty = newty2 t1'.level d1 in
@@ -1456,9 +1549,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) ->
@@ -1466,27 +1559,7 @@ and unify3 env t1 t1' t2 t2' =
| (Tpoly (t1, []), Tpoly (t2, [])) ->
unify env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- if List.length tl1 <> List.length tl2 then raise (Unify []);
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try
- unify env t1 t2;
- let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in
- List.iter
- (fun t1 ->
- if List.memq t1 tl2 then () else
- try
- let t2 =
- List.find (fun t2 -> not (List.memq (repr t2) tl1)) tl2 in
- link_type t2 t1
- with Not_found -> assert false)
- tl1;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
+ enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
| (_, _) ->
raise (Unify [])
end;
@@ -1540,15 +1613,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;
@@ -1600,12 +1674,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; row_object = []})
- 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 +1725,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;
List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
if row_object <> [] then begin
@@ -1675,7 +1746,7 @@ and unify_row env row1 row2 =
if row0.row_closed then begin
match filter_row_fields false (row_repr row1).row_fields with [l, fi] ->
begin match row_field_repr fi with
- Reither(c, t1::tl, _, e) as f1 ->
+ Reither(c, t1::tl, _, e) ->
let f1' = Rpresent (Some t1) in
set_row_field e f1';
begin try
@@ -1683,7 +1754,7 @@ and unify_row env row1 row2 =
List.iter (unify env t1) tl
with exn ->
e := None;
- List.assoc l !undo := Some f1';
+ set_row_field (List.assoc l !undo) f1';
raise exn
end
| Reither(true, [], _, e) ->
@@ -1740,6 +1811,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
@@ -1878,7 +1950,7 @@ let moregen_occur env level ty =
unmark_type ty; raise (Unify [])
end;
(* also check for free univars *)
- occur_univar ty;
+ occur_univar env ty;
update_level env level ty
let rec moregen inst_nongen type_pairs env t1 t2 =
@@ -1933,16 +2005,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
| (Tpoly (t1, []), Tpoly (t2, [])) ->
moregen inst_nongen type_pairs env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try
- moregen inst_nongen type_pairs env t1 t2;
- univar_pairs := old_univars
- with exn ->
- univar_pairs := old_univars; raise exn
- end
+ enter_poly env univar_pairs t1 tl1 t2 tl2
+ (moregen inst_nongen type_pairs env)
| (_, _) ->
raise (Unify [])
end
@@ -2191,16 +2255,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
| (Tpoly (t1, []), Tpoly (t2, [])) ->
eqtype rename type_pairs subst env t1 t2
| (Tpoly (t1, tl1), Tpoly (t2, tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- begin try eqtype rename type_pairs subst env t1 t2
- with exn ->
- univar_pairs := old_univars;
- raise exn
- end;
- univar_pairs := old_univars
+ enter_poly env univar_pairs t1 tl1 t2 tl2
+ (eqtype rename type_pairs subst env)
| (Tunivar, Tunivar) ->
unify_univar t1 t2 !univar_pairs
| (_, _) ->
@@ -2859,14 +2915,13 @@ let rec subtype_rec env trace t1 t2 cstrs =
end
| (Tpoly (u1, []), Tpoly (u2, [])) ->
subtype_rec env trace u1 u2 cstrs
- | (Tpoly (t1, tl1), Tpoly (t2,tl2)) ->
- let old_univars = !univar_pairs in
- let cl1 = List.map (fun t -> t, ref None) tl1
- and cl2 = List.map (fun t -> t, ref None) tl2 in
- univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
- let cstrs = subtype_rec env trace t1 t2 cstrs in
- univar_pairs := old_univars;
- cstrs
+ | (Tpoly (u1, tl1), Tpoly (u2,tl2)) ->
+ begin try
+ enter_poly env univar_pairs u1 tl1 u2 tl2
+ (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs)
+ with Unify _ ->
+ (trace, t1, t2, !univar_pairs)::cstrs
+ end
| (_, _) ->
(trace, t1, t2, !univar_pairs)::cstrs
end
@@ -3188,7 +3243,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
@@ -3206,6 +3264,7 @@ let nondep_class_declaration env id decl =
assert (not (Path.isfree id decl.cty_path));
let decl =
{ cty_params = List.map (nondep_type_rec env id) decl.cty_params;
+ cty_variance = decl.cty_variance;
cty_type = nondep_class_type env id decl.cty_type;
cty_path = decl.cty_path;
cty_new =
@@ -3227,6 +3286,7 @@ let nondep_cltype_declaration env id decl =
assert (not (Path.isfree id decl.clty_path));
let decl =
{ clty_params = List.map (nondep_type_rec env id) decl.clty_params;
+ clty_variance = decl.clty_variance;
clty_type = nondep_class_type env id decl.clty_type;
clty_path = decl.clty_path }
in
diff --git a/typing/ctype.mli b/typing/ctype.mli
index bc0ce50cc6..a4eca32df6 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -219,6 +219,7 @@ val closed_schema: type_expr -> bool
(* Check whether the given type scheme contains no non-generic
type variables *)
+val free_variables: type_expr -> type_expr list
val closed_type_decl: type_declaration -> type_expr option
type closed_class_failure =
CC_Method of type_expr * bool * string * type_expr
diff --git a/typing/env.ml b/typing/env.ml
index 4ccb7f7e27..f1b803658b 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 ->
let p = Pdot(root, Ident.name id, nopos) in
let (pl, final_sub) =
prefix_idents root pos (Subst.add_type id p sub) rem in
@@ -429,7 +429,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
@@ -440,11 +440,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)
@@ -472,7 +472,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', nopos) c.comp_types;
@@ -491,7 +491,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;
@@ -505,12 +505,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)
@@ -652,12 +652,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
@@ -677,21 +677,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 d2f2436a69..cf89fc9d71 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 rec is_identity_coercion pos = function
+ | [] ->
+ true
+ | (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
@@ -184,13 +182,13 @@ and signatures env subst sig1 sig2 =
let nextpos =
match item with
Tsig_value(_,{val_kind = Val_prim _})
- | Tsig_type(_,_)
+ | Tsig_type(_,_,_)
| Tsig_modtype(_,_)
- | Tsig_cltype(_,_) -> pos
+ | Tsig_cltype(_,_,_) -> pos
| Tsig_value(_,_)
| 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 =
@@ -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 (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;
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 0b4805c144..b7b58ae39d 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -28,6 +28,9 @@ let rec scrape env mty =
end
| _ -> mty
+let freshen mty =
+ Subst.modtype Subst.identity mty
+
let rec strengthen env mty p =
match scrape env mty with
Tmty_signature sg ->
@@ -42,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 ->
@@ -50,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 =
@@ -67,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.
@@ -101,12 +104,13 @@ let nondep_supertype env mid mty =
Tsig_value(id, d) ->
Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
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_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'
@@ -115,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
@@ -148,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 =
@@ -166,9 +174,9 @@ 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 ->
Pdot(p, Ident.name id, nopos) :: 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 ->
@@ -177,3 +185,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 ee720be283..b15b09ec9c 100644
--- a/typing/mtype.mli
+++ b/typing/mtype.mli
@@ -20,6 +20,9 @@ val scrape: Env.t -> module_type -> module_type
(* Expand toplevel module type abbreviations
till hitting a "hard" module type (signature, functor,
or abstract module type ident. *)
+val freshen: module_type -> module_type
+ (* Return an alpha-equivalent copy of the given module type
+ where bound identifiers are fresh. *)
val strengthen: Env.t -> module_type -> Path.t -> module_type
(* Strengthen abstract type components relative to the
given path. *)
@@ -27,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 537ec6e924..8845151681 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -253,13 +253,16 @@ let out_type = ref print_out_type
(* Class types *)
+let type_parameter ppf (ty, (co, cn)) =
+ fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
+ ty
+
let print_out_class_params ppf =
function
[] -> ()
| tyl ->
fprintf ppf "@[<1>[%a]@]@ "
- (print_list (fun ppf x -> fprintf ppf "'%s" x)
- (fun ppf -> fprintf ppf ", "))
+ (print_list type_parameter (fun ppf -> fprintf ppf ", "))
tyl
let rec print_out_class_type ppf =
@@ -322,12 +325,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) ->
@@ -336,9 +341,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 =
@@ -350,13 +362,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
@@ -365,10 +371,6 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
!out_type ty2)
params
in
- let type_parameter ppf (ty, (co, cn)) =
- fprintf ppf "%s'%s" (if not cn then "+" else if not co then "-" else "")
- ty
- in
let type_defined ppf =
match args with
[] -> fprintf ppf "%s" name
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 9493e90179..633a01ee64 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -80,16 +80,24 @@ 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 * (bool * bool)) list * out_class_type *
+ out_rec_status
+ | Osig_class_type of
+ bool * string * (string * (bool * bool)) 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/parmatch.ml b/typing/parmatch.ml
index 20bdb0585c..6ee656cb06 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -696,7 +696,7 @@ let build_other_constant proj make first next p env =
*)
let build_other env = match env with
-| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_) as p
+| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _} as c,_)},_)
::_ ->
make_pat
(Tpat_construct
@@ -1519,10 +1519,7 @@ let check_partial loc casel =
*)
begin match casel with
| [] -> ()
- | _ ->
- Location.prerr_warning loc
- (Warnings.Other
- "Bad style, all clauses in this pattern-matching are guarded.")
+ | _ -> Location.prerr_warning loc Warnings.All_clauses_guarded
end ;
Partial
| ps::_ ->
@@ -1584,7 +1581,7 @@ let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
| [] -> ()
- | (q,act as clause)::rem ->
+ | (q,act)::rem ->
let qs = [q] in
begin try
let pss =
@@ -1602,10 +1599,7 @@ let check_unused tdefs casel =
ps
| Used ->
check_used_extra pss qs
- with e -> (* useless ? *)
- Location.prerr_warning (location_of_clause qs)
- (Warnings.Other "Fatal Error in Parmatch.check_unused") ;
- raise e
+ with e -> assert false
end ;
if has_guard act then
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index ae0ce15e78..6dd729b994 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -24,16 +24,6 @@ open Types
open Btype
open Outcometree
-(* Redefine it here since goal differs *)
-
-let rec opened_object ty =
- match (repr ty).desc with
- Tobject (t, _) -> opened_object t
- | Tfield(_, _, _, t) -> opened_object t
- | Tvar -> true
- | Tunivar -> true
- | _ -> false
-
(* Print a long identifier *)
let rec longident ppf = function
@@ -69,6 +59,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
@@ -406,11 +403,8 @@ and tree_of_row_field sch (l, f) =
else (l, false, tree_of_typlist sch tyl)
| Rabsent -> (l, false, [] (* une erreur, en fait *))
-and tree_of_typlist sch = function
- | [] -> []
- | ty :: tyl ->
- let tr = tree_of_typexp sch ty in
- tr :: tree_of_typlist sch tyl
+and tree_of_typlist sch tyl =
+ List.map (tree_of_typexp sch) tyl
and tree_of_typobject sch fi nm =
begin match !nm with
@@ -539,8 +533,12 @@ let rec tree_of_type_decl id decl =
| _ -> "?"
in
let type_defined decl =
- if decl.type_kind = Type_abstract && ty_manifest = None
- && List.exists (fun x -> x <> (true,true,true)) decl.type_variance then
+ if List.exists2
+ (fun ty x -> x <> (true,true,true) &&
+ (decl.type_kind = Type_abstract && ty_manifest = None
+ || (repr ty).desc <> Tvar))
+ decl.type_params decl.type_variance
+ then
let vari = List.map (fun (co,cn,ct) -> (co,cn)) decl.type_variance in
(Ident.name id,
List.combine
@@ -583,11 +581,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 *)
@@ -711,13 +709,17 @@ let class_type ppf cty =
prepare_class_type [] cty;
!Oprint.out_class_type ppf (tree_of_class_type false [] cty)
-let tree_of_class_params = function
- | [] -> []
- | params ->
- let tyl = tree_of_typlist true params in
- List.map (function Otyp_var (_, s) -> s | _ -> "?") tyl
+let tree_of_class_param param variance =
+ (match tree_of_typexp true param with
+ Otyp_var (_, s) -> s
+ | _ -> "?"),
+ if (repr param).desc = Tvar then (true, true) else variance
+
+let tree_of_class_params params =
+ 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 ();
@@ -731,13 +733,15 @@ 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)
+ (vir_flag, Ident.name id,
+ List.map2 tree_of_class_param params cl.cty_variance,
+ 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 ();
@@ -760,11 +764,13 @@ let tree_of_cltype_declaration id cl =
fields in
Osig_class_type
- (virt, Ident.name id, tree_of_class_params params,
- tree_of_class_type true params cl.clty_type)
+ (virt, Ident.name id,
+ List.map2 tree_of_class_param params cl.clty_variance,
+ 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 *)
@@ -779,48 +785,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 =
@@ -830,7 +813,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 =
@@ -859,11 +843,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
@@ -886,12 +865,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 _ ->
@@ -913,6 +917,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
@@ -933,22 +939,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>\
@@ -959,7 +972,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;
@@ -986,6 +999,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 438adb5247..782179b6b2 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
@@ -197,6 +201,7 @@ let rec class_type s =
let class_declaration s decl =
let decl =
{ cty_params = List.map (typexp s) decl.cty_params;
+ cty_variance = decl.cty_variance;
cty_type = class_type s decl.cty_type;
cty_path = type_path s decl.cty_path;
cty_new =
@@ -212,6 +217,7 @@ let class_declaration s decl =
let cltype_declaration s decl =
let decl =
{ clty_params = List.map (typexp s) decl.clty_params;
+ clty_variance = decl.clty_variance;
clty_type = class_type s decl.clty_type;
clty_path = type_path s decl.clty_path }
in
@@ -233,10 +239,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 ->
@@ -244,7 +250,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
@@ -277,18 +283,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 a0f9dd64ec..7301b1f9c6 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
@@ -350,7 +359,6 @@ and class_type env scty =
let (params, clty) =
Ctype.instance_class decl.clty_params decl.clty_type
in
- let sty = Ctype.self_type clty in
if List.length params <> List.length styl then
raise(Error(scty.pcty_loc,
Parameter_arity_mismatch (lid, List.length params,
@@ -376,10 +384,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 +431,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 +449,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 +498,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 (defs, val_env) =
@@ -517,7 +533,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
@@ -534,22 +550,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
@@ -568,30 +586,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
@@ -599,11 +620,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;
@@ -625,12 +653,7 @@ and class_structure cl_num final val_env met_env loc (spat, str) =
let l1 = names priv_meths and l2 = names pub_meths' in
let added = List.filter (fun x -> List.mem x l1) l2 in
if added <> [] then
- Location.prerr_warning loc
- (Warnings.Other
- (String.concat " "
- ("the following private methods were made public implicitly:\n "
- :: added)));
-
+ Location.prerr_warning loc (Warnings.Implicit_public_methods added);
{cl_field = fields; cl_meths = meths}, sign
and class_expr cl_num val_env met_env scl =
@@ -735,7 +758,7 @@ and class_expr cl_num val_env met_env scl =
Ctype.end_def ();
if Btype.is_optional l && all_labeled cl.cl_type then
Location.prerr_warning pat.pat_loc
- (Warnings.Other "This optional argument cannot be erased");
+ Warnings.Unerasable_optional_argument;
rc {cl_desc = Tclass_fun (pat, pv, cl, partial);
cl_loc = scl.pcl_loc;
cl_type = Tcty_fun (l, Ctype.instance pat.pat_type, cl.cl_type);
@@ -948,10 +971,12 @@ 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 *)
+ cty_variance = [];
cty_type = dummy_cty; (* Dummy value *)
cty_path = unbound_class;
cty_new =
@@ -962,6 +987,7 @@ let rec initial_env define_class approx
let env =
Env.add_cltype ty_id
{clty_params = []; (* Dummy value *)
+ clty_variance = [];
clty_type = dummy_cty; (* Dummy value *)
clty_path = unbound_class} (
if define_class then
@@ -1076,11 +1102,14 @@ let class_infos define_class kind
end;
(* Class and class type temporary definitions *)
+ let cty_variance = List.map (fun _ -> true, true) params in
let cltydef =
{clty_params = params; clty_type = class_body typ;
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params; cty_type = typ;
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
@@ -1112,9 +1141,11 @@ let class_infos define_class kind
let (params', typ') = Ctype.instance_class params typ in
let cltydef =
{clty_params = params'; clty_type = class_body typ';
+ clty_variance = cty_variance;
clty_path = Path.Pident obj_id}
and clty =
{cty_params = params'; cty_type = typ';
+ cty_variance = cty_variance;
cty_path = Path.Pident obj_id;
cty_new =
match cl.pci_virt with
@@ -1193,16 +1224,11 @@ let final_decl env define_class
let extract_type_decls
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr, required) decls =
- ((obj_id, obj_abbr), required) :: ((cl_id, cl_abbr), required) :: decls
-
-let rec compact = function
- [] -> []
- | a :: b :: l -> (a,b) :: compact l
- | _ -> fatal_error "Typeclass.compact"
+ (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) :: decls
let merge_type_decls
- (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
- arity, pub_meths, coe, expr, req) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+ (id, _clty, ty_id, _cltydef, obj_id, _obj_abbr, cl_id, _cl_abbr,
+ arity, pub_meths, coe, expr, req) (obj_abbr, cl_abbr, clty, cltydef) =
(id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, coe, expr)
@@ -1268,7 +1294,7 @@ let type_classes define_class approx kind env cls =
let res = List.rev_map (final_decl env define_class) res in
let decls = List.fold_right extract_type_decls res [] in
let decls = Typedecl.compute_variance_decls env decls in
- let res = List.map2 merge_type_decls res (compact decls) in
+ let res = List.map2 merge_type_decls res decls in
let env = List.fold_left (final_env define_class) env res in
let res = List.map (check_coercions env) res in
(res, env)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 49929feba3..e907259ca5 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -38,6 +38,7 @@ type error =
| Label_missing of string list
| Label_not_mutable of Longident.t
| Bad_format of string
+ | Bad_conversion of string * string
| Undefined_method of type_expr * string
| Undefined_inherited_method of string
| Unbound_class of Longident.t
@@ -337,6 +338,22 @@ let build_or_pat env loc lid =
pat pats in
rp { r with pat_loc = loc }
+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 rec type_pat env sp =
match sp.ppat_desc with
Ppat_any ->
@@ -445,7 +462,7 @@ let rec type_pat env sp =
(label, arg)
in
rp {
- pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
+ 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 }
@@ -613,110 +630,116 @@ and is_nonexpansive_opt = function
(Handling of * modifiers contributed by Thorsten Ohl.) *)
let type_format loc fmt =
- let len = String.length fmt in
- let ty_input = newvar ()
- 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 rec scan_format i =
- if i >= len then ty_aresult, ty_result else
- match fmt.[i] with
- | '%' -> scan_flags i (i + 1)
- | _ -> scan_format (i + 1)
- and scan_flags i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
- | _ -> scan_skip i j
- and scan_skip i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '_' -> scan_rest true i j
- | _ -> scan_rest false i j
- and scan_rest skip i j =
- let rec scan_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_dot i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | '_' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_fixed_width i j
- and scan_fixed_width i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_width i (j + 1)
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_dot i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '.' -> scan_precision i (j + 1)
- | _ -> scan_conversion i j
- and scan_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '*' ->
- let ty_aresult, ty_result = scan_conversion i (j + 1) in
- ty_aresult, ty_arrow Predef.type_int ty_result
- | _ -> scan_fixed_precision i j
- and scan_fixed_precision i j =
- if j >= len then incomplete i else
- match fmt.[j] with
- | '0' .. '9' | '-' | '+' -> scan_fixed_precision i (j + 1)
- | _ -> scan_conversion i j
- and conversion j ty_arg =
- let ty_aresult, ty_result = scan_format (j + 1) in
- ty_aresult,
- if skip then ty_result else ty_arrow ty_arg ty_result
+ let rec type_in_format fmt =
+ let len = String.length fmt in
+
+ let bad_conversion fmt i c =
+ raise (Error (loc, Bad_conversion (fmt, String.sub fmt i len))) in
+ let incomplete i =
+ raise (Error (loc, Bad_format (String.sub fmt i (len - i)))) in
+
+ let ty_input = newvar ()
+ and ty_result = newvar ()
+ and ty_aresult = newvar () in
- and scan_conversion i j =
+ let meta = ref 0 in
+
+ let rec scan_format i =
+ if i >= len then
+ if !meta = 0 then ty_aresult, ty_result else incomplete (i - 1) else
+ match fmt.[i] with
+ | '%' -> scan_opts i (i + 1)
+ | _ -> scan_format (i + 1)
+ and scan_opts i j =
if j >= len then incomplete i else
match fmt.[j] with
- | '%' | '!' -> 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' ->
+ | '_' -> scan_rest true i (j + 1)
+ | _ -> scan_rest false i j
+ and scan_rest skip i j =
+ let rec scan_flags i j =
+ if j >= len then incomplete i else
+ match fmt.[j] with
+ | '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
+ | _ -> scan_width i j
+ and scan_width i j = scan_width_or_prec_value scan_precision i j
+ and scan_decimal_string scan i j =
+ if j >= len then incomplete i else
+ match fmt.[j] with
+ | '0' .. '9' -> scan_decimal_string scan i (j + 1)
+ | _ -> scan i j
+ and scan_width_or_prec_value scan i j =
+ if j >= len then incomplete i else
+ match fmt.[j] with
+ | '*' ->
+ let ty_aresult, ty_result = scan i (j + 1) in
+ ty_aresult, ty_arrow Predef.type_int ty_result
+ | '-' | '+' -> scan_decimal_string scan i (j + 1)
+ | _ -> scan_decimal_string scan i j
+ and scan_precision i j =
+ if j >= len then incomplete i else
+ match fmt.[j] with
+ | '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
+ | _ -> scan_conversion i j
+
+ and conversion j ty_arg =
+ let ty_aresult, ty_result = scan_format (j + 1) in
+ ty_aresult,
+ if skip then ty_result else ty_arrow ty_arg ty_result
+
+ and scan_conversion i j =
+ if j >= len then incomplete i else
+ match fmt.[j] with
+ | '%' | '!' -> 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
- | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
- | 'B' | 'b' -> conversion j Predef.type_bool
- | 'a' ->
+ | 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
+ | 'B' | 'b' -> conversion j Predef.type_bool
+ | 'a' ->
let ty_arg = newvar () in
let ty_a = ty_arrow ty_input (ty_arrow ty_arg ty_aresult) in
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 ->
+ | 't' -> conversion j (ty_arrow ty_input ty_aresult)
+ | 'l' | 'n' | 'L' as c ->
let j = j + 1 in
- if j >= len then incomplete i else begin
+ if j >= len then conversion (j - 1) Predef.type_int 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)
+ let ty_arg =
+ match c with
+ | 'l' -> Predef.type_int32
+ | 'n' -> Predef.type_nativeint
+ | _ -> Predef.type_int64 in
+ conversion j ty_arg
+ | c -> conversion (j - 1) Predef.type_int
end
- | c -> bad_format i (j - i + 1) in
- scan_width i j in
-
- let ty_ares, ty_res = scan_format 0 in
- newty
- (Tconstr(Predef.path_format4,
- [ty_res; ty_input; ty_ares; ty_result],
- ref Mnil))
+ | '{' | '(' as c ->
+ let j = j + 1 in
+ if j >= len then incomplete i else
+ let sj =
+ Printf.sub_format
+ (fun fmt -> incomplete 0) bad_conversion c fmt j in
+ let sfmt = String.sub fmt j (sj - j - 1) in
+ let ty_sfmt = type_in_format sfmt in
+ begin match c with
+ | '{' -> conversion sj ty_sfmt
+ | _ -> incr meta; conversion (j - 1) ty_sfmt end
+ | ')' when !meta > 0 -> decr meta; scan_format (j + 1)
+ | c -> bad_conversion fmt i c in
+ scan_flags i j in
+
+ let ty_ares, ty_res = scan_format 0 in
+ newty
+ (Tconstr(Predef.path_format4,
+ [ty_res; ty_input; ty_ares; ty_result],
+ ref Mnil)) in
+
+ type_in_format fmt
(* Approximate the type of an expression, for better recursion *)
@@ -850,14 +873,27 @@ let rec type_exp env sexp =
| Pexp_function _ -> (* defined in type_expect *)
type_expect env sexp (newvar())
| Pexp_apply(sfunct, sargs) ->
+ 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 rec lower_args ty_fun =
+ match (expand_head env ty_fun).desc with
+ Tarrow (l, ty, ty_fun, com) ->
+ unify_var env (newvar()) ty;
+ lower_args ty_fun
+ | _ -> ()
+ in
+ let ty = instance funct.exp_type in
+ end_def ();
+ lower_args ty;
+ begin_def ();
let (args, ty_res) = type_application env funct sargs in
- let funct = {funct with exp_type = instance funct.exp_type} in
+ end_def ();
+ unify_var env (newvar()) funct.exp_type;
re {
exp_desc = Texp_apply(funct, args);
exp_loc = sexp.pexp_loc;
@@ -938,7 +974,7 @@ let rec type_exp env sexp =
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) ->
@@ -1149,6 +1185,9 @@ let rec type_exp env sexp =
let (id, typ) =
filter_self_method env met Private meths privty
in
+ if (repr typ).desc = Tvar then
+ Location.prerr_warning sexp.pexp_loc
+ (Warnings.Undeclared_virtual_method met);
(Texp_send(obj, Tmeth_val id), typ)
| Texp_ident(path, {val_kind = Val_anc (methods, cl_num)}) ->
let method_id =
@@ -1221,8 +1260,7 @@ let rec type_exp env sexp =
| {desc = Tpoly (ty, tl); level = l} ->
if !Clflags.principal && l <> generic_level then
Location.prerr_warning sexp.pexp_loc
- (Warnings.Other
- "This use of a polymorphic method is not principal");
+ (Warnings.Not_principal "this use of a polymorphic method");
snd (instance_poly false tl ty)
| {desc = Tvar} as ty ->
let ty' = newvar () in
@@ -1431,7 +1469,7 @@ and type_argument env sarg ty_expected' =
[Some eta_var, Required])}],
Total) } in
if warn then Location.prerr_warning texp.exp_loc
- (Warnings.Other "Eliminated optional argument without principality");
+ (Warnings.Without_principality "eliminated optional argument");
if is_nonexpansive texp then func texp else
(* let-expand to have side effects *)
let let_pat, let_var = var_pair "let" texp.exp_type in
@@ -1461,9 +1499,18 @@ and type_application env funct sargs =
instance (result_type omitted ty_fun))
| (l1, sarg1) :: sargl ->
let (ty1, ty2) =
- match (expand_head env ty_fun).desc with
+ let ty_fun = expand_head env ty_fun in
+ match ty_fun.desc with
Tvar ->
let t1 = newvar () and t2 = newvar () in
+ let not_identity = function
+ Texp_ident(_,{val_kind=Val_prim
+ {Primitive.prim_name="%identity"}}) ->
+ false
+ | _ -> true
+ in
+ if ty_fun.level >= t1.level && not_identity funct.exp_desc then
+ Location.prerr_warning sarg1.pexp_loc Warnings.Unused_argument;
unify env ty_fun (newty (Tarrow(l1,t1,t2,Clink(ref Cunknown))));
(t1, t2)
| Tarrow (l,t1,t2,_) when l = l1
@@ -1510,11 +1557,11 @@ and type_application env funct sargs =
match expand_head env ty_fun with
{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
- let may_warn loc msg =
+ let may_warn loc w =
if not !warned && !Clflags.principal && lv <> generic_level
then begin
warned := true;
- Location.prerr_warning loc (Warnings.Other msg)
+ Location.prerr_warning loc w
end
in
let name = label_name l
@@ -1538,14 +1585,14 @@ and type_application env funct sargs =
let (l', sarg0, sargs1, sargs2) = extract_label name sargs in
if sargs1 <> [] then
may_warn sarg0.pexp_loc
- "Commuting this argument is not principal";
+ (Warnings.Not_principal "commuting this argument");
(l', sarg0, sargs1 @ sargs2, more_sargs)
with Not_found ->
let (l', sarg0, sargs1, sargs2) =
extract_label name more_sargs in
if sargs1 <> [] || sargs <> [] then
may_warn sarg0.pexp_loc
- "Commuting this argument is not principal";
+ (Warnings.Not_principal "commuting this argument");
(l', sarg0, sargs @ sargs1, sargs2)
in
sargs, more_sargs,
@@ -1553,7 +1600,7 @@ and type_application env funct sargs =
Some (fun () -> type_argument env sarg0 ty)
else begin
may_warn sarg0.pexp_loc
- "Using an optional argument here is not principal";
+ (Warnings.Not_principal "using an optional argument here");
Some (fun () -> option_some (type_argument env sarg0
(extract_option_type env ty)))
end
@@ -1563,12 +1610,12 @@ and type_application env funct sargs =
(List.mem_assoc "" sargs || List.mem_assoc "" more_sargs)
then begin
may_warn funct.exp_loc
- "Eliminated an optional argument without principality";
+ (Warnings.Without_principality "eliminated optional argument");
ignored := (l,ty,lv) :: !ignored;
Some (fun () -> option_none (instance ty) Location.none)
end else begin
may_warn funct.exp_loc
- "Commuted an argument without principality";
+ (Warnings.Without_principality "commuted an argument");
None
end
in
@@ -1728,7 +1775,7 @@ and type_expect ?in_function env sexp ty_expected =
in
if is_optional l && all_labeled ty_res then
Location.prerr_warning (fst (List.hd cases)).pat_loc
- (Warnings.Other "This optional argument cannot be erased");
+ Warnings.Unerasable_optional_argument;
re {
exp_desc = Texp_function(cases, partial);
exp_loc = sexp.pexp_loc;
@@ -1770,18 +1817,23 @@ and type_expect ?in_function env sexp ty_expected =
(* Typing of statements (expressions whose values are discarded) *)
and type_statement env sexp =
- let exp = type_exp env sexp in
- match (expand_head env exp.exp_type).desc with
- | Tarrow _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
- exp
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
- | Tvar ->
- add_delayed_check (fun () -> check_partial_application env exp);
- exp
- | _ ->
- Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
- exp
+ begin_def();
+ let exp = type_exp env sexp in
+ end_def();
+ let ty = expand_head env exp.exp_type and tv = newvar() in
+ begin match ty.desc with
+ | Tarrow _ ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Partial_application
+ | Tconstr (p, _, _) when Path.same p Predef.path_unit -> ()
+ | Tvar when ty.level > tv.level ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Nonreturning_statement
+ | Tvar ->
+ add_delayed_check (fun () -> check_partial_application env exp)
+ | _ ->
+ Location.prerr_warning sexp.pexp_loc Warnings.Statement_type
+ end;
+ unify_var env tv ty;
+ exp
(* Typing of match cases *)
@@ -1969,7 +2021,9 @@ let report_error ppf = function
| Label_not_mutable lid ->
fprintf ppf "The record field label %a is not mutable" longident lid
| Bad_format s ->
- fprintf ppf "Bad format `%s'" s
+ fprintf ppf "Bad format %S" s
+ | Bad_conversion (fmt, conv) ->
+ fprintf ppf "Bad conversion %S in format %S" fmt conv
| Undefined_method (ty, me) ->
reset_and_mark_loops ty;
fprintf ppf
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 3511b93b5a..3a337c2de1 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -75,6 +75,7 @@ type error =
| Label_missing of string list
| Label_not_mutable of Longident.t
| Bad_format of string
+ | Bad_conversion of string * string
| Undefined_method of type_expr * string
| Undefined_inherited_method of string
| Unbound_class of Longident.t
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index c4bcc9def1..2567eb37f3 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -109,29 +109,29 @@ let transl_declaration env (name, sdecl) id =
| Ptype_variant (cstrs, priv) ->
let all_constrs = ref StringSet.empty in
List.iter
- (fun (name, args) ->
+ (fun (name, args, loc) ->
if StringSet.mem name !all_constrs then
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
- if List.length (List.filter (fun (name, args) -> args <> []) cstrs)
+ if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
Type_variant(List.map
- (fun (name, args) ->
+ (fun (name, args, loc) ->
(name, List.map (transl_simple_type env true) args))
cstrs, priv)
| Ptype_record (lbls, priv) ->
let all_labels = ref StringSet.empty in
List.iter
- (fun (name, mut, arg) ->
+ (fun (name, mut, arg, loc) ->
if StringSet.mem name !all_labels then
raise(Error(sdecl.ptype_loc, Duplicate_label name));
all_labels := StringSet.add name !all_labels)
lbls;
let lbls' =
List.map
- (fun (name, mut, arg) ->
+ (fun (name, mut, arg, loc) ->
let ty = transl_simple_type env true arg in
name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
lbls in
@@ -223,7 +223,9 @@ let check_constraints env (_, sdecl) (_, decl) =
let pl = find_pl sdecl.ptype_kind in
List.iter
(fun (name, tyl) ->
- let styl = try List.assoc name pl with Not_found -> assert false in
+ let styl =
+ try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+ with Not_found -> assert false in
List.iter2
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
@@ -237,7 +239,7 @@ let check_constraints env (_, sdecl) (_, decl) =
let pl = find_pl sdecl.ptype_kind in
let rec get_loc name = function
[] -> assert false
- | (name', _, sty) :: tl ->
+ | (name', _, sty, _) :: tl ->
if name = name' then sty.ptyp_loc else get_loc name tl
in
List.iter
@@ -416,14 +418,32 @@ let compute_variance env tvl nega posi cntr ty =
if TypeSet.mem ty !cvisited then ctvar := true)
tvl
-let compute_variance_decl env decl (required, loc) =
+let make_variance ty = (ty, ref false, ref false, ref false)
+let whole_type decl =
+ match decl.type_kind with
+ Type_variant (tll,_) ->
+ Btype.newgenty
+ (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
+ | Type_record (ftl, _, _) ->
+ Btype.newgenty
+ (Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
+ | Type_abstract ->
+ match decl.type_manifest with
+ Some ty -> ty
+ | _ -> Btype.newgenty (Ttuple [])
+
+let compute_variance_decl env sharp decl (required, loc) =
if decl.type_kind = Type_abstract && decl.type_manifest = None then
List.map (fun (c, n) -> if c || n then (c, n, n) else (true, true, true))
required
else
- let tvl =
- List.map (fun ty -> (Btype.repr ty, ref false, ref false, ref false))
- decl.type_params in
+ let params = List.map Btype.repr decl.type_params in
+ let tvl0 = List.map make_variance params in
+ let fvl = Ctype.free_variables (whole_type decl) in
+ let fvl = List.filter (fun v -> not (List.memq v params)) fvl in
+ let tvl1 = List.map make_variance fvl in
+ let tvl2 = List.map make_variance fvl in
+ let tvl = tvl0 @ tvl1 in
begin match decl.type_kind with
Type_abstract ->
begin match decl.type_manifest with
@@ -442,12 +462,36 @@ let compute_variance_decl env decl (required, loc) =
compute_variance env tvl true cn cn ty)
ftl
end;
+ let priv =
+ match decl.type_kind with
+ Type_abstract -> Public
+ | Type_variant (_, priv) | Type_record (_, _, priv) -> priv
+ in
+ List.iter2
+ (fun (ty, co, cn, ct) (c, n) ->
+ if ty.desc <> Tvar || priv = Private then begin
+ let (c, n) = if c || n then (c, n) else (true, true) in
+ co := c; cn := n; ct := n;
+ compute_variance env tvl2 c n n ty
+ end)
+ tvl0 required;
+ if not sharp then
+ List.iter2
+ (fun (_, c1, n1, t1) (_, c2, n2, t2) ->
+ if !c1 && not !c2 || !n1 && not !n2 ||
+ !t1 && not !t2 && decl.type_kind = Type_abstract
+ then raise (Error(loc, Bad_variance)))
+ tvl1 tvl2;
List.map2
(fun (_, co, cn, ct) (c, n) ->
if c && !cn || n && !co then raise (Error(loc, Bad_variance));
let ct = if decl.type_kind = Type_abstract then ct else cn in
(!co, !cn, !ct))
- tvl required
+ tvl0 required
+
+let is_sharp id =
+ let s = Ident.name id in
+ String.length s > 0 && s.[0] = '#'
let rec compute_variance_fixpoint env decls required variances =
let new_decls =
@@ -460,7 +504,8 @@ let rec compute_variance_fixpoint env decls required variances =
new_decls env
in
let new_variances =
- List.map2 (fun (_, decl) -> compute_variance_decl new_env decl)
+ List.map2
+ (fun (id, decl) -> compute_variance_decl new_env (is_sharp id) decl)
new_decls required
in
let new_variances =
@@ -472,13 +517,26 @@ let rec compute_variance_fixpoint env decls required variances =
else
compute_variance_fixpoint env decls required new_variances
+let init_variance (id, decl) =
+ List.map (fun _ -> (false, false, false)) decl.type_params
+
(* for typeclass.ml *)
-let compute_variance_decls env decls =
- let decls, required = List.split decls in
- let variances =
- List.map (fun (l,_) -> List.map (fun _ -> false, false, false) l) required
+let compute_variance_decls env cldecls =
+ let decls, required =
+ List.fold_right
+ (fun (obj_id, obj_abbr, cl_abbr, clty, cltydef, required) (decls, req) ->
+ (obj_id, obj_abbr) :: decls, required :: req)
+ cldecls ([],[])
in
- fst (compute_variance_fixpoint env decls required variances)
+ let variances = List.map init_variance decls in
+ let (decls, _) = compute_variance_fixpoint env decls required variances in
+ List.map2
+ (fun (_,decl) (_, _, cl_abbr, clty, cltydef, _) ->
+ let variance = List.map (fun (c,n,t) -> (c,n)) decl.type_variance in
+ (decl, {cl_abbr with type_variance = decl.type_variance},
+ {clty with cty_variance = variance},
+ {cltydef with clty_variance = variance}))
+ decls cldecls
(* Translate a set of mutually recursive type declarations *)
let transl_type_decl env name_sdecl_list =
@@ -535,11 +593,8 @@ let transl_type_decl env name_sdecl_list =
name_sdecl_list
in
let final_decls, final_env =
- compute_variance_fixpoint env decls required
- (List.map
- (fun (_,decl) -> List.map (fun _ -> (false, false, false))
- decl.type_params)
- decls) in
+ compute_variance_fixpoint env decls required (List.map init_variance decls)
+ in
(* Done *)
(final_decls, final_env)
@@ -614,7 +669,8 @@ let transl_with_constraint env sdecl =
raise(Error(sdecl.ptype_loc, Unbound_type_var));
let decl =
{decl with type_variance =
- compute_variance_decl env decl (sdecl.ptype_variance, sdecl.ptype_loc)} in
+ compute_variance_decl env false decl
+ (sdecl.ptype_variance, sdecl.ptype_loc)} in
Ctype.end_def();
generalize_decl decl;
decl
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index e5e723b760..cab8dc52a5 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -42,8 +42,10 @@ val check_recmod_typedecl:
(* for typeclass.ml *)
val compute_variance_decls:
Env.t ->
- ((Ident.t * type_declaration) * ((bool * bool) list * Location.t)) list ->
- (Ident.t * type_declaration) list
+ (Ident.t * type_declaration * type_declaration * class_declaration *
+ cltype_declaration * ((bool * bool) list * Location.t)) list ->
+ (type_declaration * type_declaration * class_declaration *
+ cltype_declaration) list
type error =
Repeated_parameter
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 00e87b60e3..15c4c35c0f 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)
@@ -237,7 +249,7 @@ let rec transl_modtype env smty =
(fun sg (lid, sdecl) ->
merge_constraint env smty.pmty_loc sg lid sdecl)
init_sg constraints in
- Tmty_signature final_sg
+ Mtype.freshen (Tmty_signature final_sg)
and transl_signature env sg =
let type_names = ref StringSet.empty
@@ -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 *)
@@ -539,7 +554,7 @@ and type_structure anchor env 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
@@ -562,7 +577,7 @@ and type_structure anchor env 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
@@ -590,7 +605,7 @@ and type_structure anchor env 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 ->
@@ -622,10 +637,12 @@ and type_structure anchor env 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 ->
@@ -642,9 +659,11 @@ and type_structure anchor env 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 ->
@@ -682,7 +701,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.
@@ -709,9 +728,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
@@ -719,11 +738,11 @@ 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 (str, sg, finalenv) =
Misc.try_finally (fun () -> type_structure initial_env ast)
- (fun () -> Stypes.dump (prefixname ^ ".annot"))
+ (fun () -> Stypes.dump (outputprefix ^ ".annot"))
in
Typecore.force_delayed_checks ();
if !Clflags.print_types then begin
@@ -731,17 +750,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)
@@ -756,7 +779,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 =
@@ -766,6 +789,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 *)
@@ -840,3 +867,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 63f1f6614c..72823ac082 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 7cb8c89be7..908e7fd322 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -159,18 +159,21 @@ 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;
mutable cty_type: class_type;
cty_path: Path.t;
- cty_new: type_expr option }
+ cty_new: type_expr option;
+ cty_variance: (bool * bool) list }
type cltype_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
- clty_path: Path.t }
+ clty_path: Path.t;
+ clty_variance: (bool * bool) list }
(* Type expressions for the module language *)
@@ -183,13 +186,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 9ba94fdd55..4e9ab98d6b 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -161,18 +161,21 @@ 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;
mutable cty_type: class_type;
cty_path: Path.t;
- cty_new: type_expr option }
+ cty_new: type_expr option;
+ cty_variance: (bool * bool) list }
type cltype_declaration =
{ clty_params: type_expr list;
clty_type: class_type;
- clty_path: Path.t }
+ clty_path: Path.t;
+ clty_variance: (bool * bool) list }
(* Type expressions for the module language *)
@@ -185,13 +188,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 *)
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 0fbc12f1e2..6b3072d738 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -446,7 +446,7 @@ and transl_fields env policy =
function
[] ->
newty Tnil
- | {pfield_desc = Pfield_var} as field::_ ->
+ | {pfield_desc = Pfield_var}::_ ->
if policy = Univars then new_pre_univar () else newvar ()
| {pfield_desc = Pfield(s, e)}::l ->
let ty1 = transl_type env policy e in
View Lorry Controller Status