diff options
52 files changed, 990 insertions, 431 deletions
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 5b65b578b8..10c4303f82 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -633,8 +633,10 @@ let rec expr_size env = function RHS_block (List.length args) | Uprim(Pmakearray(Pfloatarray), args, _) -> RHS_floatblock (List.length args) - | Uprim (Pduprecord (Record_regular, sz), _, _) -> + | Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) -> RHS_block sz + | Uprim (Pduprecord (Record_exception _, sz), _, _) -> + RHS_block (sz + 1) | Uprim (Pduprecord (Record_float, sz), _, _) -> RHS_floatblock sz | Usequence(exp, exp') -> diff --git a/boot/ocamlc b/boot/ocamlc Binary files differindex 37c3a0fb0f..d306407875 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex 58fbaec030..5c8dabda77 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 4fc5156a74..123a23b62f 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index f7bdd5d7c1..47349d6f35 100644 --- a/bytecomp/bytegen.ml +++ b/bytecomp/bytegen.ml @@ -144,8 +144,9 @@ let rec size_of_lambda = function | Llet (Strict, id, Lprim (Pduprecord (kind, size), _), body) when check_recordwith_updates id body -> begin match kind with - | Record_regular -> RHS_block size + | Record_regular | Record_inlined _ -> RHS_block size | Record_float -> RHS_floatblock size + | Record_exception _ -> RHS_block (size + 1) end | Llet(str, id, arg, body) -> size_of_lambda body | Lletrec(bindings, body) -> size_of_lambda body @@ -154,7 +155,10 @@ let rec size_of_lambda = function RHS_block (List.length args) | Lprim (Pmakearray Pfloatarray, args) -> RHS_floatblock (List.length args) | Lprim (Pmakearray Pgenarray, args) -> assert false - | Lprim (Pduprecord (Record_regular, size), args) -> RHS_block size + | Lprim (Pduprecord ((Record_regular | Record_inlined _), size), args) -> + RHS_block size + | Lprim (Pduprecord (Record_exception _, size), args) -> + RHS_block (size + 1) | Lprim (Pduprecord (Record_float, size), args) -> RHS_floatblock size | Levent (lam, _) -> size_of_lambda lam | Lsequence (lam, lam') -> size_of_lambda lam' diff --git a/bytecomp/matching.ml b/bytecomp/matching.ml index c57518afb3..b1036ec9a5 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1350,7 +1350,9 @@ let make_constr_matching p def ctx = function | ((arg, mut) :: argl) -> let cstr = pat_as_constr p in let newargs = - match cstr.cstr_tag with + if cstr.cstr_inlined then + (arg, Alias) :: argl + else match cstr.cstr_tag with Cstr_constant _ | Cstr_block _ -> make_field_args Alias arg 0 (cstr.cstr_arity - 1) argl | Cstr_exception _ -> @@ -1630,8 +1632,10 @@ let make_record_matching all_labels def = function let lbl = all_labels.(pos) in let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + in let str = match lbl.lbl_mut with Immutable -> Alias diff --git a/bytecomp/printlambda.ml b/bytecomp/printlambda.ml index fd90caf595..006c8e2798 100644 --- a/bytecomp/printlambda.ml +++ b/bytecomp/printlambda.ml @@ -84,7 +84,9 @@ let print_bigarray name unsafe kind ppf layout = let record_rep ppf r = match r with | Record_regular -> fprintf ppf "regular" + | Record_inlined i -> fprintf ppf "inlined(%i)" i | Record_float -> fprintf ppf "float" + | Record_exception p -> fprintf ppf "exn (%s)" (Path.name p) ;; let string_of_loc_kind = function diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index eb60c03018..0df2c9ce2d 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -749,7 +749,10 @@ and transl_exp0 e = end | Texp_construct(_, cstr, args) -> let ll = transl_list args in - begin match cstr.cstr_tag with + if cstr.cstr_inlined then begin match ll with + | [x] -> x + | _ -> assert false + end else begin match cstr.cstr_tag with Cstr_constant n -> Lconst(Const_pointer n) | Cstr_block n -> @@ -777,20 +780,27 @@ and transl_exp0 e = [Lconst(Const_base(Const_int tag)); lam]) end | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) -> - transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr + transl_record e.exp_env lbl1.lbl_all lbl1.lbl_repres lbl_expr_list + opt_init_expr | Texp_record ([], _) -> fatal_error "Translcore.transl_exp: bad Texp_record" | Texp_field(arg, _, lbl) -> let access = match lbl.lbl_repres with - Record_regular -> Pfield lbl.lbl_pos - | Record_float -> Pfloatfield lbl.lbl_pos in + Record_regular | Record_inlined _ -> Pfield lbl.lbl_pos + | Record_float -> Pfloatfield lbl.lbl_pos + | Record_exception _ -> Pfield (lbl.lbl_pos + 1) + in Lprim(access, [transl_exp arg]) | Texp_setfield(arg, _, lbl, newval) -> let access = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer newval) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_exception _ -> + Psetfield (lbl.lbl_pos + 1, maybe_pointer newval) + in Lprim(access, [transl_exp arg; transl_exp newval]) | Texp_array expr_list -> let kind = array_kind e in @@ -1073,7 +1083,7 @@ and transl_setinstvar self var expr = Lprim(Parraysetu (if maybe_pointer expr then Paddrarray else Pintarray), [self; transl_normal_path var; transl_exp expr]) -and transl_record all_labels repres lbl_expr_list opt_init_expr = +and transl_record env all_labels repres lbl_expr_list opt_init_expr = let size = Array.length all_labels in (* Determine if there are "enough" new fields *) if 3 + 2 * List.length lbl_expr_list >= size @@ -1088,7 +1098,8 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = for i = 0 to Array.length all_labels - 1 do let access = match all_labels.(i).lbl_repres with - Record_regular -> Pfield i + Record_regular | Record_inlined _ -> Pfield i + | Record_exception _ -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1106,13 +1117,21 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = if mut = Mutable then raise Not_constant; let cl = List.map extract_constant ll in match repres with - Record_regular -> Lconst(Const_block(0, cl)) + | Record_regular -> Lconst(Const_block(0, cl)) + | Record_inlined tag -> Lconst(Const_block(tag, cl)) | Record_float -> Lconst(Const_float_array(List.map extract_float cl)) + | Record_exception _ -> + raise Not_constant with Not_constant -> match repres with Record_regular -> Lprim(Pmakeblock(0, mut), ll) - | Record_float -> Lprim(Pmakearray Pfloatarray, ll) in + | Record_inlined tag -> Lprim(Pmakeblock(tag, mut), ll) + | Record_float -> Lprim(Pmakearray Pfloatarray, ll) + | Record_exception path -> + let slot = transl_path env path in + Lprim(Pmakeblock(0, Immutable), slot :: ll) + in begin match opt_init_expr with None -> lam | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) @@ -1126,8 +1145,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr = let update_field (_, lbl, expr) cont = let upd = match lbl.lbl_repres with - Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr) - | Record_float -> Psetfloatfield lbl.lbl_pos in + Record_regular + | Record_inlined _ -> Psetfield(lbl.lbl_pos, maybe_pointer expr) + | Record_float -> Psetfloatfield lbl.lbl_pos + | Record_exception _ -> Psetfield(lbl.lbl_pos + 1, maybe_pointer expr) + in Lsequence(Lprim(upd, [Lvar copy_id; transl_exp expr]), cont) in begin match opt_init_expr with None -> assert false diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml index c96e32b66e..eb8c9435e7 100644 --- a/bytecomp/typeopt.ml +++ b/bytecomp/typeopt.ml @@ -34,7 +34,7 @@ let maybe_pointer exp = match Env.find_type p exp.exp_env with | {type_kind = Type_variant []} -> true (* type exn *) | {type_kind = Type_variant cstrs} -> - List.exists (fun c -> c.Types.cd_args <> []) cstrs + List.exists (fun c -> c.Types.cd_args <> Cstr_tuple []) cstrs | _ -> true with Not_found -> true (* This can happen due to e.g. missing -I options, @@ -64,7 +64,8 @@ let array_element_kind env ty = {type_kind = Type_abstract} -> Pgenarray | {type_kind = Type_variant cstrs} - when List.for_all (fun c -> c.Types.cd_args = []) cstrs -> + when List.for_all (fun c -> c.Types.cd_args = Cstr_tuple []) + cstrs -> Pintarray | {type_kind = _} -> Paddrarray diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 5363893486..c6873aee0e 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -341,7 +341,7 @@ module Type = struct ptype_loc = loc; } - let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let constructor ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = { pcd_name = name; pcd_args = args; diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index de9be66852..e2bc166bdf 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -141,7 +141,7 @@ module Type: sig val mk: ?loc:loc -> ?attrs:attrs -> ?params:(str option * variance) list -> ?cstrs:(core_type * core_type * loc) list -> ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> type_declaration - val constructor: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> constructor_declaration + val constructor: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> constructor_declaration val field: ?loc:loc -> ?attrs:attrs -> ?mut:mutable_flag -> str -> core_type -> label_declaration end diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index e3399e40e2..2706e94e62 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -504,9 +504,15 @@ let default_mapper = constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> + let args = + match pcd_args with + | Pcstr_tuple l -> Pcstr_tuple (List.map (this.typ this) l) + | Pcstr_record l -> + Pcstr_record (List.map (this.label_declaration this) l) + in Type.constructor (map_loc this pcd_name) - ~args:(List.map (this.typ this) pcd_args) + ~args ?res:(map_opt (this.typ this) pcd_res) ~loc:(this.location this pcd_loc) ~attrs:(this.attributes this pcd_attributes) diff --git a/parsing/parser.mly b/parsing/parser.mly index 43cd5344f6..078c652e00 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1606,16 +1606,18 @@ exception_declaration: } ; generalized_constructor_arguments: - /*empty*/ { ([],None) } - | OF core_type_list { (List.rev $2,None) } - | COLON core_type_list MINUSGREATER simple_core_type - { (List.rev $2,Some $4) } + /*empty*/ { (Pcstr_tuple [],None) } + | OF constructor_arguments { ($2,None) } + | COLON constructor_arguments MINUSGREATER simple_core_type + { ($2,Some $4) } | COLON simple_core_type - { ([],Some $2) } + { (Pcstr_tuple [],Some $2) } ; - - +constructor_arguments: + | core_type_list { Pcstr_tuple (List.rev $1) } + | LBRACE label_declarations RBRACE { Pcstr_record (List.rev $2) } +; label_declarations: label_declaration { [$1] } | label_declarations SEMI label_declaration { $3 :: $1 } @@ -1634,7 +1636,7 @@ with_constraints: | with_constraints AND with_constraint { $3 :: $1 } ; with_constraint: - TYPE type_parameters label_longident with_type_binder core_type constraints + TYPE type_parameters /*label_longident*/ type_longident with_type_binder core_type constraints { Pwith_type (mkrhs $3 3, (Type.mk (mkrhs (Longident.last $3) 3) @@ -1914,8 +1916,12 @@ label_longident: | mod_longident DOT LIDENT { Ldot($1, $3) } ; type_longident: - LIDENT { Lident $1 } - | mod_ext_longident DOT LIDENT { Ldot($1, $3) } + type_ident { Lident $1 } + | mod_ext_longident DOT type_ident { Ldot($1, $3) } +; +type_ident: + LIDENT { $1 } + | LIDENT DOT UIDENT { $1 ^ "." ^ $3 } ; mod_longident: UIDENT { Lident $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index dd9b768b9f..6c558577dd 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -373,15 +373,23 @@ and label_declaration = and constructor_declaration = { pcd_name: string loc; - pcd_args: core_type list; + pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: Location.t; pcd_attributes: attributes; (* C [@id1] [@id2] of ... *) } + +and constructor_arguments = + | Pcstr_tuple of core_type list + | Pcstr_record of label_declaration list + (* - | C of T1 * ... * Tn (res = None) - | C: T0 (args = [], res = Some T0) - | C: T1 * ... * Tn -> T0 (res = Some T0) + | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) + | C: T0 (res = Some T0, args = []) + | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) + | C of {...} (res = None, args = Pcstr_record) + | C: {...} -> T0 (res = Some T0, args = Pcstr_record) + | C of {...} as t (res = None, args = Pcstr_record) *) (** {2 Class language} *) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index ea4f60ac2f..ff48dafbfb 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -711,8 +711,10 @@ class printer ()= object(self:'self) method exception_declaration f cd = pp f "@[<hov2>exception@ %s%a@]" cd.pcd_name.txt (fun f ed -> match ed with - |[] -> () - |_ -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) ed) cd.pcd_args + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> pp f "@ of@ %a" (self#list ~sep:"*" self#core_type) l + | Pcstr_record _ -> assert false (* TODO *) + ) cd.pcd_args method class_signature f { pcsig_self = ct; pcsig_fields = l ;_} = let class_type_field f x = @@ -1155,11 +1157,18 @@ class printer ()= object(self:'self) |None -> pp f "@\n|@;%s%a" pcd_name.txt (fun f l -> match l with - | [] -> () - | _ -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l) pcd_args + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l + | Pcstr_record _ -> assert false (* TODO *) + ) pcd_args |Some x -> - pp f "@\n|@;%s:@;%a" pcd_name.txt - (self#list self#core_type1 ~sep:"@;->@;") (pcd_args@[x]) in + begin match pcd_args with + | Pcstr_tuple l -> + pp f "@\n|@;%s:@;%a" pcd_name.txt + (self#list self#core_type1 ~sep:"@;->@;") (l@[x]) + | Pcstr_record _ -> assert false (* TODO *) + end + in pp f "%a%a@ %a" (fun f x -> match (x.ptype_manifest,x.ptype_kind,x.ptype_private) with | (None,_,Public) -> pp f "@;" diff --git a/parsing/printast.ml b/parsing/printast.ml index b669773143..4cc175b1d4 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -773,7 +773,10 @@ and constructor_decl i ppf line i ppf "%a\n" fmt_location pcd_loc; attributes i ppf pcd_attributes; line (i+1) ppf "%a\n" fmt_string_loc pcd_name; - list (i+1) core_type ppf pcd_args; + begin match pcd_args with + | Pcstr_tuple l -> list (i+1) core_type ppf l; + | Pcstr_record l -> list (i+1) label_decl ppf l + end; option (i+1) core_type ppf pcd_res and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= diff --git a/testsuite/tests/typing-recordarg/Makefile b/testsuite/tests/typing-recordarg/Makefile new file mode 100644 index 0000000000..1834e83ab7 --- /dev/null +++ b/testsuite/tests/typing-recordarg/Makefile @@ -0,0 +1,14 @@ +######################################################################### +# # +# OCaml # +# # +# Xavier Clerc, SED, INRIA Rocquencourt # +# # +# Copyright 2010 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### + +include $(BASEDIR)/makefiles/Makefile.toplevel +include $(BASEDIR)/makefiles/Makefile.common diff --git a/testsuite/tests/typing-recordarg/recordarg.ml b/testsuite/tests/typing-recordarg/recordarg.ml new file mode 100644 index 0000000000..97b7561c81 --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -0,0 +1,43 @@ +module M = struct + type t = A of {x:int} + let f (A r) = r +end;; +M.f;; + +module A : sig + type t = A of {x:int} + val f: t -> t.A +end = struct + type t = A of {x:int} + let f (A r) = r +end;; + +module type S = sig type t = A of {x:int} val f: t -> t.A end;; +module N : S with type t = M.t = M;; + + +type 'a t = A: {x : 'a; y : 'b} -> 'a t;; +let f r = A r;; + +module M = struct + type 'a t = + | A of {x : 'a} + | B: {u : 'b} -> unit t + + exception Foo of {x : int} +end;; + +module N : sig + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'bla} -> unit t + + exception Foo of {x : int} +end = struct + type 'b t = 'b M.t = + | A of {x : 'b} + | B: {u : 'z} -> unit t + + exception Foo = M.Foo +end;; + diff --git a/testsuite/tests/typing-recordarg/recordarg.ml.reference b/testsuite/tests/typing-recordarg/recordarg.ml.reference new file mode 100644 index 0000000000..ad954903ff --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -0,0 +1,19 @@ + +# module M : sig type t = A of { x : int; } val f : t -> t.A end +# - : M.t -> M.t.A = <fun> +# module A : sig type t = A of { x : int; } val f : t -> t.A end +# module type S = sig type t = A of { x : int; } val f : t -> t.A end +# module N : sig type t = M.t = A of { x : int; } val f : t -> t.A end +# type 'a t = A : { x : 'a; y : 'b; } -> 'a t +# val f : ('a, 'b) t.A -> 'a t = <fun> +# module M : + sig + type 'a t = A of { x : 'a; } | B : { u : 'b; } -> unit t + exception Foo of { x : int; } + end +# module N : + sig + type 'b t = 'b M.t = A of { x : 'b; } | B : { u : 'bla; } -> unit t + exception Foo of { x : int; } + end +# diff --git a/tools/depend.ml b/tools/depend.ml index 7ff6704f70..82c2db8320 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -64,7 +64,11 @@ let add_opt add_fn bv = function | Some x -> add_fn bv x let add_constructor_decl bv pcd = - List.iter (add_type bv) pcd.pcd_args; Misc.may (add_type bv) pcd.pcd_res + begin match pcd.pcd_args with + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + end; + Misc.may (add_type bv) pcd.pcd_res let add_type_declaration bv td = List.iter diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index c8af136701..2f5f0756f0 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -18,7 +18,10 @@ let structure sub str = List.iter (sub # structure_item) str.str_items let constructor_decl sub cd = - List.iter (sub # core_type) cd.cd_args; + begin match cd.cd_args with + | Cstr_tuple l -> List.iter (sub # core_type) l + | Cstr_record l -> List.iter (fun ld -> sub # core_type ld.ld_type) l + end; opt (sub # core_type) cd.cd_res let structure_item sub x = diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 1acbb2c31d..84877bfb29 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -124,13 +124,7 @@ and untype_type_declaration decl = | Ttype_variant list -> Ptype_variant (List.map untype_constructor_declaration list) | Ttype_record list -> - Ptype_record (List.map (fun ld -> - {pld_name=ld.ld_name; - pld_mutable=ld.ld_mutable; - pld_type=untype_core_type ld.ld_type; - pld_loc=ld.ld_loc; - pld_attributes=ld.ld_attributes} - ) list) + Ptype_record (List.map untype_label_declaration list) ); ptype_private = decl.typ_private; ptype_manifest = option untype_core_type decl.typ_manifest; @@ -138,10 +132,22 @@ and untype_type_declaration decl = ptype_loc = decl.typ_loc; } +and untype_label_declaration ld = + { + pld_name=ld.ld_name; + pld_mutable=ld.ld_mutable; + pld_type=untype_core_type ld.ld_type; + pld_loc=ld.ld_loc; + pld_attributes=ld.ld_attributes; + } + and untype_constructor_declaration cd = { pcd_name = cd.cd_name; - pcd_args = List.map untype_core_type cd.cd_args; + pcd_args = begin match cd.cd_args with + | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l) + | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l) + end; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes; diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 10f4fdeb71..2ebff822fa 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -259,40 +259,41 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | _ -> assert false end | None -> decl.type_params in - let ty_args = - List.map - (function ty -> - try Ctype.apply env type_params ty ty_list with - Ctype.Cannot_apply -> abstract_type) - cd_args in - tree_of_constr_with_args (tree_of_constr env path) - (Ident.name cd_id) 0 depth obj ty_args + begin + match cd_args with + | Cstr_tuple l -> + let ty_args = + List.map + (function ty -> + try Ctype.apply env type_params ty ty_list with + Ctype.Cannot_apply -> abstract_type) + l + in + tree_of_constr_with_args (tree_of_constr env path) + (Ident.name cd_id) false 0 depth obj + ty_args + | Cstr_record (_, lbls) -> + let r = + tree_of_record_fields depth + env path type_params ty_list + lbls 0 + in + Oval_constr(tree_of_constr env path + (Ident.name cd_id), + [ r ]) + end | {type_kind = Type_record(lbl_list, rep)} -> begin match check_depth depth obj ty with Some x -> x | None -> - let rec tree_of_fields pos = function - | [] -> [] - | {ld_id; ld_type} :: remainder -> - let ty_arg = - try - Ctype.apply env decl.type_params ld_type - ty_list - with - Ctype.Cannot_apply -> abstract_type in - let name = Ident.name ld_id in - (* PR#5722: print full module path only - for first record field *) - let lid = - if pos = 0 then tree_of_label env path name - else Oide_ident name - and v = - tree_of_val (depth - 1) (O.field obj pos) - ty_arg - in - (lid, v) :: tree_of_fields (pos + 1) remainder + let pos = + match rep with + | Record_exception _ -> 1 + | _ -> 0 in - Oval_record (tree_of_fields 0 lbl_list) + tree_of_record_fields depth + env path decl.type_params ty_list + lbl_list pos end with Not_found -> (* raised by Env.find_type *) @@ -337,6 +338,31 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "<module>" end + and tree_of_record_fields depth env path type_params ty_list + lbl_list pos = + let rec tree_of_fields pos = function + | [] -> [] + | {ld_id; ld_type} :: remainder -> + let ty_arg = + try + Ctype.apply env type_params ld_type + ty_list + with + Ctype.Cannot_apply -> abstract_type in + let name = Ident.name ld_id in + (* PR#5722: print full module path only + for first record field *) + let lid = + if pos = 0 then tree_of_label env path name + else Oide_ident name + and v = + tree_of_val (depth - 1) (O.field obj pos) + ty_arg + in + (lid, v) :: tree_of_fields (pos + 1) remainder + in + Oval_record (tree_of_fields pos lbl_list) + and tree_of_val_list start depth obj ty_list = let rec tree_list i = function | [] -> [] @@ -346,9 +372,16 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct tree_list start ty_list and tree_of_constr_with_args - tree_of_cstr cstr_name start depth obj ty_args = + tree_of_cstr cstr_name inlined start depth obj ty_args = let lid = tree_of_cstr cstr_name in - let args = tree_of_val_list start depth obj ty_args in + let args = + if inlined then + match ty_args with + | [ty] -> [ tree_of_val (depth - 1) obj ty ] + | _ -> assert false + else + tree_of_val_list start depth obj ty_args + in Oval_constr (lid, args) and tree_of_exception depth bucket = @@ -371,7 +404,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if not (EVP.same_value slot (EVP.eval_path env path)) then raise Not_found; tree_of_constr_with_args - (fun x -> Oide_ident x) name 1 depth bucket cstr.cstr_args + (fun x -> Oide_ident x) name cstr.cstr_inlined 1 depth bucket + cstr.cstr_args with Not_found | EVP.Error -> match check_depth depth bucket ty with Some x -> x diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index 503a11e5e0..a0f6072d83 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -169,50 +169,14 @@ let load_lambda ppf lam = (* Print the outcome of an evaluation *) -let rec pr_item env items = - Printtyp.hide_rec_items items; - match items with - | Sig_value(id, decl) :: rem -> - let tree = Printtyp.tree_of_value_description id decl in - let valopt = - match decl.val_kind with - | Val_prim _ -> None - | _ -> - let v = - outval_of_value env (getvalue (Translmod.toplevel_name id)) - decl.val_type - in - Some v - in - Some (tree, valopt, rem) - | Sig_type(id, _, _) :: rem when Btype.is_row_name (Ident.name id) -> - pr_item env rem - | Sig_type(id, decl, rs) :: rem -> - let tree = Printtyp.tree_of_type_declaration id decl rs in - Some (tree, None, rem) - | Sig_exception(id, decl) :: rem -> - let tree = Printtyp.tree_of_exception_declaration id decl in - Some (tree, None, rem) - | Sig_module(id, md, rs) :: rem -> - let tree = Printtyp.tree_of_module id md.md_type rs in - Some (tree, None, rem) - | Sig_modtype(id, decl) :: rem -> - let tree = Printtyp.tree_of_modtype_declaration id decl in - Some (tree, None, rem) - | Sig_class(id, decl, rs) :: cltydecl :: tydecl1 :: tydecl2 :: rem -> - let tree = Printtyp.tree_of_class_declaration id decl rs in - Some (tree, None, rem) - | Sig_class_type(id, decl, rs) :: tydecl1 :: tydecl2 :: rem -> - let tree = Printtyp.tree_of_cltype_declaration id decl rs in - Some (tree, None, rem) - | _ -> None - -let rec item_list env = function - | [] -> [] - | items -> - match pr_item env items with - | None -> [] - | Some (tree, valopt, items) -> (tree, valopt) :: item_list env items +let pr_item = + Printtyp.print_items + (fun env -> function + | Sig_value(id, {val_kind = Val_reg; val_type}) -> + Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) + val_type) + | _ -> None + ) (* The current typing environment for the toplevel *) @@ -261,7 +225,7 @@ let execute_phrase print_outcome ppf phr = let ty = Printtyp.tree_of_type_scheme exp.exp_type in Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (item_list newenv sg')) + | _ -> Ophr_signature (pr_item newenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/typing/btype.ml b/typing/btype.ml index 366e09e9a3..b93290dcf4 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -252,6 +252,22 @@ type type_iterators = it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } +let iter_type_expr_kind f = function + | Type_abstract -> () + | Type_variant cstrs -> + List.iter + (fun cd -> + begin match cd.cd_args with + | Cstr_tuple tl -> List.iter f tl + | Cstr_record (_, lbls) -> List.iter (fun d -> f d.ld_type) lbls + end; + Misc.may f cd.cd_res + ) + cstrs + | Type_record(lbls, _) -> + List.iter (fun d -> f d.ld_type) lbls + + let type_iterators = let it_signature it = List.iter (it.it_signature_item it) @@ -270,7 +286,10 @@ let type_iterators = may (it.it_type_expr it) td.type_manifest; it.it_type_kind it td.type_kind and it_exception_declaration it ed = - List.iter (it.it_type_expr it) ed.exn_args + match ed.exn_args with + | Cstr_tuple tl -> List.iter (it.it_type_expr it) tl + | Cstr_record (_, lbls) -> + List.iter (fun d -> it.it_type_expr it d.ld_type) lbls and it_module_declaration it md = it.it_module_type it md.md_type and it_modtype_declaration it mtd = @@ -305,15 +324,8 @@ let type_iterators = | Cty_arrow (_, ty, cty) -> it.it_type_expr it ty; it.it_class_type it cty - and it_type_kind it = function - Type_abstract -> () - | Type_record (ll, _) -> - List.iter (fun ld -> it.it_type_expr it ld.ld_type) ll - | Type_variant cl -> - List.iter (fun cd -> - List.iter (it.it_type_expr it) cd.cd_args; - may (it.it_type_expr it) cd.cd_res) - cl + and it_type_kind it kind = + iter_type_expr_kind (it.it_type_expr it) kind and it_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; match ty.desc with @@ -440,17 +452,7 @@ let rec unmark_type ty = let unmark_type_decl decl = List.iter unmark_type decl.type_params; - begin match decl.type_kind with - Type_abstract -> () - | Type_variant cstrs -> - List.iter - (fun d -> - List.iter unmark_type d.cd_args; - Misc.may unmark_type d.cd_res) - cstrs - | Type_record(lbls, rep) -> - List.iter (fun d -> unmark_type d.ld_type) lbls - end; + iter_type_expr_kind unmark_type decl.type_kind; begin match decl.type_manifest with None -> () | Some ty -> unmark_type ty diff --git a/typing/btype.mli b/typing/btype.mli index 8717600932..e670fa724d 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -194,3 +194,5 @@ val log_type: type_expr -> unit (**** Forward declarations ****) val print_raw: (Format.formatter -> type_expr -> unit) ref + +val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) diff --git a/typing/ctype.ml b/typing/ctype.ml index cd468fde9b..4989aa7ced 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -546,7 +546,12 @@ let closed_type_decl decl = (fun {cd_args; cd_res; _} -> match cd_res with | Some _ -> () - | None -> List.iter closed_type cd_args) + | None -> + match cd_args with + | Cstr_tuple l -> List.iter closed_type l + | Cstr_record (_, l) -> + List.iter (fun l -> closed_type l.ld_type) l + ) v | Type_record(r, rep) -> List.iter (fun l -> closed_type l.ld_type) r @@ -1156,25 +1161,36 @@ let instance_parameterized_type_2 sch_args sch_lst sch = cleanup_types (); (ty_args, ty_lst, ty) +let map_kind f = function + | Type_abstract -> Type_abstract + | Type_variant cl -> + Type_variant ( + List.map + (fun c -> + {c with + cd_args = + begin match c.cd_args with + | Cstr_tuple l-> Cstr_tuple (List.map f l) + | Cstr_record (id, l) -> + let field l = {l with ld_type = f l.ld_type} in + Cstr_record (id, List.map field l) + end; + cd_res=may_map f c.cd_res + }) + cl) + | Type_record (fl, rr) -> + Type_record ( + List.map + (fun l -> + {l with ld_type = f l.ld_type} + ) fl, rr) + + let instance_declaration decl = let decl = {decl with type_params = List.map simple_copy decl.type_params; type_manifest = may_map simple_copy decl.type_manifest; - type_kind = match decl.type_kind with - | Type_abstract -> Type_abstract - | Type_variant cl -> - Type_variant ( - List.map - (fun c -> - {c with cd_args=List.map simple_copy c.cd_args; - cd_res=may_map simple_copy c.cd_res}) - cl) - | Type_record (fl, rr) -> - Type_record ( - List.map - (fun l -> - {l with ld_type = copy l.ld_type} - ) fl, rr) + type_kind = map_kind simple_copy decl.type_kind; } in cleanup_types (); @@ -2137,7 +2153,12 @@ and mcomp_variant_description type_pairs env xs ys = match x, y with | c1 :: xs, c2 :: ys -> mcomp_type_option type_pairs env c1.cd_res c2.cd_res; - mcomp_list type_pairs env c1.cd_args c2.cd_args; + begin match c1.cd_args, c2.cd_args with + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_record (_, l1), Cstr_record (_, l2) -> + mcomp_record_description type_pairs env l1 l2 + | _ -> raise (Unify []) + end; if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys else raise (Unify []) @@ -4286,27 +4307,7 @@ let nondep_type_decl env mid id is_covariant decl = try let params = List.map (nondep_type_rec env mid) decl.type_params in let tk = - try match decl.type_kind with - Type_abstract -> - Type_abstract - | Type_variant cstrs -> - Type_variant - (List.map - (fun c -> - {c with - cd_args = List.map (nondep_type_rec env mid) c.cd_args; - cd_res = may_map (nondep_type_rec env mid) c.cd_res; - } - ) - cstrs) - | Type_record(lbls, rep) -> - Type_record - (List.map - (fun l -> - {l with ld_type = nondep_type_rec env mid l.ld_type} - ) - lbls, - rep) + try map_kind (nondep_type_rec env mid) decl.type_kind with Not_found when is_covariant -> Type_abstract and tm = try match decl.type_manifest with diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 13b7bf5316..5ef5e9ae6b 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -39,13 +39,43 @@ let free_vars ty = unmark_type ty; !ret -let constructor_descrs ty_res cstrs priv = +let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) + +let constructor_args ty_path type_manifest arg_vars rep = + function + | Cstr_tuple l -> l, false, [] + | Cstr_record (id, lbls) -> + let path = + match ty_path with + | Path.Pdot(m, _, _) -> Path.Pdot(m, Ident.name id, Path.nopos) + | Path.Pident _ -> Path.Pident id + | Path.Papply _ -> assert false + in + let tdecl = + { + type_params = arg_vars; + type_arity = List.length arg_vars; + type_kind = Type_record (lbls, rep); + type_private = Public; + type_manifest = type_manifest (); + type_variance = List.map (fun _ -> Variance.full) arg_vars; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + } + in + [ newgenconstr path arg_vars ], + true, [ (id, path, tdecl) ] + +let constructor_descrs ty_path decl manifest_decl cstrs = + let ty_res = newgenconstr ty_path decl.type_params in let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in List.iter (fun {cd_args; cd_res; _} -> - if cd_args = [] then incr num_consts else incr num_nonconsts; + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; if cd_res = None then incr num_normal) cstrs; + let tdecls = ref [] in let rec describe_constructors idx_const idx_nonconst = function [] -> [] | {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem -> @@ -56,42 +86,93 @@ let constructor_descrs ty_res cstrs priv = in let (tag, descr_rem) = match cd_args with - [] -> (Cstr_constant idx_const, + Cstr_tuple [] -> (Cstr_constant idx_const, describe_constructors (idx_const+1) idx_nonconst rem) | _ -> (Cstr_block idx_nonconst, describe_constructors idx_const (idx_nonconst+1) rem) in - let existentials = + let arg_vars, existentials = match cd_res with - | None -> [] + | None -> decl.type_params, [] | Some type_ret -> let res_vars = free_vars type_ret in - let arg_vars = free_vars (newgenty (Ttuple cd_args)) in + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record (_, l) -> List.map (fun l -> l.ld_type) l + in + (* Note: variables bound by Tpoly are Tvar, not Tunivar, + and thus they are not considered as free, which is + what we want. *) + let arg_vars = free_vars (newgenty (Ttuple tyl)) in + TypeSet.elements arg_vars, TypeSet.elements (TypeSet.diff arg_vars res_vars) in + let type_manifest () = + match decl.type_manifest, manifest_decl with + | Some {desc = Tconstr(Path.Pdot (m, name, _), _, _)}, _ -> + let p = + Path.Pdot (m, name ^ "." ^ Ident.name cd_id, Path.nopos) + in + Some (newgenconstr p arg_vars) + | Some {desc = Tconstr(Path.Pident _, _, _)}, + Some {type_kind = Type_variant cstrs} -> + let c = + try + List.find + (fun c -> Ident.name c.cd_id = Ident.name cd_id) + cstrs + with Not_found -> assert false + in + begin match c.cd_args with + | Cstr_record (id, _) -> + Some (newgenconstr (Path.Pident id) arg_vars) + | _ -> assert false + end + | _ -> None + in + let cstr_args, cstr_inlined, tds = + constructor_args ty_path type_manifest + arg_vars + (Record_inlined idx_nonconst) + cd_args + in + tdecls := tds @ !tdecls; let cstr = { cstr_name = Ident.name cd_id; cstr_res = ty_res; cstr_existentials = existentials; - cstr_args = cd_args; - cstr_arity = List.length cd_args; + cstr_args; + cstr_arity = List.length cstr_args; cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; cstr_normal = !num_normal; - cstr_private = priv; + cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; cstr_attributes = cd_attributes; + cstr_inlined; } in (cd_id, cstr) :: descr_rem in - describe_constructors 0 0 cstrs + let r = describe_constructors 0 0 cstrs in + r, !tdecls -let exception_descr path_exc decl = +let exception_descr ?rebind path_exc decl = + let type_manifest () = + match rebind with + | None -> None + | Some p -> Some (newgenconstr p []) + in + let cstr_args, cstr_inlined, tds = + constructor_args path_exc type_manifest [] + (Record_exception path_exc) + decl.exn_args + in { cstr_name = Path.last path_exc; cstr_res = Predef.type_exn; cstr_existentials = []; - cstr_args = decl.exn_args; - cstr_arity = List.length decl.exn_args; + cstr_args; + cstr_arity = List.length cstr_args; cstr_tag = Cstr_exception (path_exc, decl.exn_loc); cstr_consts = -1; cstr_nonconsts = -1; @@ -100,7 +181,8 @@ let exception_descr path_exc decl = cstr_generalized = false; cstr_loc = decl.exn_loc; cstr_attributes = decl.exn_attributes; - } + cstr_inlined; + }, tds let none = {desc = Ttuple []; level = -1; id = -1} (* Clearly ill-formed type *) @@ -138,7 +220,7 @@ exception Constr_not_found let rec find_constr tag num_const num_nonconst = function [] -> raise Constr_not_found - | {cd_args = []; _} as c :: rem -> + | {cd_args = Cstr_tuple []; _} as c :: rem -> if tag = Cstr_constant num_const then c else find_constr tag (num_const + 1) num_nonconst rem diff --git a/typing/datarepr.mli b/typing/datarepr.mli index 13ced46098..fd5f07e0bf 100644 --- a/typing/datarepr.mli +++ b/typing/datarepr.mli @@ -17,10 +17,17 @@ open Asttypes open Types val constructor_descrs: - type_expr -> constructor_declaration list -> - private_flag -> (Ident.t * constructor_description) list + Path.t -> type_declaration -> type_declaration option -> + constructor_declaration list -> + (Ident.t * constructor_description) list * + (Ident.t * Path.t * type_declaration) list + val exception_descr: - Path.t -> exception_declaration -> constructor_description + ?rebind:Path.t -> + Path.t -> exception_declaration -> + constructor_description * (Ident.t * Path.t * type_declaration) list + + val label_descrs: type_expr -> label_declaration list -> record_representation -> private_flag -> diff --git a/typing/env.ml b/typing/env.ml index 01fb2db3ad..f5c3abc229 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -1033,21 +1033,37 @@ let scrape_alias env mty = scrape_alias env mty (* Compute constructor descriptions *) -let constructors_of_type ty_path decl = - let handle_variants cstrs = - Datarepr.constructor_descrs - (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) - cstrs decl.type_private - in +let constructors_of_type env ty_path decl = match decl.type_kind with - | Type_variant cstrs -> handle_variants cstrs - | Type_record _ | Type_abstract -> [] + | Type_variant cstrs -> + let manifest_decl = + match decl.type_manifest with + | Some {desc = Tconstr((Path.Pident id) as p, _, _)} -> + begin try Some (find_type p env) + with Not_found -> None + end + | _ -> None + in + Datarepr.constructor_descrs ty_path decl manifest_decl cstrs + | Type_record _ | Type_abstract -> [], [] (* Compute label descriptions *) let labels_of_type ty_path decl = match decl.type_kind with Type_record(labels, rep) -> + let rep = + match rep with + | Record_exception (Pident id) -> + begin match ty_path with + | Path.Pdot (path, _, pos) -> + Record_exception (Path.Pdot (path, Ident.name id, pos)) + | Path.Pident _ -> + rep + | Path.Papply _ -> assert false + end + | rep -> rep + in Datarepr.label_descrs (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil))) labels rep decl.type_private @@ -1065,11 +1081,13 @@ let rec prefix_idents root pos sub = function (p::pl, final_sub) | Sig_type(id, decl, _) :: rem -> let p = Pdot(root, Ident.name id, nopos) in + let sub = Subst.add_prefixes root (Subst.sub_ids decl) sub in let (pl, final_sub) = prefix_idents root pos (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_exception(id, decl) :: rem -> let p = Pdot(root, Ident.name id, pos) in + let sub = Subst.add_prefixes root (Subst.sub_ids_exn decl) sub in let (pl, final_sub) = prefix_idents root (pos+1) sub rem in (p::pl, final_sub) | Sig_module(id, mty, _) :: rem -> @@ -1160,7 +1178,7 @@ and components_of_module_maker (env, sub, path, mty) = let pl, sub, _ = prefix_idents_and_subst path sub sg in let env = ref env in let pos = ref 0 in - List.iter2 (fun item path -> + let rec aux item path = match item with Sig_value(id, decl) -> let decl' = Subst.value_description sub decl in @@ -1171,13 +1189,18 @@ and components_of_module_maker (env, sub, path, mty) = end | Sig_type(id, decl, _) -> let decl' = Subst.type_declaration sub decl in - let constructors = List.map snd (constructors_of_type path decl') in + let constrs, tdecls = constructors_of_type !env path decl' in + let constructors = List.map snd constrs in let labels = List.map snd (labels_of_type path decl') in c.comp_types <- Tbl.add (Ident.name id) ((decl', (constructors, labels)), nopos) c.comp_types; List.iter + (fun (id, path, td) -> + aux (Sig_type(id, td, Trec_next)) path; + ) tdecls; + List.iter (fun descr -> c.comp_constrs <- add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs) @@ -1190,7 +1213,11 @@ and components_of_module_maker (env, sub, path, mty) = env := store_type_infos None id path decl !env !env | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in - let cstr = Datarepr.exception_descr path decl' in + let cstr, tdecls = Datarepr.exception_descr path decl' in + List.iter + (fun (id, path, td) -> + aux (Sig_type(id, td, Trec_next)) path; + ) tdecls; let s = Ident.name id in c.comp_constrs <- add_to_tbl s (cstr, !pos) c.comp_constrs; @@ -1218,9 +1245,10 @@ and components_of_module_maker (env, sub, path, mty) = | Sig_class_type(id, decl, _) -> let decl' = Subst.cltype_declaration sub decl in c.comp_cltypes <- - Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes) - sg pl; - Structure_comps c + Tbl.add (Ident.name id) (decl', !pos) c.comp_cltypes + in + List.iter2 aux sg pl; + Structure_comps c | Mty_functor(param, ty_arg, ty_res) -> Functor_comps { fcomp_param = param; @@ -1265,12 +1293,20 @@ and store_value ?check slot id path decl env renv = values = EnvTbl.add "value" slot id (path, decl) env.values renv.values; summary = Env_value(env.summary, id, decl) } +and store_extra_tdecls slot tdecls env renv = + (* Note: we should probably keep the original summary *) + List.fold_left (fun env (id, path, td) -> + store_type ~check:false slot id path td env renv + ) + env + tdecls + and store_type ~check slot id path info env renv = let loc = info.type_loc in if check then check_usage loc id (fun s -> Warnings.Unused_type_declaration s) type_declarations; - let constructors = constructors_of_type path info in + let constructors, tdecls = constructors_of_type env path info in let labels = labels_of_type path info in let descrs = (List.map snd constructors, List.map snd labels) in @@ -1294,6 +1330,7 @@ and store_type ~check slot id path info env renv = end constructors end; + let env = store_extra_tdecls slot tdecls env renv in { env with constrs = List.fold_right @@ -1322,7 +1359,7 @@ and store_type_infos slot id path info env renv = renv.types; summary = Env_type(env.summary, id, info) } -and store_exception ~check slot id path decl env renv = +and store_exception ?rebind ~check slot id path decl env renv = let loc = decl.exn_loc in if check && not loc.Location.loc_ghost && Warnings.is_active (Warnings.Unused_exception ("", false)) @@ -1343,10 +1380,10 @@ and store_exception ~check slot id path decl env renv = ) end; end; + let constr, tdecls = Datarepr.exception_descr ?rebind path decl in + let env = store_extra_tdecls slot tdecls env renv in { env with - constrs = EnvTbl.add "constructor" slot id - (Datarepr.exception_descr path decl) env.constrs - renv.constrs; + constrs = EnvTbl.add "constructor" slot id constr env.constrs renv.constrs; summary = Env_exception(env.summary, id, decl) } and store_module slot id path md env renv = @@ -1451,7 +1488,7 @@ let enter store_fun name data env = let enter_value ?check = enter (store_value ?check) and enter_type = enter (store_type ~check:true) -and enter_exception = enter (store_exception ~check:true) +and enter_exception ?rebind = enter (store_exception ?rebind ~check:true) and enter_module_declaration ?arg name md env = let id = Ident.create name in (id, add_module_declaration ?arg id md env) diff --git a/typing/env.mli b/typing/env.mli index 888869ebfc..8b72f6e5fb 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -128,7 +128,8 @@ val enter_value: ?check:(string -> Warnings.t) -> string -> value_description -> t -> Ident.t * t val enter_type: string -> type_declaration -> t -> Ident.t * t -val enter_exception: string -> exception_declaration -> t -> Ident.t * t +val enter_exception: + ?rebind:Path.t -> string -> exception_declaration -> t -> Ident.t * t val enter_module: ?arg:bool -> string -> module_type -> t -> Ident.t * t val enter_module_declaration: ?arg:bool -> string -> module_declaration -> t -> Ident.t * t diff --git a/typing/includecore.ml b/typing/includecore.ml index 7d505c406c..523cf30c1a 100644 --- a/typing/includecore.ml +++ b/typing/includecore.ml @@ -120,7 +120,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of bool + | Record_representation of record_representation * record_representation let report_type_mismatch0 first second decl ppf err = let pr fmt = Format.fprintf ppf fmt in @@ -143,10 +143,16 @@ let report_type_mismatch0 first second decl ppf err = | Field_missing (b, s) -> pr "The field %s is only present in %s %s" (Ident.name s) (if b then second else first) decl - | Record_representation b -> - pr "Their internal representations differ:@ %s %s %s" - (if b then second else first) decl - "uses unboxed float representation" + | Record_representation (r1, r2) -> + let repr = function + | Record_regular -> "regular" + | Record_inlined i -> Printf.sprintf"inlined(tag %i)" i + | Record_float -> "unboxed float" + | Record_exception p -> Printf.sprintf "exception %s" (Path.name p) + in + pr "Their internal representations differ:@ %s vs %s" + (repr r1) + (repr r2) let report_type_mismatch first second decl ppf = List.iter @@ -154,7 +160,21 @@ let report_type_mismatch first second decl ppf = if err = Manifest then () else Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err) -let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = +let rec compare_constructor_arguments env cstr params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then [Field_arity cstr] + else if Misc.for_all2 + (fun ty1 ty2 -> Ctype.equal env true (ty1::params1) (ty2::params2)) + (arg1) (arg2) + then [] else [Field_type cstr] + | Types.Cstr_record (_, l1), Types.Cstr_record (_, l2) -> + compare_records env params1 params2 0 l1 l2 + | _ -> + (* TODO: better report? *) + [Field_arity cstr] + +and compare_variants env params1 params2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], c::_ -> [Field_missing (true, c.Types.cd_id)] @@ -163,25 +183,21 @@ let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 = {Types.cd_id=cstr2; cd_args=arg2; cd_res=ret2}::rem2 -> if Ident.name cstr1 <> Ident.name cstr2 then [Field_names (n, cstr1, cstr2)] - else if List.length arg1 <> List.length arg2 then - [Field_arity cstr1] else match ret1, ret2 with | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> [Field_type cstr1] | Some _, None | None, Some _ -> [Field_type cstr1] | _ -> - if Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true (ty1::decl1.type_params) - (ty2::decl2.type_params)) - (arg1) (arg2) - then - compare_variants env decl1 decl2 (n+1) rem1 rem2 - else [Field_type cstr1] + let r = + compare_constructor_arguments env cstr1 + params1 params2 arg1 arg2 + in + if r <> [] then r + else compare_variants env params1 params2 (n+1) rem1 rem2 -let rec compare_records env decl1 decl2 n labels1 labels2 = +and compare_records env params1 params2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], l::_ -> [Field_missing (true, l.ld_id)] @@ -191,11 +207,20 @@ let rec compare_records env decl1 decl2 n labels1 labels2 = if Ident.name lab1 <> Ident.name lab2 then [Field_names (n, lab1, lab2)] else if mut1 <> mut2 then [Field_mutable lab1] else - if Ctype.equal env true (arg1::decl1.type_params) - (arg2::decl2.type_params) - then compare_records env decl1 decl2 (n+1) rem1 rem2 + if Ctype.equal env true (arg1::params1) + (arg2::params2) + then compare_records env params1 params2 (n+1) rem1 rem2 else [Field_type lab1] +let record_representations r1 r2 = + match r1, r2 with + | Record_regular, Record_regular -> true + | Record_inlined i, Record_inlined j -> i = j + | Record_float, Record_float -> true + | Record_exception _, Record_exception _ -> true + (* allow a different path to support exception rebinding *) + | _ -> false + let type_declarations ?(equality = false) env name decl1 id decl2 = if decl1.type_arity <> decl2.type_arity then [Arity] else if not (private_flags decl1 decl2) then [Privacy] else @@ -215,11 +240,12 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = in mark cstrs1 usage name decl1; if equality then mark cstrs2 Env.Positive (Ident.name id) decl2; - compare_variants env decl1 decl2 1 cstrs1 cstrs2 + compare_variants env decl1.type_params decl2.type_params 1 cstrs1 cstrs2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - let err = compare_records env decl1 decl2 1 labels1 labels2 in - if err <> [] || rep1 = rep2 then err else - [Record_representation (rep2 = Record_float)] + let err = compare_records env decl1.type_params decl2.type_params + 1 labels1 labels2 in + if err <> [] || record_representations rep1 rep2 then err else + [Record_representation (rep1, rep2)] | (_, _) -> [Kind] in if err <> [] then err else @@ -259,8 +285,11 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = (* Inclusion between exception declarations *) let exception_declarations env ed1 ed2 = - Misc.for_all2 (fun ty1 ty2 -> Ctype.equal env false [ty1] [ty2]) + (* note: we use 'Ctype.equal true' now (allow renaming), but + since the type are closed, this doesn't matter *) + compare_constructor_arguments env (Ident.create "") [] [] ed1.exn_args ed2.exn_args + = [] (* Inclusion between class types *) let encode_val (mut, ty) rem = diff --git a/typing/includecore.mli b/typing/includecore.mli index 083624194e..75e6c1957b 100644 --- a/typing/includecore.mli +++ b/typing/includecore.mli @@ -29,7 +29,7 @@ type type_mismatch = | Field_arity of Ident.t | Field_names of int * Ident.t * Ident.t | Field_missing of bool * Ident.t - | Record_representation of bool + | Record_representation of record_representation * record_representation val value_descriptions: Env.t -> value_description -> value_description -> module_coercion diff --git a/typing/includemod.ml b/typing/includemod.ml index 02887a9074..4c8327862b 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -299,17 +299,44 @@ and signatures env cxt subst sig1 sig2 = Field_type (String.sub s 0 (String.length s - 4)), false | _ -> name2, true in + let equate_subtypes ids1 ids2 subst = + if List.length ids1 = List.length ids2 then + List.fold_left2 + (fun sub id1 id2 -> + if Ident.name id1 = Ident.name id2 then + Subst.add_type id2 (Pident id1) sub + else + sub + ) subst ids1 ids2 + else + subst + in begin try let (id1, item1, pos1) = Tbl.find name2 comps1 in let new_subst = match item2 with - Sig_type _ -> - Subst.add_type id2 (Pident id1) subst + Sig_type (id2', decl2, _) -> + let subst = Subst.add_type id2 (Pident id1) subst in + begin match item1 with + | Sig_type (id1', decl1, _) -> + let ids1 = Subst.sub_ids decl1 in + let ids2 = Subst.sub_ids decl2 in + equate_subtypes ids1 ids2 subst + | _ -> assert false + end | Sig_module _ -> Subst.add_module id2 (Pident id1) subst | Sig_modtype _ -> Subst.add_modtype id2 (Mty_ident (Pident id1)) subst - | Sig_value _ | Sig_exception _ | Sig_class _ | Sig_class_type _ -> + | Sig_exception (id2', decl2) -> + begin match item1 with + | Sig_exception (id1', decl1) -> + let ids1 = Subst.sub_ids_exn decl1 in + let ids2 = Subst.sub_ids_exn decl2 in + equate_subtypes ids1 ids2 subst + | _ -> assert false + end + | Sig_value _ | Sig_class _ | Sig_class_type _ -> subst in pair_components new_subst diff --git a/typing/mtype.ml b/typing/mtype.ml index 9fa63f5c9d..17904500d9 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -131,7 +131,14 @@ let nondep_supertype env mid mty = | Sig_exception(id, d) -> let d = {d with - exn_args = List.map (Ctype.nondep_type env mid) d.exn_args + exn_args = match d.exn_args with + | Cstr_tuple l -> + Cstr_tuple (List.map (Ctype.nondep_type env mid) l) + | Cstr_record (id, l) -> + let field l = + {l with ld_type = Ctype.nondep_type env mid l.ld_type} + in + Cstr_record (id, List.map field l) } in Sig_exception(id, d) :: rem' diff --git a/typing/oprint.ml b/typing/oprint.ml index 47a0c04a52..8084dff06a 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -223,7 +223,8 @@ and print_simple_out_type ppf = print_out_type ppf ty; pp_print_char ppf ')'; pp_close_box ppf () - | Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () + | Otyp_abstract | Otyp_sum _ | Otyp_manifest (_, _) -> () + | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> fprintf ppf "@[<1>(module %s" p; let first = ref true in @@ -234,6 +235,9 @@ and print_simple_out_type ppf = ) n tyl; fprintf ppf ")@]" +and print_record_decl ppf lbls = + fprintf ppf "{%a@;<1 -2>}" + (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls and print_fields rest ppf = function [] -> @@ -278,6 +282,9 @@ and print_typargs ppf = pp_print_char ppf ')'; pp_close_box ppf (); pp_print_space ppf () +and print_out_label ppf (name, mut, arg) = + fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name + print_out_type arg let out_type = ref print_out_type @@ -441,9 +448,9 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) = let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> - fprintf ppf " =%a {%a@;<1 -2>}" + fprintf ppf " =%a %a" print_private priv - (print_list_init print_out_label (fun ppf -> fprintf ppf "@ ")) lbls + print_record_decl lbls | Otyp_sum constrs -> fprintf ppf " =%a@;<1 2>%a" print_private priv @@ -477,11 +484,6 @@ and print_out_constr ppf (name, tyl,ret_type_opt) = tyl print_simple_out_type ret_type end - -and print_out_label ppf (name, mut, arg) = - fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name - !out_type arg - let _ = out_module_type := print_out_module_type let _ = out_signature := print_out_signature let _ = out_sig_item := print_out_sig_item diff --git a/typing/predef.ml b/typing/predef.ml index 9b95d62642..55fe4b880e 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -106,7 +106,7 @@ let decl_abstr = let cstr id args = { cd_id = id; - cd_args = args; + cd_args = Cstr_tuple args; cd_res = None; cd_loc = Location.none; cd_attributes = []; @@ -166,7 +166,7 @@ let build_initial_env add_type add_exception empty_env = let add_exception id l = add_exception id - { exn_args = l; exn_loc = Location.none; exn_attributes = [] } + { exn_args = Cstr_tuple l; exn_loc = Location.none; exn_attributes = [] } in add_exception ident_match_failure [newgenty (Ttuple[type_string; type_int; type_int])] ( diff --git a/typing/printtyp.ml b/typing/printtyp.ml index cd3a631b8a..ee39b36ded 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -739,6 +739,11 @@ let string_of_mutable = function | Immutable -> "" | Mutable -> "mutable " + +let mark_loops_constructor_arguments = function + | Cstr_tuple l -> List.iter mark_loops l + | Cstr_record (_, l) -> List.iter (fun l -> mark_loops l.ld_type) l + let rec tree_of_type_decl id decl = reset(); @@ -781,9 +786,7 @@ let rec tree_of_type_decl id decl = | Type_abstract -> () | Type_variant cstrs -> List.iter - (fun c -> - List.iter mark_loops c.cd_args; - may mark_loops c.cd_res) + (fun cd -> mark_loops_constructor_arguments cd.cd_args) cstrs | Type_record(l, rep) -> List.iter (fun l -> mark_loops l.ld_type) l @@ -840,15 +843,20 @@ let rec tree_of_type_decl id decl = in (name, args, ty, priv, constraints) +and tree_of_constructor_arguments = function + | Cstr_tuple l -> tree_of_typlist false l + | Cstr_record (_, l) -> [ Otyp_record (List.map tree_of_label l) ] + and tree_of_constructor cd = let name = Ident.name cd.cd_id in + let arg () = tree_of_constructor_arguments cd.cd_args in match cd.cd_res with - | None -> (name, tree_of_typlist false cd.cd_args, None) + | None -> (name, arg (), None) | Some res -> let nm = !names in names := []; let ret = tree_of_typexp false res in - let args = tree_of_typlist false cd.cd_args in + let args = arg () in names := nm; (name, args, Some ret) @@ -870,8 +878,9 @@ let type_declaration id ppf decl = (* Print an exception declaration *) let tree_of_exception_declaration id decl = - reset_and_mark_loops_list decl.exn_args; - let tyl = tree_of_typlist false decl.exn_args in + reset (); + mark_loops_constructor_arguments decl.exn_args; + let tyl = tree_of_constructor_arguments decl.exn_args in Osig_exception (Ident.name id, tyl) let exception_declaration id ppf decl = @@ -1124,36 +1133,35 @@ and tree_of_signature sg = and tree_of_signature_rec env' = function [] -> [] - | item :: rem -> + | item :: rem as items -> begin match item with Sig_type (_, _, rs) when rs <> Trec_next -> () | _ -> set_printing_env env' end; let (sg, rem) = filter_rem_sig item rem in - let trees = - match item with - | Sig_value(id, decl) -> - [tree_of_value_description id decl] - | Sig_type(id, _, _) when is_row_name (Ident.name id) -> - [] - | Sig_type(id, decl, rs) -> - hide_rec_items (item :: rem); - [Osig_type(tree_of_type_decl id decl, tree_of_rec rs)] - | Sig_exception(id, decl) -> - [tree_of_exception_declaration id decl] - | Sig_module(id, md, rs) -> - [Osig_module (Ident.name id, tree_of_modtype md.md_type, - tree_of_rec rs)] - | Sig_modtype(id, decl) -> - [tree_of_modtype_declaration id decl] - | Sig_class(id, decl, rs) -> - [tree_of_class_declaration id decl rs] - | Sig_class_type(id, decl, rs) -> - [tree_of_cltype_declaration id decl rs] - in + hide_rec_items items; + let trees = trees_of_sigitem item in let env' = Env.add_signature (item :: sg) env' in trees @ tree_of_signature_rec env' rem +and trees_of_sigitem = function + | Sig_value(id, decl) -> + [tree_of_value_description id decl] + | Sig_type(id, _, _) when is_row_name (Ident.name id) -> + [] + | Sig_type(id, decl, rs) -> + [tree_of_type_declaration id decl rs] + | Sig_exception(id, decl) -> + [tree_of_exception_declaration id decl] + | Sig_module(id, md, rs) -> + [tree_of_module id md.md_type rs] + | Sig_modtype(id, decl) -> + [tree_of_modtype_declaration id decl] + | Sig_class(id, decl, rs) -> + [tree_of_class_declaration id decl rs] + | Sig_class_type(id, decl, rs) -> + [tree_of_cltype_declaration id decl rs] + and tree_of_modtype_declaration id decl = let mty = match decl.mtd_type with @@ -1162,13 +1170,23 @@ and tree_of_modtype_declaration id decl = in Osig_modtype (Ident.name id, mty) -let tree_of_module id mty rs = +and tree_of_module id mty rs = Osig_module (Ident.name id, tree_of_modtype mty, tree_of_rec rs) let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) +(* For the toplevel: merge with tree_of_signature? *) +let rec print_items showval env = function + | [] -> [] + | item :: rem as items -> + let (sg, rem) = filter_rem_sig item rem in + hide_rec_items items; + let trees = trees_of_sigitem item in + List.map (fun d -> (d, showval env item)) trees @ + print_items showval env rem + (* Print a signature body (used by -i when compiling a .ml) *) let print_signature ppf tree = diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 7fa00ff44d..82b8608e54 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -42,8 +42,10 @@ val type_scheme_max: ?b_reset_names: bool -> (* Fin Maxence *) val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit +(* val tree_of_type_declaration: Ident.t -> type_declaration -> rec_status -> out_sig_item +*) val type_declaration: Ident.t -> formatter -> type_declaration -> unit val tree_of_exception_declaration: Ident.t -> exception_declaration -> out_sig_item @@ -80,4 +82,5 @@ val report_ambiguous_type_error: (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit (* for toploop *) -val hide_rec_items: signature_item list -> unit +val print_items: (Env.t -> signature_item -> 'a option) -> + Env.t -> signature_item list -> (out_sig_item * 'a option) list diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 209121e834..8f697066c6 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -744,7 +744,10 @@ and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attr line i ppf "%a\n" fmt_location cd_loc; attributes i ppf cd_attributes; line (i+1) ppf "%a\n" fmt_ident cd_id; - list (i+1) core_type ppf cd_args; + begin match cd_args with + | Cstr_tuple l -> list (i+1) core_type ppf l; + | Cstr_record l -> list (i+1) label_decl ppf l + end; option (i+1) core_type ppf cd_res and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = diff --git a/typing/subst.ml b/typing/subst.ml index df84e59eff..ed476f0e34 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -184,6 +184,21 @@ let type_expr s ty = cleanup_types (); ty' +let label_declaration s l = + { + ld_id = l.ld_id; + ld_mutable = l.ld_mutable; + ld_type = typexp s l.ld_type; + ld_loc = loc s l.ld_loc; + ld_attributes = attrs s l.ld_attributes; + } + +let constructor_arguments s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp s) l) + | Cstr_record (id, l) -> + Cstr_record (id, List.map (label_declaration s) l) + let type_declaration s decl = let decl = { type_params = List.map (typexp s) decl.type_params; @@ -197,7 +212,7 @@ let type_declaration s decl = (fun c -> { cd_id = c.cd_id; - cd_args = List.map (typexp s) c.cd_args; + cd_args = constructor_arguments s c.cd_args; cd_res = may_map (typexp s) c.cd_res; cd_loc = loc s c.cd_loc; cd_attributes = attrs s c.cd_attributes; @@ -205,18 +220,7 @@ let type_declaration s decl = ) cstrs) | Type_record(lbls, rep) -> - Type_record - (List.map (fun l -> - { - ld_id = l.ld_id; - ld_mutable = l.ld_mutable; - ld_type = typexp s l.ld_type; - ld_loc = loc s l.ld_loc; - ld_attributes = attrs s l.ld_attributes; - } - ) - lbls, - rep) + Type_record (List.map (label_declaration s) lbls, rep) end; type_manifest = begin @@ -299,10 +303,14 @@ let value_description s descr = } let exception_declaration s descr = - { exn_args = List.map (type_expr s) descr.exn_args; - exn_loc = loc s descr.exn_loc; - exn_attributes = attrs s descr.exn_attributes; - } + let r = + { exn_args = constructor_arguments s descr.exn_args; + exn_loc = loc s descr.exn_loc; + exn_attributes = attrs s descr.exn_attributes; + } + in + cleanup_types (); + r let rec rename_bound_idents s idents = function [] -> (List.rev idents, s) @@ -341,6 +349,7 @@ let rec modtype s = function Mty_alias(module_path s p) and signature s sg = + (* TODO: rename the Ident.t in Cstr_record *) (* Components of signature may be mutually recursive (e.g. type declarations or class and type declarations), so first build global renaming substitution... *) @@ -393,3 +402,30 @@ let compose s1 s2 = modules = merge_tbls (module_path s2) s1.modules s2.modules; modtypes = merge_tbls (modtype s2) s1.modtypes s2.modtypes; for_saving = false } + + +let sub_ids decl = + match decl.type_kind with + | Type_variant cstrs -> + List.fold_left + (fun l c -> + match c.cd_args with + | Cstr_record (id, _) -> id :: l + | Cstr_tuple _ -> l + ) + [] cstrs + | _ -> [] + + +let sub_ids_exn exn = + match exn.exn_args with + | Cstr_record (id, _) -> [id] + | Cstr_tuple _ -> [] + + +let add_prefixes root ids sub = + List.fold_left + (fun sub id -> + add_type id (Pdot(root, Ident.name id, nopos)) sub + ) + sub ids diff --git a/typing/subst.mli b/typing/subst.mli index 24a63b3e39..4d6762374b 100644 --- a/typing/subst.mli +++ b/typing/subst.mli @@ -55,3 +55,10 @@ val module_declaration: t -> module_declaration -> module_declaration (* Composition of substitutions: apply (compose s1 s2) x = apply s2 (apply s1 x) *) val compose: t -> t -> t + + +val sub_ids: type_declaration -> Ident.t list +val sub_ids_exn: exception_declaration -> Ident.t list + + +val add_prefixes: Path.t -> Ident.t list -> t -> t diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 3f02d310cb..da27a46875 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -133,6 +133,12 @@ module StringSet = let compare (x:t) y = compare x y end) +module StringMap = + Map.Make(struct + type t = string + let compare (x:t) y = compare x y + end) + let make_params sdecl = try List.map @@ -144,6 +150,70 @@ let make_params sdecl = with Already_bound loc -> raise(Error(loc, Repeated_parameter)) +let freevars bound kind = + let open Ast_mapper in + let vars = ref StringMap.empty in + let bound = ref bound in + let super = default_mapper in + let typ m ct = + match ct.ptyp_desc with + | Ptyp_var s -> + if not (StringSet.mem s !bound) then + vars := StringMap.add s ct.ptyp_loc !vars; + ct + | Ptyp_poly (sl, t) -> + let old_bound = !bound in + List.iter (fun s -> bound := StringSet.add s !bound) sl; + ignore (m.typ m t); + bound := old_bound; + ct + | _ -> super.typ m ct + in + let mapper = {super with typ} in + ignore (mapper.type_kind mapper kind); + StringMap.bindings !vars + +let transl_labels env closed lbls = + let all_labels = ref StringSet.empty in + List.iter + (fun {pld_name = {txt=name; loc}} -> + if StringSet.mem name !all_labels then + raise(Error(loc, Duplicate_label name)); + all_labels := StringSet.add name !all_labels) + lbls; + let mk {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} = + let arg = Ast_helper.Typ.force_poly arg in + let cty = transl_simple_type env closed arg in + {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty; + ld_loc = loc; ld_attributes = attrs} + in + let lbls = List.map mk lbls in + let lbls' = + List.map + (fun ld -> + let ty = ld.ld_type.ctyp_type in + let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in + {Types.ld_id = ld.ld_id; + ld_mutable = ld.ld_mutable; + ld_type = ty; + ld_loc = ld.ld_loc; + ld_attributes = ld.ld_attributes + } + ) + lbls in + lbls, lbls' + +let transl_constructor_arguments env closed ty_name c_name = function + | Pcstr_tuple l -> + let l = List.map (transl_simple_type env closed) l in + Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), + Cstr_tuple l + | Pcstr_record l -> + let lbls, lbls' = transl_labels env closed l in + let id = Ident.create (ty_name ^ "." ^ c_name) in + Types.Cstr_record (id, lbls'), + Cstr_record lbls + let transl_declaration env sdecl id = (* Bind type parameters *) reset_type_variables(); @@ -167,21 +237,27 @@ let transl_declaration env sdecl id = all_constrs := StringSet.add name !all_constrs) cstrs; if List.length - (List.filter (fun cd -> cd.pcd_args <> []) cstrs) + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) cstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); - let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} = + let make_cstr {pcd_name = lid; pcd_args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} = let name = Ident.create lid.txt in match ret_type with | None -> - (name, lid, List.map (transl_simple_type env true) args, - None, None, loc, attrs) + let args = + transl_constructor_arguments env true (Ident.name id) lid.txt + pcd_args + in + (name, lid, args, None, None, loc, attrs) | Some sty -> (* if it's a generalized constructor we must first narrow and then widen so as to not introduce any new constraints *) let z = narrow () in reset_type_variables (); - let args = List.map (transl_simple_type env false) args in + let args = + transl_constructor_arguments env false (Ident.name id) lid.txt + pcd_args + in let cty = transl_simple_type env false sty in let ret_type = let ty = cty.ctyp_type in @@ -196,48 +272,25 @@ let transl_declaration env sdecl id = (name, lid, args, Some cty, Some ret_type, loc, attrs) in let cstrs = List.map make_cstr cstrs in - Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs) -> - {cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res; + Ttype_variant (List.map (fun (name, lid, (_, args), res, _, loc, attrs) -> + {cd_id = name; cd_name = lid; cd_args = args; cd_res = res; cd_loc = loc; cd_attributes = attrs} ) cstrs), - Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, attrs) -> - {Types.cd_id = name; cd_args = List.map (fun cty -> cty.ctyp_type) ctys; + Type_variant (List.map (fun (name, name_loc, (args, _), _, option, loc, attrs) -> + {Types.cd_id = name; cd_args = args; cd_res = option; - cd_loc = loc; cd_attributes = attrs} + cd_loc = loc; cd_attributes = attrs; + } ) cstrs) | Ptype_record lbls -> - let all_labels = ref StringSet.empty in - List.iter - (fun {pld_name = {txt=name}} -> - if StringSet.mem name !all_labels then - raise(Error(sdecl.ptype_loc, Duplicate_label name)); - all_labels := StringSet.add name !all_labels) - lbls; - let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} -> - let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env true arg in - {ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty; - ld_loc = loc; ld_attributes = attrs} - ) lbls in - let lbls' = - List.map - (fun ld -> - let ty = ld.ld_type.ctyp_type in - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in - {Types.ld_id = ld.ld_id; - ld_mutable = ld.ld_mutable; - ld_type = ty; - ld_loc = ld.ld_loc; - ld_attributes = ld.ld_attributes - } - ) - lbls in - let rep = - if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' - then Record_float - else Record_regular in - Ttype_record lbls, Type_record(lbls', rep) + let lbls, lbls' = transl_labels env true lbls in + let rep = + if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' + then Record_float + else Record_regular + in + Ttype_record lbls, Type_record(lbls', rep) in let (tman, man) = match sdecl.ptype_manifest with None -> None, None @@ -297,18 +350,7 @@ let transl_declaration env sdecl id = let generalize_decl decl = List.iter Ctype.generalize decl.type_params; - begin match decl.type_kind with - Type_abstract -> - () - | Type_variant v -> - List.iter - (fun c -> - List.iter Ctype.generalize c.Types.cd_args; - may Ctype.generalize c.Types.cd_res) - v - | Type_record(r, rep) -> - List.iter (fun l -> Ctype.generalize l.Types.ld_type) r - end; + Btype.iter_type_expr_kind Ctype.generalize decl.type_kind; begin match decl.type_manifest with | None -> () | Some ty -> Ctype.generalize ty @@ -342,6 +384,17 @@ let rec check_constraints_rec env loc visited ty = module SMap = Map.Make(String) +let check_constraints_labels env visited l pl = + let rec get_loc name = function + [] -> assert false + | pld :: tl -> + if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl + in + List.iter + (fun {Types.ld_id=name; ld_type=ty} -> + check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) + l + let check_constraints env sdecl (_, decl) = let visited = ref TypeSet.empty in begin match decl.type_kind with @@ -359,14 +412,20 @@ let check_constraints env sdecl (_, decl) = List.fold_left foldf SMap.empty pl in List.iter - (fun {Types.cd_id=name; cd_args=tyl; cd_res=ret_type} -> - let {pcd_args = styl; pcd_res = sret_type; _} = + (fun {Types.cd_id=name; cd_args; cd_res=ret_type} -> + let {pcd_args; pcd_res = sret_type; _} = try SMap.find (Ident.name name) pl_index with Not_found -> assert false in - List.iter2 - (fun sty ty -> - check_constraints_rec env sty.ptyp_loc visited ty) - styl tyl; + begin match cd_args, pcd_args with + | Cstr_tuple tyl, Pcstr_tuple styl -> + List.iter2 + (fun sty ty -> + check_constraints_rec env sty.ptyp_loc visited ty) + styl tyl + | Cstr_record (_, tyl), Pcstr_record styl -> + check_constraints_labels env visited tyl styl + | _ -> assert false (* todo *) + end; match sret_type, ret_type with | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r @@ -379,15 +438,7 @@ let check_constraints env sdecl (_, decl) = | Ptype_variant _ | Ptype_abstract -> assert false in let pl = find_pl sdecl.ptype_kind in - let rec get_loc name = function - [] -> assert false - | pld :: tl -> - if name = pld.pld_name.txt then pld.pld_type.ptyp_loc else get_loc name tl - in - List.iter - (fun {Types.ld_id=name; ld_type=ty} -> - check_constraints_rec env (get_loc (Ident.name name) pl) visited ty) - l + check_constraints_labels env visited l pl end; begin match decl.type_manifest with | None -> () @@ -712,12 +763,19 @@ let constrained env vars ty = | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars | _ -> true +let for_constr = function + | Types.Cstr_tuple l -> add_false l + | Types.Cstr_record (_, l) -> + List.map + (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) + l + let compute_variance_gadt env check (required, loc as rloc) decl (tl, ret_type_opt) = match ret_type_opt with | None -> compute_variance_type env check rloc {decl with type_private = Private} - (add_false tl) + (for_constr tl) | Some ret_type -> match Ctype.repr ret_type with | {desc=Tconstr (path, tyl, _)} -> @@ -737,7 +795,7 @@ let compute_variance_gadt env check (required, loc as rloc) decl in compute_variance_type env check rloc {decl with type_params = tyl; type_private = Private} - (add_false tl) + (for_constr tl) | _ -> assert false let compute_variance_decl env check decl (required, loc as rloc) = @@ -758,10 +816,11 @@ let compute_variance_decl env check decl (required, loc as rloc) = | Type_variant tll -> if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env check rloc decl - (mn @ add_false (List.flatten (List.map (fun c -> c.Types.cd_args) tll))) + (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) + tll)) else begin let mn = - List.map (fun (_,ty) -> ([ty],None)) mn in + List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env check rloc decl) tll with | vari :: rem -> @@ -902,6 +961,7 @@ let transl_type_decl env sdecl_list = fixed_types @ sdecl_list in + (* Create identifiers. *) let id_list = List.map (fun sdecl -> Ident.create sdecl.ptype_name.txt) sdecl_list @@ -1022,46 +1082,78 @@ let transl_closed_type env sty = let transl_exception env excdecl = let loc = excdecl.pcd_loc in - if excdecl.pcd_res <> None then raise (Error (loc, Exception_constructor_with_result)); + let id = Ident.create excdecl.pcd_name.txt in + if excdecl.pcd_res <> None then + raise (Error (loc, Exception_constructor_with_result)); reset_type_variables(); Ctype.begin_def(); - let ttypes = List.map (transl_closed_type env) excdecl.pcd_args in - Ctype.end_def(); - let types = List.map (fun cty -> cty.ctyp_type) ttypes in - List.iter Ctype.generalize types; - let exn_decl = - { - exn_args = types; - exn_attributes = excdecl.pcd_attributes; - Types.exn_loc = loc; - } + let exn_args, cd_args = + transl_constructor_arguments env true "exn" excdecl.pcd_name.txt + excdecl.pcd_args in - let (id, newenv) = Env.enter_exception excdecl.pcd_name.txt exn_decl env in + Ctype.end_def(); let cd = { cd_id = id; cd_name = excdecl.pcd_name; - cd_args = ttypes; + cd_args; cd_loc = loc; cd_res = None; cd_attributes = excdecl.pcd_attributes; } in + begin match exn_args with + | Types.Cstr_tuple l -> List.iter Ctype.generalize l + | Types.Cstr_record (_,l) -> + List.iter (fun l -> Ctype.generalize l.Types.ld_type) l + end; + let exn_decl = + { + exn_args; + exn_attributes = excdecl.pcd_attributes; + Types.exn_loc = loc; + } + in + let newenv = Env.add_exception ~check:true id exn_decl env in cd, exn_decl, newenv (* Translate an exception rebinding *) -let transl_exn_rebind env loc lid = +let transl_exn_rebind env loc name lid = let cdescr = try Env.lookup_constructor lid env with Not_found -> raise(Error(loc, Unbound_exception lid)) in Env.mark_constructor Env.Positive env (Longident.last lid) cdescr; - match cdescr.cstr_tag with - Cstr_exception (path, _) -> - (path, {exn_args = cdescr.cstr_args; - exn_attributes = []; - Types.exn_loc = loc}) - | _ -> raise(Error(loc, Not_an_exception lid)) + let path = + match cdescr.cstr_tag with + | Cstr_exception (path, _) -> path + | _ -> raise(Error(loc, Not_an_exception lid)) + in + let exn_args, manifest_path = + if cdescr.cstr_inlined then + let p = + match cdescr.cstr_args with + | [ {desc=Tconstr(p, [], _)} ] -> p + | _ -> assert false + in + let decl = + try Env.find_type p env with Not_found -> assert false + in + let lbls = + match decl.type_kind with Type_record (l, _) -> l | _ -> assert false + in + let id = Ident.create ("exn." ^ name) in + Types.Cstr_record (id, lbls), Some p + else + Types.Cstr_tuple cdescr.cstr_args, None + in + let d = { + Types.exn_args; + exn_attributes = []; + exn_loc = loc + } + in + (path, d, manifest_path) (* Translate a value declaration *) let transl_value_decl env loc valdecl = @@ -1309,7 +1401,11 @@ let report_error ppf = function begin match decl.type_kind, decl.type_manifest with | Type_variant tl, _ -> explain_unbound ppf ty tl (fun c -> - Btype.newgenty (Ttuple c.Types.cd_args)) + match c.cd_args with + | Cstr_tuple tl -> + Btype.newgenty (Ttuple tl) + | Cstr_record _ -> assert false + ) "case" (fun c -> Ident.name c.Types.cd_id ^ " of ") | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) diff --git a/typing/typedecl.mli b/typing/typedecl.mli index 89eb07517e..7237f3d24e 100644 --- a/typing/typedecl.mli +++ b/typing/typedecl.mli @@ -21,10 +21,13 @@ val transl_type_decl: val transl_exception: Env.t -> - Parsetree.constructor_declaration -> Typedtree.constructor_declaration * exception_declaration * Env.t + Parsetree.constructor_declaration -> + Typedtree.constructor_declaration * exception_declaration * Env.t val transl_exn_rebind: - Env.t -> Location.t -> Longident.t -> Path.t * exception_declaration + Env.t -> Location.t -> string -> Longident.t -> + Path.t * + exception_declaration * Path.t option val transl_value_decl: Env.t -> Location.t -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 166086ae86..db56cf853d 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -385,12 +385,16 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attribute list; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + and class_type = { cltyp_desc: class_type_desc; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 1e6d0a6c07..1e6c03e8c0 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -385,12 +385,16 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; - cd_args: core_type list; + cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; cd_attributes: attributes; } +and constructor_arguments = + | Cstr_tuple of core_type list + | Cstr_record of label_declaration list + and class_type = { cltyp_desc: class_type_desc; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index c0d61297d4..f847a2e5ad 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -164,7 +164,10 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.leave_value_description v and iter_constructor_declaration cd = - List.iter iter_core_type cd.cd_args; + begin match cd.cd_args with + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + end; option iter_core_type cd.cd_res; and iter_type_declaration decl = diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index 93881a0f12..b4c00d04a6 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -185,7 +185,16 @@ module MakeMap(Map : MapArgument) = struct typ_kind = typ_kind; typ_manifest = typ_manifest } and map_constructor_declaration cd = - {cd with cd_args = List.map map_core_type cd.cd_args; + let cd_args = + match cd.cd_args with + | Cstr_tuple l -> + Cstr_tuple (List.map map_core_type l) + | Cstr_record l -> + Cstr_record + (List.map (fun ld -> {ld with ld_type = map_core_type ld.ld_type}) + l) + in + {cd with cd_args; cd_res = may_map map_core_type cd.cd_res } diff --git a/typing/typemod.ml b/typing/typemod.ml index 72dbe70743..aff624b7cf 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -472,6 +472,13 @@ let mksig desc env loc = (* let signature sg = List.map (fun item -> item.sig_type) sg *) +let prepend_sig_types decls rem = + map_rec'' (fun rs td -> Sig_type(td.typ_id, td.typ_type, rs)) decls rem + +let prepend_sig_types' decls rem = + map_rec (fun rs (id, td) -> Sig_type(id, td, rs)) decls rem + + let rec transl_modtype env smty = let loc = smty.pmty_loc in match smty.pmty_desc with @@ -516,7 +523,6 @@ let rec transl_modtype env smty = | Pmty_extension (s, _arg) -> raise (Error (s.loc, env, Extension s.txt)) - and transl_signature env sg = let type_names = ref StringSet.empty and module_names = ref StringSet.empty @@ -544,14 +550,14 @@ and transl_signature env sg = let (decls, newenv) = Typedecl.transl_type_decl env sdecls in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_type decls) env loc :: trem, - map_rec'' (fun rs td -> - Sig_type(td.typ_id, td.typ_type, rs)) decls rem, + prepend_sig_types decls rem, final_env | Psig_exception sarg -> let (arg, decl, newenv) = Typedecl.transl_exception env sarg in let (trem, rem, final_env) = transl_sig newenv srem in let id = arg.cd_id in - mksig (Tsig_exception arg) env loc :: trem, + let trem = mksig (Tsig_exception arg) env loc :: trem in + trem, (if List.exists (Ident.equal id) (get_exceptions rem) then rem else Sig_exception(id, decl) :: rem), final_env @@ -1149,15 +1155,18 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = sdecls; let (decls, newenv) = Typedecl.transl_type_decl env sdecls in Tstr_type decls, - map_rec'' (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) - decls [], + prepend_sig_types decls [], enrich_type_decls anchor decls env newenv | Pstr_exception sarg -> let (arg, decl, newenv) = Typedecl.transl_exception env sarg in - Tstr_exception arg, [Sig_exception(arg.cd_id, decl)], newenv + Tstr_exception arg, + [Sig_exception(arg.cd_id, decl)], + newenv | Pstr_exn_rebind(name, longid, attrs) -> - let (path, arg) = Typedecl.transl_exn_rebind env loc longid.txt in - let (id, newenv) = Env.enter_exception name.txt arg env in + let (path, arg, rebind) = + Typedecl.transl_exn_rebind env loc name.txt longid.txt + in + let (id, newenv) = Env.enter_exception ?rebind name.txt arg env in Tstr_exn_rebind(id, name, path, longid, attrs), [Sig_exception(id, arg)], newenv diff --git a/typing/types.ml b/typing/types.ml index dc159cd09e..57328026d1 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -119,6 +119,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: bool; } and constructor_tag = @@ -143,7 +144,9 @@ type label_description = and record_representation = Record_regular (* All fields are boxed / tagged *) + | Record_inlined of int (* Same, for inlined records *) | Record_float (* All fields are floats *) + | Record_exception of Path.t (* Inlined record under exception *) (* Variance *) @@ -206,12 +209,15 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of Ident.t * label_declaration list and type_transparence = Type_public (* unrestricted expansion *) @@ -219,7 +225,7 @@ and type_transparence = | Type_private (* private type *) type exception_declaration = - { exn_args: type_expr list; + { exn_args: constructor_arguments; exn_loc: Location.t; exn_attributes: Parsetree.attributes; } diff --git a/typing/types.mli b/typing/types.mli index b53cf913e3..d268ddafa7 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -116,6 +116,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: bool; } and constructor_tag = @@ -140,7 +141,9 @@ type label_description = and record_representation = Record_regular (* All fields are boxed / tagged *) + | Record_inlined of int (* Same, for inlined records *) | Record_float (* All fields are floats *) + | Record_exception of Path.t (* Inlined record under exception *) (* Variance *) @@ -194,19 +197,23 @@ and label_declaration = and constructor_declaration = { cd_id: Ident.t; - cd_args: type_expr list; + cd_args: constructor_arguments; cd_res: type_expr option; cd_loc: Location.t; cd_attributes: Parsetree.attributes; } +and constructor_arguments = + | Cstr_tuple of type_expr list + | Cstr_record of Ident.t * label_declaration list + and type_transparence = Type_public (* unrestricted expansion *) | Type_new (* "new" type *) | Type_private (* private type *) type exception_declaration = - { exn_args: type_expr list; + { exn_args: constructor_arguments; exn_loc: Location.t; exn_attributes: Parsetree.attributes; } diff --git a/utils/config.mlp b/utils/config.mlp index c83071da14..209f90ce15 100644 --- a/utils/config.mlp +++ b/utils/config.mlp @@ -49,7 +49,7 @@ let mkexe = "%%MKEXE%%" let mkmaindll = "%%MKMAINDLL%%" let exec_magic_number = "Caml1999X011" -and cmi_magic_number = "Caml1999I016" +and cmi_magic_number = "Caml1999I017" and cmo_magic_number = "Caml1999O009" and cma_magic_number = "Caml1999A010" and cmx_magic_number = "Caml1999Y012" |