summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--stdlib/sys.ml2
-rw-r--r--typing/ctype.ml10
-rw-r--r--typing/includecore.ml2
-rw-r--r--typing/predef.ml11
-rw-r--r--typing/printtyp.ml5
-rw-r--r--typing/typeclass.ml6
-rw-r--r--typing/typedecl.ml76
-rw-r--r--typing/types.ml2
-rw-r--r--typing/types.mli3
9 files changed, 67 insertions, 50 deletions
diff --git a/stdlib/sys.ml b/stdlib/sys.ml
index 7faaf27f0..1a12fca48 100644
--- a/stdlib/sys.ml
+++ b/stdlib/sys.ml
@@ -78,4 +78,4 @@ let catch_break on =
(* OCaml version string, must be in the format described in sys.mli. *)
-let ocaml_version = "3.06+33 (2003-05-19)";;
+let ocaml_version = "3.06+34 (2003-05-21)";;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index ab6e13927..8237fb726 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -629,11 +629,11 @@ let rec generalize_expansive env var_level ty =
Tconstr (path, tyl, abbrev) ->
let variance =
try (Env.find_type path env).type_variance
- with Not_found -> List.map (fun _ -> (true,true)) tyl in
+ with Not_found -> List.map (fun _ -> (true,true,true)) tyl in
abbrev := Mnil;
List.iter2
- (fun (co,cn) t ->
- if cn then update_level env var_level t
+ (fun (co,cn,ct) t ->
+ if ct then update_level env var_level t
else generalize_expansive env var_level t)
variance tyl
| Tarrow (_, t1, t2, _) ->
@@ -2607,7 +2607,7 @@ let rec build_subtype env visited loops posi level t =
if level = 0 && generic_abbrev env p then warn := true;
let tl' =
List.map2
- (fun (co,cn) t ->
+ (fun (co,cn,_) t ->
if cn then
if co then (t, Unchanged)
else build_subtype env visited loops (not posi) level t
@@ -2744,7 +2744,7 @@ let rec subtype_rec env trace t1 t2 cstrs =
begin try
let decl = Env.find_type p1 env in
List.fold_left2
- (fun cstrs (co, cn) (t1, t2) ->
+ (fun cstrs (co, cn, _) (t1, t2) ->
if co then
if cn then
(trace, newty2 t1.level (Ttuple[t1]),
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 63050cf6d..a67eb3f87 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -78,7 +78,7 @@ let type_declarations env id decl1 decl2 =
end &&
begin decl2.type_kind <> Type_abstract || decl2.type_manifest <> None ||
List.for_all2
- (fun (co1,cn1) (co2,cn2) -> (not co1 || co2) && (not cn1 || cn2))
+ (fun (co1,cn1,ct1) (co2,cn2,ct2) -> (not co1 || co2) && (not cn1 || cn2))
decl1.type_variance decl2.type_variance
end
diff --git a/typing/predef.ml b/typing/predef.ml
index 290654553..bd141224e 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -111,34 +111,35 @@ let build_initial_env add_type add_exception empty_env =
type_arity = 1;
type_kind = Type_abstract;
type_manifest = None;
- type_variance = [true, true]}
+ type_variance = [true, 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_variance = [true, false]}
+ type_variance = [true, false, false]}
and decl_format =
{type_params = [newgenvar(); newgenvar(); newgenvar(); newgenvar()];
type_arity = 4;
type_kind = Type_abstract;
type_manifest = None;
- type_variance = [true, true; true, true; true, true; true, true]}
+ type_variance = [true, true, true; true, true, true;
+ 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_variance = [true, false]}
+ type_variance = [true, false, false]}
and decl_lazy_t =
let tvar = newgenvar() in
{type_params = [tvar];
type_arity = 1;
type_kind = Type_abstract;
type_manifest = None;
- type_variance = [true, false]}
+ type_variance = [true, false, false]}
in
add_exception ident_match_failure
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 629f96a46..e56b8e9ac 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -412,11 +412,12 @@ let rec tree_of_type_decl id decl =
in
let type_defined decl =
if decl.type_kind = Type_abstract && decl.type_manifest = None
- && List.exists (fun x -> x <> (true, true)) decl.type_variance then
+ && List.exists (fun x -> x <> (true,true,true)) decl.type_variance then
+ let vari = List.map (fun (co,cn,ct) -> (co,cn)) decl.type_variance in
(Ident.name id,
List.combine
(List.map (fun ty -> type_param (tree_of_typexp false ty)) params)
- decl.type_variance)
+ vari)
else
let ty =
tree_of_typexp false
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 716f6fd36..bf4185d23 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -864,7 +864,7 @@ let temp_abbrev env id arity =
type_arity = arity;
type_kind = Type_abstract;
type_manifest = Some ty;
- type_variance = List.map (fun _ -> true, true) !params}
+ type_variance = List.map (fun _ -> true, true, true) !params}
env
in
(!params, ty, env)
@@ -1061,7 +1061,7 @@ let class_infos define_class kind
type_arity = List.length obj_params;
type_kind = Type_abstract;
type_manifest = Some obj_ty;
- type_variance = List.map (fun _ -> true, true) obj_params}
+ type_variance = List.map (fun _ -> true, true, true) obj_params}
in
let (cl_params, cl_ty) =
Ctype.instance_parameterized_type params (Ctype.self_type typ)
@@ -1073,7 +1073,7 @@ let class_infos define_class kind
type_arity = List.length cl_params;
type_kind = Type_abstract;
type_manifest = Some cl_ty;
- type_variance = List.map (fun _ -> true, true) cl_params}
+ type_variance = List.map (fun _ -> true, true, true) cl_params}
in
((cl, id, clty, ty_id, cltydef, obj_id, obj_abbr, cl_id, cl_abbr,
arity, pub_meths, List.rev !coercion_locs, expr) :: res,
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 64dd11fc4..0bb25ddcb 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -54,7 +54,7 @@ let enter_type env (name, sdecl) id =
type_manifest =
begin match sdecl.ptype_manifest with None -> None
| Some _ -> Some(Ctype.newvar ()) end;
- type_variance = List.map (fun _ -> true, true) sdecl.ptype_params;
+ type_variance = List.map (fun _ -> true, true, true) sdecl.ptype_params;
}
in
Env.add_type id decl env
@@ -152,7 +152,7 @@ let transl_declaration env (name, sdecl) id =
raise(Error(sdecl.ptype_loc, Recursive_abbrev name));
Some ty
end;
- type_variance = List.map (fun _ -> true, true) params;
+ type_variance = List.map (fun _ -> true, true, true) params;
} in
(* Check constraints *)
@@ -352,92 +352,103 @@ let check_expansion env id_loc_list (id, decl) =
(List.assoc id id_loc_list) id_check_list [] body
(* Compute variance *)
-let compute_variance env tvl nega posi ty =
+let compute_variance env tvl nega posi cntr ty =
let pvisited = ref TypeSet.empty
- and nvisited = ref TypeSet.empty in
- let rec compute_variance_rec posi nega ty =
+ and nvisited = ref TypeSet.empty
+ and cvisited = ref TypeSet.empty in
+ let rec compute_variance_rec posi nega cntr ty =
let ty = Ctype.repr ty in
if (not posi || TypeSet.mem ty !pvisited)
- && (not nega || TypeSet.mem ty !nvisited) then
+ && (not nega || TypeSet.mem ty !nvisited)
+ && (not cntr || TypeSet.mem ty !cvisited) then
()
else begin
if posi then pvisited := TypeSet.add ty !pvisited;
if nega then nvisited := TypeSet.add ty !nvisited;
+ if cntr then cvisited := TypeSet.add ty !cvisited;
+ let compute_same = compute_variance_rec posi nega cntr in
match ty.desc with
Tarrow (_, ty1, ty2, _) ->
- compute_variance_rec nega posi ty1;
- compute_variance_rec posi nega ty2
+ compute_variance_rec nega posi true ty1;
+ compute_same ty2
| Ttuple tl ->
- List.iter (compute_variance_rec posi nega) tl
+ List.iter compute_same tl
| Tconstr (path, tl, _) ->
if tl = [] then () else begin
try
let decl = Env.find_type path env in
List.iter2
- (fun ty (co,cn) ->
+ (fun ty (co,cn,ct) ->
compute_variance_rec
(posi && co || nega && cn)
(posi && cn || nega && co)
+ (cntr || ct)
ty)
tl decl.type_variance
with Not_found ->
- List.iter (compute_variance_rec true true) tl
+ List.iter (compute_variance_rec true true true) tl
end
| Tobject (ty, _) ->
- compute_variance_rec posi nega ty
+ compute_same ty
| Tfield (_, _, ty1, ty2) ->
- compute_variance_rec posi nega ty1;
- compute_variance_rec posi nega ty2
+ compute_same ty1;
+ compute_same ty2
| Tsubst ty ->
- compute_variance_rec posi nega ty
+ compute_same ty
| Tvariant row ->
List.iter
(fun (_,f) ->
match Btype.row_field_repr f with
Rpresent (Some ty) ->
- compute_variance_rec posi nega ty
+ compute_same ty
| Reither (_, tyl, _, _) ->
- List.iter (compute_variance_rec posi nega) tyl
+ List.iter compute_same tyl
| _ -> ())
(Btype.row_repr row).row_fields
| Tpoly (ty, _) ->
- compute_variance_rec posi nega ty
+ compute_same ty
| Tvar | Tnil | Tlink _ | Tunivar -> ()
end
in
- compute_variance_rec nega posi ty;
+ compute_variance_rec nega posi cntr ty;
List.iter
- (fun (ty, covar, convar) ->
+ (fun (ty, covar, convar, ctvar) ->
if TypeSet.mem ty !pvisited then covar := true;
- if TypeSet.mem ty !nvisited then convar := true)
+ if TypeSet.mem ty !nvisited then convar := true;
+ if TypeSet.mem ty !cvisited then ctvar := true)
tvl
let compute_variance_decl env 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) else (true, true)) required
+ 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))
+ let tvl =
+ List.map (fun ty -> (Btype.repr ty, ref false, ref false, ref false))
decl.type_params in
let rec variance_tkind = function
Type_abstract ->
begin match decl.type_manifest with
None -> assert false
- | Some ty -> compute_variance env tvl true false ty
+ | Some ty -> compute_variance env tvl true false false ty
end
| Type_variant tll ->
List.iter
- (fun (_,tl) -> List.iter (compute_variance env tvl true false) tl)
+ (fun (_,tl) ->
+ List.iter (compute_variance env tvl true false false) tl)
tll
| Type_record (ftl, _) ->
List.iter
- (fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
+ (fun (_, mut, ty) ->
+ let cn = (mut = Mutable) in
+ compute_variance env tvl true cn cn ty)
ftl
| Type_private tkind -> variance_tkind tkind in
variance_tkind decl.type_kind;
List.map2
- (fun (_, co, cn) (c, n) ->
+ (fun (_, co, cn, ct) (c, n) ->
if c && !cn || n && !co then raise (Error(loc, Bad_variance));
- (!co, !cn))
+ (!co, !cn, !ct))
tvl required
let rec compute_variance_fixpoint env decls required variances =
@@ -455,7 +466,8 @@ let rec compute_variance_fixpoint env decls required variances =
new_decls required
in
let new_variances =
- List.map2 (List.map2 (fun (c1,n1) (c2,n2) -> (c1||c2), (n1||n2)))
+ List.map2
+ (List.map2 (fun (c1,n1,t1) (c2,n2,t2) -> c1||c2, n1||n2, t1||t2))
new_variances variances in
if new_variances = variances then
new_decls, new_env
@@ -466,7 +478,8 @@ let rec compute_variance_fixpoint env decls required variances =
let compute_variance_decls env decls =
let decls, required = List.split decls in
let variances =
- List.map (fun (l,_) -> List.map (fun _ -> false, false) l) required in
+ List.map (fun (l,_) -> List.map (fun _ -> false, false, false) l) required
+ in
fst (compute_variance_fixpoint env decls required variances)
(* Translate a set of mutually recursive type declarations *)
@@ -531,7 +544,8 @@ let transl_type_decl env name_sdecl_list =
let final_decls, final_env =
compute_variance_fixpoint env decls required
(List.map
- (fun (_,decl) -> List.map (fun _ -> (false, false)) decl.type_params)
+ (fun (_,decl) -> List.map (fun _ -> (false, false, false))
+ decl.type_params)
decls) in
(* Done *)
(final_decls, final_env)
diff --git a/typing/types.ml b/typing/types.ml
index 6d67a89f0..f541f50e6 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -133,7 +133,7 @@ type type_declaration =
type_arity: int;
type_kind: type_kind;
type_manifest: type_expr option;
- type_variance: (bool * bool) list }
+ type_variance: (bool * bool * bool) list }
and type_kind =
Type_abstract
diff --git a/typing/types.mli b/typing/types.mli
index c2a219db3..62d9654c7 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -134,7 +134,8 @@ type type_declaration =
type_arity: int;
type_kind: type_kind;
type_manifest: type_expr option;
- type_variance: (bool * bool) list } (* covariant, contravariant *)
+ type_variance: (bool * bool * bool) list }
+ (* covariant, contravariant, weakly contravariant *)
and type_kind =
Type_abstract
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-20 04:07:34 +0000