diff options
48 files changed, 290 insertions, 224 deletions
@@ -623,8 +623,10 @@ asmcomp/proc.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/arch.cmx asmcomp/proc.cmi asmcomp/reg.cmo: asmcomp/cmm.cmi asmcomp/reg.cmi asmcomp/reg.cmx: asmcomp/cmm.cmx asmcomp/reg.cmi -asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reload.cmi -asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reload.cmi +asmcomp/reload.cmo: asmcomp/reloadgen.cmi asmcomp/reg.cmi asmcomp/mach.cmi \ + asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/reload.cmi +asmcomp/reload.cmx: asmcomp/reloadgen.cmx asmcomp/reg.cmx asmcomp/mach.cmx \ + asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/reload.cmi asmcomp/reloadgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/reloadgen.cmi asmcomp/reloadgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ @@ -635,20 +637,20 @@ asmcomp/schedgen.cmo: asmcomp/reg.cmi utils/misc.cmi asmcomp/mach.cmi \ asmcomp/schedgen.cmx: asmcomp/reg.cmx utils/misc.cmx asmcomp/mach.cmx \ asmcomp/linearize.cmx asmcomp/cmm.cmx asmcomp/arch.cmx \ asmcomp/schedgen.cmi -asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/mach.cmi \ - asmcomp/arch.cmo asmcomp/scheduling.cmi -asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/mach.cmx \ - asmcomp/arch.cmx asmcomp/scheduling.cmi +asmcomp/scheduling.cmo: asmcomp/schedgen.cmi asmcomp/scheduling.cmi +asmcomp/scheduling.cmx: asmcomp/schedgen.cmx asmcomp/scheduling.cmi asmcomp/selectgen.cmo: utils/tbl.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ utils/misc.cmi asmcomp/mach.cmi typing/ident.cmi asmcomp/debuginfo.cmi \ asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selectgen.cmi asmcomp/selectgen.cmx: utils/tbl.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ utils/misc.cmx asmcomp/mach.cmx typing/ident.cmx asmcomp/debuginfo.cmx \ asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selectgen.cmi -asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi utils/misc.cmi \ - asmcomp/mach.cmi asmcomp/cmm.cmi asmcomp/arch.cmo asmcomp/selection.cmi -asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx utils/misc.cmx \ - asmcomp/mach.cmx asmcomp/cmm.cmx asmcomp/arch.cmx asmcomp/selection.cmi +asmcomp/selection.cmo: asmcomp/selectgen.cmi asmcomp/reg.cmi asmcomp/proc.cmi \ + utils/misc.cmi asmcomp/mach.cmi asmcomp/debuginfo.cmi asmcomp/cmm.cmi \ + asmcomp/arch.cmo asmcomp/selection.cmi +asmcomp/selection.cmx: asmcomp/selectgen.cmx asmcomp/reg.cmx asmcomp/proc.cmx \ + utils/misc.cmx asmcomp/mach.cmx asmcomp/debuginfo.cmx asmcomp/cmm.cmx \ + asmcomp/arch.cmx asmcomp/selection.cmi asmcomp/spill.cmo: asmcomp/reg.cmi asmcomp/proc.cmi utils/misc.cmi \ asmcomp/mach.cmi asmcomp/spill.cmi asmcomp/spill.cmx: asmcomp/reg.cmx asmcomp/proc.cmx utils/misc.cmx \ diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 7c34fd622..e7c55708e 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 734b04ce8..ad2fd5fec 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 6c31d1dd9..448b13be1 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index 883814546..a7ee4cf1a 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/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml index 98237ffd9..4756f9e85 100644 --- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml +++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml @@ -278,10 +278,11 @@ module Make (Ast : Sig.Camlp4Ast) = struct | _ -> assert False ] ; - value mktype loc tl cl tk tm = + value mktype loc tl cl tk tp tm = let (params, variance) = List.split tl in {ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; - ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance} + ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; + ptype_variance = variance} ; value mkprivate' m = if m then Private else Public; value mkprivate m = mkprivate' (mb2b m); @@ -306,10 +307,10 @@ module Make (Ast : Sig.Camlp4Ast) = struct type_decl tl cl loc m True t | <:ctyp< { $t$ } >> -> mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t [])) (mkprivate' pflag)) m - | <:ctyp< [ $t$ ] >> -> + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) (mkprivate' pflag) m + | TySum _ t -> mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t [])) (mkprivate' pflag)) m + (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) (mkprivate' pflag) m | t -> if m <> None then error loc "only one manifest type allowed by definition" else @@ -318,8 +319,7 @@ module Make (Ast : Sig.Camlp4Ast) = struct [ <:ctyp<>> -> None | _ -> Some (ctyp t) ] in - let k = if pflag then Ptype_private else Ptype_abstract in - mktype loc tl cl k m ] + mktype loc tl cl Ptype_abstract (mkprivate' pflag) m ] ; value type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None False t; @@ -343,8 +343,8 @@ module Make (Ast : Sig.Camlp4Ast) = struct value opt_private_ctyp = fun - [ <:ctyp< private $t$ >> -> (Ptype_private, ctyp t) - | t -> (Ptype_abstract, ctyp t) ]; + [ <:ctyp< private $t$ >> -> (Ptype_abstract, Private, ctyp t) + | t -> (Ptype_abstract, Public, ctyp t) ]; value rec type_parameters t acc = match t with @@ -376,11 +376,12 @@ module Make (Ast : Sig.Camlp4Ast) = struct | WcTyp loc id_tpl ct -> let (id, tpl) = type_parameters_and_type_name id_tpl [] in let (params, variance) = List.split tpl in - let (kind, ct) = opt_private_ctyp ct in + let (kind, priv, ct) = opt_private_ctyp ct in [(id, Pwith_type {ptype_params = params; ptype_cstrs = []; ptype_kind = kind; + ptype_private = priv; ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance}) :: acc] | WcMod _ i1 i2 -> diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml index 067a09933..8135aaaf2 100644 --- a/camlp4/boot/Camlp4.ml +++ b/camlp4/boot/Camlp4.ml @@ -11441,13 +11441,14 @@ module Struct = | Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) -> (mkfield loc (Pfield (lab, mkpolytype (ctyp t)))) :: acc | _ -> assert false - let mktype loc tl cl tk tm = + let mktype loc tl cl tk tp tm = let (params, variance) = List.split tl in { ptype_params = params; ptype_cstrs = cl; ptype_kind = tk; + ptype_private = tp; ptype_manifest = tm; ptype_loc = mkloc loc; ptype_variance = variance; @@ -11477,13 +11478,13 @@ module Struct = | Ast.TyPrv (_, t) -> type_decl tl cl loc m true t | Ast.TyRec (_, t) -> mktype loc tl cl - (Ptype_record (List.map mktrecord (list_of_ctyp t []), - mkprivate' pflag)) + (Ptype_record (List.map mktrecord (list_of_ctyp t []))) + (mkprivate' pflag) m | Ast.TySum (_, t) -> mktype loc tl cl - (Ptype_variant (List.map mkvariant (list_of_ctyp t []), - mkprivate' pflag)) + (Ptype_variant (List.map mkvariant (list_of_ctyp t []))) + (mkprivate' pflag) m | t -> if m <> None @@ -11494,8 +11495,8 @@ module Struct = match t with | Ast.TyNil _ -> None | _ -> Some (ctyp t) in - let k = if pflag then Ptype_private else Ptype_abstract - in mktype loc tl cl k m) + let p = if pflag then Private else Public + in mktype loc tl cl Ptype_abstract p m) let type_decl tl cl t = type_decl tl cl (loc_of_ctyp t) None false t let mkvalue_desc t p = { pval_type = ctyp t; pval_prim = p; } @@ -11515,8 +11516,8 @@ module Struct = | _ -> lab let opt_private_ctyp = function - | Ast.TyPrv (_, t) -> (Ptype_private, (ctyp t)) - | t -> (Ptype_abstract, (ctyp t)) + | Ast.TyPrv (_, t) -> (Ptype_abstract, Private, (ctyp t)) + | t -> (Ptype_abstract, Public, (ctyp t)) let rec type_parameters t acc = match t with | Ast.TyApp (_, t1, t2) -> @@ -11545,7 +11546,7 @@ module Struct = | WcTyp (loc, id_tpl, ct) -> let (id, tpl) = type_parameters_and_type_name id_tpl [] in let (params, variance) = List.split tpl in - let (kind, ct) = opt_private_ctyp ct + let (kind, priv, ct) = opt_private_ctyp ct in (id, (Pwith_type @@ -11553,6 +11554,7 @@ module Struct = ptype_params = params; ptype_cstrs = []; ptype_kind = kind; + ptype_private = priv; ptype_manifest = Some ct; ptype_loc = mkloc loc; ptype_variance = variance; diff --git a/debugger/eval.ml b/debugger/eval.ml index a53589382..07c9688ec 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, priv) -> + Type_record(lbl_list, repr) -> 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_ast.ml b/ocamldoc/odoc_ast.ml index 7c4e022ca..e1e1d33ca 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1129,6 +1129,7 @@ module Analyser = tt_type_decl.Types.type_params tt_type_decl.Types.type_variance ; ty_kind = kind ; + ty_private = tt_type_decl.Types.type_private; ty_manifest = (match tt_type_decl.Types.type_manifest with None -> None diff --git a/ocamldoc/odoc_cross.ml b/ocamldoc/odoc_cross.ml index 02ad79f50..c5686338a 100644 --- a/ocamldoc/odoc_cross.ml +++ b/ocamldoc/odoc_cross.ml @@ -889,11 +889,11 @@ and assoc_comments_type module_list t = t.ty_info <- ao (assoc_comments_info parent module_list) t.ty_info ; (match t.ty_kind with Type_abstract -> () - | Type_variant (vl, _) -> + | Type_variant vl -> List.iter (fun vc -> vc.vc_text <- ao (assoc_comments_text parent module_list) vc.vc_text) vl - | Type_record (fl, _) -> + | Type_record fl -> List.iter (fun rf -> rf.rf_text <- ao (assoc_comments_text parent module_list) rf.rf_text) fl diff --git a/ocamldoc/odoc_dep.ml b/ocamldoc/odoc_dep.ml index 94cd51024..c7ff69346 100644 --- a/ocamldoc/odoc_dep.ml +++ b/ocamldoc/odoc_dep.ml @@ -147,7 +147,7 @@ let type_deps t = in (match t.T.ty_kind with T.Type_abstract -> () - | T.Type_variant (cl, _) -> + | T.Type_variant cl -> List.iter (fun c -> List.iter @@ -158,7 +158,7 @@ let type_deps t = c.T.vc_args ) cl - | T.Type_record (rl, _) -> + | T.Type_record rl -> List.iter (fun r -> let s = Odoc_print.string_of_type_expr r.T.rf_type in diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index 8687f3d1d..8f93fcf75 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -1367,19 +1367,21 @@ class html = self#html_of_type_expr_param_list b father t; (match t.ty_parameters with [] -> () | _ -> bs b " "); bs b ((Name.simple t.ty_name)^" "); + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> bs b "= "; + if priv then bs b "private "; self#html_of_type_expr b father typ; bs b " " ); (match t.ty_kind with Type_abstract -> bs b "</pre>" - | Type_variant (l, priv) -> + | Type_variant l -> bs b "= "; - if priv then bs b "private" ; + if priv then bs b "private "; bs b ( match t.ty_manifest with @@ -1423,7 +1425,7 @@ class html = print_concat b "\n" print_one l; bs b "</table>\n" - | Type_record (l, priv) -> + | Type_record l -> bs b "= "; if priv then bs b "private " ; bs b "{"; @@ -1814,7 +1816,7 @@ class html = (Naming.type_target { ty_name = c.cl_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } @@ -1861,7 +1863,7 @@ class html = (Naming.type_target { ty_name = ct.clt_name ; ty_info = None ; ty_parameters = [] ; - ty_kind = Type_abstract ; ty_manifest = None ; + ty_kind = Type_abstract ; ty_private = Asttypes.Public; ty_manifest = None ; ty_loc = Odoc_info.dummy_loc ; ty_code = None ; } diff --git a/ocamldoc/odoc_info.mli b/ocamldoc/odoc_info.mli index 613d066f8..f5ad42ddf 100644 --- a/ocamldoc/odoc_info.mli +++ b/ocamldoc/odoc_info.mli @@ -207,10 +207,10 @@ module Type : (** The various kinds of a type. *) type type_kind = Odoc_type.type_kind = Type_abstract (** Type is abstract, for example [type t]. *) - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = Odoc_type.t_type = @@ -219,7 +219,8 @@ module Type : mutable ty_info : info option ; (** Information found in the optional associated comment. *) ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) - ty_kind : type_kind ; (** Type kind. *) + ty_kind : type_kind; (** Type kind. *) + ty_private : Asttypes.private_flag; (** Private or public type. *) ty_manifest : Types.type_expr option; (** Type manifest. *) mutable ty_loc : location ; mutable ty_code : string option; diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 95d1b9178..14f5aeab7 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -474,11 +474,12 @@ class latex = self#latex_of_type_params fmt2 mod_name t; (match t.ty_parameters with [] -> () | _ -> ps fmt2 " "); ps fmt2 s_name; + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> - p fmt2 " = %s" (self#normal_type mod_name typ) + p fmt2 " = %s%s" (if priv then "private " else "") (self#normal_type mod_name typ) ); let s_type3 = p fmt2 @@ -486,8 +487,8 @@ class latex = ( match t.ty_kind with Type_abstract -> "" - | Type_variant (_, priv) -> "="^(if priv then " private" else "") - | Type_record (_, priv) -> "= "^(if priv then "private " else "")^"{" + | Type_variant _ -> "="^(if priv then " private" else "") + | Type_record _ -> "= "^(if priv then "private " else "")^"{" ) ; flush2 () in @@ -495,7 +496,7 @@ class latex = let defs = match t.ty_kind with Type_abstract -> [] - | Type_variant (l, _) -> + | Type_variant l -> (List.flatten (List.map (fun constr -> @@ -527,7 +528,7 @@ class latex = l ) ) - | Type_record (l, _) -> + | Type_record l -> (List.flatten (List.map (fun r -> diff --git a/ocamldoc/odoc_man.ml b/ocamldoc/odoc_man.ml index b77439f6e..eb2a1bac4 100644 --- a/ocamldoc/odoc_man.ml +++ b/ocamldoc/odoc_man.ml @@ -410,17 +410,19 @@ class man = ); bs b (Name.simple t.ty_name); bs b " \n"; + let priv = t.ty_private = Asttypes.Private in ( match t.ty_manifest with None -> () | Some typ -> bs b "= "; + if priv then bs b "private "; self#man_of_type_expr b father typ ); ( match t.ty_kind with Type_abstract -> () - | Type_variant (l, priv) -> + | Type_variant l -> bs b "="; if priv then bs b " private"; bs b "\n "; @@ -448,7 +450,7 @@ class man = ) ) l - | Type_record (l, priv) -> + | Type_record l -> bs b "= "; if priv then bs b "private "; bs b "{"; diff --git a/ocamldoc/odoc_merge.ml b/ocamldoc/odoc_merge.ml index 468c47113..fd046752e 100644 --- a/ocamldoc/odoc_merge.ml +++ b/ocamldoc/odoc_merge.ml @@ -196,7 +196,7 @@ let merge_types merge_options mli ml = Type_abstract, _ -> () - | Type_variant (l1, _), Type_variant (l2, _) -> + | Type_variant l1, Type_variant l2 -> let f cons = try let cons2 = List.find @@ -224,7 +224,7 @@ let merge_types merge_options mli ml = in List.iter f l1 - | Type_record (l1, _), Type_record (l2, _) -> + | Type_record l1, Type_record l2 -> let f record = try let record2= List.find diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 36b3b1411..9e0fc743e 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -172,9 +172,9 @@ module Analyser = let name_comment_from_type_kind pos_end pos_limit tk = match tk with - Parsetree.Ptype_abstract | Parsetree.Ptype_private -> + Parsetree.Ptype_abstract -> (0, []) - | Parsetree.Ptype_variant (cons_core_type_list_list, _) -> + | Parsetree.Ptype_variant cons_core_type_list_list -> let rec f acc cons_core_type_list_list = match cons_core_type_list_list with [] -> @@ -197,7 +197,7 @@ module Analyser = in f [] 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 [] -> [] @@ -220,7 +220,7 @@ module Analyser = Types.Type_abstract -> Odoc_type.Type_abstract - | Types.Type_variant (l, priv) -> + | Types.Type_variant l -> let f (constructor_name, type_expr_list) = let comment_opt = try @@ -235,9 +235,9 @@ module Analyser = vc_text = comment_opt } in - Odoc_type.Type_variant (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_variant (List.map f l) - | Types.Type_record (l, _, priv) -> + | Types.Type_record (l, _) -> let f (field_name, mutable_flag, type_expr) = let comment_opt = try @@ -253,7 +253,7 @@ module Analyser = rf_text = comment_opt } in - Odoc_type.Type_record (List.map f l, priv = Asttypes.Private) + Odoc_type.Type_record (List.map f l) (** 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).*) @@ -609,7 +609,8 @@ module Analyser = ) sig_type_decl.Types.type_params sig_type_decl.Types.type_variance; - ty_kind = type_kind ; + ty_kind = type_kind; + ty_private = sig_type_decl.Types.type_private; ty_manifest = (match sig_type_decl.Types.type_manifest with None -> None diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index fb1d2b31d..3fafb9622 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -150,6 +150,10 @@ let string_of_class_params c = iter c.Odoc_class.cl_type; Buffer.contents b +let bool_of_private = function + | Asttypes.Private -> true + | _ -> false + let string_of_type t = let module M = Odoc_type in "type "^ @@ -162,15 +166,18 @@ let string_of_type t = t.M.ty_parameters ) )^ + let priv = bool_of_private (t.M.ty_private) in (Name.simple t.M.ty_name)^" "^ (match t.M.ty_manifest with None -> "" - | Some typ -> "= "^(Odoc_print.string_of_type_expr typ)^" " + | Some typ -> + "= " ^ (if priv then "private " else "" ) ^ + (Odoc_print.string_of_type_expr typ)^" " )^ (match t.M.ty_kind with M.Type_abstract -> "" - | M.Type_variant (l, priv) -> + | M.Type_variant l -> "="^(if priv then " private" else "")^"\n"^ (String.concat "" (List.map @@ -192,7 +199,7 @@ let string_of_type t = l ) ) - | M.Type_record (l, priv) -> + | M.Type_record l -> "= "^(if priv then "private " else "")^"{\n"^ (String.concat "" (List.map diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index 07217e992..33d589f3c 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -631,15 +631,17 @@ class texi = [ Newline ; minus ; Raw "type " ; Raw (self#string_of_type_parameters ty) ; Raw (Name.simple ty.ty_name) ] @ + let priv = ty.ty_private = Asttypes.Private in ( match ty.ty_manifest with | None -> [] | Some typ -> - (Raw " = ") :: (self#text_of_short_type_expr - (Name.father ty.ty_name) typ) ) @ + (Raw " = ") :: + (Raw (if priv then "private " else "")) :: + (self#text_of_short_type_expr (Name.father ty.ty_name) typ) ) @ ( match ty.ty_kind with | Type_abstract -> [ Newline ] - | Type_variant (l, priv) -> + | Type_variant l -> (Raw (" ="^(if priv then " private" else "")^"\n")) :: (List.flatten (List.map @@ -652,7 +654,7 @@ class texi = ((Raw (indent 5 "\n(* ")) :: (self#soft_fix_linebreaks 8 t)) @ [ Raw " *)" ; Newline ] ) ) l ) ) - | Type_record (l, priv) -> + | Type_record l -> (Raw (" = "^(if priv then "private " else "")^"{\n")) :: (List.flatten (List.map diff --git a/ocamldoc/odoc_type.ml b/ocamldoc/odoc_type.ml index bcf194d14..eaaca5dc7 100644 --- a/ocamldoc/odoc_type.ml +++ b/ocamldoc/odoc_type.ml @@ -33,10 +33,10 @@ type record_field = { (** The various kinds of type. *) type type_kind = Type_abstract - | Type_variant of variant_constructor list * bool - (** constructors * bool *) - | Type_record of record_field list * bool - (** fields * bool *) + | Type_variant of variant_constructor list + (** constructors *) + | Type_record of record_field list + (** fields *) (** Representation of a type. *) type t_type = { @@ -45,6 +45,7 @@ type t_type = { ty_parameters : (Types.type_expr * bool * bool) list ; (** type parameters: (type, covariant, contravariant) *) ty_kind : type_kind ; + ty_private : Asttypes.private_flag; ty_manifest : Types.type_expr option; (** type manifest *) mutable ty_loc : Odoc_types.location ; mutable ty_code : string option; diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml index 01a2be2c8..206b735c2 100644 --- a/otherlibs/labltk/browser/searchid.ml +++ b/otherlibs/labltk/browser/searchid.ml @@ -228,9 +228,9 @@ let rec search_type_in_signature t ~sign ~prefix ~mode = end || begin match td.type_kind with Type_abstract -> false - | Type_variant(l, priv) -> + | Type_variant l -> List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches) - | Type_record(l, rep, priv) -> + | Type_record(l, rep) -> List.exists l ~f:(fun (_, _, t) -> matches t) end then [lid_of_id id, Ptype] else [] diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index e9c1ffad0..52d4c0b0d 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -165,11 +165,11 @@ let search_pos_type_decl td ~pos ~env = | None -> () end; let rec search_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (dl, _) -> + Ptype_abstract -> () + | Ptype_variant dl -> List.iter dl ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) - | Ptype_record (dl, _) -> + | 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: diff --git a/otherlibs/threads/Makefile b/otherlibs/threads/Makefile index 7c546c449..b0ad09945 100644 --- a/otherlibs/threads/Makefile +++ b/otherlibs/threads/Makefile @@ -88,7 +88,7 @@ unix.mli: $(UNIXLIB)/unix.mli unix.cmi: $(UNIXLIB)/unix.cmi ln -sf $(UNIXLIB)/unix.cmi unix.cmi -unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo +unix.cmo: unix.mli unix.cmi $(UNIXLIB)/unixLabels.cmo $(CAMLC) ${COMPFLAGS} -c unix.ml partialclean: diff --git a/parsing/parser.mly b/parsing/parser.mly index 6e2092063..e30a6a3c9 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1149,10 +1149,11 @@ type_declarations: type_declaration: type_parameters LIDENT type_kind constraints { let (params, variance) = List.split $1 in - let (kind, manifest) = $3 in + let (kind, private_flag, manifest) = $3 in ($2, {ptype_params = params; ptype_cstrs = List.rev $4; ptype_kind = kind; + ptype_private = private_flag; ptype_manifest = manifest; ptype_variance = variance; ptype_loc = symbol_rloc()}) } @@ -1163,23 +1164,23 @@ constraints: ; type_kind: /*empty*/ - { (Ptype_abstract, None) } + { (Ptype_abstract, Public, None) } | EQUAL core_type - { (Ptype_abstract, Some $2) } + { (Ptype_abstract, Public, Some $2) } | EQUAL constructor_declarations - { (Ptype_variant(List.rev $2, Public), None) } + { (Ptype_variant(List.rev $2), Public, None) } | EQUAL PRIVATE constructor_declarations - { (Ptype_variant(List.rev $3, Private), None) } + { (Ptype_variant(List.rev $3), Private, None) } | EQUAL private_flag BAR constructor_declarations - { (Ptype_variant(List.rev $4, $2), None) } + { (Ptype_variant(List.rev $4), $2, None) } | EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $4, $2), None) } + { (Ptype_record(List.rev $4), $2, None) } | EQUAL core_type EQUAL private_flag opt_bar constructor_declarations - { (Ptype_variant(List.rev $6, $4), Some $2) } + { (Ptype_variant(List.rev $6), $4, Some $2) } | EQUAL core_type EQUAL private_flag LBRACE label_declarations opt_semi RBRACE - { (Ptype_record(List.rev $6, $4), Some $2) } + { (Ptype_record(List.rev $6), $4, Some $2) } | EQUAL PRIVATE core_type - { (Ptype_private, Some $3) } + { (Ptype_abstract, Private, Some $3) } ; type_parameters: /*empty*/ { [] } @@ -1228,8 +1229,9 @@ with_constraint: { let params, variance = List.split $2 in ($3, Pwith_type {ptype_params = params; ptype_cstrs = List.rev $6; - ptype_kind = $4; + ptype_kind = Ptype_abstract; ptype_manifest = Some $5; + ptype_private = $4; ptype_variance = variance; ptype_loc = symbol_rloc()}) } /* used label_longident instead of type_longident to disallow @@ -1238,8 +1240,8 @@ with_constraint: { ($2, Pwith_module $4) } ; with_type_binder: - EQUAL { Ptype_abstract } - | EQUAL PRIVATE { Ptype_private } + EQUAL { Public } + | EQUAL PRIVATE { Private } ; /* Polymorphic types */ diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 1ca2fec1d..1bd334c8a 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -124,16 +124,16 @@ and type_declaration = { ptype_params: string list; ptype_cstrs: (core_type * core_type * Location.t) list; ptype_kind: type_kind; + ptype_private: private_flag; ptype_manifest: core_type option; ptype_variance: (bool * bool) list; ptype_loc: Location.t } and type_kind = Ptype_abstract - | Ptype_variant of (string * core_type list * Location.t) list * private_flag + | Ptype_variant of (string * core_type list * Location.t) list | Ptype_record of - (string * mutable_flag * core_type * Location.t) list * private_flag - | Ptype_private + (string * mutable_flag * core_type * Location.t) list and exception_declaration = core_type list diff --git a/parsing/printast.ml b/parsing/printast.ml index 005a757f0..a70414a83 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -317,6 +317,7 @@ and type_declaration i ppf x = list (i+1) core_type_x_core_type_x_location ppf x.ptype_cstrs; line i ppf "ptype_kind =\n"; type_kind (i+1) ppf x.ptype_kind; + line i ppf "ptype_private = %a\n" fmt_private_flag x.ptype_private; line i ppf "ptype_manifest =\n"; option (i+1) core_type ppf x.ptype_manifest; @@ -324,14 +325,12 @@ and type_kind i ppf x = match x with | Ptype_abstract -> line i ppf "Ptype_abstract\n" - | Ptype_variant (l, priv) -> - line i ppf "Ptype_variant %a\n" fmt_private_flag priv; + | Ptype_variant l -> + line i ppf "Ptype_variant\n"; list (i+1) string_x_core_type_list_x_location ppf l; - | Ptype_record (l, priv) -> - line i ppf "Ptype_record %a\n" fmt_private_flag priv; + | Ptype_record l -> + line i ppf "Ptype_record\n"; list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l; - | Ptype_private -> - line i ppf "Ptype_private\n" and exception_declaration i ppf x = list i core_type ppf x diff --git a/test/Moretest/Makefile b/test/Moretest/Makefile index f8b0c8bcc..f6c90642e 100644 --- a/test/Moretest/Makefile +++ b/test/Moretest/Makefile @@ -21,6 +21,15 @@ CAMLDEP=../../boot/ocamlrun ../../tools/ocamldep CAMLRUN=../../byterun/ocamlrun CODERUNPARAMS=OCAMLRUNPARAM='o=100' +OUTS=callback.out manyargs.out \ +cm.byt cmlinked.out cm.out \ +bigarrays.out bigarrf.out fftba.out globroots.out float.out intext.out \ +printf scanf regexp.byt regexp.opt md5.out recmod.out + +BROKENS=# multdef.out + +all: $(OUTS) + callback.byt: callback.cmo callbackprim.o $(CAMLC) -o callback.byt -custom callback.cmo callbackprim.o ../../otherlibs/unix/libunix.a callback.out: callback.cmx callbackprim.o diff --git a/test/Moretest/cmcaml.ml b/test/Moretest/cmcaml.ml index a7e1cf55e..4ebed1e7d 100644 --- a/test/Moretest/cmcaml.ml +++ b/test/Moretest/cmcaml.ml @@ -6,7 +6,7 @@ let rec fib n = let format_result n = let r = "Result = " ^ string_of_int n in (* Allocate gratuitously to test GC *) - for i = 1 to 1500 do String.create 256 done; + for i = 1 to 1500 do ignore (String.create 256) done; r (* Registration *) @@ -14,4 +14,3 @@ let format_result n = let _ = Callback.register "fib" fib; Callback.register "format_result" format_result - diff --git a/test/Moretest/manyargsprim.c b/test/Moretest/manyargsprim.c index c80e5346d..fb715c6bb 100644 --- a/test/Moretest/manyargsprim.c +++ b/test/Moretest/manyargsprim.c @@ -1,4 +1,5 @@ #include "mlvalues.h" +#include "stdio.h" value manyargs(value a, value b, value c, value d, value e, value f, value g, value h, value i, value j, value k) diff --git a/test/Moretest/tcallback.ml b/test/Moretest/tcallback.ml index 025c7a46c..32914119b 100644 --- a/test/Moretest/tcallback.ml +++ b/test/Moretest/tcallback.ml @@ -3,7 +3,7 @@ external mycallback2 : ('a -> 'b -> 'c) -> 'a -> 'b -> 'c = "mycallback2" external mycallback3 : ('a -> 'b -> 'c -> 'd) -> 'a -> 'b -> 'c -> 'd = "mycallback3" external mycallback4 : ('a -> 'b -> 'c -> 'd -> 'e) -> 'a -> 'b -> 'c -> 'd -> 'e = "mycallback4" -let rec tak (x, y, z as tuple) = +let rec tak (x, y, z as _tuple) = if x > y then tak(tak (x-1, y, z), tak (y-1, z, x), tak (z-1, x, y)) else z @@ -38,8 +38,7 @@ let sighandler signo = print_newline(); *) (* Thoroughly wipe the minor heap *) - tak (18, 12, 6); - () + ignore (tak (18, 12, 6)) external unix_getpid : unit -> int = "unix_getpid" "noalloc" external unix_kill : int -> int -> unit = "unix_kill" "noalloc" @@ -64,6 +63,6 @@ let _ = print_int(trapexit ()); print_newline(); print_string(tripwire mypushroot); print_newline(); print_string(tripwire mycamlparam); print_newline(); - Sys.signal Sys.sigusr1 (Sys.Signal_handle sighandler); + Sys.set_signal Sys.sigusr1 (Sys.Signal_handle sighandler); print_string(callbacksig ()); print_newline() diff --git a/tools/depend.ml b/tools/depend.ml index 5afe1435e..c39002516 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -68,10 +68,10 @@ let add_type_declaration bv td = td.ptype_cstrs; add_opt add_type bv td.ptype_manifest; let rec add_tkind = function - Ptype_abstract | Ptype_private -> () - | Ptype_variant (cstrs, _) -> + Ptype_abstract -> () + | Ptype_variant cstrs -> List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs - | Ptype_record (lbls, _) -> + | Ptype_record lbls -> List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in add_tkind td.ptype_kind diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 116740d56..1a16bc80c 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -242,7 +242,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct 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, priv)} -> + | {type_kind = Type_variant constr_list} -> 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, priv)} -> + | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> diff --git a/typing/btype.ml b/typing/btype.ml index fb7a289a2..290d43e58 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -140,7 +140,7 @@ let proxy ty = in proxy_obj ty | _ -> ty0 -(**** Utilities for private types ****) +(**** Utilities for fixed row private types ****) let has_constr_row t = match (repr t).desc with @@ -318,9 +318,9 @@ let unmark_type_decl decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with diff --git a/typing/btype.mli b/typing/btype.mli index 6e1f2f215..5d2702775 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -59,7 +59,7 @@ val proxy: type_expr -> type_expr (* Return the proxy representative of the type: either itself or a row variable *) -(**** Utilities for private types ****) +(**** Utilities for private abbreviations with fixed rows ****) val has_constr_row: type_expr -> bool val is_row_name: string -> bool diff --git a/typing/ctype.ml b/typing/ctype.ml index cf9b1b3b8..69ae27b27 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -439,9 +439,9 @@ let closed_type_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant(v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter closed_type tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> closed_type ty) r end; begin match decl.type_manifest with @@ -3267,16 +3267,16 @@ let nondep_type_decl env mid id is_covariant decl = match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> Type_variant(List.map (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl)) - cstrs, priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (c, mut, t) -> (c, mut, nondep_type_rec env mid t)) lbls, - rep, priv) + rep) with Not_found when is_covariant -> Type_abstract end; @@ -3289,6 +3289,7 @@ let nondep_type_decl env mid id is_covariant decl = with Not_found when is_covariant -> None end; + type_private = decl.type_private; type_variance = decl.type_variance; } in @@ -3296,9 +3297,9 @@ let nondep_type_decl env mid id is_covariant decl = List.iter unmark_type decl.type_params; begin match decl.type_kind with Type_abstract -> () - | Type_variant(cstrs, priv) -> + | Type_variant cstrs -> List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs - | Type_record(lbls, rep, priv) -> + | Type_record(lbls, rep) -> List.iter (fun (c, mut, t) -> unmark_type t) lbls end; begin match decl.type_manifest with diff --git a/typing/env.ml b/typing/env.ml index 46bb2efd9..1a80da9e5 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -262,8 +262,8 @@ and find_cltype = let find_type_expansion path env = let decl = find_type path env in match decl.type_manifest with - None -> raise Not_found - | Some body -> (decl.type_params, body) + | Some body when decl.type_private = Public -> (decl.type_params, body) + | _ -> raise Not_found let find_modtype_expansion path env = match find_modtype path env with @@ -426,20 +426,20 @@ let rec scrape_modtype mty env = let constructors_of_type ty_path decl = match decl.type_kind with - Type_variant(cstrs, priv) -> + Type_variant cstrs -> Datarepr.constructor_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs priv + cstrs decl.type_private | Type_record _ | Type_abstract -> [] (* Compute label descriptions *) let labels_of_type ty_path decl = match decl.type_kind with - Type_record(labels, rep, priv) -> + Type_record(labels, rep) -> Datarepr.label_descrs (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - labels rep priv + labels rep decl.type_private | Type_variant _ | Type_abstract -> [] (* Given a signature and a root path, prefix all idents in the signature @@ -521,7 +521,7 @@ let rec components_of_module env sub path mty = List.iter (fun (name, descr) -> c.comp_labels <- Tbl.add name (descr, nopos) c.comp_labels) - (labels_of_type path decl'); + (labels_of_type path decl'); env := store_type_infos id path decl !env | Tsig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in diff --git a/typing/includecore.ml b/typing/includecore.ml index f66e068f7..9e3f32a11 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -38,7 +38,9 @@ let value_descriptions env vd1 vd2 = (* Inclusion between "private" annotations *) let private_flags priv1 priv2 = - match (priv1, priv2) with (Private, Public) -> false | (_, _) -> true + match priv1, priv2 with + | Private, Public -> false + | _, _ -> true (* Inclusion between manifest types (particularly for private row types) *) @@ -93,17 +95,17 @@ let type_manifest env ty1 params1 ty2 params2 = let tl1, tl2 = List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in Ctype.equal env true (params1 @ tl1) (params2 @ tl2) - | _ -> + | _ -> Ctype.equal env true (ty1 :: params1) (ty2 :: params2) (* Inclusion between type declarations *) let type_declarations env id decl1 decl2 = decl1.type_arity = decl2.type_arity && + private_flags decl1.type_private decl2.type_private && begin match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> true - | (Type_variant (cstrs1, priv1), Type_variant (cstrs2, priv2)) -> - private_flags priv1 priv2 && + | (Type_variant cstrs1, Type_variant cstrs2) -> Misc.for_all2 (fun (cstr1, arg1) (cstr2, arg2) -> cstr1 = cstr2 && @@ -113,8 +115,7 @@ let type_declarations env id decl1 decl2 = (ty2::decl2.type_params)) arg1 arg2) cstrs1 cstrs2 - | (Type_record(labels1,rep1,priv1), Type_record(labels2,rep2,priv2)) -> - private_flags priv1 priv2 && + | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> rep1 = rep2 && Misc.for_all2 (fun (lbl1, mut1, ty1) (lbl2, mut2, ty2) -> @@ -137,9 +138,10 @@ let type_declarations env id decl1 decl2 = Ctype.equal env false [ty1] [ty2] end && if match decl2.type_kind with - | Type_record(_,_,priv) | Type_variant(_,priv) -> priv = Private + | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private | Type_abstract -> - match decl2.type_manifest with None -> true + match decl2.type_manifest with + | None -> true | Some ty -> Btype.has_constr_row (Ctype.expand_head env ty) then List.for_all2 diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 8c7b96581..3624fcc79 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -125,7 +125,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, priv)} -> + | {type_kind=Type_variant constr_list} -> Datarepr.find_constr_by_tag tag constr_list | {type_manifest = Some _} -> get_constr tag (Ctype.expand_head_once tenv ty) tenv @@ -139,7 +139,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, priv)} -> lbls + | {type_kind = Type_record(lbls, rep)} -> 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 bd643b90e..ce43b5a3b 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -89,24 +89,28 @@ let build_initial_env add_type add_exception empty_env = {type_params = []; type_arity = 0; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = []} and decl_bool = {type_params = []; type_arity = 0; - type_kind = Type_variant(["false",[]; "true",[]], Public); + type_kind = Type_variant(["false", []; "true", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_unit = {type_params = []; type_arity = 0; - type_kind = Type_variant(["()",[]], Public); + type_kind = Type_variant(["()", []]); + type_private = Public; type_manifest = None; type_variance = []} and decl_exn = {type_params = []; type_arity = 0; - type_kind = Type_variant([], Public); + type_kind = Type_variant []; + type_private = Public; type_manifest = None; type_variance = []} and decl_array = @@ -114,6 +118,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, true, true]} and decl_list = @@ -121,7 +126,8 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = - Type_variant(["[]", []; "::", [tvar; type_list tvar]], Public); + Type_variant(["[]", []; "::", [tvar; type_list tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_format6 = @@ -131,6 +137,7 @@ let build_initial_env add_type add_exception empty_env = ]; type_arity = 6; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [ true, true, true; true, true, true; @@ -141,7 +148,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(["None", []; "Some", [tvar]], Public); + type_kind = Type_variant(["None", []; "Some", [tvar]]); + type_private = Public; type_manifest = None; type_variance = [true, false, false]} and decl_lazy_t = @@ -149,6 +157,7 @@ let build_initial_env add_type add_exception empty_env = {type_params = [tvar]; type_arity = 1; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = [true, false, false]} in diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 42ffcafe1..242765e34 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -518,10 +518,10 @@ let rec tree_of_type_decl id decl = in begin match decl.type_kind with | Type_abstract -> () - | Type_variant ([], _) -> () - | Type_variant (cstrs, priv) -> + | Type_variant [] -> () + | Type_variant cstrs -> List.iter (fun (_, args) -> List.iter mark_loops args) cstrs - | Type_record(l, rep, priv) -> + | Type_record(l, rep) -> List.iter (fun (_, _, ty) -> mark_loops ty) l end; @@ -538,8 +538,8 @@ let rec tree_of_type_decl id decl = None -> true | Some ty -> has_constr_row ty end - | Type_variant(_,p) | Type_record(_,_,p) -> - p = Private + | Type_variant _ | Type_record(_,_) -> + decl.type_private = Private in let vari = List.map2 @@ -565,12 +565,14 @@ let rec tree_of_type_decl id decl = | None -> (Otyp_abstract, Public) | Some ty -> tree_of_typexp false ty, - (if has_constr_row ty then Private else Public) + (if has_constr_row ty then Private else decl.type_private) end - | 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 + | Type_variant cstrs -> + tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), + decl.type_private + | Type_record(lbls, rep) -> + tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), + decl.type_private in (name, args, ty, priv, constraints) diff --git a/typing/subst.ml b/typing/subst.ml index 25f557ec5..f959f8af3 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -154,22 +154,22 @@ let type_declaration s decl = type_kind = begin match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant (cstrs, priv) -> + | Type_variant cstrs -> Type_variant( List.map (fun (n, args) -> (n, List.map (typexp s) args)) - cstrs, - priv) - | Type_record(lbls, rep, priv) -> + cstrs) + | Type_record(lbls, rep) -> Type_record( List.map (fun (n, mut, arg) -> (n, mut, typexp s arg)) lbls, - rep, priv) + rep) end; type_manifest = begin match decl.type_manifest with None -> None | Some ty -> Some(typexp s ty) end; + type_private = decl.type_private; type_variance = decl.type_variance; } in diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 6111c4c4c..a7ed236f3 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1007,6 +1007,7 @@ let temp_abbrev env id arity = {type_params = !params; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = Some ty; type_variance = List.map (fun _ -> true, true, true) !params} env @@ -1217,6 +1218,7 @@ let class_infos define_class kind {type_params = obj_params; type_arity = List.length obj_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some obj_ty; type_variance = List.map (fun _ -> true, true, true) obj_params} in @@ -1229,6 +1231,7 @@ let class_infos define_class kind {type_params = cl_params; type_arity = List.length cl_params; type_kind = Type_abstract; + type_private = Public; type_manifest = Some cl_ty; type_variance = List.map (fun _ -> true, true, true) cl_params} in diff --git a/typing/typecore.ml b/typing/typecore.ml index 7939fe69c..5865d31ce 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -128,7 +128,7 @@ let rec extract_label_names sexp env ty = | Tconstr (path, _, _) -> let td = Env.find_type path env in begin match td.type_kind with - | Type_record (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) diff --git a/typing/typedecl.ml b/typing/typedecl.ml index f0ce9836c..1339ebbca 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -38,7 +38,7 @@ type error = | Unbound_type_var of type_expr * type_declaration | Unbound_exception of Longident.t | Not_an_exception of Longident.t - | Bad_variance of int * (bool*bool) * (bool*bool) + | Bad_variance of int * (bool * bool) * (bool * bool) | Unavailable_type_constructor of Path.t | Bad_fixed_type of string @@ -52,6 +52,7 @@ let enter_type env (name, sdecl) id = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some _ -> Some(Ctype.newvar ()) end; @@ -77,6 +78,14 @@ let is_float env ty = {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float | _ -> false +(* Determine if a type definition defines a fixed type. (PW) *) +let is_fixed_type sd = + (match sd.ptype_manifest with + | Some { ptyp_desc = (Ptyp_variant _ | Ptyp_object _); } -> true + | _ -> false) && + sd.ptype_kind = Ptype_abstract && + sd.ptype_private = Private + (* Set the row variable in a fixed type *) let set_fixed_row env loc p decl = let tm = @@ -128,9 +137,8 @@ let transl_declaration env (name, sdecl) id = type_arity = List.length params; type_kind = begin match sdecl.ptype_kind with - Ptype_abstract | Ptype_private -> - Type_abstract - | Ptype_variant (cstrs, priv) -> + Ptype_abstract -> Type_abstract + | Ptype_variant cstrs -> let all_constrs = ref StringSet.empty in List.iter (fun (name, args, loc) -> @@ -141,11 +149,12 @@ let transl_declaration env (name, sdecl) id = if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); - Type_variant(List.map - (fun (name, args, loc) -> - (name, List.map (transl_simple_type env true) args)) - cstrs, priv) - | Ptype_record (lbls, priv) -> + Type_variant + (List.map + (fun (name, args, loc) -> + (name, List.map (transl_simple_type env true) args)) + cstrs) + | Ptype_record lbls -> let all_labels = ref StringSet.empty in List.iter (fun (name, mut, arg, loc) -> @@ -163,14 +172,16 @@ 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, priv) + Type_record(lbls', rep) end; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None | Some sty -> + let no_row = not (is_fixed_type sdecl) in let ty = - transl_simple_type env (sdecl.ptype_kind <> Ptype_private) sty in + transl_simple_type env no_row sty in if Ctype.cyclic_abbrev env id ty then raise(Error(sdecl.ptype_loc, Recursive_abbrev name)); Some ty @@ -185,7 +196,7 @@ let transl_declaration env (name, sdecl) id = raise(Error(loc, Unconsistent_constraint tr))) cstrs; Ctype.end_def (); - if sdecl.ptype_kind = Ptype_private then begin + if is_fixed_type sdecl then begin let (p, _) = try Env.lookup_type (Longident.Lident(Ident.name id ^ "#row")) env with Not_found -> assert false in @@ -200,9 +211,9 @@ let generalize_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant (v, priv) -> + | Type_variant v -> List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v - | Type_record(r, rep, priv) -> + | Type_record(r, rep) -> List.iter (fun (_, _, ty) -> Ctype.generalize ty) r end; begin match decl.type_manifest with @@ -245,10 +256,10 @@ let check_constraints env (_, sdecl) (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with | Type_abstract -> () - | Type_variant (l, _) -> + | Type_variant l -> let rec find_pl = function - Ptype_variant(pl, _) -> pl - | Ptype_record _ | Ptype_abstract | Ptype_private -> assert false + Ptype_variant pl -> pl + | Ptype_record _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in List.iter @@ -261,10 +272,10 @@ 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_variant _ | Ptype_abstract | Ptype_private -> assert false + Ptype_record pl -> pl + | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in let rec get_loc name = function @@ -454,10 +465,10 @@ let compute_variance env tvl nega posi cntr ty = let make_variance ty = (ty, ref false, ref false, ref false) let whole_type decl = match decl.type_kind with - Type_variant (tll,_) -> + Type_variant tll -> Btype.newgenty (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) - | Type_record (ftl, _, _) -> + | Type_record (ftl, _) -> Btype.newgenty (Ttuple (List.map (fun (_, _, ty) -> ty) ftl)) | Type_abstract -> @@ -483,26 +494,19 @@ let compute_variance_decl env check decl (required, loc) = 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 end; - let priv = - match decl.type_kind with - Type_abstract -> - begin match decl.type_manifest with - Some ty when not (Btype.has_constr_row ty) -> Public - | _ -> Private - end - | Type_variant (_, priv) | Type_record (_, _, priv) -> priv + let priv = decl.type_private and required = List.map (fun (c,n as r) -> if c || n then r else (true,true)) required @@ -589,22 +593,23 @@ let compute_variance_decls env cldecls = (* Force recursion to go through id for private types*) let name_recursion sdecl id decl = match decl with - { type_kind = Type_abstract; type_manifest = Some ty } - when sdecl.ptype_kind = Ptype_private -> - let ty = Ctype.repr ty in - let ty' = Btype.newty2 ty.level ty.desc in - if Ctype.deep_occur ty ty' then - let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in - Btype.link_type ty (Btype.newty2 ty.level td); - {decl with type_manifest = Some ty'} - else decl + | { type_kind = Type_abstract; + type_manifest = Some ty; + type_private = Private; } when is_fixed_type sdecl -> + let ty = Ctype.repr ty in + let ty' = Btype.newty2 ty.level ty.desc in + if Ctype.deep_occur ty ty' then + let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in + Btype.link_type ty (Btype.newty2 ty.level td); + {decl with type_manifest = Some ty'} + else decl | _ -> decl (* Translate a set of mutually recursive type declarations *) let transl_type_decl env name_sdecl_list = (* Add dummy types for fixed rows *) let fixed_types = - List.filter (fun (_,sd) -> sd.ptype_kind = Ptype_private) name_sdecl_list + List.filter (fun (_, sd) -> is_fixed_type sd) name_sdecl_list in let name_sdecl_list = List.map @@ -732,11 +737,12 @@ let transl_with_constraint env id row_path sdecl = with Ctype.Unify tr -> raise(Error(loc, Unconsistent_constraint tr))) sdecl.ptype_cstrs; - let no_row = sdecl.ptype_kind <> Ptype_private in + let no_row = not (is_fixed_type sdecl) in let decl = { type_params = params; type_arity = List.length params; type_kind = Type_abstract; + type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None @@ -771,6 +777,7 @@ let abstract_type_decl arity = { type_params = make_params arity; type_arity = arity; type_kind = Type_abstract; + type_private = Public; type_manifest = None; type_variance = replicate_list (true, true, true) arity } in Ctype.end_def(); @@ -858,10 +865,10 @@ let report_error ppf = function kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr ty in begin try match decl.type_kind, decl.type_manifest with - Type_variant (tl, _), _ -> + Type_variant tl, _ -> explain tl (fun (_,tl) -> Btype.newgenty (Ttuple tl)) "case" (fun (lab,_) -> lab ^ " of ") - | Type_record (tl, _, _), _ -> + | Type_record (tl, _), _ -> explain tl (fun (_,_,t) -> t) "field" (fun (lab,_,_) -> lab ^ ": ") | Type_abstract, Some ty' -> diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 96c5c2cdb..fe54126ea 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -40,6 +40,9 @@ val approx_type_decl: val check_recmod_typedecl: Env.t -> Location.t -> Ident.t list -> Path.t -> type_declaration -> unit +(* for fixed types *) +val is_fixed_type : Parsetree.type_declaration -> bool + (* for typeclass.ml *) val compute_variance_decls: Env.t -> diff --git a/typing/typemod.ml b/typing/typemod.ml index 2bbe203ae..70037182c 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -87,13 +87,14 @@ let merge_constraint initial_env loc sg lid constr = ([], _, _) -> raise(Error(loc, With_no_component lid)) | (Tsig_type(id, decl, rs) :: rem, [s], - Pwith_type ({ptype_kind = Ptype_private} as sdecl)) - when Ident.name id = s -> + Pwith_type ({ptype_kind = Ptype_abstract} as sdecl)) + when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = { type_params = List.map (fun _ -> Btype.newgenvar()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; type_kind = Type_abstract; + type_private = Private; type_manifest = None; type_variance = List.map (fun (c,n) -> (not n, not c, not c)) diff --git a/typing/types.ml b/typing/types.ml index d2512500c..fe876760f 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -20,7 +20,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -33,7 +33,7 @@ and type_desc = | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr - | Tsubst of type_expr + | Tsubst of type_expr (* for copying *) | Tvariant of row_desc | Tunivar | Tpoly of type_expr * type_expr list @@ -49,6 +49,9 @@ and row_desc = and row_field = Rpresent of type_expr option | Reither of bool * type_expr list * bool * row_field option ref + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) | Rabsent and abbrev_memo = @@ -135,14 +138,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } + (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list @@ -198,6 +203,6 @@ and modtype_declaration = | Tmodtype_manifest of module_type and rec_status = - Trec_not - | Trec_first - | Trec_next + Trec_not (* not recursive *) + | Trec_first (* first in a recursive group *) + | Trec_next (* not first in a recursive group *) diff --git a/typing/types.mli b/typing/types.mli index 6ac6f2ad1..05d205267 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -19,7 +19,7 @@ open Asttypes (* Type expressions for the core language *) type type_expr = - { mutable desc: type_desc; + { mutable desc: type_desc; mutable level: int; mutable id: int } @@ -136,15 +136,16 @@ type type_declaration = { type_params: type_expr list; type_arity: int; type_kind: type_kind; + type_private: private_flag; type_manifest: type_expr option; type_variance: (bool * bool * bool) list } (* covariant, contravariant, weakly contravariant *) and type_kind = Type_abstract - | Type_variant of (string * type_expr list) list * private_flag - | Type_record of (string * mutable_flag * type_expr) list - * record_representation * private_flag + | Type_variant of (string * type_expr list) list + | Type_record of + (string * mutable_flag * type_expr) list * record_representation type exception_declaration = type_expr list |