summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--otherlibs/labltk/browser/searchpos.ml3
-rw-r--r--parsing/parser.mly8
-rw-r--r--parsing/parsetree.mli2
-rw-r--r--parsing/printast.ml4
-rw-r--r--tools/ocamldep.ml2
-rw-r--r--typing/ctype.ml120
-rw-r--r--typing/includecore.ml7
-rw-r--r--typing/mtype.ml10
-rw-r--r--typing/predef.ml24
-rw-r--r--typing/printtyp.ml17
-rw-r--r--typing/subst.ml3
-rw-r--r--typing/typeclass.ml59
-rw-r--r--typing/typedecl.ml150
-rw-r--r--typing/typedecl.mli6
-rw-r--r--typing/types.ml3
-rw-r--r--typing/types.mli3
-rw-r--r--utils/config.mlp4
17 files changed, 333 insertions, 92 deletions
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index c224c5fbe..5ddb852ac 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -144,7 +144,8 @@ let search_pos_type_decl td ~pos ~env =
| None -> ()
end;
begin match td.ptype_kind with
- Ptype_abstract -> ()
+ Ptype_abstract None -> ()
+ | Ptype_abstract(Some t) -> search_pos_type t ~pos ~env
| Ptype_variant dl ->
List.iter dl
~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env))
diff --git a/parsing/parser.mly b/parsing/parser.mly
index e4fdd8038..75e42099e 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1157,9 +1157,11 @@ constraints:
;
type_kind:
/*empty*/
- { (Ptype_abstract, None) }
+ { (Ptype_abstract None, None) }
+ | AS core_type
+ { (Ptype_abstract (Some $2), None) }
| EQUAL core_type %prec prec_type_def
- { (Ptype_abstract, Some $2) }
+ { (Ptype_abstract None, Some $2) }
| EQUAL constructor_declarations
{ (Ptype_variant(List.rev $2), None) }
| EQUAL BAR constructor_declarations
@@ -1213,7 +1215,7 @@ with_constraint:
TYPE type_parameters label_longident EQUAL core_type constraints
{ ($3, Pwith_type {ptype_params = $2;
ptype_cstrs = List.rev $6;
- ptype_kind = Ptype_abstract;
+ ptype_kind = Ptype_abstract None;
ptype_manifest = Some $5;
ptype_loc = symbol_rloc()}) }
/* used label_longident instead of type_longident to disallow
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 358ab7ff5..a5cc290d0 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -117,7 +117,7 @@ and type_declaration =
ptype_loc: Location.t }
and type_kind =
- Ptype_abstract
+ Ptype_abstract of core_type option
| Ptype_variant of (string * core_type list) list
| Ptype_record of (string * mutable_flag * core_type) list
diff --git a/parsing/printast.ml b/parsing/printast.ml
index fc8d71edf..6c1c6caee 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -286,7 +286,9 @@ and type_declaration i ppf x =
and type_kind i ppf x =
match x with
- | Ptype_abstract -> line i ppf "Ptype_abstract\n"
+ | Ptype_abstract (x) ->
+ line i ppf "Ptype_abstract\n";
+ option (i+1) core_type ppf x;
| Ptype_variant (l) ->
line i ppf "Ptype_variant\n";
list (i+1) string_x_core_type_list ppf l;
diff --git a/tools/ocamldep.ml b/tools/ocamldep.ml
index 89fe9c132..36c1366f1 100644
--- a/tools/ocamldep.ml
+++ b/tools/ocamldep.ml
@@ -64,7 +64,7 @@ let add_type_declaration bv td =
td.ptype_cstrs;
add_opt add_type bv td.ptype_manifest;
match td.ptype_kind with
- Ptype_abstract -> ()
+ Ptype_abstract _ -> ()
| Ptype_variant cstrs ->
List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs
| Ptype_record lbls ->
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 1b21baab5..f61cc72dc 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -2074,37 +2074,38 @@ let match_class_declarations env patt_params patt_type subj_params subj_type =
let subtypes = ref []
-let rec build_subtype env visited t =
+let rec build_subtype env visited posi t =
+ if not posi then (t, false) else
let t = repr t in
match t.desc with
- Tlink t' -> (* Redundant ! *)
- build_subtype env visited t'
- | Tvar ->
- begin try
- (List.assq t !subtypes, true)
- with Not_found ->
+ Tvar ->
+ if posi then
+ try
+ (List.assq t !subtypes, true)
+ with Not_found ->
+ (t, false)
+ else
(t, false)
- end
| Tarrow(l, t1, t2) ->
if List.memq t visited then (t, false) else
- let (t1', c1) = (t1, false) in
- let (t2', c2) = build_subtype env (t::visited) t2 in
+ let visited = t :: visited in
+ let (t1', c1) = build_subtype env visited (not posi) t1 in
+ let (t2', c2) = build_subtype env visited posi t2 in
if c1 or c2 then (newty (Tarrow(l, t1', t2')), true)
else (t, false)
| Ttuple tlist ->
if List.memq t visited then (t, false) else
let visited = t :: visited in
- let (tlist', clist) =
- List.split (List.map (build_subtype env visited) tlist)
+ let tlist' = List.map (build_subtype env visited posi) tlist
in
- if List.exists (function c -> c) clist then
- (newty (Ttuple tlist'), true)
+ if List.exists snd tlist' then
+ (newty (Ttuple (List.map fst tlist')), true)
else (t, false)
| Tconstr(p, tl, abbrev) when generic_abbrev env p ->
let t' = repr (expand_abbrev env t) in
let (t'', c) =
try match t'.desc with
- Tobject _ ->
+ Tobject _ when posi ->
if List.memq t' visited then (t, false) else
begin try
(List.assq t' !subtypes, true)
@@ -2132,18 +2133,33 @@ let rec build_subtype env visited t =
ty.desc <- Tvar;
let t'' = newvar () in
subtypes := (ty, t'') :: !subtypes;
- let (ty1', _) = build_subtype env (t' :: visited) ty1 in
+ let (ty1', _) = build_subtype env (t' :: visited) posi ty1 in
assert (t''.desc = Tvar);
t''.desc <- Tobject (ty1', ref None);
(try unify env ty t with Unify _ -> assert false);
(t'', true)
end
| _ -> raise Not_found
- with Not_found -> build_subtype env visited t'
+ with Not_found -> build_subtype env visited posi t'
in
if c then (t'', true) else (t, false)
| Tconstr(p, tl, abbrev) ->
- (t, false)
+ let decl = Env.find_type p env in
+ let tl' =
+ List.map2
+ (fun (co,cn) t ->
+ if cn then
+ if co then (t, false)
+ else build_subtype env visited (not posi) t
+ else
+ if co then build_subtype env visited posi t
+ else (newvar(), true))
+ decl.type_variance tl
+ in
+ if List.exists snd tl' then
+ (newconstr p (List.map fst tl'), true)
+ else
+ (t, false)
| Tvariant row ->
if List.memq t visited then (t, false) else
let visited = t :: visited in
@@ -2152,21 +2168,31 @@ let rec build_subtype env visited t =
let bound = ref row.row_bound in
let fields =
List.map
- (fun (l,f) -> match row_field_repr f with
+ (fun (l,f as orig) -> match row_field_repr f with
Rpresent None ->
- (l, Reither(true, [], ref None)), false
+ if posi then
+ (l, Reither(true, [], ref None)), false
+ else
+ orig, false
| Rpresent(Some t) ->
- let (t', c) = build_subtype env visited t in
- bound := t' :: !bound;
- (l, Reither(false, [t'], ref None)), c
+ let (t', c) = build_subtype env visited posi t in
+ if posi then begin
+ bound := t' :: !bound;
+ (l, Reither(false, [t'], ref None)), c
+ end else
+ (l, Rpresent(Some t')), c
| _ -> assert false)
(filter_row_fields false row.row_fields)
in
- if fields = [] then (t, false) else
+ if posi && fields = [] then (t, false) else
let row =
- {row with row_fields = List.map fst fields;
- row_more = newvar(); row_bound = !bound;
- row_name = if List.exists snd fields then None else row.row_name }
+ if posi then
+ {row_fields = List.map fst fields; row_more = newvar();
+ row_bound = !bound; row_closed = true;
+ row_name = if List.exists snd fields then None else row.row_name }
+ else
+ {row_fields = List.map fst fields; row_more = newvar ();
+ row_bound = !bound; row_closed = false; row_name = None}
in
(newty (Tvariant row), true)
| Tobject (t1, _) when opened_object t1 ->
@@ -2174,24 +2200,31 @@ let rec build_subtype env visited t =
| Tobject (t1, _) ->
if List.memq t visited then (t, false) else
begin try
+ if not posi then raise Not_found;
(List.assq t !subtypes, true)
with Not_found ->
- let (t1', _) = build_subtype env (t :: visited) t1 in
+ let (t1', _) = build_subtype env (t :: visited) posi t1 in
(newty (Tobject (t1', ref None)), true)
end
| Tfield(s, _, t1, t2) (* Always present *) ->
- let (t1', _) = build_subtype env visited t1 in
- let (t2', _) = build_subtype env visited t2 in
- (newty (Tfield(s, Fpresent, t1', t2')), true)
+ let (t1', c1) = build_subtype env visited posi t1 in
+ let (t2', c2) = build_subtype env visited posi t2 in
+ if c1 || c2 then
+ (newty (Tfield(s, Fpresent, t1', t2')), true)
+ else
+ (t, false)
| Tnil ->
- let v = newvar () in
- (v, true)
- | Tsubst _ ->
+ if posi then
+ let v = newvar () in
+ (v, true)
+ else
+ (t, false)
+ | Tsubst _ | Tlink _ ->
assert false
let enlarge_type env ty =
subtypes := [];
- let (ty', _) = build_subtype env [] ty in
+ let (ty', _) = build_subtype env [] true ty in
subtypes := [];
ty'
@@ -2241,6 +2274,19 @@ let rec subtype_rec env trace t1 t2 cstrs =
subtype_rec env trace (expand_abbrev env t1) t2 cstrs
| (_, Tconstr(p2, tl2, abbrev2)) when generic_abbrev env p2 ->
subtype_rec env trace t1 (expand_abbrev env t2) cstrs
+ | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+ let decl = Env.find_type p1 env in
+ List.fold_left2
+ (fun cstrs (co, cn) (t1, t2) ->
+ if co then
+ if cn then
+ (trace, newty2 t1.level (Ttuple[t1]),
+ newty2 t2.level (Ttuple[t2])) :: cstrs
+ else subtype_rec env ((t1, t2)::trace) t1 t2 cstrs
+ else
+ if cn then subtype_rec env ((t2, t1)::trace) t2 t1 cstrs
+ else cstrs)
+ cstrs decl.type_variance (List.combine tl1 tl2)
| (Tobject (f1, _), Tobject (f2, _))
when opened_object f1 & opened_object f2 ->
(* Same row variable implies same object. *)
@@ -2574,7 +2620,9 @@ let nondep_type_decl env mid id is_covariant decl =
Some (unroll_abbrev id params (nondep_type_rec env mid ty))
with Not_found when is_covariant ->
None
- end }
+ end;
+ type_variance = decl.type_variance;
+ }
in
cleanup_types ();
List.iter unmark_type decl.type_params;
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 11fa5cd14..a91621fb0 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -59,7 +59,7 @@ let type_declarations env id decl1 decl2 =
(ty2::decl2.type_params))
labels1 labels2
| (_, _) -> false
- end &
+ end &&
begin match (decl1.type_manifest, decl2.type_manifest) with
(_, None) ->
Ctype.equal env true decl1.type_params decl2.type_params
@@ -73,7 +73,10 @@ let type_declarations env id decl1 decl2 =
Ctype.equal env true decl1.type_params decl2.type_params
&
Ctype.equal env false [ty1] [ty2]
- end
+ end &&
+ List.for_all2
+ (fun (co1,cn1) (co2,cn2) -> (not co1 || co2) && (not cn1 || cn2))
+ decl1.type_variance decl2.type_variance
(* Inclusion between exception declarations *)
diff --git a/typing/mtype.ml b/typing/mtype.ml
index 111367daa..d984a32a3 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -46,13 +46,9 @@ and strengthen_sig env sg p =
let newdecl =
match decl.type_manifest with
None ->
- { type_params = decl.type_params;
- type_arity = decl.type_arity;
- type_kind = decl.type_kind;
- type_manifest = Some(Btype.newgenty(
- Tconstr(Pdot(p, Ident.name id, nopos),
- decl.type_params,
- ref Mnil))) }
+ { decl with type_manifest =
+ 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_exception(id, d) as sigelt) :: rem ->
diff --git a/typing/predef.ml b/typing/predef.ml
index e9df52b34..b32faada4 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -80,45 +80,53 @@ let build_initial_env add_type add_exception empty_env =
{type_params = [];
type_arity = 0;
type_kind = Type_abstract;
- type_manifest = None}
+ type_manifest = None;
+ type_variance = []}
and decl_bool =
{type_params = [];
type_arity = 0;
type_kind = Type_variant["false",[]; "true",[]];
- type_manifest = None}
+ type_manifest = None;
+ type_variance = []}
and decl_unit =
{type_params = [];
type_arity = 0;
type_kind = Type_variant["()",[]];
- type_manifest = None}
+ type_manifest = None;
+ type_variance = []}
and decl_exn =
{type_params = [];
type_arity = 0;
type_kind = Type_variant [];
- type_manifest = None}
+ type_manifest = None;
+ type_variance = []}
and decl_array =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = Type_abstract;
- type_manifest = None}
+ type_manifest = None;
+ type_variance = [true, true]}
and decl_list =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = Type_variant["[]", []; "::", [tvar; type_list tvar]];
- type_manifest = None}
+ type_manifest = None;
+ type_variance = [true, false]}
and decl_format =
{type_params = [newgenvar(); newgenvar(); newgenvar()];
type_arity = 3;
type_kind = Type_abstract;
- type_manifest = None}
+ type_manifest = None;
+ type_variance = [true, true; true, true; true, true]}
and decl_option =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = Type_variant["None", []; "Some", [tvar]];
- type_manifest = None}
+ type_manifest = None;
+ type_variance = [true, false]}
in
add_exception ident_match_failure
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 9d3e83bf4..5adffc907 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -383,7 +383,22 @@ let rec type_decl kwd id ppf decl =
let print_manifest ppf decl =
match decl.type_manifest with
- | None -> ()
+ | None ->
+ if decl.type_kind = Type_abstract
+ && List.exists (fun p -> p <> (true,true)) decl.type_variance then
+ let select f l1 l2 =
+ List.fold_right2 (fun x y l -> if f x then y :: l else l) l1 l2 []
+ in
+ let repres f =
+ let l = select f decl.type_variance params in
+ if l = [] then Predef.type_unit else Btype.newgenty (Ttuple l)
+ in
+ let covar = repres fst and convar = repres snd in
+ let ty =
+ if convar == Predef.type_unit then covar
+ else Btype.newgenty (Tarrow ("", convar, covar))
+ in
+ fprintf ppf " as@ %a" type_expr ty
| Some ty -> fprintf ppf " =@ %a" type_expr ty in
let print_name_args ppf decl =
diff --git a/typing/subst.ml b/typing/subst.ml
index b556a2bae..c850684fa 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -168,7 +168,8 @@ let type_declaration s decl =
begin match decl.type_manifest with
None -> None
| Some ty -> Some(typexp s ty)
- end
+ end;
+ type_variance = decl.type_variance;
}
in
cleanup_types ();
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 2669e0763..33daadf10 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -784,7 +784,8 @@ let temp_abbrev env id arity =
{type_params = !params;
type_arity = arity;
type_kind = Type_abstract;
- type_manifest = Some ty }
+ type_manifest = Some ty;
+ type_variance = List.map (fun _ -> true, true) !params}
env
in
(!params, ty, env)
@@ -964,7 +965,8 @@ let class_infos define_class kind
{type_params = obj_params;
type_arity = List.length obj_params;
type_kind = Type_abstract;
- type_manifest = Some obj_ty }
+ type_manifest = Some obj_ty;
+ type_variance = List.map (fun _ -> true, true) obj_params}
in
let (cl_params, cl_ty) =
Ctype.instance_parameterized_type params (Ctype.self_type typ)
@@ -975,16 +977,16 @@ let class_infos define_class kind
{type_params = cl_params;
type_arity = List.length cl_params;
type_kind = Type_abstract;
- type_manifest = Some cl_ty }
+ type_manifest = Some cl_ty;
+ type_variance = List.map (fun _ -> true, true) cl_params}
in
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, expr) :: res,
env)
-let final_env define_class
+let final_decl define_class
(cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, expr)
- (res, env) =
+ arity, pub_meths, expr) =
List.iter Ctype.generalize clty.cty_params;
generalize_class_type clty.cty_type;
@@ -1020,15 +1022,32 @@ let final_env define_class
raise(Error(cl.pci_loc, Unbound_type_var(printer, reason)))
end;
- let env =
- Env.add_type obj_id obj_abbr (
- Env.add_type cl_id cl_abbr (
- Env.add_cltype ty_id cltydef (
- if define_class then Env.add_class id clty env else env)))
- in
- ((id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
- arity, pub_meths, expr)::res,
- env)
+ (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+ arity, pub_meths, expr)
+
+let extract_type_decls
+ (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+ arity, pub_meths, expr) decls =
+ (obj_id, obj_abbr) :: (cl_id, cl_abbr) :: decls
+
+let rec compact = function
+ [] -> []
+ | a :: b :: l -> (a,b) :: compact l
+ | _ -> fatal_error "Typeclass.compact"
+
+let merge_type_decls
+ (id, clty, ty_id, cltydef, _obj_id, _obj_abbr, _cl_id, _cl_abbr,
+ arity, pub_meths, expr) ((obj_id, obj_abbr), (cl_id, cl_abbr)) =
+ (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+ arity, pub_meths, expr)
+
+let final_env define_class env
+ (id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
+ arity, pub_meths, expr) =
+ Env.add_type obj_id obj_abbr (
+ Env.add_type cl_id cl_abbr (
+ Env.add_cltype ty_id cltydef (
+ if define_class then Env.add_class id clty env else env)))
(*******************************)
@@ -1050,10 +1069,12 @@ let type_classes define_class approx kind env cls =
List.fold_right (class_infos define_class kind) res ([], env)
in
Ctype.end_def ();
- let (res, env) =
- List.fold_right (final_env define_class) res ([], env)
- in
- (List.rev res, env)
+ let res = List.rev_map (final_decl 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 env = List.fold_left (final_env define_class) env res in
+ (res, env)
let class_num = ref 0
let class_declaration env sexpr =
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 984bab486..8dd6e628e 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -15,6 +15,7 @@
(**** Typing of type definitions ****)
open Misc
+open Asttypes
open Parsetree
open Primitive
open Types
@@ -37,6 +38,7 @@ type error =
| Unbound_type_var
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
+ | Constructor_in_variance
exception Error of Location.t * error
@@ -49,8 +51,10 @@ let enter_type env (name, sdecl) id =
type_arity = List.length sdecl.ptype_params;
type_kind = Type_abstract;
type_manifest =
- match sdecl.ptype_manifest with None -> None
- | Some _ -> Some(Ctype.newvar ()) }
+ begin match sdecl.ptype_manifest with None -> None
+ | Some _ -> Some(Ctype.newvar ()) end;
+ type_variance = List.map (fun _ -> true, true) sdecl.ptype_params;
+ }
in
Env.add_type id decl env
@@ -92,7 +96,7 @@ let transl_declaration env (name, sdecl) id =
type_arity = List.length params;
type_kind =
begin match sdecl.ptype_kind with
- Ptype_abstract ->
+ Ptype_abstract _ ->
Type_abstract
| Ptype_variant cstrs ->
let all_constrs = ref StringSet.empty in
@@ -136,7 +140,18 @@ let transl_declaration env (name, sdecl) id =
if Ctype.cyclic_abbrev env id ty then
raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
Some ty
- end; } in
+ end;
+ type_variance = List.map (fun _ -> true, true) params;
+ } in
+ let variance =
+ match sdecl.ptype_kind with
+ Ptype_abstract(Some sty) ->
+ begin try Some (transl_simple_type Env.initial true sty)
+ with Typetexp.Error (loc, Unbound_type_constructor lid) ->
+ raise (Error(loc, Constructor_in_variance))
+ end
+ | _ -> None
+ in
(* Check constraints *)
List.iter
@@ -148,7 +163,7 @@ let transl_declaration env (name, sdecl) id =
raise(Error(loc, Unconsistent_constraint)))
sdecl.ptype_cstrs;
- (id, decl)
+ ((id, decl), variance)
(* Generalize a type declaration *)
@@ -312,6 +327,114 @@ let check_expansion env id_loc_list (id, decl) =
check_expansion_rec env id args
(List.assoc id id_loc_list) id_loc_list [] body
+(* Compute variance *)
+let compute_variance env tvl nega posi ty =
+ let pvisited = ref TypeSet.empty
+ and nvisited = ref TypeSet.empty in
+ let rec compute_variance_rec posi nega ty =
+ let ty = Ctype.repr ty in
+ if (not posi || TypeSet.mem ty !pvisited)
+ && (not nega || TypeSet.mem ty !nvisited) then
+ ()
+ else begin
+ if posi then pvisited := TypeSet.add ty !pvisited;
+ if nega then nvisited := TypeSet.add ty !nvisited;
+ match ty.desc with
+ Tarrow (_, ty1, ty2) ->
+ compute_variance_rec nega posi ty1;
+ compute_variance_rec posi nega ty2
+ | Ttuple tl ->
+ List.iter (compute_variance_rec posi nega) tl
+ | Tconstr (path, tl, _) ->
+ if tl = [] then () else
+ let decl = Env.find_type path env in
+ List.iter2
+ (fun ty (co,cn) ->
+ compute_variance_rec
+ (posi && co || nega && cn)
+ (posi && cn || nega && co)
+ ty)
+ tl decl.type_variance
+ | Tobject (ty, _) ->
+ compute_variance_rec posi nega ty
+ | Tfield (_, _, ty1, ty2) ->
+ compute_variance_rec posi nega ty1;
+ compute_variance_rec posi nega ty2
+ | Tsubst ty ->
+ compute_variance_rec posi nega ty
+ | Tvariant row ->
+ List.iter
+ (fun (_,f) ->
+ match Btype.row_field_repr f with
+ Rpresent (Some ty) ->
+ compute_variance_rec posi nega ty
+ | Reither (_, tyl, _) ->
+ List.iter (compute_variance_rec posi nega) tyl
+ | _ -> ())
+ (Btype.row_repr row).row_fields
+ | Tvar | Tnil | Tlink _ -> ()
+ end
+ in
+ compute_variance_rec nega posi ty;
+ List.iter
+ (fun (ty, covar, convar) ->
+ if TypeSet.mem ty !pvisited then covar := true;
+ if TypeSet.mem ty !nvisited then convar := true)
+ tvl
+
+let compute_variance_decl env decl abstract =
+ let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false))
+ decl.type_params in
+ begin match decl.type_kind with
+ Type_abstract ->
+ begin match decl.type_manifest, abstract with
+ None, None -> List.iter (fun (_, co, cn) -> co := true; cn := true) tvl
+ | Some ty, None -> compute_variance env tvl true false ty
+ | None, Some ty -> compute_variance env tvl true false ty
+ | _ -> assert false
+ end
+ | Type_variant tll ->
+ List.iter
+ (fun (_,tl) -> List.iter (compute_variance env tvl true false) tl)
+ tll
+ | Type_record (ftl, _) ->
+ List.iter
+ (fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
+ ftl
+ end;
+ List.map (fun (_, co, cn) -> (!co, !cn)) tvl
+
+let rec compute_variance_fixpoint env decls abstract variances =
+ let new_decls =
+ List.map2
+ (fun (id, decl) variance -> id, {decl with type_variance = variance})
+ decls variances
+ in
+ let new_env =
+ List.fold_right (fun (id, decl) env -> Env.add_type id decl env)
+ new_decls env
+ in
+ let new_variances =
+ List.map2 (fun (_, decl) -> compute_variance_decl new_env decl)
+ new_decls abstract
+ in
+ let new_variances =
+ List.map2 (List.map2 (fun (c1,n1) (c2,n2) -> (c1||c2), (n1||n2)))
+ new_variances variances in
+ if new_variances = variances then
+ new_decls, new_env
+ else
+ compute_variance_fixpoint env decls abstract new_variances
+
+(* for typeclass.ml *)
+let compute_variance_decls env decls =
+ let variances =
+ List.map
+ (fun (_, decl) -> List.map (fun _ -> (false, false)) decl.type_params)
+ decls
+ and abstract = List.map (fun _ -> None) decls in
+ fst (compute_variance_fixpoint env decls abstract variances)
+
(* Translate a set of mutually recursive type declarations *)
let transl_type_decl env name_sdecl_list =
(* Create identifiers. *)
@@ -331,6 +454,7 @@ let transl_type_decl env name_sdecl_list =
(* Translate each declaration. *)
let decls =
List.map2 (transl_declaration temp_env) name_sdecl_list id_list in
+ let decls, abstract = List.split decls in
(* Build the final env. *)
let newenv =
List.fold_right
@@ -366,8 +490,14 @@ let transl_type_decl env name_sdecl_list =
id_list name_sdecl_list
in
List.iter (check_expansion newenv (List.flatten id_loc_list)) decls;
+ (* Add variances to the environment *)
+ let final_decls, final_env =
+ compute_variance_fixpoint env decls abstract
+ (List.map
+ (fun (_,decl) -> List.map (fun _ -> (false, false)) decl.type_params)
+ decls) in
(* Done *)
- (decls, newenv)
+ (final_decls, final_env)
(* Translate an exception declaration *)
let transl_exception env excdecl =
@@ -432,8 +562,12 @@ let transl_with_constraint env sdecl =
begin match sdecl.ptype_manifest with
None -> None
| Some sty -> Some(transl_simple_type env true sty)
- end }
+ end;
+ type_variance = [];
+ }
in
+ let decl =
+ {decl with type_variance = compute_variance_decl env decl None} in
Ctype.end_def();
generalize_decl decl;
decl
@@ -493,3 +627,5 @@ let report_error ppf = function
| Not_an_exception lid ->
fprintf ppf "The constructor@ %a@ is not an exception"
Printtyp.longident lid
+ | Constructor_in_variance ->
+ fprintf ppf "Type constructors are not allowed in variance declarations"
diff --git a/typing/typedecl.mli b/typing/typedecl.mli
index 95d23887a..198398561 100644
--- a/typing/typedecl.mli
+++ b/typing/typedecl.mli
@@ -31,6 +31,11 @@ val transl_value_decl:
val transl_with_constraint:
Env.t -> Parsetree.type_declaration -> type_declaration
+
+(* for typeclass.ml *)
+val compute_variance_decls:
+ Env.t ->
+ (Ident.t * type_declaration) list -> (Ident.t * type_declaration) list
type error =
Repeated_parameter
@@ -48,6 +53,7 @@ type error =
| Unbound_type_var
| Unbound_exception of Longident.t
| Not_an_exception of Longident.t
+ | Constructor_in_variance
exception Error of Location.t * error
diff --git a/typing/types.ml b/typing/types.ml
index b9b54a00c..b35d81d84 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -117,7 +117,8 @@ type type_declaration =
{ type_params: type_expr list;
type_arity: int;
type_kind: type_kind;
- type_manifest: type_expr option }
+ type_manifest: type_expr option;
+ type_variance: (bool * bool) list }
and type_kind =
Type_abstract
diff --git a/typing/types.mli b/typing/types.mli
index 9a66d1b57..784af17fa 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -116,7 +116,8 @@ type type_declaration =
{ type_params: type_expr list;
type_arity: int;
type_kind: type_kind;
- type_manifest: type_expr option }
+ type_manifest: type_expr option;
+ type_variance: (bool * bool) list } (* covariant, contravariant *)
and type_kind =
Type_abstract
diff --git a/utils/config.mlp b/utils/config.mlp
index 0b0fa9046..024d65aaf 100644
--- a/utils/config.mlp
+++ b/utils/config.mlp
@@ -12,7 +12,7 @@
(* $Id$ *)
-let version = "3.00+12 (2000-09-04)"
+let version = "3.00+13 (2000-09-06)"
let standard_library =
try
@@ -30,7 +30,7 @@ let c_libraries = "%%CCLIBS%%"
let ranlib = "%%RANLIBCMD%%"
let exec_magic_number = "Caml1999X006"
-and cmi_magic_number = "Caml1999I006"
+and cmi_magic_number = "Caml1999I007"
and cmo_magic_number = "Caml1999O004"
and cma_magic_number = "Caml1999A005"
and cmx_magic_number = "Caml1999Y006"
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-14 07:18:47 +0000