summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/btype.ml5
-rw-r--r--typing/ctype.ml53
-rw-r--r--typing/env.ml19
-rw-r--r--typing/ident.ml9
-rw-r--r--typing/ident.mli4
-rw-r--r--typing/includecore.ml9
-rw-r--r--typing/oprint.ml42
-rw-r--r--typing/outcometree.mli4
-rw-r--r--typing/parmatch.ml224
-rw-r--r--typing/printtyp.ml19
-rw-r--r--typing/subst.ml9
-rw-r--r--typing/typeclass.ml51
-rw-r--r--typing/typecore.ml225
-rw-r--r--typing/typecore.mli2
-rw-r--r--typing/typedecl.ml84
-rw-r--r--typing/typemod.ml124
-rw-r--r--typing/typemod.mli2
-rw-r--r--typing/types.ml1
-rw-r--r--typing/types.mli1
-rw-r--r--typing/typetexp.ml46
-rw-r--r--typing/typetexp.mli3
21 files changed, 627 insertions, 309 deletions
diff --git a/typing/btype.ml b/typing/btype.ml
index df5242c7f3..263eec2c63 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -252,13 +252,14 @@ let rec unmark_type ty =
let unmark_type_decl decl =
List.iter unmark_type decl.type_params;
- begin match decl.type_kind with
+ let rec unmark_tkind = function
Type_abstract -> ()
| Type_variant cstrs ->
List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
| Type_record(lbls, rep) ->
List.iter (fun (c, mut, t) -> unmark_type t) lbls
- end;
+ | Type_private tkind -> unmark_tkind tkind in
+ unmark_tkind decl.type_kind;
begin match decl.type_manifest with
None -> ()
| Some ty -> unmark_type ty
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 21e6571d19..02b4ce2196 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -422,14 +422,15 @@ let closed_parameterized_type params ty =
let closed_type_decl decl =
try
List.iter mark_type decl.type_params;
- begin match decl.type_kind with
+ let rec closed_tkind = function
Type_abstract ->
()
| Type_variant v ->
List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> closed_type ty) r
- end;
+ | Type_private tkind -> closed_tkind tkind in
+ closed_tkind decl.type_kind;
begin match decl.type_manifest with
None -> ()
| Some ty -> closed_type ty
@@ -760,7 +761,7 @@ let rec copy ty =
let more = repr row.row_more in
(* We must substitute in a subtle way *)
begin match more.desc with
- Tsubst ({desc=Tvariant _} as ty2) ->
+ Tsubst ty2 when (repr ty2).desc <> Tunivar ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
@@ -928,7 +929,7 @@ let rec copy_sep fixed free bound visited ty =
let bound = tl @ bound in
let visited =
List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in
- Tpoly (copy_rec t1, tl')
+ Tpoly (copy_sep fixed free bound visited t1, tl')
| _ -> copy_type_desc copy_rec ty.desc
end;
t
@@ -1022,7 +1023,19 @@ let rec find_expans p1 =
| Mlink {contents = rem} ->
find_expans p1 rem
+
+(*
+ If the environnement has changed, memorized expansions might not
+ be correct anymore, and so we flush the cache. This is safe but
+ quite pessimistic: it would be enough to flush the cache when a
+ type or module definition is overriden in the environnement.
+*)
let previous_env = ref Env.empty
+let check_abbrev_env env =
+ if env != !previous_env then begin
+ cleanup_abbrev ();
+ previous_env := env
+ end
(* Expand an abbreviation. The expansion is memorized. *)
(*
@@ -1043,16 +1056,7 @@ let previous_env = ref Env.empty
and this other expansion fails.
*)
let expand_abbrev env ty =
- (*
- If the environnement has changed, memorized expansions might not
- be correct anymore, and so we flush the cache. This is safe but
- quite pessimistic: it would be enough to flush the cache when a
- type or module definition is overriden in the environnement.
- *)
- if env != !previous_env then begin
- cleanup_abbrev ();
- previous_env := env
- end;
+ check_abbrev_env env;
match ty with
{desc = Tconstr (path, args, abbrev); level = level} ->
let lookup_abbrev = proper_abbrevs path args abbrev in
@@ -1173,6 +1177,7 @@ let rec non_recursive_abbrev env ty0 ty =
end
let correct_abbrev env ident params ty =
+ check_abbrev_env env;
let ty0 = newgenvar () in
visited := [];
let abbrev = Mcons (Path.Pident ident, ty0, ty0, Mnil) in
@@ -2342,6 +2347,11 @@ let moregeneral env inst_nongen pat_sch subj_sch =
(* Equivalence between parameterized types *)
(*********************************************)
+let normalize_subst subst =
+ if List.exists
+ (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false)
+ !subst
+ then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst
let rec eqtype rename type_pairs subst env t1 t2 =
if t1 == t2 then () else
@@ -2353,6 +2363,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
match (t1.desc, t2.desc) with
(Tvar, Tvar) when rename ->
begin try
+ normalize_subst subst;
if List.assq t1 !subst != t2 then raise (Unify [])
with Not_found ->
subst := (t1, t2) :: !subst
@@ -2372,6 +2383,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
match (t1'.desc, t2'.desc) with
(Tvar, Tvar) when rename ->
begin try
+ normalize_subst subst;
if List.assq t1' !subst != t2' then raise (Unify [])
with Not_found ->
subst := (t1', t2') :: !subst
@@ -2808,7 +2820,7 @@ let rec build_subtype env visited loops posi level t =
try
let t' = List.assq t loops in
warn := true;
- (List.assq t loops, Equiv)
+ (t', Equiv)
with Not_found ->
(t, Unchanged)
else
@@ -2852,7 +2864,7 @@ let rec build_subtype env visited loops posi level t =
end
| None -> assert false in
let ty =
- subst env t'.level abbrev None cl_abbr.type_params tl body in
+ subst env !current_level abbrev None cl_abbr.type_params tl body in
let ty = repr ty in
let ty1, tl1 =
match ty.desc with
@@ -3354,7 +3366,7 @@ let nondep_type_decl env mid id is_covariant decl =
type_arity = decl.type_arity;
type_kind =
begin try
- match decl.type_kind with
+ let rec kind_of_tkind = function
Type_abstract ->
Type_abstract
| Type_variant cstrs ->
@@ -3367,6 +3379,8 @@ let nondep_type_decl env mid id is_covariant decl =
(fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t))
lbls,
rep)
+ | Type_private tkind -> Type_private (kind_of_tkind tkind) in
+ kind_of_tkind decl.type_kind
with Not_found when is_covariant ->
Type_abstract
end;
@@ -3384,13 +3398,14 @@ let nondep_type_decl env mid id is_covariant decl =
in
cleanup_types ();
List.iter unmark_type decl.type_params;
- begin match decl.type_kind with
+ let rec unmark_tkind = function
Type_abstract -> ()
| Type_variant cstrs ->
List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
| Type_record(lbls, rep) ->
List.iter (fun (c, mut, t) -> unmark_type t) lbls
- end;
+ | Type_private tkind -> unmark_tkind tkind in
+ unmark_tkind decl.type_kind;
begin match decl.type_manifest with
None -> ()
| Some ty -> unmark_type ty
diff --git a/typing/env.ml b/typing/env.ml
index 1e93b40ff8..33788d4796 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -363,7 +363,7 @@ and lookup_class =
lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
and lookup_cltype =
lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
-
+
(* Expand manifest module type names at the top of the given module type *)
let rec scrape_modtype mty env =
@@ -379,22 +379,27 @@ let rec scrape_modtype mty env =
(* Compute constructor descriptions *)
let constructors_of_type ty_path decl =
- match decl.type_kind with
- Type_variant cstrs ->
+ let rec constructors_of_tkind = function
+ | Type_variant cstrs ->
Datarepr.constructor_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
cstrs
- | _ -> []
+ | Type_private tkind -> constructors_of_tkind tkind
+ | Type_record _ | Type_abstract -> [] in
+ constructors_of_tkind decl.type_kind
+
(* Compute label descriptions *)
let labels_of_type ty_path decl =
- match decl.type_kind with
- Type_record(labels, rep) ->
+ let rec labels_of_tkind = function
+ | Type_record(labels, rep) ->
Datarepr.label_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
labels rep
- | _ -> []
+ | Type_private tkind -> labels_of_tkind tkind
+ | Type_variant _ | Type_abstract -> [] in
+ labels_of_tkind decl.type_kind
(* Given a signature and a root path, prefix all idents in the signature
by the root path and build the corresponding substitution. *)
diff --git a/typing/ident.ml b/typing/ident.ml
index afa589bad6..8997600d51 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -35,6 +35,8 @@ let name i = i.name
let unique_name i = i.name ^ "_" ^ string_of_int i.stamp
+let unique_toplevel_name i = i.name ^ "/" ^ string_of_int i.stamp
+
let persistent i = (i.stamp = 0)
let equal i1 i2 = i1.name = i2.name
@@ -50,6 +52,13 @@ let binding_time i = i.stamp
let current_time() = !currentstamp
let set_current_time t = currentstamp := max !currentstamp t
+let reinit_level = ref (-1)
+
+let reinit () =
+ if !reinit_level < 0
+ then reinit_level := !currentstamp
+ else currentstamp := !reinit_level
+
let hide i =
{ i with stamp = -1 }
diff --git a/typing/ident.mli b/typing/ident.mli
index 1d8d0580c7..1bec7fb7a1 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -21,6 +21,7 @@ val create_persistent: string -> t
val rename: t -> t
val name: t -> string
val unique_name: t -> string
+val unique_toplevel_name: t -> string
val persistent: t -> bool
val equal: t -> t -> bool
(* Compare identifiers by name. *)
@@ -32,7 +33,7 @@ val same: t -> t -> bool
name. *)
val hide: t -> t
(* Return an identifier with same name as the given identifier,
- but stamp different from any stamp returns by new.
+ but stamp different from any stamp returned by new.
When put in a 'a tbl, this identifier can only be looked
up by name. *)
@@ -42,6 +43,7 @@ val global: t -> bool
val binding_time: t -> int
val current_time: unit -> int
val set_current_time: int -> unit
+val reinit: unit -> unit
val print: Format.formatter -> t -> unit
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 9a8c941473..63050cf6d9 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -38,7 +38,7 @@ let value_descriptions env vd1 vd2 =
let type_declarations env id decl1 decl2 =
decl1.type_arity = decl2.type_arity &&
- begin match (decl1.type_kind, decl2.type_kind) with
+ let rec incl_tkinds = function
(_, Type_abstract) -> true
| (Type_variant cstrs1, Type_variant cstrs2) ->
Misc.for_all2
@@ -58,8 +58,11 @@ let type_declarations env id decl1 decl2 =
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
labels1 labels2
- | (_, _) -> false
- end &&
+ | (Type_private tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
+ | (tkind1, Type_private tkind2) -> incl_tkinds (tkind1, tkind2)
+ | (_, _) -> false in
+ incl_tkinds (decl1.type_kind, decl2.type_kind)
+ &&
begin match (decl1.type_manifest, decl2.type_manifest) with
(_, None) ->
Ctype.equal env true decl1.type_params decl2.type_params
diff --git a/typing/oprint.ml b/typing/oprint.ml
index 42f1331859..483230c324 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -40,6 +40,12 @@ let value_ident ppf name =
(* Values *)
+let parenthesize_if_neg ppf fmt v zero =
+ let neg = (v < zero) in
+ if neg then pp_print_char ppf '(';
+ fprintf ppf fmt v;
+ if neg then pp_print_char ppf ')'
+
let print_out_value ppf tree =
let rec print_tree_1 ppf =
function
@@ -52,14 +58,18 @@ let print_out_value ppf tree =
fprintf ppf "@[<2>`%s@ %a@]" name print_simple_tree param
| tree -> print_simple_tree ppf tree
and print_constr_param ppf = function
- | Oval_int i ->
- if i < 0 then fprintf ppf "(%i)" i else fprintf ppf "%i" i
- | Oval_float f ->
- if f < 0.0 then fprintf ppf "(%F)" f else fprintf ppf "%F" f
+ | Oval_int i -> parenthesize_if_neg ppf "%i" i 0
+ | Oval_int32 i -> parenthesize_if_neg ppf "%lil" i 0l
+ | Oval_int64 i -> parenthesize_if_neg ppf "%LiL" i 0L
+ | Oval_nativeint i -> parenthesize_if_neg ppf "%nin" i 0n
+ | Oval_float f -> parenthesize_if_neg ppf "%F" f 0.0
| tree -> print_simple_tree ppf tree
and print_simple_tree ppf =
function
Oval_int i -> fprintf ppf "%i" i
+ | Oval_int32 i -> fprintf ppf "%lil" i
+ | Oval_int64 i -> fprintf ppf "%LiL" i
+ | Oval_nativeint i -> fprintf ppf "%nin" i
| Oval_float f -> fprintf ppf "%F" f
| Oval_char c -> fprintf ppf "%C" c
| Oval_string s ->
@@ -78,7 +88,7 @@ let print_out_value ppf tree =
| Oval_ellipsis -> raise Ellipsis
| Oval_printer f -> f ppf
| Oval_tuple tree_list ->
- fprintf ppf "@[(%a)@]" (print_tree_list print_tree_1 ",") tree_list
+ fprintf ppf "@[<1>(%a)@]" (print_tree_list print_tree_1 ",") tree_list
| tree -> fprintf ppf "@[<1>(%a)@]" (cautious print_tree_1) tree
and print_fields first ppf =
function
@@ -125,7 +135,7 @@ let pr_vars =
let rec print_out_type ppf =
function
| Otyp_alias (ty, s) ->
- fprintf ppf "@[%a as '%s@]" print_out_type ty s
+ fprintf ppf "@[%a@ as '%s@]" print_out_type ty s
| Otyp_poly (sl, ty) ->
fprintf ppf "@[<hov 2>%a.@ %a@]"
pr_vars sl
@@ -169,14 +179,15 @@ and print_simple_out_type ppf =
| Ovar_name (id, tyl) ->
fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
in
- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a]@]" (if non_gen then "_" else "")
+ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
(if closed then if tags = None then " " else "< "
else if tags = None then "> " else "? ")
print_fields row_fields
print_present tags
| Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
fprintf ppf "@[<1>(%a)@]" print_out_type ty
- | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
+ | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_private _
+ | Otyp_manifest (_, _) -> ()
and print_fields rest ppf =
function
[] ->
@@ -359,21 +370,26 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) =
Otyp_manifest (_, ty) -> ty
| _ -> ty
in
- match ty with
- Otyp_abstract ->
+ let print_private ppf v = if v then fprintf ppf "private " in
+ let rec print_out_tkind v = function
+ | Otyp_abstract ->
fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints
constraints
| Otyp_record lbls ->
- fprintf ppf "@[<2>@[<hv 2>%t = {%a@;<1 -2>}@]@ %a@]" print_name_args
+ fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args
+ print_private v
(print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls
print_constraints constraints
| Otyp_sum constrs ->
- fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a@]%a@]" print_name_args
+ fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args
+ print_private v
(print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs
print_constraints constraints
+ | Otyp_private ty -> print_out_tkind true ty
| ty ->
fprintf ppf "@[<2>@[<hv 2>%t =@ %a@]%a@]" print_name_args !out_type
- ty print_constraints constraints
+ ty print_constraints constraints in
+ print_out_tkind false ty
and print_out_constr ppf (name, tyl) =
match tyl with
[] -> fprintf ppf "%s" name
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 0b027dd6be..1b0a30a79f 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -33,6 +33,9 @@ type out_value =
| Oval_ellipsis
| Oval_float of float
| Oval_int of int
+ | Oval_int32 of int32
+ | Oval_int64 of int64
+ | Oval_nativeint of nativeint
| Oval_list of out_value list
| Oval_printer of (Format.formatter -> unit)
| Oval_record of (out_ident * out_value) list
@@ -52,6 +55,7 @@ type out_type =
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
| Otyp_sum of (string * out_type list) list
+ | Otyp_private of out_type
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 95151e6bb3..828e004945 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -114,6 +114,12 @@ let get_type_descr ty tenv =
| Tconstr (path,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
+let get_type_path ty tenv =
+ let ty = Ctype.repr (Ctype.expand_head tenv ty) in
+ match ty.desc with
+ | Tconstr (path,_,_) -> path
+ | _ -> fatal_error "Parmatch.get_type_path"
+
let get_constr tag ty tenv =
match get_type_descr ty tenv with
| {type_kind=Type_variant constr_list} ->
@@ -156,12 +162,12 @@ let rec pretty_val ppf v = match v.pat_desc with
| Tpat_any -> fprintf ppf "_"
| Tpat_var x -> Ident.print ppf x
| Tpat_constant (Const_int i) -> fprintf ppf "%d" i
- | Tpat_constant (Const_char c) ->
- fprintf ppf "%C" c
- | Tpat_constant (Const_string s) ->
- fprintf ppf "%S" s
- | Tpat_constant (Const_float s) ->
- fprintf ppf "%s" s
+ | Tpat_constant (Const_char c) -> fprintf ppf "%C" c
+ | Tpat_constant (Const_string s) -> fprintf ppf "%S" s
+ | Tpat_constant (Const_float f) -> fprintf ppf "%s" f
+ | Tpat_constant (Const_int32 i) -> fprintf ppf "%ldl" i
+ | Tpat_constant (Const_int64 i) -> fprintf ppf "%LdL" i
+ | Tpat_constant (Const_nativeint i) -> fprintf ppf "%ndn" i
| Tpat_tuple vs ->
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
| Tpat_construct ({cstr_tag=tag},[]) ->
@@ -578,6 +584,17 @@ let full_match tdefs force env = match env with
| ({pat_desc = Tpat_array(_)},_) :: _ -> false
| _ -> fatal_error "Parmatch.full_match"
+let extendable_match env = match env with
+| ({pat_desc = Tpat_construct ({cstr_tag=Cstr_exception _},_)},_)::_ -> false
+| ({pat_desc = Tpat_construct(c,_)} as p,_) :: _ ->
+ let path = get_type_path p.pat_type p.pat_env in
+ not
+ (Path.same path Predef.path_bool ||
+ Path.same path Predef.path_list ||
+ Path.same path Predef.path_option)
+| _ -> false
+
+
(* complement constructor tags *)
let complete_tags nconsts nconstrs tags =
let seen_const = Array.create nconsts false
@@ -633,6 +650,16 @@ with
| _ -> fatal_error "Parmatch.complete_constr"
+(* Auxiliary for build_other *)
+
+let build_other_constant proj make first next p env =
+ let all = List.map (fun (p, _) -> proj p.pat_desc) env in
+ let rec try_const i =
+ if List.mem i all
+ then try_const (next i)
+ else make_pat (make i) p.pat_type p.pat_env
+ in try_const first
+
(*
Builds a pattern that is incompatible with all patterns in
in the first column of env
@@ -709,47 +736,40 @@ let build_other env = match env with
try_chars
[ 'a', 'z' ; 'A', 'Z' ; '0', '9' ;
' ', '~' ; Char.chr 0 , Char.chr 255]
+
| ({pat_desc=(Tpat_constant (Const_int _))} as p,_) :: _ ->
- let all_ints =
- List.map
- (fun (p,_) -> match p.pat_desc with
- | Tpat_constant (Const_int i) -> i
- | _ -> assert false)
- env in
- let rec try_ints i =
- if List.mem i all_ints then try_ints (i+1)
- else
- make_pat
- (Tpat_constant (Const_int i)) p.pat_type p.pat_env in
- try_ints 0
+ build_other_constant
+ (function Tpat_constant(Const_int i) -> i | _ -> assert false)
+ (function i -> Tpat_constant(Const_int i))
+ 0 succ p env
+| ({pat_desc=(Tpat_constant (Const_int32 _))} as p,_) :: _ ->
+ build_other_constant
+ (function Tpat_constant(Const_int32 i) -> i | _ -> assert false)
+ (function i -> Tpat_constant(Const_int32 i))
+ 0l Int32.succ p env
+| ({pat_desc=(Tpat_constant (Const_int64 _))} as p,_) :: _ ->
+ build_other_constant
+ (function Tpat_constant(Const_int64 i) -> i | _ -> assert false)
+ (function i -> Tpat_constant(Const_int64 i))
+ 0L Int64.succ p env
+| ({pat_desc=(Tpat_constant (Const_nativeint _))} as p,_) :: _ ->
+ build_other_constant
+ (function Tpat_constant(Const_nativeint i) -> i | _ -> assert false)
+ (function i -> Tpat_constant(Const_nativeint i))
+ 0n Nativeint.succ p env
| ({pat_desc=(Tpat_constant (Const_string _))} as p,_) :: _ ->
- let all_lengths =
- List.map
- (fun (p,_) -> match p.pat_desc with
- | Tpat_constant (Const_string s) -> String.length s
- | _ -> assert false)
- env in
- let rec try_strings i =
- if List.mem i all_lengths then try_strings (i+1)
- else
- make_pat
- (Tpat_constant (Const_string (String.make i '*')))
- p.pat_type p.pat_env in
- try_strings 0
+ build_other_constant
+ (function Tpat_constant(Const_string s) -> String.length s
+ | _ -> assert false)
+ (function i -> Tpat_constant(Const_string(String.make i '*')))
+ 0 succ p env
| ({pat_desc=(Tpat_constant (Const_float _))} as p,_) :: _ ->
- let all_floats =
- List.map
- (fun (p,_) -> match p.pat_desc with
- | Tpat_constant (Const_float s) -> float_of_string s
- | _ -> assert false)
- env in
- let rec try_floats f =
- if List.mem f all_floats then try_floats (f +. 1.0)
- else
- make_pat
- (Tpat_constant (Const_float (string_of_float f)))
- p.pat_type p.pat_env in
- try_floats 0.0
+ build_other_constant
+ (function Tpat_constant(Const_float f) -> float_of_string f
+ | _ -> assert false)
+ (function f -> Tpat_constant(Const_float (string_of_float f)))
+ 0.0 (fun f -> f +. 1.0) p env
+
| ({pat_desc = Tpat_array args} as p,_)::_ ->
let all_lengths =
List.map
@@ -796,28 +816,83 @@ and has_instances = function
let rec satisfiable pss qs = match pss with
| [] -> has_instances qs
| _ ->
-match qs with
-| [] -> false
-| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
- satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+ match qs with
+ | [] -> false
+ | {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+ satisfiable pss (q1::qs) || satisfiable pss (q2::qs)
+ | {pat_desc = Tpat_alias(q,_)}::qs ->
+ satisfiable pss (q::qs)
+ | {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+ let q0 = discr_pat omega pss in
+ begin match filter_all q0 pss with
+ (* first column of pss is made of variables only *)
+ | [] -> satisfiable (filter_extra pss) qs
+ | constrs ->
+ (not (full_match Env.empty false constrs) &&
+ satisfiable (filter_extra pss) qs) ||
+ List.exists
+ (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
+ constrs
+ end
+ | {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
+ | q::qs ->
+ let q0 = discr_pat q pss in
+ satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+
+(*
+ Like satisfiable, looking for a matching value with an extra constructor.
+ That is, look for the situation where adding one constructor
+ would NOT yield a non-exhaustive matching.
+ *)
+
+let relevant_location loc r = match r with
+ | None -> None
+ | Some rloc ->
+ if rloc = Location.none then
+ Some loc
+ else
+ r
+
+let rec satisfiable_extra some pss qs = match qs with
+| [] -> if pss = [] then some else None
+| {pat_desc = Tpat_or(q1,q2,_)}::qs ->
+ let r1 = satisfiable_extra some pss (q1::qs) in
+ begin match r1 with
+ | Some _ -> r1
+ | None -> satisfiable_extra some pss (q2::qs)
+ end
| {pat_desc = Tpat_alias(q,_)}::qs ->
- satisfiable pss (q::qs)
-| {pat_desc = (Tpat_any | Tpat_var(_))}::qs ->
+ satisfiable_extra some pss (q::qs)
+| {pat_desc = (Tpat_any | Tpat_var(_))} as q::qs ->
let q0 = discr_pat omega pss in
- begin match filter_all q0 pss with
+ let r =
+ match filter_all q0 pss with
(* first column of pss is made of variables only *)
- | [] -> satisfiable (filter_extra pss) qs
- | constrs ->
- (not (full_match Env.empty false constrs) &&
- satisfiable (filter_extra pss) qs) ||
- List.exists
- (fun (p,pss) -> satisfiable pss (simple_match_args p omega @ qs))
- constrs
- end
-| {pat_desc=Tpat_variant (l,_,r)}::_ when is_absent l r -> false
+ | [] -> satisfiable_extra some (filter_extra pss) qs
+ | constrs ->
+ if extendable_match constrs then
+ let rloc =
+ satisfiable_extra (Some q.pat_loc) (filter_extra pss) qs in
+ match rloc with
+ | Some loc -> rloc
+ | None -> try_many_extra some qs constrs
+ else
+ try_many_extra some qs constrs in
+ relevant_location q.pat_loc r
| q::qs ->
let q0 = discr_pat q pss in
- satisfiable (filter_one q0 pss) (simple_match_args q0 q @ qs)
+ relevant_location
+ q.pat_loc
+ (satisfiable_extra
+ some (filter_one q0 pss) (simple_match_args q0 q @ qs))
+
+and try_many_extra some qs = function
+ | [] -> None
+ | (p,pss)::rem ->
+ let rloc = satisfiable_extra some pss (simple_match_args p omega @ qs) in
+ match rloc with
+ | Some _ -> rloc
+ | None -> try_many_extra some qs rem
(*
@@ -964,6 +1039,7 @@ let is_var_column rs =
| [] -> assert false)
rs
+(* Standard or-args for left-to-right matching *)
let rec or_args p = match p.pat_desc with
| Tpat_or (p1,p2,_) -> p1,p2
| Tpat_alias (p,_) -> or_args p
@@ -1095,7 +1171,10 @@ let rec every_satisfiables pss qs = match qs.active with
(* otherwise this is direct food for satisfiable *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
| Tpat_or (q1,q2,_) ->
- if uq.pat_loc.Location.loc_ghost then
+ if
+ q1.pat_loc.Location.loc_ghost &&
+ q2.pat_loc.Location.loc_ghost
+ then
(* syntactically generated or-pats should not be expanded *)
every_satisfiables (push_no_or_column pss) (push_no_or qs)
else
@@ -1427,6 +1506,24 @@ let location_of_clause = function
let seen_pat q pss = [q]::pss
+(* Extra check
+ Will this clause match if someone adds a constructor somewhere
+*)
+
+let warn_fragile () = Warnings.is_active (Warnings.Fragile_pat "")
+
+let check_used_extra pss qs =
+ if warn_fragile () then begin
+ match satisfiable_extra None pss qs with
+ | Some location ->
+ Location.prerr_warning
+ location
+ (Warnings.Fragile_pat "")
+ | None -> ()
+ end
+
+
+
let check_unused tdefs casel =
if Warnings.is_active Warnings.Unused_match then
let rec do_rec pref = function
@@ -1446,7 +1543,8 @@ let check_unused tdefs casel =
Location.prerr_warning
p.pat_loc Warnings.Unused_pat)
ps
- | Used -> ()
+ | Used ->
+ check_used_extra pss qs
with e -> (* useless ? *)
Location.prerr_warning (location_of_clause qs)
(Warnings.Other "Fatal Error in Parmatch.check_unused") ;
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index a189f9ac08..2e82271d22 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -413,14 +413,15 @@ let rec tree_of_type_decl id decl =
| None -> ()
| Some ty -> mark_loops ty
end;
- begin match decl.type_kind with
+ let rec mark = function
| Type_abstract -> ()
| Type_variant [] -> ()
| Type_variant cstrs ->
List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
| Type_record(l, rep) ->
List.iter (fun (_, _, ty) -> mark_loops ty) l
- end;
+ | Type_private tkind -> mark tkind in
+ mark decl.type_kind;
let type_param =
function
@@ -451,8 +452,7 @@ let rec tree_of_type_decl id decl =
in
let (name, args) = type_defined decl in
let constraints = tree_of_constraints params in
- let ty =
- match decl.type_kind with
+ let rec tree_of_tkind = function
| Type_abstract ->
begin match decl.type_manifest with
| None -> Otyp_abstract
@@ -462,6 +462,8 @@ let rec tree_of_type_decl id decl =
tree_of_manifest decl (Otyp_sum (List.map tree_of_constructor cstrs))
| Type_record(lbls, rep) ->
tree_of_manifest decl (Otyp_record (List.map tree_of_label lbls))
+ | Type_private tkind -> Otyp_private (tree_of_tkind tkind) in
+ let ty = tree_of_tkind decl.type_kind
in
(name, args, ty, constraints)
@@ -539,7 +541,7 @@ let tree_of_metho sch concrete csil (lab, kind, ty) =
let rec prepare_class_type params = function
| Tcty_constr (p, tyl, cty) ->
let sty = Ctype.self_type cty in
- if List.memq sty !visited_objects
+ if List.memq (proxy sty) !visited_objects
|| List.exists (fun ty -> (repr ty).desc <> Tvar) params
|| List.exists (deep_occur sty) tyl
then prepare_class_type params cty
@@ -547,8 +549,9 @@ let rec prepare_class_type params = function
| Tcty_signature sign ->
let sty = repr sign.cty_self in
(* Self may have a name *)
- if List.memq sty !visited_objects then add_alias sty
- else visited_objects := proxy sty :: !visited_objects;
+ let px = proxy sty in
+ if List.memq px !visited_objects then add_alias sty
+ else visited_objects := px :: !visited_objects;
let (fields, _) =
Ctype.flatten_fields (Ctype.object_fields sign.cty_self)
in
@@ -562,7 +565,7 @@ let rec tree_of_class_type sch params =
function
| Tcty_constr (p', tyl, cty) ->
let sty = Ctype.self_type cty in
- if List.memq sty !visited_objects
+ if List.memq (proxy sty) !visited_objects
|| List.exists (fun ty -> (repr ty).desc <> Tvar) params
then
tree_of_class_type sch params cty
diff --git a/typing/subst.ml b/typing/subst.ml
index 32452902ba..8225877953 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -99,7 +99,7 @@ let rec typexp s ty =
let more = repr row.row_more in
(* We must substitute in a subtle way *)
begin match more.desc with
- Tsubst ({desc=Tvariant _} as ty2) ->
+ Tsubst ty2 when (repr ty2).desc <> Tunivar ->
(* This variant type has been already copied *)
ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *)
Tlink ty2
@@ -154,8 +154,9 @@ let type_declaration s decl =
{ type_params = List.map (typexp s) decl.type_params;
type_arity = decl.type_arity;
type_kind =
- begin match decl.type_kind with
- Type_abstract -> Type_abstract
+ begin
+ let rec kind_of_tkind = function
+ | Type_abstract -> Type_abstract
| Type_variant cstrs ->
Type_variant(
List.map (fun (n, args) -> (n, List.map (typexp s) args))
@@ -165,6 +166,8 @@ let type_declaration s decl =
List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
lbls,
rep)
+ | Type_private tkind -> Type_private (kind_of_tkind tkind) in
+ kind_of_tkind decl.type_kind
end;
type_manifest =
begin match decl.type_manifest with
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 0296055fb1..74b863ef9b 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -176,6 +176,12 @@ let rec limited_generalize rv =
Ctype.limited_generalize rv ty;
limited_generalize rv cty
+(* Record a class type *)
+let rc node =
+ Stypes.record (Stypes.Ti_class node);
+ node
+
+
(***********************************)
(* Primitives for typing classes *)
(***********************************)
@@ -597,19 +603,19 @@ and class_expr cl_num val_env met_env scl =
raise(Error(loc, Parameter_mismatch trace)))
tyl params;
let cl =
- {cl_desc = Tclass_ident path;
- cl_loc = scl.pcl_loc;
- cl_type = clty'}
+ rc {cl_desc = Tclass_ident path;
+ cl_loc = scl.pcl_loc;
+ cl_type = clty'}
in
let (vals, meths, concrs) = extract_constraints clty in
- {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
- cl_loc = scl.pcl_loc;
- cl_type = clty'}
+ rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
+ cl_loc = scl.pcl_loc;
+ cl_type = clty'}
| Pcl_structure cl_str ->
let (desc, ty) = class_structure cl_num val_env met_env cl_str in
- {cl_desc = Tclass_structure desc;
- cl_loc = scl.pcl_loc;
- cl_type = Tcty_signature ty}
+ rc {cl_desc = Tclass_structure desc;
+ cl_loc = scl.pcl_loc;
+ cl_type = Tcty_signature ty}
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let scases =
@@ -669,9 +675,9 @@ and class_expr cl_num val_env met_env scl =
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");
- {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)}
+ 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)}
| Pcl_apply (scl', sargs) ->
let cl = class_expr cl_num val_env met_env scl' in
let rec nonopt_labels ls ty_fun =
@@ -756,9 +762,9 @@ and class_expr cl_num val_env met_env scl =
else
type_args [] [] cl.cl_type sargs []
in
- {cl_desc = Tclass_apply (cl, args);
- cl_loc = scl.pcl_loc;
- cl_type = cty}
+ rc {cl_desc = Tclass_apply (cl, args);
+ cl_loc = scl.pcl_loc;
+ cl_type = cty}
| Pcl_let (rec_flag, sdefs, scl') ->
let (defs, val_env) =
try
@@ -789,9 +795,9 @@ and class_expr cl_num val_env met_env scl =
([], met_env)
in
let cl = class_expr cl_num val_env met_env scl' in
- {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
- cl_loc = scl.pcl_loc;
- cl_type = cl.cl_type}
+ rc {cl_desc = Tclass_let (rec_flag, defs, vals, cl);
+ cl_loc = scl.pcl_loc;
+ cl_type = cl.cl_type}
| Pcl_constraint (scl', scty) ->
Ctype.begin_class_def ();
let context = Typetexp.narrow () in
@@ -811,9 +817,9 @@ and class_expr cl_num val_env met_env scl =
| error -> raise(Error(cl.cl_loc, Class_match_failure error))
end;
let (vals, meths, concrs) = extract_constraints clty in
- {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
- cl_loc = scl.pcl_loc;
- cl_type = snd (Ctype.instance_class [] clty)}
+ rc {cl_desc = Tclass_constraint (cl, vals, meths, concrs);
+ cl_loc = scl.pcl_loc;
+ cl_type = snd (Ctype.instance_class [] clty)}
(*******************************)
@@ -917,7 +923,8 @@ let class_infos define_class kind
(* Introduce class parameters *)
let params =
try
- List.map (enter_type_variable true) (fst cl.pci_params)
+ let params, loc = cl.pci_params in
+ List.map (enter_type_variable true loc) params
with Already_bound ->
raise(Error(snd cl.pci_params, Repeated_parameter))
in
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 57588d2712..8bebbef1ad 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -42,6 +42,8 @@ type error =
| Undefined_inherited_method of string
| Unbound_class of Longident.t
| Virtual_class of Longident.t
+ | Private_type of string
+ | Private_type_setfield of Longident.t * string
| Unbound_instance_variable of string
| Instance_variable_not_mutable of string
| Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
@@ -65,6 +67,23 @@ let type_module =
ref ((fun env md -> assert false) :
Env.t -> Parsetree.module_expr -> Typedtree.module_expr)
+
+(*
+ Saving and outputting type information.
+ We keep these function names short, because they have to be
+ called each time we create a record of type [Typedtree.expression]
+ or [Typedtree.pattern] that will end up in the typed AST.
+*)
+let re node =
+ Stypes.record (Stypes.Ti_expr node);
+ node
+;;
+let rp node =
+ Stypes.record (Stypes.Ti_pat node);
+ node
+;;
+
+
(* Typing of constants *)
let type_constant = function
@@ -72,7 +91,10 @@ let type_constant = function
| Const_char _ -> instance Predef.type_char
| Const_string _ -> instance Predef.type_string
| Const_float _ -> instance Predef.type_float
-
+ | Const_int32 _ -> instance Predef.type_int32
+ | Const_int64 _ -> instance Predef.type_int64
+ | Const_nativeint _ -> instance Predef.type_nativeint
+
(* Specific version of type_option, using newty rather than newgenty *)
let type_option ty =
@@ -93,20 +115,38 @@ let extract_option_type env ty =
when Path.same path Predef.path_option -> ty
| _ -> assert false
-let rec extract_label_names env ty =
+let rec extract_label_names sexp env ty =
let ty = repr ty in
match ty.desc with
| Tconstr (path, _, _) ->
let td = Env.find_type path env in
- begin match td.type_kind with
+ let rec extract = function
| Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields
| Type_abstract when td.type_manifest <> None ->
- extract_label_names env (expand_head env ty)
- | _ -> assert false
- end
+ extract_label_names sexp env (expand_head env ty)
+ | Type_private tkind ->
+ raise (Error(sexp.pexp_loc, Private_type (Path.name path)))
+ | _ -> assert false in
+ extract td.type_kind
| _ ->
assert false
+let check_private get_exc loc env ty =
+ let ty = repr ty in
+ match ty.desc with
+ | Tconstr (path, _, _) ->
+ let td = Env.find_type path env in
+ begin match td.type_kind with
+ | Type_private tkind ->
+ raise (Error(loc, get_exc (Path.name path)))
+ | _ -> () end
+ | _ ->
+ assert false
+
+let check_private_type = check_private (fun s -> Private_type s)
+let check_private_type_setfield lid =
+ check_private (fun s -> Private_type_setfield (lid, s))
+
(* Typing of patterns *)
(* Creating new conjunctive types is not allowed when typing patterns *)
@@ -240,8 +280,8 @@ let build_or_pat env loc lid =
(l, Reither(true,[], true, [], ref None)) :: fields
| Rpresent (Some ty) ->
bound := ty :: !bound;
- (l, Some{pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
- pat_type=ty})
+ (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env;
+ pat_type=ty})
:: pats,
(l, Reither(false, [ty], true, [], ref None)) :: fields
| _ -> pats, fields)
@@ -260,10 +300,12 @@ let build_or_pat env loc lid =
match pats with
[] -> raise(Error(loc, Not_a_variant_type lid))
| pat :: pats ->
- List.fold_left
- (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path); pat_loc=gloc;
- pat_env=env; pat_type=ty})
- pat pats
+ let r =
+ List.fold_left
+ (fun pat pat0 -> {pat_desc=Tpat_or(pat0,pat,Some path);
+ pat_loc=gloc; pat_env=env; pat_type=ty})
+ pat pats in
+ rp { r with pat_loc = loc }
let rec flatten_or_pat pat =
match pat.pat_desc with
@@ -280,14 +322,16 @@ let all_variants pat =
let rec type_pat env sp =
match sp.ppat_desc with
Ppat_any ->
- { pat_desc = Tpat_any;
+ rp {
+ pat_desc = Tpat_any;
pat_loc = sp.ppat_loc;
pat_type = newvar();
pat_env = env }
| Ppat_var name ->
let ty = newvar() in
let id = enter_variable sp.ppat_loc name ty in
- { pat_desc = Tpat_var id;
+ rp {
+ pat_desc = Tpat_var id;
pat_loc = sp.ppat_loc;
pat_type = ty;
pat_env = env }
@@ -298,18 +342,21 @@ let rec type_pat env sp =
end_def ();
generalize ty_var;
let id = enter_variable sp.ppat_loc name ty_var in
- { pat_desc = Tpat_alias(q, id);
+ rp {
+ pat_desc = Tpat_alias(q, id);
pat_loc = sp.ppat_loc;
pat_type = q.pat_type;
pat_env = env }
| Ppat_constant cst ->
- { pat_desc = Tpat_constant cst;
+ rp {
+ pat_desc = Tpat_constant cst;
pat_loc = sp.ppat_loc;
pat_type = type_constant cst;
pat_env = env }
| Ppat_tuple spl ->
let pl = List.map (type_pat env) spl in
- { pat_desc = Tpat_tuple pl;
+ rp {
+ pat_desc = Tpat_tuple pl;
pat_loc = sp.ppat_loc;
pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
pat_env = env }
@@ -333,7 +380,8 @@ let rec type_pat env sp =
let args = List.map (type_pat env) sargs in
let (ty_args, ty_res) = instance_constructor constr in
List.iter2 (unify_pat env) args ty_args;
- { pat_desc = Tpat_construct(constr, args);
+ rp {
+ pat_desc = Tpat_construct(constr, args);
pat_loc = sp.ppat_loc;
pat_type = ty_res;
pat_env = env }
@@ -347,7 +395,8 @@ let rec type_pat env sp =
row_more = newvar ();
row_fixed = false;
row_name = None } in
- { pat_desc = Tpat_variant(l, arg, row);
+ rp {
+ pat_desc = Tpat_variant(l, arg, row);
pat_loc = sp.ppat_loc;
pat_type = newty (Tvariant row);
pat_env = env }
@@ -376,7 +425,8 @@ let rec type_pat env sp =
unify_pat env arg ty_arg;
(label, arg)
in
- { pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
+ rp {
+ pat_desc = Tpat_record(List.map type_label_pat lid_sp_list);
pat_loc = sp.ppat_loc;
pat_type = ty;
pat_env = env }
@@ -384,7 +434,8 @@ let rec type_pat env sp =
let pl = List.map (type_pat env) spl in
let ty_elt = newvar() in
List.iter (fun p -> unify_pat env p ty_elt) pl;
- { pat_desc = Tpat_array pl;
+ rp {
+ pat_desc = Tpat_array pl;
pat_loc = sp.ppat_loc;
pat_type = instance (Predef.type_array ty_elt);
pat_env = env }
@@ -399,7 +450,8 @@ let rec type_pat env sp =
let alpha_env =
enter_orpat_variables sp.ppat_loc env p1_variables p2_variables in
pattern_variables := p1_variables ;
- { pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
+ rp {
+ pat_desc = Tpat_or(p1, alpha_pat alpha_env p2, None);
pat_loc = sp.ppat_loc;
pat_type = p1.pat_type;
pat_env = env }
@@ -648,7 +700,7 @@ let type_format loc fmt =
and scan_conversion i j =
if j >= len then incomplete i else
match fmt.[j] with
- | '%' -> scan_format (j + 1)
+ | '%' | '!' -> scan_format (j + 1)
| 's' | 'S' | '[' -> conversion j Predef.type_string
| 'c' | 'C' -> conversion j Predef.type_char
| 'b' | 'd' | 'i' | 'o' | 'x' | 'X' | 'u' | 'N' ->
@@ -656,10 +708,15 @@ let type_format loc fmt =
| 'f' | 'e' | 'E' | 'g' | 'G' | 'F' -> conversion j Predef.type_float
| 'B' -> conversion j Predef.type_bool
| 'a' ->
- let ty_arg = newvar() in
+ 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
+ | '$' ->
+ let ty_arg = Predef.type_string in
+ let ty_f = ty_arrow Predef.type_string Predef.type_string in
+ let ty_aresult, ty_result = conversion j ty_arg in
+ ty_aresult, ty_arrow ty_f ty_result
| 'r' ->
let ty_res = newvar() in
let ty_r = ty_arrow ty_input ty_res in
@@ -780,7 +837,8 @@ let rec type_exp env sexp =
Pexp_ident lid ->
begin try
let (path, desc) = Env.lookup_value lid env in
- { exp_desc =
+ re {
+ exp_desc =
begin match desc.val_kind with
Val_ivar (_, cl_num) ->
let (self_path, _) =
@@ -804,14 +862,16 @@ let rec type_exp env sexp =
raise(Error(sexp.pexp_loc, Unbound_value lid))
end
| Pexp_constant cst ->
- { exp_desc = Texp_constant cst;
+ re {
+ exp_desc = Texp_constant cst;
exp_loc = sexp.pexp_loc;
exp_type = type_constant cst;
exp_env = env }
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
let body = type_exp new_env sbody in
- { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+ re {
+ exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
exp_env = env }
@@ -826,7 +886,8 @@ let rec type_exp env sexp =
end;
let (args, ty_res) = type_application env funct sargs in
let funct = {funct with exp_type = instance funct.exp_type} in
- { exp_desc = Texp_apply(funct, args);
+ re {
+ exp_desc = Texp_apply(funct, args);
exp_loc = sexp.pexp_loc;
exp_type = ty_res;
exp_env = env }
@@ -836,7 +897,8 @@ let rec type_exp env sexp =
let cases, partial =
type_cases env arg.exp_type ty_res (Some sexp.pexp_loc) caselist ~multi
in
- { exp_desc = Texp_match(arg, cases, partial);
+ re {
+ exp_desc = Texp_match(arg, cases, partial);
exp_loc = sexp.pexp_loc;
exp_type = ty_res;
exp_env = env }
@@ -854,13 +916,15 @@ let rec type_exp env sexp =
let cases, _ =
type_cases env (instance Predef.type_exn) body.exp_type None
caselist in
- { exp_desc = Texp_try(body, cases);
+ re {
+ exp_desc = Texp_try(body, cases);
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
exp_env = env }
| Pexp_tuple sexpl ->
let expl = List.map (type_exp env) sexpl in
- { exp_desc = Texp_tuple expl;
+ re {
+ exp_desc = Texp_tuple expl;
exp_loc = sexp.pexp_loc;
exp_type = newty (Ttuple(List.map (fun exp -> exp.exp_type) expl));
exp_env = env }
@@ -869,7 +933,8 @@ let rec type_exp env sexp =
| Pexp_variant(l, sarg) ->
let arg = may_map (type_exp env) sarg in
let arg_type = may_map (fun arg -> arg.exp_type) arg in
- { exp_desc = Texp_variant(l, arg);
+ re {
+ exp_desc = Texp_variant(l, arg);
exp_loc = sexp.pexp_loc;
exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type];
row_more = newvar ();
@@ -938,7 +1003,7 @@ let rec type_exp env sexp =
if opt_sexp = None && List.length lid_sexp_list <> !num_fields then begin
let present_indices =
List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
- let label_names = extract_label_names env ty in
+ let label_names = extract_label_names sexp env ty in
let rec missing_labels n = function
[] -> []
| lbl :: rem ->
@@ -948,7 +1013,9 @@ let rec type_exp env sexp =
let missing = missing_labels 0 label_names in
raise(Error(sexp.pexp_loc, Label_missing missing))
end;
- { exp_desc = Texp_record(lbl_exp_list, opt_exp);
+ check_private_type sexp.pexp_loc env ty;
+ re {
+ exp_desc = Texp_record(lbl_exp_list, opt_exp);
exp_loc = sexp.pexp_loc;
exp_type = ty;
exp_env = env }
@@ -961,7 +1028,8 @@ let rec type_exp env sexp =
raise(Error(sexp.pexp_loc, Unbound_label lid)) in
let (_, ty_arg, ty_res) = instance_label false label in
unify_exp env arg ty_res;
- { exp_desc = Texp_field(arg, label);
+ re {
+ exp_desc = Texp_field(arg, label);
exp_loc = sexp.pexp_loc;
exp_type = ty_arg;
exp_env = env }
@@ -982,14 +1050,17 @@ let rec type_exp env sexp =
if vars <> [] && not (is_nonexpansive newval) then
generalize_expansive env newval.exp_type;
check_univars env "field value" newval label.lbl_arg vars;
- { exp_desc = Texp_setfield(record, label, newval);
+ check_private_type_setfield lid sexp.pexp_loc env ty_res;
+ re {
+ exp_desc = Texp_setfield(record, label, newval);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env }
| Pexp_array(sargl) ->
let ty = newvar() in
let argl = List.map (fun sarg -> type_expect env sarg ty) sargl in
- { exp_desc = Texp_array argl;
+ re {
+ exp_desc = Texp_array argl;
exp_loc = sexp.pexp_loc;
exp_type = instance (Predef.type_array ty);
exp_env = env }
@@ -998,14 +1069,16 @@ let rec type_exp env sexp =
begin match sifnot with
None ->
let ifso = type_expect env sifso (instance Predef.type_unit) in
- { exp_desc = Texp_ifthenelse(cond, ifso, None);
+ re {
+ exp_desc = Texp_ifthenelse(cond, ifso, None);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env }
| Some sifnot ->
let ifso = type_exp env sifso in
let ifnot = type_expect env sifnot ifso.exp_type in
- { exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
+ re {
+ exp_desc = Texp_ifthenelse(cond, ifso, Some ifnot);
exp_loc = sexp.pexp_loc;
exp_type = ifso.exp_type;
exp_env = env }
@@ -1013,14 +1086,16 @@ let rec type_exp env sexp =
| Pexp_sequence(sexp1, sexp2) ->
let exp1 = type_statement env sexp1 in
let exp2 = type_exp env sexp2 in
- { exp_desc = Texp_sequence(exp1, exp2);
+ re {
+ exp_desc = Texp_sequence(exp1, exp2);
exp_loc = sexp.pexp_loc;
exp_type = exp2.exp_type;
exp_env = env }
| Pexp_while(scond, sbody) ->
let cond = type_expect env scond (instance Predef.type_bool) in
let body = type_statement env sbody in
- { exp_desc = Texp_while(cond, body);
+ re {
+ exp_desc = Texp_while(cond, body);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env }
@@ -1031,7 +1106,8 @@ let rec type_exp env sexp =
Env.enter_value param {val_type = instance Predef.type_int;
val_kind = Val_reg} env in
let body = type_statement new_env sbody in
- { exp_desc = Texp_for(id, low, high, dir, body);
+ re {
+ exp_desc = Texp_for(id, low, high, dir, body);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env }
@@ -1084,14 +1160,16 @@ let rec type_exp env sexp =
end;
(type_expect env sarg ty, ty')
in
- { exp_desc = arg.exp_desc;
+ re {
+ exp_desc = arg.exp_desc;
exp_loc = arg.exp_loc;
exp_type = ty';
exp_env = env }
| Pexp_when(scond, sbody) ->
let cond = type_expect env scond (instance Predef.type_bool) in
let body = type_exp env sbody in
- { exp_desc = Texp_when(cond, body);
+ re {
+ exp_desc = Texp_when(cond, body);
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
exp_env = env }
@@ -1125,7 +1203,7 @@ let rec type_exp env sexp =
let (obj_ty, res_ty) = filter_arrow env method_type "" in
unify env obj_ty desc.val_type;
unify env res_ty (instance typ);
- (Texp_apply({exp_desc = Texp_ident(Path.Pident method_id,
+ (Texp_apply({ exp_desc = Texp_ident(Path.Pident method_id,
{val_type = method_type;
val_kind = Val_reg});
exp_loc = sexp.pexp_loc;
@@ -1167,7 +1245,8 @@ let rec type_exp env sexp =
| _ ->
assert false
in
- { exp_desc = exp;
+ re {
+ exp_desc = exp;
exp_loc = sexp.pexp_loc;
exp_type = typ;
exp_env = env }
@@ -1183,7 +1262,8 @@ let rec type_exp env sexp =
None ->
raise(Error(sexp.pexp_loc, Virtual_class cl))
| Some ty ->
- { exp_desc = Texp_new (cl_path, cl_decl);
+ re {
+ exp_desc = Texp_new (cl_path, cl_decl);
exp_loc = sexp.pexp_loc;
exp_type = instance ty;
exp_env = env }
@@ -1197,7 +1277,8 @@ let rec type_exp env sexp =
let (path_self, _) =
Env.lookup_value (Longident.Lident ("self-" ^ cl_num)) env
in
- { exp_desc = Texp_setinstvar(path_self, path, newval);
+ re {
+ exp_desc = Texp_setinstvar(path_self, path, newval);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env }
@@ -1238,7 +1319,8 @@ let rec type_exp env sexp =
end
in
let modifs = List.map type_override lst in
- { exp_desc = Texp_override(path_self, modifs);
+ re {
+ exp_desc = Texp_override(path_self, modifs);
exp_loc = sexp.pexp_loc;
exp_type = self_ty;
exp_env = env }
@@ -1264,20 +1346,21 @@ let rec type_exp env sexp =
with Unify _ ->
raise(Error(sexp.pexp_loc, Scoping_let_module(name, body.exp_type)))
end;
- { exp_desc = Texp_letmodule(id, modl, body);
+ re {
+ exp_desc = Texp_letmodule(id, modl, body);
exp_loc = sexp.pexp_loc;
exp_type = ty;
exp_env = env }
| Pexp_assert (e) ->
let cond = type_expect env e (instance Predef.type_bool) in
- {
+ re {
exp_desc = Texp_assert (cond);
exp_loc = sexp.pexp_loc;
exp_type = instance Predef.type_unit;
exp_env = env;
}
| Pexp_assertfalse ->
- {
+ re {
exp_desc = Texp_assertfalse;
exp_loc = sexp.pexp_loc;
exp_type = newvar ();
@@ -1285,7 +1368,7 @@ let rec type_exp env sexp =
}
| Pexp_lazy (e) ->
let arg = type_exp env e in
- {
+ re {
exp_desc = Texp_lazy arg;
exp_loc = sexp.pexp_loc;
exp_type = instance (Predef.type_lazy_t arg.exp_type);
@@ -1356,8 +1439,8 @@ and type_argument env sarg ty_expected' =
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
- { texp with exp_type = ty_fun; exp_desc =
- Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
+ re { texp with exp_type = ty_fun; exp_desc =
+ Texp_let (Nonrecursive, [let_pat, texp], func let_var) }
end
| _ ->
type_expect env sarg ty_expected
@@ -1500,7 +1583,7 @@ and type_application env funct sargs =
| _ ->
match sargs with
(l, sarg0) :: _ when ignore_labels ->
- raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)));
+ raise(Error(sarg0.pexp_loc, Apply_wrong_label(l, ty_old)))
| _ ->
type_unknown_args args omitted (instance ty_fun)
(sargs @ more_sargs)
@@ -1549,12 +1632,14 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
generalize_structure ty_res
end;
let texp =
- { exp_desc = Texp_construct(constr, []);
+ re {
+ exp_desc = Texp_construct(constr, []);
exp_loc = loc;
exp_type = instance ty_res;
exp_env = env } in
unify_exp env texp ty_expected;
let args = List.map2 (type_argument env) sargs ty_args in
+ check_private_type loc env ty_res;
{ texp with exp_desc = Texp_construct(constr, args) }
(* Typing of an expression with an expected type.
@@ -1564,7 +1649,8 @@ and type_expect ?in_function env sexp ty_expected =
match sexp.pexp_desc with
Pexp_constant(Const_string s as cst) ->
let exp =
- { exp_desc = Texp_constant cst;
+ re {
+ exp_desc = Texp_constant cst;
exp_loc = sexp.pexp_loc;
exp_type =
(* Terrible hack for format strings *)
@@ -1581,14 +1667,16 @@ and type_expect ?in_function env sexp ty_expected =
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list in
let body = type_expect new_env sbody ty_expected in
- { exp_desc = Texp_let(rec_flag, pat_exp_list, body);
+ re {
+ exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = sexp.pexp_loc;
exp_type = body.exp_type;
exp_env = env }
| Pexp_sequence(sexp1, sexp2) ->
let exp1 = type_statement env sexp1 in
let exp2 = type_expect env sexp2 ty_expected in
- { exp_desc = Texp_sequence(exp1, exp2);
+ re {
+ exp_desc = Texp_sequence(exp1, exp2);
exp_loc = sexp.pexp_loc;
exp_type = exp2.exp_type;
exp_env = env }
@@ -1644,7 +1732,8 @@ and type_expect ?in_function env sexp ty_expected =
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");
- { exp_desc = Texp_function(cases, partial);
+ re {
+ exp_desc = Texp_function(cases, partial);
exp_loc = sexp.pexp_loc;
exp_type = newty (Tarrow(l, ty_arg, ty_res, Cok));
exp_env = env }
@@ -1664,7 +1753,7 @@ and type_expect ?in_function env sexp ty_expected =
Tpoly (ty', []) ->
if sty <> None then set_type ty;
let exp = type_expect env sbody ty' in
- { exp with exp_type = ty }
+ re { exp with exp_type = ty }
| Tpoly (ty', tl) ->
if sty <> None then set_type ty;
(* One more level to generalize locally *)
@@ -1673,7 +1762,7 @@ and type_expect ?in_function env sexp ty_expected =
let exp = type_expect env sbody ty'' in
end_def ();
check_univars env "method" exp ty_expected vars;
- { exp with exp_type = ty }
+ re { exp with exp_type = ty }
| _ -> assert false
end
| _ ->
@@ -1909,7 +1998,8 @@ let report_error ppf = function
| Apply_non_function typ ->
begin match (repr typ).desc with
Tarrow _ ->
- fprintf ppf "This function is applied to too many arguments"
+ fprintf ppf "This function is applied to too many arguments,@ ";
+ fprintf ppf "maybe you forgot a `;'"
| _ ->
fprintf ppf
"This expression is not a function, it cannot be applied"
@@ -1947,7 +2037,7 @@ let report_error ppf = function
fprintf ppf "Unbound class %a" longident cl
| Virtual_class cl ->
fprintf ppf "One cannot create instances of the virtual class %a"
- longident cl
+ longident cl
| Unbound_instance_variable v ->
fprintf ppf "Unbound instance variable %s" v
| Instance_variable_not_mutable v ->
@@ -2000,6 +2090,11 @@ let report_error ppf = function
"The instance variable %a@ \
cannot be accessed from the definition of another instance variable"
longident lid
+ | Private_type ty ->
+ fprintf ppf "One cannot create values of the private type %s" ty
+ | Private_type_setfield (lid, ty) ->
+ fprintf ppf "Cannot assign field %a of the private type %s"
+ longident lid ty
| Not_a_variant_type lid ->
fprintf ppf "The type %a@ is not a variant type" longident lid
| Incoherent_label_order ->
diff --git a/typing/typecore.mli b/typing/typecore.mli
index c4112183af..4bd6f19456 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -79,6 +79,8 @@ type error =
| Undefined_inherited_method of string
| Unbound_class of Longident.t
| Virtual_class of Longident.t
+ | Private_type of string
+ | Private_type_setfield of Longident.t * string
| Unbound_instance_variable of string
| Instance_variable_not_mutable of string
| Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index f00c18f3a6..6c6fa2dc99 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -89,7 +89,7 @@ let transl_declaration env (name, sdecl) id =
reset_type_variables();
Ctype.begin_def ();
let params =
- try List.map (enter_type_variable true) sdecl.ptype_params
+ try List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
with Already_bound ->
raise(Error(sdecl.ptype_loc, Repeated_parameter))
in
@@ -103,7 +103,7 @@ let transl_declaration env (name, sdecl) id =
{ type_params = params;
type_arity = List.length params;
type_kind =
- begin match sdecl.ptype_kind with
+ begin let rec get_tkind = function
Ptype_abstract ->
Type_abstract
| Ptype_variant cstrs ->
@@ -140,7 +140,9 @@ let transl_declaration env (name, sdecl) id =
then Record_float
else Record_regular in
Type_record(lbls', rep)
- end;
+ | Ptype_private kind -> Type_private (get_tkind kind) in
+ get_tkind sdecl.ptype_kind
+ end;
type_manifest =
begin match sdecl.ptype_manifest with
None -> None
@@ -167,16 +169,18 @@ let transl_declaration env (name, sdecl) id =
let generalize_decl decl =
List.iter Ctype.generalize decl.type_params;
- begin match decl.type_kind with
- Type_abstract ->
+ let rec gen = function
+ | Type_abstract ->
()
| Type_variant v ->
List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
- end;
+ | Type_private tkind ->
+ gen tkind in
+ gen decl.type_kind;
begin match decl.type_manifest with
- None -> ()
+ | None -> ()
| Some ty -> Ctype.generalize ty
end
@@ -189,7 +193,7 @@ module TypeSet =
let compare t1 t2 = t1.id - t2.id
end)
-let rec check_constraints_rec env loc visited ty =
+let rec check_constraints_rec env newenv loc visited ty =
let ty = Ctype.repr ty in
if TypeSet.mem ty !visited then () else begin
visited := TypeSet.add ty !visited;
@@ -198,7 +202,7 @@ let rec check_constraints_rec env loc visited ty =
Ctype.begin_def ();
let args' = List.map (fun _ -> Ctype.newvar ()) args in
let ty' = Ctype.newconstr path args' in
- begin try Ctype.enforce_constraints env ty'
+ begin try Ctype.enforce_constraints newenv ty'
with Ctype.Unify _ -> assert false
| Not_found -> raise (Error(loc, Unavailable_type_constructor path))
end;
@@ -206,33 +210,40 @@ let rec check_constraints_rec env loc visited ty =
Ctype.generalize ty';
if not (List.for_all2 (Ctype.moregeneral env false) args' args) then
raise (Error(loc, Constraint_failed (ty, ty')));
- List.iter (check_constraints_rec env loc visited) args
+ List.iter (check_constraints_rec env newenv loc visited) args
| Tpoly (ty, tl) ->
let _, ty = Ctype.instance_poly false tl ty in
- check_constraints_rec env loc visited ty
+ check_constraints_rec env newenv loc visited ty
| _ ->
- Btype.iter_type_expr (check_constraints_rec env loc visited) ty
+ Btype.iter_type_expr (check_constraints_rec env newenv loc visited) ty
end
-let check_constraints env (_, sdecl) (_, decl) =
+let check_constraints env newenv (_, sdecl) (_, decl) =
let visited = ref TypeSet.empty in
- begin match decl.type_kind with
+ let rec check = function
| Type_abstract -> ()
| Type_variant l ->
- let pl =
- match sdecl.ptype_kind with Ptype_variant pl -> pl | _ -> assert false
+ let rec find_pl = function
+ Ptype_variant pl -> pl
+ | Ptype_private tkind -> find_pl tkind
+ | Ptype_record _ | Ptype_abstract -> assert false
in
+ 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
List.iter2
- (fun sty ty -> check_constraints_rec env sty.ptyp_loc visited ty)
+ (fun sty ty ->
+ check_constraints_rec env newenv sty.ptyp_loc visited ty)
styl tyl)
l
| Type_record (l, _) ->
- let pl =
- match sdecl.ptype_kind with Ptype_record pl -> pl | _ -> assert false
+ let rec find_pl = function
+ Ptype_record pl -> pl
+ | Ptype_private tkind -> find_pl tkind
+ | Ptype_variant _ | Ptype_abstract -> assert false
in
+ let pl = find_pl sdecl.ptype_kind in
let rec get_loc name = function
[] -> assert false
| (name', _, sty) :: tl ->
@@ -240,16 +251,17 @@ let check_constraints env (_, sdecl) (_, decl) =
in
List.iter
(fun (name, _, ty) ->
- check_constraints_rec env (get_loc name pl) visited ty)
+ check_constraints_rec env newenv (get_loc name pl) visited ty)
l
- end;
+ | Type_private tkind -> check tkind in
+ check decl.type_kind;
begin match decl.type_manifest with
| None -> ()
| Some ty ->
let sty =
match sdecl.ptype_manifest with Some sty -> sty | _ -> assert false
in
- check_constraints_rec env sty.ptyp_loc visited ty
+ check_constraints_rec env newenv sty.ptyp_loc visited ty
end
(*
@@ -297,8 +309,9 @@ let check_recursive_abbrev env (name, sdecl) (id, decl) =
let rec check_expansion_rec env id args loc id_check_list visited ty =
let ty = Ctype.repr ty in
if List.memq ty visited then () else
- let visited = ty :: visited in
- begin match ty.desc with
+ let check_rec =
+ check_expansion_rec env id args loc id_check_list (ty :: visited) in
+ match ty.desc with
| Tconstr(Path.Pident id' as path, args', _) ->
if Ident.same id id' then begin
if not (Ctype.equal env false args args') then
@@ -315,14 +328,16 @@ let rec check_expansion_rec env id args loc id_check_list visited ty =
try List.iter2 (Ctype.unify env) params args'
with Ctype.Unify _ -> assert false
end;
- check_expansion_rec env id args loc id_check_list visited body
+ check_rec body
end
with Not_found -> ()
- end
- | _ -> ()
- end;
- Btype.iter_type_expr
- (check_expansion_rec env id args loc id_check_list visited) ty
+ end;
+ List.iter check_rec args'
+ | Tpoly (ty, tl) ->
+ let _, ty = Ctype.instance_poly false tl ty in
+ check_rec ty
+ | _ ->
+ Btype.iter_type_expr check_rec ty
let check_expansion env id_loc_list (id, decl) =
if decl.type_params = [] then () else
@@ -405,7 +420,7 @@ let compute_variance_decl env decl (required, loc) =
else
let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false))
decl.type_params in
- begin match decl.type_kind with
+ let rec variance_tkind = function
Type_abstract ->
begin match decl.type_manifest with
None -> assert false
@@ -419,7 +434,8 @@ let compute_variance_decl env decl (required, loc) =
List.iter
(fun (_, mut, ty) -> compute_variance env tvl true (mut = Mutable) ty)
ftl
- end;
+ | Type_private tkind -> variance_tkind tkind in
+ variance_tkind decl.type_kind;
List.map2
(fun (_, co, cn) (c, n) ->
if c && !cn || n && !co then raise (Error(loc, Bad_variance));
@@ -499,7 +515,7 @@ let transl_type_decl env name_sdecl_list =
(* Check re-exportation *)
List.iter2 (check_abbrev newenv) name_sdecl_list decls;
(* Check that constraints are enforced *)
- List.iter2 (check_constraints newenv) name_sdecl_list decls;
+ List.iter2 (check_constraints temp_env newenv) name_sdecl_list decls;
(* Check that abbreviations have same parameters *)
let id_loc_list =
List.map2
@@ -566,7 +582,7 @@ let transl_with_constraint env sdecl =
Ctype.begin_def();
let params =
try
- List.map (enter_type_variable true) sdecl.ptype_params
+ List.map (enter_type_variable true sdecl.ptype_loc) sdecl.ptype_params
with Already_bound ->
raise(Error(sdecl.ptype_loc, Repeated_parameter)) in
List.iter
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 89963b0d74..503b497853 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -59,6 +59,11 @@ let type_module_path env loc lid =
with Not_found ->
raise(Error(loc, Unbound_module lid))
+(* Record a module type *)
+let rm node =
+ Stypes.record (Stypes.Ti_mod node);
+ node
+
(* Merge one "with" constraint in a signature *)
let merge_constraint initial_env loc sg lid constr =
@@ -281,24 +286,24 @@ let rec type_module env smod =
match smod.pmod_desc with
Pmod_ident lid ->
let (path, mty) = type_module_path env smod.pmod_loc lid in
- { mod_desc = Tmod_ident path;
- mod_type = Mtype.strengthen env mty path;
- mod_env = env;
- mod_loc = smod.pmod_loc }
+ rm { mod_desc = Tmod_ident path;
+ mod_type = Mtype.strengthen env mty path;
+ mod_env = env;
+ mod_loc = smod.pmod_loc }
| Pmod_structure sstr ->
let (str, sg, finalenv) = type_structure env sstr in
- { mod_desc = Tmod_structure str;
- mod_type = Tmty_signature sg;
- mod_env = env;
- mod_loc = smod.pmod_loc }
+ rm { mod_desc = Tmod_structure str;
+ mod_type = Tmty_signature sg;
+ mod_env = env;
+ mod_loc = smod.pmod_loc }
| Pmod_functor(name, smty, sbody) ->
let mty = transl_modtype env smty in
let (id, newenv) = Env.enter_module name mty env in
let body = type_module newenv sbody in
- { mod_desc = Tmod_functor(id, mty, body);
- mod_type = Tmty_functor(id, mty, body.mod_type);
- mod_env = env;
- mod_loc = smod.pmod_loc }
+ rm { mod_desc = Tmod_functor(id, mty, body);
+ mod_type = Tmty_functor(id, mty, body.mod_type);
+ mod_env = env;
+ mod_loc = smod.pmod_loc }
| Pmod_apply(sfunct, sarg) ->
let funct = type_module env sfunct in
let arg = type_module env sarg in
@@ -321,10 +326,10 @@ let rec type_module env smod =
with Not_found ->
raise(Error(smod.pmod_loc,
Cannot_eliminate_dependency mty_functor)) in
- { mod_desc = Tmod_apply(funct, arg, coercion);
- mod_type = mty_appl;
- mod_env = env;
- mod_loc = smod.pmod_loc }
+ rm { mod_desc = Tmod_apply(funct, arg, coercion);
+ mod_type = mty_appl;
+ mod_env = env;
+ mod_loc = smod.pmod_loc }
| _ ->
raise(Error(sfunct.pmod_loc, Cannot_apply funct.mod_type))
end
@@ -336,10 +341,10 @@ let rec type_module env smod =
Includemod.modtypes env arg.mod_type mty
with Includemod.Error msg ->
raise(Error(sarg.pmod_loc, Not_included msg)) in
- { mod_desc = Tmod_constraint(arg, mty, coercion);
- mod_type = mty;
- mod_env = env;
- mod_loc = smod.pmod_loc }
+ rm { mod_desc = Tmod_constraint(arg, mty, coercion);
+ mod_type = mty;
+ mod_env = env;
+ mod_loc = smod.pmod_loc }
and type_structure env sstr =
let type_names = ref StringSet.empty
@@ -488,30 +493,6 @@ and normalize_signature_item env = function
| Tsig_module(id, mty) -> normalize_modtype env mty
| _ -> ()
-(* Typecheck an implementation file *)
-
-let type_implementation sourcefile prefixname modulename initial_env ast =
- Typecore.reset_delayed_checks ();
- let (str, sg, finalenv) = type_structure initial_env ast in
- Typecore.force_delayed_checks ();
- if !Clflags.print_types then
- fprintf std_formatter "%a@." Printtyp.signature sg;
- let coercion =
- if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
- let intf_file =
- try find_in_path !Config.load_path (prefixname ^ ".cmi")
- with Not_found -> prefixname ^ ".cmi" 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");
- Tcoerce_none
- end in
- (str, coercion)
-
(* Simplify multiple specifications of a value or an exception in a signature.
(Other signature components, e.g. types, modules, etc, are checked for
name uniqueness.) If multiple specifications with the same name,
@@ -536,11 +517,41 @@ 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 ->
+ simplif val_names exn_names
+ (Tsig_module(id, simplify_modtype mty) :: res) sg
| component :: sg ->
simplif val_names exn_names (component :: res) sg
in
simplif StringSet.empty StringSet.empty [] (List.rev sg)
+(* Typecheck an implementation file *)
+
+let type_implementation sourcefile prefixname 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 ^ ".types"))
+ in
+ Typecore.force_delayed_checks ();
+ if !Clflags.print_types then
+ fprintf std_formatter "%a@." Printtyp.signature (simplify_signature sg);
+ let coercion =
+ if Sys.file_exists (prefixname ^ !Config.interface_suffix) then begin
+ let intf_file =
+ try find_in_path !Config.load_path (prefixname ^ ".cmi")
+ with Not_found -> prefixname ^ ".cmi" 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");
+ Tcoerce_none
+ end in
+ (str, coercion)
+
(* "Packaging" of several compilation units into one unit
having them as sub-modules. *)
@@ -564,14 +575,23 @@ let package_units objfiles cmifile modulename =
objfiles in
(* Compute signature of packaged unit *)
let sg = package_signatures Subst.identity units in
- (* Determine imports *)
- let unit_names = List.map fst units in
- let imports =
- List.filter
- (fun (name, crc) -> not (List.mem name unit_names))
- (Env.imported_units()) in
- (* Write packaged signature *)
- Env.save_signature_with_imports sg modulename cmifile imports
+ (* See if explicit interface is provided *)
+ let mlifile =
+ chop_extension_if_any cmifile ^ !Config.interface_suffix in
+ if Sys.file_exists mlifile then begin
+ let dclsig = Env.read_signature modulename cmifile in
+ Includemod.compunit "(obtained by packing)" sg mlifile dclsig
+ end else begin
+ (* Determine imports *)
+ let unit_names = List.map fst units in
+ let imports =
+ List.filter
+ (fun (name, crc) -> not (List.mem name unit_names))
+ (Env.imported_units()) in
+ (* Write packaged signature *)
+ Env.save_signature_with_imports sg modulename cmifile imports;
+ Tcoerce_none
+ end
(* Error report *)
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 7017dcf0de..63f1f6614c 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -32,7 +32,7 @@ val check_nongen_schemes:
val simplify_signature: signature -> signature
val package_units:
- string list -> string -> string -> unit
+ string list -> string -> string -> Typedtree.module_coercion
type error =
Unbound_module of Longident.t
diff --git a/typing/types.ml b/typing/types.ml
index 2c3b5b6ebb..ed6e5bc02d 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -142,6 +142,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of (string * mutable_flag * type_expr) list
* record_representation
+ | Type_private of type_kind
type exception_declaration = type_expr list
diff --git a/typing/types.mli b/typing/types.mli
index 8ed6e6a844..3a26fd3791 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -143,6 +143,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of (string * mutable_flag * type_expr) list
* record_representation
+ | Type_private of type_kind
type exception_declaration = type_expr list
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 5da55d93eb..7b57260f75 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -39,6 +39,7 @@ type error =
| Variant_tags of string * string
| No_row_variable of string
| Bad_alias of string
+ | Invalid_variable_name of string
exception Error of Location.t * error
@@ -49,11 +50,16 @@ type variable_context = int * (string, type_expr) Tbl.t
let type_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
let univars = ref ([] : (string * (type_expr * type_expr ref)) list)
let pre_univars = ref ([] : type_expr list)
+let local_aliases = ref ([] : string list)
let used_variables = ref (Tbl.empty : (string, type_expr) Tbl.t)
let bindings = ref ([] : (Location.t * type_expr * type_expr) list)
(* These two variables are used for the "delayed" policy. *)
+let reset_pre_univars () =
+ pre_univars := [];
+ local_aliases := []
+
let reset_type_variables () =
reset_global_level ();
type_variables := Tbl.empty
@@ -65,8 +71,10 @@ let widen (gl, tv) =
restore_global_level gl;
type_variables := tv
-let enter_type_variable strict name =
+let enter_type_variable strict loc name =
try
+ if name <> "" && name.[0] = '_' then
+ raise (Error (loc, Invalid_variable_name ("'" ^ name)));
let v = Tbl.find name !type_variables in
if strict then raise Already_bound;
v
@@ -105,6 +113,8 @@ let rec transl_type env policy rowvar styp =
Ptyp_any ->
if policy = Univars then new_pre_univar () else newvar ()
| Ptyp_var name ->
+ if name <> "" && name.[0] = '_' then
+ raise (Error (styp.ptyp_loc, Invalid_variable_name ("'" ^ name)));
begin try
instance (fst (List.assoc name !univars))
with Not_found ->
@@ -129,6 +139,7 @@ let rec transl_type env policy rowvar styp =
with Not_found ->
let v = new_pre_univar () in
type_variables := Tbl.add name v !type_variables;
+ local_aliases := name :: !local_aliases;
v
end
| Delayed ->
@@ -163,16 +174,22 @@ let rec transl_type env policy rowvar styp =
raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
List.length stl)));
let args = List.map (transl_type env policy None) stl in
- let params = List.map (fun _ -> Ctype.newvar ()) args in
+ let params = Ctype.instance_list decl.type_params in
let cstr = newty (Tconstr(path, params, ref Mnil)) in
begin try
Ctype.enforce_constraints env cstr
with Unify trace ->
raise (Error(styp.ptyp_loc, Type_mismatch trace))
end;
+ let unify_param =
+ match decl.type_manifest with
+ None -> unify_var
+ | Some ty ->
+ if (repr ty).level = Btype.generic_level then unify_var else unify
+ in
List.iter2
(fun (sty, ty) ty' ->
- try unify_var env ty' ty with Unify trace ->
+ try unify_param env ty' ty with Unify trace ->
raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
(List.combine stl args) params;
cstr
@@ -225,8 +242,8 @@ let rec transl_type env policy rowvar styp =
in
let params = Ctype.instance_list decl.type_params in
List.iter2
- (fun (sty, ty') ty ->
- try unify_var env ty ty' with Unify trace ->
+ (fun (sty, ty) ty' ->
+ try unify_var env ty' ty with Unify trace ->
raise (Error(sty.ptyp_loc, Type_mismatch (swap_list trace))))
(List.combine stl args) params;
begin match ty.desc with
@@ -315,6 +332,7 @@ let rec transl_type env policy rowvar styp =
begin_def ();
let t = newvar () in
type_variables := Tbl.add alias t !type_variables;
+ if policy = Univars then local_aliases := alias :: !local_aliases;
if policy = Delayed then
used_variables := Tbl.add alias t !used_variables;
let ty = transl_type env policy None st in
@@ -323,7 +341,8 @@ let rec transl_type env policy rowvar styp =
raise(Error(styp.ptyp_loc, Alias_type_mismatch trace))
end;
end_def ();
- generalize_global t;
+ if policy = Univars then generalize_structure t
+ else generalize_global t;
instance t
end
| Ptyp_variant(fields, closed, present) ->
@@ -472,7 +491,7 @@ let transl_simple_type env fixed styp =
let transl_simple_type_univars env styp =
univars := [];
- pre_univars := [];
+ reset_pre_univars ();
begin_def ();
let typ = transl_type env Univars None styp in
end_def ();
@@ -481,17 +500,12 @@ let transl_simple_type_univars env styp =
List.fold_left
(fun acc v ->
let v = repr v in
- if v.desc <> Tvar || v.level <> Btype.generic_level || List.memq v acc
- then acc
+ if v.level <> Btype.generic_level || v.desc <> Tvar then acc
else (v.desc <- Tunivar ; v :: acc))
[] !pre_univars
in
- pre_univars := [];
- Tbl.iter
- (fun name ty ->
- if List.exists (fun tu -> repr ty == repr tu) univs
- then type_variables := Tbl.remove name !type_variables)
- !type_variables;
+ type_variables := List.fold_right Tbl.remove !local_aliases !type_variables;
+ reset_pre_univars ();
instance (Btype.newgenty (Tpoly (typ, univs)))
let transl_simple_type_delayed env styp =
@@ -583,3 +597,5 @@ let report_error ppf = function
fprintf ppf
"The alias %s cannot be used here. It captures universal variables."
name
+ | Invalid_variable_name name ->
+ fprintf ppf "The type variable name %s is not allowed in programs" name
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index bc36515228..300ebe5ace 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -27,7 +27,7 @@ val transl_simple_type_delayed:
val transl_type_scheme:
Env.t -> Parsetree.core_type -> Types.type_expr
val reset_type_variables: unit -> unit
-val enter_type_variable: bool -> string -> Types.type_expr
+val enter_type_variable: bool -> Location.t -> string -> Types.type_expr
val type_variable: Location.t -> string -> Types.type_expr
type variable_context
@@ -54,6 +54,7 @@ type error =
| Variant_tags of string * string
| No_row_variable of string
| Bad_alias of string
+ | Invalid_variable_name of string
exception Error of Location.t * error
View Lorry Controller Status