Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ajout des variances 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@3294 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2000-09-06 10:21:07 +00:00
parent e477ccd225
commit 83ca813e4b
17 changed files with 333 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
otherlibs/labltk/browser/searchpos.ml
View File

@ -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))

8
parsing/parser.mly
View File

@ -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

2
parsing/parsetree.mli
View File

@ -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

4
parsing/printast.ml
View File

@ -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;

2
tools/ocamldep.ml
View File

@ -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 ->

120
typing/ctype.ml
View File

@ -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;

7
typing/includecore.ml
View File

@ -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 *)

10
typing/mtype.ml
View File

@ -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 ->

24
typing/predef.ml
View File

@ -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

17
typing/printtyp.ml
View File

@ -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 =

3
typing/subst.ml
View File

@ -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 ();

59
typing/typeclass.ml
View File

@ -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 =

150
typing/typedecl.ml
View File

@ -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"

6
typing/typedecl.mli
View File

@ -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

3
typing/types.ml
View File

@ -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

3
typing/types.mli
View File

@ -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

4
utils/config.mlp
View File

@ -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"