diff options
32 files changed, 196 insertions, 238 deletions
diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 7eee8318c..47b22a0f8 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 45c139da2..db6e3d2b1 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index ed019747c..c931519ee 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -38,8 +38,8 @@ let maybe_pointer exp = not (Path.same p Predef.path_char) && begin try match Env.find_type p exp.exp_env with - {type_kind = Type_variant []} -> true (* type exn *) - | {type_kind = Type_variant cstrs} -> + {type_kind = Type_variant([], _)} -> true (* type exn *) + | {type_kind = Type_variant(cstrs, _)} -> List.exists (fun (name, args) -> args <> []) cstrs | _ -> true with Not_found -> true @@ -70,7 +70,7 @@ let array_element_kind env ty = match Env.find_type p env with {type_kind = Type_abstract} -> Pgenarray - | {type_kind = Type_variant cstrs} + | {type_kind = Type_variant(cstrs, _)} when List.for_all (fun (name, args) -> args = []) cstrs -> Pintarray | {type_kind = _} -> diff --git a/camlp4/camlp4/ast2pt.ml b/camlp4/camlp4/ast2pt.ml index 124a6e34a..4690d83c7 100644 --- a/camlp4/camlp4/ast2pt.ml +++ b/camlp4/camlp4/ast2pt.ml @@ -219,14 +219,15 @@ value mkvariant (_, c, tl) = (c, List.map ctyp tl); value type_decl tl cl = fun [ TyMan loc t (TyRec _ ltl) -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) (Some (ctyp t)) + mktype loc tl cl (Ptype_record (List.map mktrecord ltl) Public) + (Some (ctyp t)) | TyMan loc t (TySum _ ctl) -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl)) + mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) Public) (Some (ctyp t)) | TyRec loc ltl -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) None + mktype loc tl cl (Ptype_record (List.map mktrecord ltl) Public) None | TySum loc ctl -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl)) None + mktype loc tl cl (Ptype_variant (List.map mkvariant ctl) Public) None | t -> let m = match t with diff --git a/camlp4/ocaml_src/camlp4/ast2pt.ml b/camlp4/ocaml_src/camlp4/ast2pt.ml index ec7e48e55..fe0e08873 100644 --- a/camlp4/ocaml_src/camlp4/ast2pt.ml +++ b/camlp4/ocaml_src/camlp4/ast2pt.ml @@ -211,14 +211,15 @@ let mkvariant (_, c, tl) = c, List.map ctyp tl;; let type_decl tl cl = function TyMan (loc, t, TyRec (_, ltl)) -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) (Some (ctyp t)) + mktype loc tl cl (Ptype_record (List.map mktrecord ltl, Public)) + (Some (ctyp t)) | TyMan (loc, t, TySum (_, ctl)) -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl)) + mktype loc tl cl (Ptype_variant (List.map mkvariant ctl, Public)) (Some (ctyp t)) | TyRec (loc, ltl) -> - mktype loc tl cl (Ptype_record (List.map mktrecord ltl)) None + mktype loc tl cl (Ptype_record (List.map mktrecord ltl, Public)) None | TySum (loc, ctl) -> - mktype loc tl cl (Ptype_variant (List.map mkvariant ctl)) None + mktype loc tl cl (Ptype_variant (List.map mkvariant ctl, Public)) None | t -> let m = match t with diff --git a/camlp4/top/rprint.ml b/camlp4/top/rprint.ml index bd00230c9..5d86d7abf 100644 --- a/camlp4/top/rprint.ml +++ b/camlp4/top/rprint.ml @@ -135,7 +135,7 @@ and print_out_type_2 ppf = (print_typlist print_simple_out_type "") tyl | ty -> print_simple_out_type ppf ty ] and print_simple_out_type ppf = - let rec print_tkind v ppf = + let rec print_tkind ppf = fun [ Otyp_var ng s -> fprintf ppf "'%s%s" (if ng then "_" else "") s | Otyp_constr id [] -> fprintf ppf "@[%a@]" print_ident id @@ -169,21 +169,23 @@ and print_simple_out_type ppf = print_ident id | Otyp_manifest ty1 ty2 -> fprintf ppf "@[<2>%a ==@ %a@]" print_out_type ty1 print_out_type ty2 - | Otyp_sum constrs -> - fprintf ppf "@[<hv>%a[ %a ]@]" print_private v + | Otyp_sum constrs priv -> + fprintf ppf "@[<hv>%a[ %a ]@]" print_private priv (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs - | Otyp_record lbls -> - fprintf ppf "@[<hv 2>%a{ %a }@]" print_private v + | Otyp_record lbls priv -> + fprintf ppf "@[<hv 2>%a{ %a }@]" print_private priv (print_list print_out_label (fun ppf -> fprintf ppf ";@ ")) lbls - | Otyp_private tk -> print_tkind True ppf tk | Otyp_abstract -> fprintf ppf "'abstract" | Otyp_alias _ _ | Otyp_poly _ _ | Otyp_arrow _ _ _ | Otyp_constr _ [_ :: _] as ty -> fprintf ppf "@[<1>(%a)@]" print_out_type ty ] - and print_private ppf v = - if v then fprintf ppf "private " else () + and print_private ppf = + fun + [ Asttypes.Public -> () + | Asttypes.Private -> fprintf ppf "private " + ] in - print_tkind False ppf + print_tkind ppf and print_out_constr ppf (name, tyl) = match tyl with [ [] -> fprintf ppf "%s" name diff --git a/debugger/eval.ml b/debugger/eval.ml index 07c9688ec..a53589382 100644 --- a/debugger/eval.ml +++ b/debugger/eval.ml @@ -135,7 +135,7 @@ let rec expression event env = function Tconstr(path, args, _) -> let tydesc = Env.find_type path env in begin match tydesc.type_kind with - Type_record(lbl_list, repr) -> + Type_record(lbl_list, repr, priv) -> let (pos, ty_res) = find_label lbl env ty path tydesc 0 lbl_list in (Debugcom.Remote_value.field v pos, ty_res) diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 6b4656e23..a4ba06d7a 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -170,10 +170,10 @@ module Analyser = let merge_infos = Odoc_merge.merge_info_opt Odoc_types.all_merge_options let name_comment_from_type_kind pos_start pos_end pos_limit tk = - let rec comment_from_tkind = function + match tk with Parsetree.Ptype_abstract -> (0, []) - | Parsetree.Ptype_variant cons_core_type_list_list -> + | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> (*of (string * core_type list) list *) let rec f acc last_pos cons_core_type_list_list = match cons_core_type_list_list with @@ -218,7 +218,7 @@ module Analyser = in f [] pos_start cons_core_type_list_list - | Parsetree.Ptype_record name_mutable_type_list (* of (string * mutable_flag * core_type) list*) -> + | Parsetree.Ptype_record (name_mutable_type_list, _) (* of (string * mutable_flag * core_type) list*) -> let rec f = function [] -> [] @@ -236,16 +236,12 @@ module Analyser = in (0, f name_mutable_type_list) - | Parsetree.Ptype_private tkind -> comment_from_tkind tkind in - - comment_from_tkind tk - let get_type_kind env name_comment_list type_kind = - let rec get_tkind = function + match type_kind with Types.Type_abstract -> Odoc_type.Type_abstract - | Types.Type_variant l -> + | Types.Type_variant (l, priv) -> let f (constructor_name, type_expr_list) = let comment_opt = try @@ -262,7 +258,7 @@ module Analyser = in Odoc_type.Type_variant (List.map f l) - | Types.Type_record (l, _) -> + | Types.Type_record (l, _, priv) -> let f (field_name, mutable_flag, type_expr) = let comment_opt = try @@ -280,11 +276,6 @@ module Analyser = in Odoc_type.Type_record (List.map f l) - | Types.Type_private tkind -> get_tkind tkind in - - get_tkind type_kind - - (** Analysis of the elements of a class, from the information in the parsetree and in the class signature. @return the couple (inherited_class list, elements).*) let analyse_class_elements env current_class_name last_pos pos_limit diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 2784d22d7..c285dbbce 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -226,14 +226,13 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = None -> false | Some t -> matches t end || - let rec search_tkind = function + begin match td.type_kind with Type_abstract -> false - | Type_variant l -> + | Type_variant(l, priv) -> List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) - | Type_record(l, rep) -> + | Type_record(l, rep, priv) -> List.exists l ~f:(fun (_, _, t) -> matches t) - | Type_private tkind -> search_tkind tkind in - search_tkind td.type_kind + end then [lid_of_id id, Ptype] else [] | Tsig_exception (id, l) -> if List.exists l ~f:matches diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 614f62cef..78316c77e 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -167,12 +167,11 @@ let search_pos_type_decl td ~pos ~env = end; let rec search_tkind = function Ptype_abstract -> () - | Ptype_variant dl -> + | Ptype_variant (dl, _) -> List.iter dl ~f:(fun (_, tl) -> List.iter tl ~f:(search_pos_type ~pos ~env)) - | Ptype_record dl -> - List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) - | Ptype_private tkind -> search_tkind tkind in + | Ptype_record (dl, _) -> + List.iter dl ~f:(fun (_, _, t) -> search_pos_type t ~pos ~env) in search_tkind td.ptype_kind; List.iter td.ptype_cstrs ~f: begin fun (t1, t2, _) -> diff --git a/parsing/parser.mly b/parsing/parser.mly index c749f915f..1f4791654 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -183,10 +183,6 @@ let bigarray_set arr arg newval = ["", arr; "", ghexp(Pexp_array coords); "", newval])) - -let mktype_kind pflag kind = - if pflag = Private && kind != Ptype_abstract then Ptype_private kind else kind - %} /* Tokens */ @@ -1185,17 +1181,17 @@ type_kind: | EQUAL core_type { (Ptype_abstract, Some $2) } | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2), None) } + { (Ptype_variant(List.rev $2, Public), None) } | EQUAL PRIVATE constructor_declarations - { (mktype_kind Private (Ptype_variant(List.rev $3)), None) } + { (Ptype_variant(List.rev $3, Private), None) } | EQUAL private_flag BAR constructor_declarations - { (mktype_kind $2 (Ptype_variant(List.rev $4)), None) } + { (Ptype_variant(List.rev $4, $2), None) } | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (mktype_kind $2 (Ptype_record(List.rev $4)), None) } + { (Ptype_record(List.rev $4, $2), None) } | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations - { (mktype_kind $4 (Ptype_variant(List.rev $6)), Some $2) } + { (Ptype_variant(List.rev $6, $4), Some $2) } | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (mktype_kind $4 (Ptype_record(List.rev $6)), Some $2) } + { (Ptype_record(List.rev $6, $4), Some $2) } ; type_parameters: /*empty*/ { [] } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 10c7bcd2d..f0da277bf 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -129,9 +129,8 @@ and type_declaration = and type_kind = Ptype_abstract - | Ptype_variant of (string * core_type list) list - | Ptype_record of (string * mutable_flag * core_type) list - | Ptype_private of type_kind + | Ptype_variant of (string * core_type list) list * private_flag + | Ptype_record of (string * mutable_flag * core_type) list * private_flag and exception_declaration = core_type list diff --git a/parsing/printast.ml b/parsing/printast.ml index 9cc166d44..be819a7d4 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -314,15 +314,12 @@ and type_kind i ppf x = match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" - | Ptype_variant (l) -> - line i ppf "Ptype_variant\n"; + | Ptype_variant (l, priv) -> + line i ppf "Ptype_variant %a\n" fmt_private_flag priv; list (i+1) string_x_core_type_list ppf l; - | Ptype_record (l) -> - line i ppf "Ptype_record\n"; + | Ptype_record (l, priv) -> + line i ppf "Ptype_record %a\n" fmt_private_flag priv; list (i+1) string_x_mutable_flag_x_core_type ppf l; - | Ptype_private x -> - line i ppf "Ptype_private\n"; - type_kind (i + 1) ppf x and exception_declaration i ppf x = list i core_type ppf x @@ -573,7 +570,7 @@ and structure_item i ppf x = line i ppf "Pstr_module \"%s\"\n" s; module_expr i ppf me; | Pstr_recmodule bindings -> - line i ppf "Pstr_type\n"; + line i ppf "Pstr_recmodule\n"; list i string_x_modtype_x_module ppf bindings; | Pstr_modtype (s, mt) -> line i ppf "Pstr_modtype \"%s\"\n" s; diff --git a/tools/depend.ml b/tools/depend.ml index 96e825e50..46be7b355 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -69,11 +69,10 @@ let add_type_declaration bv td = add_opt add_type bv td.ptype_manifest; let rec add_tkind = function Ptype_abstract -> () - | Ptype_variant cstrs -> + | Ptype_variant (cstrs, _) -> List.iter (fun (c, args) -> List.iter (add_type bv) args) cstrs - | Ptype_record lbls -> - List.iter (fun (l, mut, ty) -> add_type bv ty) lbls - | Ptype_private tkind -> add_tkind tkind in + | Ptype_record (lbls, _) -> + List.iter (fun (l, mut, ty) -> add_type bv ty) lbls in add_tkind td.ptype_kind let rec add_class_type bv cty = diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index a257663ce..1f8766c80 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -235,14 +235,14 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct | Tconstr(path, ty_list, _) -> begin try let decl = Env.find_type path env in - let rec tree_decl = function + match decl with | {type_kind = Type_abstract; type_manifest = None} -> Oval_stuff "<abstr>" | {type_kind = Type_abstract; type_manifest = Some body} -> tree_of_val depth obj (try Ctype.apply env decl.type_params body ty_list with Ctype.Cannot_apply -> abstract_type) - | {type_kind = Type_variant constr_list} -> + | {type_kind = Type_variant(constr_list, priv)} -> let tag = if O.is_block obj then Cstr_block(O.tag obj) @@ -257,7 +257,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct constr_args in tree_of_constr_with_args (tree_of_constr env path) constr_name 0 depth obj ty_args - | {type_kind = Type_record(lbl_list, rep)} -> + | {type_kind = Type_record(lbl_list, rep, priv)} -> begin match check_depth depth obj ty with Some x -> x | None -> @@ -279,9 +279,6 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct in Oval_record (tree_of_fields 0 lbl_list) end - | {type_kind = Type_private tkind} -> - tree_decl {decl with type_kind = tkind} in - tree_decl decl with Not_found -> (* raised by Env.find_type *) Oval_stuff "<abstr>" diff --git a/typing/btype.ml b/typing/btype.ml index 08a5d6c01..950465694 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -265,14 +265,13 @@ let rec unmark_type ty = let unmark_type_decl decl = List.iter unmark_type decl.type_params; - let rec unmark_tkind = function + begin match decl.type_kind with Type_abstract -> () - | Type_variant cstrs -> + | Type_variant (cstrs, priv) -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep) -> + | Type_record(lbls, rep, priv) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls - | Type_private tkind -> unmark_tkind tkind in - unmark_tkind decl.type_kind; + end; begin match decl.type_manifest with None -> () | Some ty -> unmark_type ty diff --git a/typing/ctype.ml b/typing/ctype.ml index afed7a70a..a2b1b2b09 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -422,15 +422,14 @@ let closed_parameterized_type params ty = let closed_type_decl decl = try List.iter mark_type decl.type_params; - let rec closed_tkind = function + begin match decl.type_kind with Type_abstract -> () - | Type_variant v -> + | Type_variant(v, priv) -> List.iter (fun (_, tyl) -> List.iter closed_type tyl) v - | Type_record(r, rep) -> + | Type_record(r, rep, priv) -> List.iter (fun (_, _, ty) -> closed_type ty) r - | Type_private tkind -> closed_tkind tkind in - closed_tkind decl.type_kind; + end; begin match decl.type_manifest with None -> () | Some ty -> closed_type ty @@ -3119,21 +3118,19 @@ let nondep_type_decl env mid id is_covariant decl = type_arity = decl.type_arity; type_kind = begin try - let rec kind_of_tkind = function + match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant cstrs -> + | Type_variant(cstrs, priv) -> Type_variant(List.map (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl)) - cstrs) - | Type_record(lbls, rep) -> + cstrs, priv) + | Type_record(lbls, rep, priv) -> Type_record( List.map (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 + rep, priv) with Not_found when is_covariant -> Type_abstract end; @@ -3151,14 +3148,13 @@ let nondep_type_decl env mid id is_covariant decl = in cleanup_types (); List.iter unmark_type decl.type_params; - let rec unmark_tkind = function + begin match decl.type_kind with Type_abstract -> () - | Type_variant cstrs -> + | Type_variant(cstrs, priv) -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep) -> + | Type_record(lbls, rep, priv) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls - | Type_private tkind -> unmark_tkind tkind in - unmark_tkind decl.type_kind; + end; begin match decl.type_manifest with None -> () | Some ty -> unmark_type ty diff --git a/typing/datarepr.ml b/typing/datarepr.ml index a5ebad55d..ddbd9fb27 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -19,7 +19,7 @@ open Misc open Asttypes open Types -let constructor_descrs ty_res cstrs = +let constructor_descrs ty_res cstrs priv = let num_consts = ref 0 and num_nonconsts = ref 0 in List.iter (function (name, []) -> incr num_consts @@ -40,7 +40,8 @@ let constructor_descrs ty_res cstrs = cstr_arity = List.length ty_args; cstr_tag = tag; cstr_consts = !num_consts; - cstr_nonconsts = !num_nonconsts } in + cstr_nonconsts = !num_nonconsts; + cstr_private = priv } in (name, cstr) :: descr_rem in describe_constructors 0 0 cstrs @@ -50,15 +51,17 @@ let exception_descr path_exc decl = cstr_arity = List.length decl; cstr_tag = Cstr_exception path_exc; cstr_consts = -1; - cstr_nonconsts = -1 } + cstr_nonconsts = -1; + cstr_private = Public } let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) let dummy_label = { lbl_res = none; lbl_arg = none; lbl_mut = Immutable; - lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular } + lbl_pos = (-1); lbl_all = [||]; lbl_repres = Record_regular; + lbl_private = Public } -let label_descrs ty_res lbls repres = +let label_descrs ty_res lbls repres priv = let all_labels = Array.create (List.length lbls) dummy_label in let rec describe_labels num = function [] -> [] @@ -69,7 +72,8 @@ let label_descrs ty_res lbls repres = lbl_mut = mut_flag; lbl_pos = num; lbl_all = all_labels; - lbl_repres = repres } in + lbl_repres = repres; + lbl_private = priv } in all_labels.(num) <- lbl; (name, lbl) :: describe_labels (num+1) rest in describe_labels 0 lbls diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 154604551..eb440aba2 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -19,13 +19,14 @@ open Asttypes open Types val constructor_descrs: - type_expr -> (string * type_expr list) list -> + type_expr -> (string * type_expr list) list -> private_flag -> (string * constructor_description) list val exception_descr: Path.t -> type_expr list -> constructor_description val label_descrs: type_expr -> (string * mutable_flag * type_expr) list -> - record_representation -> (string * label_description) list + record_representation -> private_flag -> + (string * label_description) list exception Constr_not_found diff --git a/typing/env.ml b/typing/env.ml index 33788d479..807d345e0 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -379,27 +379,22 @@ let rec scrape_modtype mty env = (* Compute constructor descriptions *) let constructors_of_type ty_path decl = - let rec constructors_of_tkind = function - | Type_variant cstrs -> + match decl.type_kind with + Type_variant(cstrs, priv) -> 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 - + cstrs priv + | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) let labels_of_type ty_path decl = - let rec labels_of_tkind = function - | Type_record(labels, rep) -> + match decl.type_kind with + Type_record(labels, rep, priv) -> 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 + labels rep priv + | Type_variant _ | Type_abstract -> [] (* 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/includecore.ml b/typing/includecore.ml index a67eb3f87..0c98acdd0 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -15,6 +15,7 @@ (* Inclusion checks for the core language *) open Misc +open Asttypes open Path open Types open Typedtree @@ -34,13 +35,19 @@ let value_descriptions env vd1 vd2 = end else raise Dont_match +(* Inclusion between "private" annotations *) + +let private_flags priv1 priv2 = + match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true + (* Inclusion between type declarations *) let type_declarations env id decl1 decl2 = decl1.type_arity = decl2.type_arity && - let rec incl_tkinds = function + begin match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> true - | (Type_variant cstrs1, Type_variant cstrs2) -> + | (Type_variant (cstrs1, priv1), Type_variant (cstrs2, priv2)) -> + private_flags priv1 priv2 && Misc.for_all2 (fun (cstr1, arg1) (cstr2, arg2) -> cstr1 = cstr2 && @@ -50,7 +57,8 @@ let type_declarations env id decl1 decl2 = (ty2::decl2.type_params)) arg1 arg2) cstrs1 cstrs2 - | (Type_record(labels1, rep1), Type_record(labels2, rep2)) -> + | (Type_record(labels1,rep1,priv1), Type_record(labels2,rep2,priv2)) -> + private_flags priv1 priv2 && rep1 = rep2 && Misc.for_all2 (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) -> @@ -58,11 +66,8 @@ let type_declarations env id decl1 decl2 = Ctype.equal env true (ty1::decl1.type_params) (ty2::decl2.type_params)) labels1 labels2 - | (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) - && + | (_, _) -> false + end && 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 32ee74896..e627bbb17 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -186,8 +186,7 @@ and print_simple_out_type ppf = 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_private _ - | Otyp_manifest (_, _) -> () + | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () and print_fields rest ppf = function [] -> @@ -366,26 +365,27 @@ and print_out_type_decl kwd ppf (name, args, ty, constraints) = Otyp_manifest (_, ty) -> ty | _ -> ty in - let print_private ppf v = if v then fprintf ppf "private " in - let rec print_out_tkind v = function + let print_private ppf = function + Asttypes.Private -> fprintf ppf "private " + | Asttypes.Public -> () in + let rec print_out_tkind = function | Otyp_abstract -> fprintf ppf "@[<2>@[<hv 2>%t@]%a@]" print_name_args print_constraints constraints - | Otyp_record lbls -> + | Otyp_record (lbls, priv) -> fprintf ppf "@[<2>@[<hv 2>%t = %a{%a@;<1 -2>}@]%a@]" print_name_args - print_private v + print_private priv (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls print_constraints constraints - | Otyp_sum constrs -> + | Otyp_sum (constrs, priv) -> fprintf ppf "@[<2>@[<hv 2>%t =@;<1 2>%a%a@]%a@]" print_name_args - print_private v + print_private priv (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 in - print_out_tkind false ty + print_out_tkind 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 051ce47e6..6017719fa 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -52,10 +52,9 @@ type out_type = | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type | Otyp_object of (string * out_type) list * bool option - | Otyp_record of (string * bool * out_type) list + | Otyp_record of (string * bool * out_type) list * Asttypes.private_flag | Otyp_stuff of string - | Otyp_sum of (string * out_type list) list - | Otyp_private of out_type + | Otyp_sum of (string * out_type list) list * Asttypes.private_flag | 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 0aa7945c6..aed352c7c 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -121,7 +121,7 @@ let get_type_descr ty tenv = let rec get_constr tag ty tenv = match get_type_descr ty tenv with - | {type_kind=Type_variant constr_list} -> + | {type_kind=Type_variant(constr_list, priv)} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> get_constr tag (Ctype.expand_head_once tenv ty) tenv @@ -135,7 +135,7 @@ let find_label lbl lbls = let rec get_record_labels ty tenv = match get_type_descr ty tenv with - | {type_kind = Type_record(lbls, rep)} -> lbls + | {type_kind = Type_record(lbls, rep, priv)} -> lbls | {type_manifest = Some _} -> get_record_labels (Ctype.expand_head_once tenv ty) tenv | _ -> fatal_error "Parmatch.get_record_labels" diff --git a/typing/predef.ml b/typing/predef.ml index 9b5b675b7..6c7a77e13 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -14,6 +14,7 @@ (* Predefined type constructors (with special typing rules in typecore) *) +open Asttypes open Path open Types open Btype @@ -92,19 +93,19 @@ let build_initial_env add_type add_exception empty_env = and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant["false",[]; "true",[]]; + type_kind = Type_variant(["false",[]; "true",[]], Public); type_manifest = None; type_variance = []} and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant["()",[]]; + type_kind = Type_variant(["()",[]], Public); type_manifest = None; type_variance = []} and decl_exn = {type_params = []; type_arity = 0; - type_kind = Type_variant []; + type_kind = Type_variant([], Public); type_manifest = None; type_variance = []} and decl_array = @@ -118,7 +119,8 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant["[]", []; "::", [tvar; type_list tvar]]; + type_kind = + Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); type_manifest = None; type_variance = [true, false, false]} and decl_format = @@ -132,7 +134,7 @@ let build_initial_env add_type add_exception empty_env = let tvar = newgenvar() in {type_params = [tvar]; type_arity = 1; - type_kind = Type_variant["None", []; "Some", [tvar]]; + type_kind = Type_variant(["None", []; "Some", [tvar]], Public); type_manifest = None; type_variance = [true, false, false]} and decl_lazy_t = diff --git a/typing/printtyp.ml b/typing/printtyp.ml index c2475b2f9..2da21c284 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -413,15 +413,14 @@ let rec tree_of_type_decl id decl = mark_loops ty; Some ty in - let rec mark = function + begin match decl.type_kind with | Type_abstract -> () - | Type_variant [] -> () - | Type_variant cstrs -> + | Type_variant ([], _) -> () + | Type_variant (cstrs, priv) -> List.iter (fun (_, args) -> List.iter mark_loops args) cstrs - | Type_record(l, rep) -> + | Type_record(l, rep, priv) -> List.iter (fun (_, _, ty) -> mark_loops ty) l - | Type_private tkind -> mark tkind in - mark decl.type_kind; + end; let type_param = function @@ -453,18 +452,17 @@ let rec tree_of_type_decl id decl = in let (name, args) = type_defined decl in let constraints = tree_of_constraints params in - let rec tree_of_tkind = function + let ty = + match decl.type_kind with | Type_abstract -> begin match ty_manifest with | None -> Otyp_abstract | Some ty -> tree_of_typexp false ty end - | Type_variant cstrs -> - tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)) - | Type_record(lbls, rep) -> - tree_of_manifest (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 + | Type_variant(cstrs, priv) -> + tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs, priv)) + | Type_record(lbls, rep, priv) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls, priv)) in (name, args, ty, constraints) diff --git a/typing/subst.ml b/typing/subst.ml index e4d81cc28..9d16d993f 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -155,20 +155,18 @@ let type_declaration s decl = { type_params = List.map (typexp s) decl.type_params; type_arity = decl.type_arity; type_kind = - begin - let rec kind_of_tkind = function - | Type_abstract -> Type_abstract - | Type_variant cstrs -> + begin match decl.type_kind with + Type_abstract -> Type_abstract + | Type_variant (cstrs, priv) -> Type_variant( List.map (fun (n, args) -> (n, List.map (typexp s) args)) - cstrs) - | Type_record(lbls, rep) -> + cstrs, + priv) + | Type_record(lbls, rep, priv) -> Type_record( 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 + rep, priv) end; type_manifest = begin match decl.type_manifest with diff --git a/typing/typecore.ml b/typing/typecore.ml index 575054860..af23cf5e7 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -42,8 +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 + | Private_type of type_expr + | Private_label of Longident.t * type_expr | Unbound_instance_variable of string | Instance_variable_not_mutable of string | Not_subtype of (type_expr * type_expr) list * (type_expr * type_expr) list @@ -121,32 +121,15 @@ let rec extract_label_names sexp env ty = | Tconstr (path, _, _) -> let td = Env.find_type path env in let rec extract = function - | Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields + | Type_record (fields, _, _) -> + List.map (fun (name, _, _) -> name) fields | Type_abstract when td.type_manifest <> None -> 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 *) @@ -939,6 +922,8 @@ let rec type_exp env sexp = generalize_expansive env arg.exp_type; check_univars env "field value" arg label.lbl_arg vars; num_fields := Array.length label.lbl_all; + if label.lbl_private = Private then + raise(Error(sexp.pexp_loc, Private_type ty)); (label, {arg with exp_type = instance arg.exp_type}) in let lbl_exp_list = List.map type_label_exp lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = @@ -981,7 +966,6 @@ let rec type_exp env sexp = let missing = missing_labels 0 label_names in raise(Error(sexp.pexp_loc, Label_missing missing)) end; - check_private_type sexp.pexp_loc env ty; re { exp_desc = Texp_record(lbl_exp_list, opt_exp); exp_loc = sexp.pexp_loc; @@ -1018,7 +1002,8 @@ 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; - check_private_type_setfield lid sexp.pexp_loc env ty_res; + if label.lbl_private = Private then + raise(Error(sexp.pexp_loc, Private_label(lid, ty_res))); re { exp_desc = Texp_setfield(record, label, newval); exp_loc = sexp.pexp_loc; @@ -1607,7 +1592,8 @@ and type_construct env loc lid sarg explicit_arity ty_expected = 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; + if constr.cstr_private = Private then + raise(Error(loc, Private_type ty_res)); { texp with exp_desc = Texp_construct(constr, args) } (* Typing of an expression with an expected type. @@ -2003,10 +1989,10 @@ let report_error ppf = function 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 + fprintf ppf "Cannot create values of the private type %a" type_expr ty + | Private_label (lid, ty) -> + fprintf ppf "Cannot assign field %a of the private type %a" + longident lid type_expr 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 4bd6f1945..06c479ea6 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -79,8 +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 + | Private_type of type_expr + | Private_label of Longident.t * type_expr | 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 21846f450..9b1b9c2fc 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -103,10 +103,10 @@ let transl_declaration env (name, sdecl) id = { type_params = params; type_arity = List.length params; type_kind = - begin let rec get_tkind = function + begin match sdecl.ptype_kind with Ptype_abstract -> Type_abstract - | Ptype_variant cstrs -> + | Ptype_variant (cstrs, priv) -> let all_constrs = ref StringSet.empty in List.iter (fun (name, args) -> @@ -120,8 +120,8 @@ let transl_declaration env (name, sdecl) id = Type_variant(List.map (fun (name, args) -> (name, List.map (transl_simple_type env true) args)) - cstrs) - | Ptype_record lbls -> + cstrs, priv) + | Ptype_record (lbls, priv) -> let all_labels = ref StringSet.empty in List.iter (fun (name, mut, arg) -> @@ -139,10 +139,8 @@ let transl_declaration env (name, sdecl) id = if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls' then Record_float else Record_regular in - Type_record(lbls', rep) - | Ptype_private kind -> Type_private (get_tkind kind) in - get_tkind sdecl.ptype_kind - end; + Type_record(lbls', rep, priv) + end; type_manifest = begin match sdecl.ptype_manifest with None -> None @@ -169,16 +167,14 @@ let transl_declaration env (name, sdecl) id = let generalize_decl decl = List.iter Ctype.generalize decl.type_params; - let rec gen = function - | Type_abstract -> + begin match decl.type_kind with + Type_abstract -> () - | Type_variant v -> + | Type_variant (v, priv) -> List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v - | Type_record(r, rep) -> + | Type_record(r, rep, priv) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r - | Type_private tkind -> - gen tkind in - gen decl.type_kind; + end; begin match decl.type_manifest with | None -> () | Some ty -> Ctype.generalize ty @@ -217,12 +213,11 @@ let rec check_constraints_rec env loc visited ty = let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in - let rec check = function + begin match decl.type_kind with | Type_abstract -> () - | Type_variant l -> + | Type_variant (l, _) -> let rec find_pl = function - Ptype_variant pl -> pl - | Ptype_private tkind -> find_pl tkind + Ptype_variant(pl, _) -> pl | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in @@ -234,10 +229,9 @@ let check_constraints env (_, sdecl) (_, decl) = check_constraints_rec env sty.ptyp_loc visited ty) styl tyl) l - | Type_record (l, _) -> + | Type_record (l, _, _) -> let rec find_pl = function - Ptype_record pl -> pl - | Ptype_private tkind -> find_pl tkind + Ptype_record(pl, _) -> pl | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in @@ -250,8 +244,7 @@ let check_constraints env (_, sdecl) (_, decl) = (fun (name, _, ty) -> check_constraints_rec env (get_loc name pl) visited ty) l - | Type_private tkind -> check tkind in - check decl.type_kind; + end; begin match decl.type_manifest with | None -> () | Some ty -> @@ -425,25 +418,24 @@ let compute_variance_decl env decl (required, loc) = let tvl = List.map (fun ty -> (Btype.repr ty, ref false, ref false, ref false)) decl.type_params in - let rec variance_tkind = function + begin match decl.type_kind with Type_abstract -> begin match decl.type_manifest with None -> assert false | Some ty -> compute_variance env tvl true false false ty end - | Type_variant tll -> + | Type_variant (tll, _) -> List.iter (fun (_,tl) -> List.iter (compute_variance env tvl true false false) tl) tll - | Type_record (ftl, _) -> + | Type_record (ftl, _, _) -> List.iter (fun (_, mut, ty) -> let cn = (mut = Mutable) in compute_variance env tvl true cn cn ty) ftl - | Type_private tkind -> variance_tkind tkind in - variance_tkind decl.type_kind; + end; List.map2 (fun (_, co, cn, ct) (c, n) -> if c && !cn || n && !co then raise (Error(loc, Bad_variance)); diff --git a/typing/types.ml b/typing/types.ml index f541f50e6..9954d56c4 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -105,7 +105,8 @@ type constructor_description = cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int } (* Number of non-const constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_private: private_flag } (* Read-only constructor? *) and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) @@ -120,7 +121,8 @@ type label_description = lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation } (* Representation for this record *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag } (* Read-only field? *) and record_representation = Record_regular (* All fields are boxed / tagged *) @@ -137,10 +139,9 @@ type type_declaration = and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list + | Type_variant of (string * type_expr list) list * private_flag | Type_record of (string * mutable_flag * type_expr) list - * record_representation - | Type_private of type_kind + * record_representation * private_flag type exception_declaration = type_expr list diff --git a/typing/types.mli b/typing/types.mli index 62d9654c7..2a52037ee 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -106,7 +106,8 @@ type constructor_description = cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) - cstr_nonconsts: int } (* Number of non-const constructors *) + cstr_nonconsts: int; (* Number of non-const constructors *) + cstr_private: private_flag } (* Read-only constructor? *) and constructor_tag = Cstr_constant of int (* Constant constructor (an int) *) @@ -121,7 +122,8 @@ type label_description = lbl_mut: mutable_flag; (* Is this a mutable field? *) lbl_pos: int; (* Position in block *) lbl_all: label_description array; (* All the labels in this type *) - lbl_repres: record_representation } (* Representation for this record *) + lbl_repres: record_representation; (* Representation for this record *) + lbl_private: private_flag } (* Read-only field? *) and record_representation = Record_regular (* All fields are boxed / tagged *) @@ -139,10 +141,9 @@ type type_declaration = and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list + | Type_variant of (string * type_expr list) list * private_flag | Type_record of (string * mutable_flag * type_expr) list - * record_representation - | Type_private of type_kind + * record_representation * private_flag type exception_declaration = type_expr list |