diff options
55 files changed, 985 insertions, 226 deletions
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml index 1f640b9bfe..17dcb8220f 100644 --- a/asmcomp/cmmgen.ml +++ b/asmcomp/cmmgen.ml @@ -641,8 +641,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_extension, 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 8282e01148..6f2237861f 100755 --- a/boot/ocamlc +++ b/boot/ocamlc diff --git a/boot/ocamldep b/boot/ocamldep Binary files differindex bb4b761452..98e22bf6df 100755 --- a/boot/ocamldep +++ b/boot/ocamldep diff --git a/boot/ocamllex b/boot/ocamllex Binary files differindex 01c4739de3..468183a044 100755 --- a/boot/ocamllex +++ b/boot/ocamllex diff --git a/bytecomp/bytegen.ml b/bytecomp/bytegen.ml index af5f0a3fd8..be884ded5f 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_extension -> 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_extension, 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 8ab6cec8bc..cba32391e9 100644 --- a/bytecomp/matching.ml +++ b/bytecomp/matching.ml @@ -1348,7 +1348,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 <> None 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_extension _ -> @@ -1628,8 +1630,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_extension -> 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 d528a35745..1b9085edd5 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_extension -> fprintf ppf "ext" ;; let string_of_loc_kind = function diff --git a/bytecomp/translcore.ml b/bytecomp/translcore.ml index 876abaa942..14f8b0659f 100644 --- a/bytecomp/translcore.ml +++ b/bytecomp/translcore.ml @@ -746,7 +746,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 <> None 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 -> @@ -776,20 +779,26 @@ 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_extension -> 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_extension -> 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 @@ -1071,7 +1080,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 @@ -1086,7 +1095,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_extension -> Pfield (i + 1) | Record_float -> Pfloatfield i in lv.(i) <- Lprim(access, [Lvar init_id]) done @@ -1104,13 +1114,26 @@ 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_extension -> + 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_extension -> + let path = + match all_labels.(0).lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + in + let slot = transl_path env path in + Lprim(Pmakeblock(0, mut), slot :: ll) + in begin match opt_init_expr with None -> lam | Some init_expr -> Llet(Strict, init_id, transl_exp init_expr, lam) @@ -1124,8 +1147,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_extension -> 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/translmod.ml b/bytecomp/translmod.ml index dc7d2d7a63..1f475565f9 100644 --- a/bytecomp/translmod.ml +++ b/bytecomp/translmod.ml @@ -805,9 +805,13 @@ let transl_toplevel_item item = let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + (* we need to use unique name in case of multiple + definitions of the same extension constructor in the toplevel *) + List.iter set_toplevel_unique_name idents; transl_type_extension item.str_env None tyext (make_sequence toploop_setvalue_id idents) | Tstr_exception ext -> + set_toplevel_unique_name ext.ext_id; toploop_setvalue ext.ext_id (transl_extension_constructor item.str_env None ext) | Tstr_module {mb_id=id; mb_expr=modl} -> 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/ocamldoc/odoc_ast.ml b/ocamldoc/odoc_ast.ml index 358a71a51c..346db02455 100644 --- a/ocamldoc/odoc_ast.ml +++ b/ocamldoc/odoc_ast.ml @@ -1316,6 +1316,11 @@ module Analyser = let new_xt = match tt_ext.ext_kind with Text_decl(args, ret_type) -> + let args = + match args with + | Cstr_tuple l -> l + | Cstr_record _ -> assert false + in { xt_name = complete_name; xt_args = @@ -1373,6 +1378,11 @@ module Analyser = Text_decl(tt_args, tt_ret_type) -> let loc_start = loc.Location.loc_start.Lexing.pos_cnum in let loc_end = loc.Location.loc_end.Lexing.pos_cnum in + let tt_args = + match tt_args with + | Cstr_tuple l -> l + | Cstr_record _ -> assert false + in { ex_name = complete_name ; ex_info = comment_opt ; diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index e41cf2b8db..8a15841b1a 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -271,12 +271,17 @@ module Analyser = Types.Type_abstract -> Odoc_type.Type_abstract | Types.Type_variant l -> - let f {Types.cd_id=constructor_name;cd_args=type_expr_list;cd_res=ret_type} = + let f {Types.cd_id=constructor_name;cd_args;cd_res=ret_type} = let constructor_name = Ident.name constructor_name in let comment_opt = try List.assoc constructor_name name_comment_list with Not_found -> None in + let type_expr_list = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record _ -> assert false + in { vc_name = constructor_name ; vc_args = List.map (Odoc_env.subst_type env) type_expr_list ; @@ -658,10 +663,15 @@ module Analyser = [] -> (maybe_more, List.rev exts_acc) | (name, types_ext) :: q -> let ext_loc_end = types_ext.Types.ext_loc.Location.loc_end.Lexing.pos_cnum in + let args = + match types_ext.ext_args with + | Cstr_tuple l -> l + | Cstr_record _ -> assert false + in let new_x = { xt_name = Name.concat current_module_name name ; - xt_args = List.map (Odoc_env.subst_type new_env) types_ext.ext_args ; + xt_args = List.map (Odoc_env.subst_type new_env) args; xt_ret = may_map (Odoc_env.subst_type new_env) types_ext.ext_ret_type ; xt_type_extension = new_te; xt_alias = None ; @@ -696,11 +706,16 @@ module Analyser = with Not_found -> raise (Failure (Odoc_messages.exception_not_found current_module_name name.txt)) in + let args = + match types_ext.ext_args with + | Cstr_tuple l -> l + | Cstr_record _ -> assert false + in let e = { ex_name = Name.concat current_module_name name.txt ; ex_info = comment_opt ; - ex_args = List.map (Odoc_env.subst_type env) types_ext.ext_args ; + ex_args = List.map (Odoc_env.subst_type env) args; ex_ret = may_map (Odoc_env.subst_type env) types_ext.ext_ret_type ; ex_alias = None ; ex_loc = { loc_impl = None ; loc_inter = Some sig_item_loc } ; diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 47c7bd338a..f53cb29288 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -364,7 +364,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; @@ -402,7 +402,7 @@ module Te = struct pext_attributes = attrs; } - let decl ?(loc = !default_loc) ?(attrs = []) ?(args = []) ?res name = + let decl ?(loc = !default_loc) ?(attrs = []) ?(args = Pcstr_tuple []) ?res name = { pext_name = name; pext_kind = Pext_decl(args, res); diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index b9b04f8223..847d428f61 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -154,7 +154,7 @@ module Type: sig val mk: ?loc:loc -> ?attrs:attrs -> ?params:(core_type * 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 @@ -165,7 +165,7 @@ module Te: val constructor: ?loc:loc -> ?attrs:attrs -> str -> extension_constructor_kind -> extension_constructor - val decl: ?loc:loc -> ?attrs:attrs -> ?args:core_type list -> ?res:core_type -> str -> extension_constructor + val decl: ?loc:loc -> ?attrs:attrs -> ?args:constructor_arguments -> ?res:core_type -> str -> extension_constructor val rebind: ?loc:loc -> ?attrs:attrs -> str -> lid -> extension_constructor end diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 669d01449c..aa9fdbfca3 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -137,6 +137,11 @@ module T = struct | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) | Ptype_open -> Ptype_open + let map_constructor_arguments sub = function + | Pcstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Pcstr_record l -> + Pcstr_record (List.map (sub.label_declaration sub) l) + let map_type_extension sub {ptyext_path; ptyext_params; ptyext_constructors; @@ -151,7 +156,7 @@ module T = struct let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> - Pext_decl(List.map (sub.typ sub) ctl, map_opt (sub.typ sub) cto) + Pext_decl(map_constructor_arguments sub ctl, map_opt (sub.typ sub) cto) | Pext_rebind li -> Pext_rebind (map_loc sub li) @@ -573,7 +578,7 @@ let default_mapper = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> Type.constructor (map_loc this pcd_name) - ~args:(List.map (this.typ this) pcd_args) + ~args:(T.map_constructor_arguments this pcd_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 4e2053be34..87086f6508 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -1658,16 +1658,18 @@ sig_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 } @@ -1999,6 +2001,13 @@ constr_longident: | FALSE { Lident "false" } | TRUE { Lident "true" } ; +constr_qual_longident: + mod_longident %prec below_DOT { $1 } + | mod_longident DOT LIDENT DOT UIDENT %prec below_DOT + { Ldot(Ldot($1, $3), $5) } + | LIDENT DOT UIDENT %prec below_DOT + { Ldot(Lident $1, $3) } +; label_longident: LIDENT { Lident $1 } | mod_longident DOT LIDENT { Ldot($1, $3) } @@ -2006,6 +2015,7 @@ label_longident: type_longident: LIDENT { Lident $1 } | mod_ext_longident DOT LIDENT { Ldot($1, $3) } + | BANG constr_qual_longident { $2 } ; mod_longident: UIDENT { Lident $1 } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index a66317f47c..d287b9eee7 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -398,15 +398,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) *) and type_extension = @@ -430,7 +438,7 @@ and extension_constructor = } and extension_constructor_kind = - Pext_decl of core_type list * core_type option + Pext_decl of constructor_arguments * core_type option (* | C of T1 * ... * Tn ([T1; ...; Tn], None) | C: T0 ([], Some T0) diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 327d67041f..5f59dacac3 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1313,18 +1313,21 @@ class printer ()= object(self:'self) pp f "%s%a%a" name self#attributes attrs (fun f -> function - | [] -> () - | l -> + | Pcstr_tuple [] -> () + | Pcstr_tuple l -> pp f "@;of@;%a" (self#list self#core_type1 ~sep:"*@;") l + | Pcstr_record l -> pp f "@;of@;%a" (self#record_declaration) l ) args | Some r -> pp f "%s%a:@;%a" name self#attributes attrs (fun f -> function - | [] -> self#core_type1 f r - | l -> pp f "%a@;->@;%a" + | Pcstr_tuple [] -> self#core_type1 f r + | Pcstr_tuple l -> pp f "%a@;->@;%a" (self#list self#core_type1 ~sep:"*@;") l self#core_type1 r + | Pcstr_record l -> + pp f "%a@;->@;%a" (self#record_declaration) l self#core_type1 r ) args diff --git a/parsing/pprintast.mli b/parsing/pprintast.mli index 22e21adc67..42a3409151 100644 --- a/parsing/pprintast.mli +++ b/parsing/pprintast.mli @@ -37,7 +37,7 @@ class printer : Format.formatter -> Parsetree.class_type_declaration list -> unit method constant : Format.formatter -> Asttypes.constant -> unit method constant_string : Format.formatter -> string -> unit - method constructor_declaration : Format.formatter -> (string * Parsetree.core_type list * Parsetree.core_type option * Parsetree.attributes) -> unit + method constructor_declaration : Format.formatter -> (string * Parsetree.constructor_arguments * Parsetree.core_type option * Parsetree.attributes) -> unit method core_type : Format.formatter -> Parsetree.core_type -> unit method core_type1 : Format.formatter -> Parsetree.core_type -> unit method direction_flag : diff --git a/parsing/printast.ml b/parsing/printast.ml index f0472bcdb0..2bf9d8f3e9 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -439,7 +439,7 @@ and extension_constructor_kind i ppf x = match x with Pext_decl(a, r) -> line i ppf "Pext_decl\n"; - list (i+1) core_type ppf a; + constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Pext_rebind li -> line i ppf "Pext_rebind\n"; @@ -810,9 +810,13 @@ and constructor_decl i ppf line i ppf "%a\n" fmt_location pcd_loc; line (i+1) ppf "%a\n" fmt_string_loc pcd_name; attributes i ppf pcd_attributes; - list (i+1) core_type ppf pcd_args; + constructor_arguments (i+1) ppf pcd_args; option (i+1) core_type ppf pcd_res +and constructor_arguments i ppf = function + | Pcstr_tuple l -> list i core_type ppf l + | Pcstr_record l -> list i label_decl ppf l + and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes}= line i ppf "%a\n" fmt_location pld_loc; attributes i ppf 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..cac47a3b7b --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml @@ -0,0 +1,114 @@ +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;; + + +module type S = sig exception A of {x:int} end;; + +module F (X : sig val x : (module S) end) = struct + module A = (val X.x) +end;; + + +module type S = sig + exception A of {x : int} + exception A of {x : string} +end;; + +module M = struct + exception A of {x : int} + exception A of {x : string} +end;; + + +module M1 = struct + exception A of {x : int} +end;; + +module M = struct + include M1 + include M1 +end;; + + +module type S1 = sig + exception A of {x : int} +end;; + +module type S = sig + include S1 + include S1 +end;; + +module M = struct + exception A = M1.A +end;; + +module X1 = struct + type t = .. +end;; +module X2 = struct + type t = .. +end;; +module Z = struct + type X1.t += A of {x: int} + type X2.t += A of {x: int} +end;; +module Z = struct + type X1.t += A of {x: int} + let f = function A r -> r | _ -> assert false + + type t = A of {x: int} + let g = function A r -> r +end;; +let f = Z.f;; +let g = Z.g;; + + +(* Self-reference to !-types *) + +module X = struct + type t = A of {x : int} | B of !A + type s = + | A of {x : !B; y : !s.B; z : !t.A; mutable u : !A option} + | B of {y : int} +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..54f9e2326b --- /dev/null +++ b/testsuite/tests/typing-recordarg/recordarg.ml.reference @@ -0,0 +1,71 @@ + +# 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 +# module type S = sig exception A of { x : int; } end +# Characters 65-74: + module A = (val X.x) + ^^^^^^^^^ +Error: This expression creates fresh types. + It is not allowed inside applicative functors. +# Characters 61-62: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# Characters 58-59: + exception A of {x : string} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M1 : sig exception A of { x : int; } end +# Characters 34-44: + include M1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module type S1 = sig exception A of { x : int; } end +# Characters 36-46: + include S1 + ^^^^^^^^^^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module M : sig exception A of { x : int; } end +# module X1 : sig type t = .. end +# module X2 : sig type t = .. end +# Characters 62-63: + type X2.t += A of {x: int} + ^ +Error: Multiple definition of the extension constructor name A. + Names must be unique in a given structure or signature. +# module Z : + sig + type X1.t += A of { x : int; } + val f : X1.t -> !A + type t = A of { x : int; } + val g : t -> !t.A + end +# val f : X1.t -> !Z.A = <fun> +# val g : Z.t -> !Z.t.A = <fun> +# module X : + sig + type t = A of { x : int; } | B of !t.A + type s = + A of { x : !s.B; y : !s.B; z : !t.A; mutable u : !s.A option; } + | B of { y : int; } + end +# diff --git a/tools/depend.ml b/tools/depend.ml index aeb121cbc8..222d08d31e 100644 --- a/tools/depend.ml +++ b/tools/depend.ml @@ -64,8 +64,13 @@ let add_opt add_fn bv = function None -> () | Some x -> add_fn bv x +let add_constructor_arguments bv = function + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + let add_constructor_decl bv pcd = - List.iter (add_type bv) pcd.pcd_args; Misc.may (add_type bv) pcd.pcd_res + add_constructor_arguments bv pcd.pcd_args; + Misc.may (add_type bv) pcd.pcd_res let add_type_declaration bv td = List.iter @@ -83,9 +88,10 @@ let add_type_declaration bv td = let add_extension_constructor bv ext = match ext.pext_kind with - Pext_decl(args, rty) -> - List.iter (add_type bv) args; Misc.may (add_type bv) rty - | Pext_rebind lid -> add bv lid + Pext_decl(args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty + | Pext_rebind lid -> add bv lid let add_type_extension bv te = add bv te.ptyext_path; diff --git a/tools/tast_iter.ml b/tools/tast_iter.ml index 791fb6a513..be5b854419 100644 --- a/tools/tast_iter.ml +++ b/tools/tast_iter.ml @@ -39,8 +39,12 @@ let structure_item sub x = let value_description sub x = sub # core_type x.val_desc +let constructor_args sub = function + | Cstr_tuple l -> List.iter (sub # core_type) l + | Cstr_record l -> List.iter (fun ld -> sub # core_type ld.ld_type) l + let constructor_decl sub cd = - List.iter (sub # core_type) cd.cd_args; + constructor_args sub cd.cd_args; opt (sub # core_type) cd.cd_res let label_decl sub ld = @@ -66,7 +70,7 @@ let type_extension sub te = let extension_constructor sub ext = match ext.ext_kind with Text_decl(ctl, cto) -> - List.iter (sub # core_type) ctl; + constructor_args sub ctl; opt (sub # core_type) cto | Text_rebind _ -> () diff --git a/tools/untypeast.ml b/tools/untypeast.ml index 7641c91d0a..58242fc23e 100644 --- a/tools/untypeast.ml +++ b/tools/untypeast.ml @@ -134,10 +134,14 @@ and untype_type_declaration decl = and untype_type_parameter (ct, v) = (untype_core_type ct, v) +and untype_constructor_arguments = function + | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l) + | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l) + and untype_constructor_declaration cd = { pcd_name = cd.cd_name; - pcd_args = List.map untype_core_type cd.cd_args; + pcd_args = untype_constructor_arguments cd.cd_args; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes; @@ -167,7 +171,7 @@ and untype_extension_constructor ext = pext_name = ext.ext_name; pext_kind = (match ext.ext_kind with Text_decl (args, ret) -> - Pext_decl (List.map untype_core_type args, + Pext_decl (untype_constructor_arguments args, option untype_core_type ret) | Text_rebind (_p, lid) -> Pext_rebind lid ); diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 27f45a2d1b..bedebd224f 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -290,40 +290,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 = - nest 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_extension -> 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 | {type_kind = Type_open} -> tree_of_extension path depth obj @@ -371,6 +372,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 = + nest 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 | [] -> [] @@ -380,9 +406,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_extension type_path depth bucket = @@ -407,7 +440,9 @@ 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 <> None) + 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/topdirs.ml b/toplevel/topdirs.ml index 59ce633cdf..1e260139e7 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -398,7 +398,7 @@ let () = let ext = { ext_type_path = Predef.path_exn; ext_type_params = []; - ext_args = desc.cstr_args; + ext_args = Cstr_tuple desc.cstr_args; ext_ret_type = ret_type; ext_private = Asttypes.Public; Types.ext_loc = desc.cstr_loc; diff --git a/typing/btype.ml b/typing/btype.ml index ce97f654f0..f23b7387b0 100644 --- a/typing/btype.ml +++ b/typing/btype.ml @@ -253,12 +253,21 @@ type type_iterators = it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } +let iter_type_expr_cstr_args f = function + | Cstr_tuple tl -> List.iter f tl + | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls + +let map_type_expr_cstr_args f = function + | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_record lbls -> + Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) + let iter_type_expr_kind f = function | Type_abstract -> () | Type_variant cstrs -> List.iter (fun cd -> - List.iter f cd.cd_args; + iter_type_expr_cstr_args f cd.cd_args; Misc.may f cd.cd_res ) cstrs @@ -288,7 +297,7 @@ let type_iterators = and it_extension_constructor it td = it.it_path td.ext_type_path; List.iter (it.it_type_expr it) td.ext_type_params; - List.iter (it.it_type_expr it) td.ext_args; + iter_type_expr_cstr_args (it.it_type_expr it) td.ext_args; may (it.it_type_expr it) td.ext_ret_type and it_module_declaration it md = it.it_module_type it md.md_type @@ -471,7 +480,7 @@ let unmark_type_decl decl = let unmark_extension_constructor ext = List.iter unmark_type ext.ext_type_params; - List.iter unmark_type ext.ext_args; + iter_type_expr_cstr_args unmark_type ext.ext_args; Misc.may unmark_type ext.ext_ret_type let unmark_class_signature sign = diff --git a/typing/btype.mli b/typing/btype.mli index 59f2e77b18..ec63e9ae63 100644 --- a/typing/btype.mli +++ b/typing/btype.mli @@ -205,3 +205,8 @@ val log_type: type_expr -> unit val print_raw: (Format.formatter -> type_expr -> unit) ref val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) diff --git a/typing/ctype.ml b/typing/ctype.ml index a7d31e7c86..aa6eabfae8 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -454,7 +454,7 @@ let rec filter_row_fields erase = function (**************************************) -exception Non_closed +exception Non_closed0 let rec closed_schema_rec ty = let ty = repr ty in @@ -463,7 +463,7 @@ let rec closed_schema_rec ty = ty.level <- pivot_level - level; match ty.desc with Tvar _ when level <> generic_level -> - raise Non_closed + raise Non_closed0 | Tfield(_, kind, t1, t2) -> if field_kind_repr kind = Fpresent then closed_schema_rec t1; @@ -482,7 +482,7 @@ let closed_schema ty = closed_schema_rec ty; unmark_type ty; true - with Non_closed -> + with Non_closed0 -> unmark_type ty; false @@ -561,7 +561,11 @@ 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 @@ -582,7 +586,7 @@ let closed_extension_constructor ext = List.iter mark_type ext.ext_type_params; begin match ext.ext_ret_type with | Some _ -> () - | None -> List.iter closed_type ext.ext_args + | None -> iter_type_expr_cstr_args closed_type ext.ext_args end; unmark_extension_constructor ext; None @@ -594,7 +598,7 @@ type closed_class_failure = CC_Method of type_expr * bool * string * type_expr | CC_Value of type_expr * bool * string * type_expr -exception Failure of closed_class_failure +exception CCFailure of closed_class_failure let closed_class params sign = let ty = object_fields (repr sign.csig_self) in @@ -610,13 +614,13 @@ let closed_class params sign = (fun (lab, kind, ty) -> if field_kind_repr kind = Fpresent then try closed_type ty with Non_closed (ty0, real) -> - raise (Failure (CC_Method (ty0, real, lab, ty)))) + raise (CCFailure (CC_Method (ty0, real, lab, ty)))) fields; mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; None - with Failure reason -> + with CCFailure reason -> mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; @@ -1193,7 +1197,7 @@ let map_kind f = function List.map (fun c -> {c with - cd_args = List.map f c.cd_args; + cd_args = map_type_expr_cstr_args f c.cd_args; cd_res = may_map f c.cd_res }) cl) @@ -2178,7 +2182,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 []) @@ -4380,7 +4389,7 @@ let nondep_extension_constructor env mid ext = in ext.ext_type_path, type_params in - let args = List.map (nondep_type_rec env mid) ext.ext_args in + let args = map_type_expr_cstr_args (nondep_type_rec env mid) ext.ext_args in let ret_type = may_map (nondep_type_rec env mid) ext.ext_ret_type in clear_hash (); { ext_type_path = type_path; diff --git a/typing/datarepr.ml b/typing/datarepr.ml index 4922cbb0d4..616370c927 100644 --- a/typing/datarepr.ml +++ b/typing/datarepr.ml @@ -17,6 +17,11 @@ open Asttypes open Types open Btype +type error = + | GADT_inlined_record + +exception Error of Location.t * error + (* Simplified version of Ctype.free_vars *) let free_vars ty = let ret = ref TypeSet.empty in @@ -41,8 +46,13 @@ let free_vars ty = let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) -let constructor_args cd_args cd_res = - let arg_vars_set = free_vars (newgenty (Ttuple cd_args)) in +let constructor_args cd_args cd_res type_params loc path type_manifest rep = + let tyl = + match cd_args with + | Cstr_tuple l -> l + | Cstr_record l -> List.map (fun l -> l.ld_type) l + in + let arg_vars_set = free_vars (newgenty (Ttuple tyl)) in let existentials = match cd_res with | None -> [] @@ -50,14 +60,42 @@ let constructor_args cd_args cd_res = let res_vars = free_vars type_ret in TypeSet.elements (TypeSet.diff arg_vars_set res_vars) in - existentials, cd_args + match cd_args with + | Cstr_tuple l -> existentials, l, None + | Cstr_record lbls -> + let type_params = + match cd_res with + | None -> type_params + | Some _ -> raise (Error (loc, GADT_inlined_record)) + in + let type_manifest = + match type_manifest with + | Some p -> Some (newgenconstr p type_params) + | None -> None + in + let tdecl = + { + type_params; + type_arity = List.length type_params; + type_kind = Type_record (lbls, rep); + type_private = Public; + type_manifest; + type_variance = List.map (fun _ -> Variance.full) type_params; + type_newtype_level = None; + type_loc = Location.none; + type_attributes = []; + } + in + existentials, + [ newgenconstr path type_params ], + Some tdecl let constructor_descrs ty_path 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 rec describe_constructors idx_const idx_nonconst = function @@ -70,12 +108,22 @@ let constructor_descrs ty_path decl cstrs = 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, cstr_args = + + let name = Ident.name cd_id in + let subpath p = Path.Pdot (p, name, Path.nopos) in + let type_manifest = + match decl.type_manifest with + | Some {desc = Tconstr(p, _, _)} -> Some (subpath p) + | _ -> None + in + let existentials, cstr_args, cstr_inlined = constructor_args cd_args cd_res + decl.type_params cd_loc + (subpath ty_path) type_manifest (Record_inlined idx_nonconst) in let cstr = { cstr_name = Ident.name cd_id; @@ -91,6 +139,7 @@ let constructor_descrs ty_path decl cstrs = 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 @@ -101,8 +150,10 @@ let extension_descr path_ext ext = Some type_ret -> type_ret | None -> newgenconstr ext.ext_type_path ext.ext_type_params in - let existentials, cstr_args = + let existentials, cstr_args, cstr_inlined = constructor_args ext.ext_args ext.ext_ret_type + ext.ext_type_params ext.ext_loc + path_ext None Record_extension in { cstr_name = Path.last path_ext; cstr_res = ty_res; @@ -117,6 +168,7 @@ let extension_descr path_ext ext = cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; cstr_attributes = ext.ext_attributes; + cstr_inlined; } let none = {desc = Ttuple []; level = -1; id = -1} @@ -155,7 +207,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 @@ -178,3 +230,16 @@ let labels_of_type ty_path decl = label_descrs (newgenconstr ty_path decl.type_params) labels rep decl.type_private | Type_variant _ | Type_abstract | Type_open -> [] + +let report_error ppf = function + | GADT_inlined_record -> + Format.fprintf ppf + "Record arguments are not allowed on GADT constructors." + +let () = + Location.register_error_of_exn + (function + | Error (loc, err) -> + Some (Location.error_of_printer loc report_error err) + | _ -> None + ) diff --git a/typing/env.ml b/typing/env.ml index 5655197a94..4e6bba0c55 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -475,6 +475,51 @@ and find_class = and find_cltype = find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) +let type_of_cstr path = function + | {cstr_inlined = Some d; _} -> + (d, ([], List.map snd (Datarepr.labels_of_type path d))) + | _ -> + assert false + +let find_type_full path env = + match Path.constructor_typath path with + | Regular p -> find_type_full p env + | Cstr (ty_path, s) -> + let (_, (cstrs, _)) = + try find_type_full ty_path env + with Not_found -> assert false + in + let cstr = + try List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + in + type_of_cstr path cstr + | LocalExt id -> + let cstr = + try EnvTbl.find_same id env.constrs + with Not_found -> assert false + in + type_of_cstr path cstr + | Ext (mod_path, s) -> + let comps = + try find_module_descr mod_path env + with Not_found -> assert false + in + let comps = + match EnvLazy.force !components_of_module_maker' comps with + | Structure_comps c -> c + | Functor_comps _ -> assert false + in + let exts = + List.filter + (function ({cstr_tag=Cstr_extension _}, _) -> true | _ -> false) + (try Tbl.find s comps.comp_constrs + with Not_found -> assert false) + in + match exts with + | [(cstr, _)] -> type_of_cstr path cstr + | _ -> assert false + let find_type p env = fst (find_type_full p env) let find_type_descrs p env = @@ -1086,7 +1131,9 @@ let rec prefix_idents root pos sub = function (p::pl, final_sub) | Sig_typext(id, ext, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in - let (pl, final_sub) = prefix_idents root (pos+1) sub rem in + (* we extend the substitution in case of an inlined record *) + let (pl, final_sub) = + prefix_idents root (pos+1) (Subst.add_type id p sub) rem in (p::pl, final_sub) | Sig_module(id, mty, _) :: rem -> let p = Pdot(root, Ident.name id, pos) in diff --git a/typing/includecore.ml b/typing/includecore.ml index ee247adad2..2f913f8a75 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,15 @@ 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 _ | Record_extension -> "inlined record" + | Record_float -> "unboxed float" + 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 +159,19 @@ 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 params1 params2 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 + | _ -> [Field_type cstr] + +and compare_variants env params1 params2 n cstrs1 cstrs2 = match cstrs1, cstrs2 with [], [] -> [] | [], c::_ -> [Field_missing (true, c.Types.cd_id)] @@ -163,24 +180,21 @@ let rec compare_variants env params1 params2 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::params1) (ty2::params2)) - (arg1) (arg2) - then - compare_variants env params1 params2 (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 params1 params2 n labels1 labels2 = +and compare_records env params1 params2 n labels1 labels2 = match labels1, labels2 with [], [] -> [] | [], l::_ -> [Field_missing (true, l.ld_id)] @@ -195,6 +209,14 @@ let rec compare_records env params1 params2 n labels1 labels2 = 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_extension, Record_extension -> true + | _ -> 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 @@ -218,8 +240,8 @@ let type_declarations ?(equality = false) env name decl1 id decl2 = | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> let err = compare_records env decl1.type_params decl2.type_params 1 labels1 labels2 in - if err <> [] || rep1 = rep2 then err else - [Record_representation (rep2 = Record_float)] + if err <> [] || record_representations rep1 rep2 then err else + [Record_representation (rep1, rep2)] | (Type_open, Type_open) -> [] | (_, _) -> [Kind] in @@ -278,17 +300,13 @@ let extension_constructors env id ext1 ext2 = (ty1 :: ext1.ext_type_params) (ty2 :: ext2.ext_type_params) then - if List.length ext1.ext_args = List.length ext2.ext_args then + if compare_constructor_arguments env (Ident.create "") + ext1.ext_type_params ext2.ext_type_params + ext1.ext_args ext2.ext_args = [] then if match ext1.ext_ret_type, ext2.ext_ret_type with Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) -> false | Some _, None | None, Some _ -> false - | _ -> - Misc.for_all2 - (fun ty1 ty2 -> - Ctype.equal env true - (ty1 :: ext1.ext_type_params) - (ty2 :: ext2.ext_type_params)) - ext1.ext_args ext2.ext_args + | _ -> true then match ext1.ext_private, ext2.ext_private with Private, Public -> false diff --git a/typing/includecore.mli b/typing/includecore.mli index 0c8e9558f4..d98455380c 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/mtype.ml b/typing/mtype.ml index 19253a10ec..5f7bec3275 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -263,7 +263,8 @@ and contains_type_sig env = List.iter (contains_type_item env) and contains_type_item env = function Sig_type (_,({type_manifest = None} | {type_kind = Type_abstract; type_private = Private}),_) - | Sig_modtype _ -> + | Sig_modtype _ + | Sig_typext (_, {ext_args = Cstr_record _}, _) -> raise Exit | Sig_module (_, {md_type = mty}, _) -> contains_type env mty diff --git a/typing/oprint.ml b/typing/oprint.ml index 994d932750..50f66ebe38 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -27,6 +27,17 @@ let rec print_ident ppf = | Oide_apply (id1, id2) -> fprintf ppf "%a(%a)" print_ident id1 print_ident id2 +let is_uident s = + match s.[0] with + | 'A'..'Z' -> true + | _ -> false + +let print_type_ident ppf = function + | Oide_ident s | Oide_dot (_, s) as p when is_uident s -> + fprintf ppf "!%a" print_ident p + | p -> + print_ident ppf p + let parenthesized_ident name = (List.mem name ["or"; "mod"; "land"; "lor"; "lxor"; "lsl"; "lsr"; "asr"]) || @@ -192,7 +203,7 @@ and print_simple_out_type ppf = | Otyp_constr (id, tyl) -> pp_open_box ppf 0; print_typargs ppf tyl; - print_ident ppf id; + print_type_ident ppf id; pp_close_box ppf () | Otyp_object (fields, rest) -> fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields @@ -224,7 +235,8 @@ and print_simple_out_type ppf = pp_print_char ppf ')'; pp_close_box ppf () | Otyp_abstract | Otyp_open - | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> () + | 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 @@ -235,6 +247,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 [] -> @@ -279,6 +294,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 @@ -471,9 +489,9 @@ and print_out_type_decl kwd ppf td = let print_out_tkind ppf = function | Otyp_abstract -> () | Otyp_record lbls -> - fprintf ppf " =%a {%a@;<1 -2>}" + fprintf ppf " =%a %a" print_private td.otype_private - (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 td.otype_private @@ -510,11 +528,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 - and print_out_extension_constructor ppf ext = let print_extended_type ppf = let print_type_parameter ppf ty = diff --git a/typing/path.ml b/typing/path.ml index 260fc0731c..b8d6864a06 100644 --- a/typing/path.ml +++ b/typing/path.ml @@ -52,3 +52,21 @@ let rec last = function | Pident id -> Ident.name id | Pdot(_, s, _) -> s | Papply(_, p) -> last p + +let is_uident s = + match s.[0] with + | 'A'..'Z' -> true + | _ -> false + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +let constructor_typath = function + | Pident id when is_uident (Ident.name id) -> LocalExt id + | Pdot(ty_path, s, _) when is_uident s -> + if is_uident (last ty_path) then Ext (ty_path, s) + else Cstr (ty_path, s) + | p -> Regular p diff --git a/typing/path.mli b/typing/path.mli index c3f84130db..861b276a89 100644 --- a/typing/path.mli +++ b/typing/path.mli @@ -28,3 +28,11 @@ val name: ?paren:(string -> bool) -> t -> string val head: t -> Ident.t val last: t -> string + +type typath = + | Regular of t + | Ext of t * string + | LocalExt of Ident.t + | Cstr of t * string + +val constructor_typath: t -> typath diff --git a/typing/predef.ml b/typing/predef.ml index e9b9f7e5c7..bcad58efdd 100644 --- a/typing/predef.ml +++ b/typing/predef.ml @@ -107,7 +107,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 = []; @@ -163,7 +163,7 @@ let common_initial_env add_type add_extension empty_env = add_extension id { ext_type_path = path_exn; ext_type_params = []; - ext_args = l; + ext_args = Cstr_tuple l; ext_ret_type = None; ext_private = Asttypes.Public; ext_loc = Location.none; diff --git a/typing/printtyp.ml b/typing/printtyp.ml index b084935dad..db856958b0 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(); @@ -782,8 +787,8 @@ let rec tree_of_type_decl id decl = | Type_variant cstrs -> List.iter (fun c -> - List.iter mark_loops c.cd_args; - may mark_loops c.cd_res) + mark_loops_constructor_arguments c.cd_args; + may mark_loops c.cd_res) cstrs | Type_record(l, rep) -> List.iter (fun l -> mark_loops l.ld_type) l @@ -850,15 +855,20 @@ let rec tree_of_type_decl id decl = otype_private = priv; otype_cstrs = 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) @@ -871,6 +881,10 @@ let tree_of_type_declaration id decl rs = let type_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_type_declaration id decl Trec_first) +let constructor_arguments ppf a = + let tys = tree_of_constructor_arguments a in + !Oprint.out_type ppf (Otyp_tuple tys) + (* Print an extension declaration *) let tree_of_extension_constructor id ext es = @@ -880,7 +894,7 @@ let tree_of_extension_constructor id ext es = List.iter add_alias ty_params; List.iter mark_loops ty_params; List.iter check_name_of_type (List.map proxy ty_params); - List.iter mark_loops ext.ext_args; + mark_loops_constructor_arguments ext.ext_args; may mark_loops ext.ext_ret_type; let type_param = function @@ -893,12 +907,12 @@ let tree_of_extension_constructor id ext es = let name = Ident.name id in let args, ret = match ext.ext_ret_type with - | None -> (tree_of_typlist false ext.ext_args, None) + | None -> (tree_of_constructor_arguments ext.ext_args, None) | Some res -> let nm = !names in names := []; let ret = tree_of_typexp false res in - let args = tree_of_typlist false ext.ext_args in + let args = tree_of_constructor_arguments ext.ext_args in names := nm; (args, Some ret) in diff --git a/typing/printtyp.mli b/typing/printtyp.mli index 3fa9bd484b..14b67cd054 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -32,6 +32,7 @@ val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit val reset_and_mark_loops_list: type_expr list -> unit val type_expr: formatter -> type_expr -> unit +val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit @@ -82,4 +83,3 @@ val report_ambiguous_type_error: (* for toploop *) 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 0e97e586bb..5184b19e5d 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -431,7 +431,7 @@ and extension_constructor_kind i ppf x = match x with Text_decl(a, r) -> line i ppf "Pext_decl\n"; - list (i+1) core_type ppf a; + constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Text_rebind(p, _) -> line i ppf "Pext_rebind\n"; @@ -779,9 +779,13 @@ 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; line (i+1) ppf "%a\n" fmt_ident cd_id; attributes i ppf cd_attributes; - list (i+1) core_type ppf cd_args; + constructor_arguments (i+1) ppf cd_args; option (i+1) core_type ppf cd_res +and constructor_arguments i ppf = function + | Cstr_tuple l -> list i core_type ppf l + | Cstr_record l -> list i label_decl ppf l + and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} = line i ppf "%a\n" fmt_location ld_loc; attributes i ppf ld_attributes; diff --git a/typing/subst.ml b/typing/subst.ml index 5b1b0c67f1..b6a0edbc5a 100644 --- a/typing/subst.ml +++ b/typing/subst.ml @@ -76,6 +76,13 @@ let type_path s = function | Papply(p1, p2) -> fatal_error "Subst.type_path" +let type_path s p = + match Path.constructor_typath p with + | Regular p -> type_path s p + | Cstr (ty_path, cstr) -> Pdot(type_path s ty_path, cstr, nopos) + | LocalExt _ -> type_path s p + | Ext (p, cstr) -> Pdot(module_path s p, cstr, nopos) + (* Special type ids for saved signatures *) let new_id = ref (-1) @@ -193,8 +200,11 @@ let label_declaration s l = ld_attributes = attrs s l.ld_attributes; } -let constructor_arguments s args = - List.map (typexp s) args +let constructor_arguments s = function + | Cstr_tuple l -> + Cstr_tuple (List.map (typexp s) l) + | Cstr_record l -> + Cstr_record (List.map (label_declaration s) l) let constructor_declaration s c = { diff --git a/typing/typecore.ml b/typing/typecore.ml index 16a310d60f..dd8243f215 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -592,6 +592,7 @@ module NameChoice(Name : sig val get_descrs: Env.type_descriptions -> t list val fold: (t -> 'a -> 'a) -> Longident.t option -> Env.t -> 'a -> 'a val unbound_name_error: Env.t -> Longident.t loc -> 'a + val in_env: t -> bool end) = struct open Name @@ -685,9 +686,12 @@ end) = struct with Not_found -> try let lbl = lookup_from_type env tpath lid in check_lk tpath lbl; + if in_env lbl then + begin let s = Printtyp.string_of_path tpath in warn lid.loc (Warnings.Name_out_of_scope (s, [Longident.last lid.txt], false)); + end; if not pr then warn_pr (); lbl with Not_found -> @@ -704,6 +708,7 @@ end) = struct raise (Error (lid.loc, env, Name_type_mismatch (type_kind, lid.txt, tp, tpl))) in + if in_env lbl then begin match scope with (lab1,_)::_ when lab1 == lbl -> () | _ -> @@ -725,6 +730,10 @@ module Label = NameChoice (struct let get_descrs = snd let fold = Env.fold_labels let unbound_name_error = Typetexp.unbound_label_error + let in_env lbl = + match lbl.lbl_repres with + | Record_regular | Record_float -> true + | Record_inlined _ | Record_extension -> false end) let disambiguate_label_by_ids keep env closed ids labels = @@ -877,6 +886,7 @@ module Constructor = NameChoice (struct let get_descrs = fst let fold = Env.fold_constructors let unbound_name_error = Typetexp.unbound_constructor_error + let in_env _ = true end) (* unification of a type with a tconstr with diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 2bcb8221ec..f804fc8d8f 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -50,14 +50,35 @@ open Typedtree exception Error of Location.t * error -(* Enter all declared types in the environment as abstract types *) +(* Enter all declared types in the environment as abstract types + (special support variant types to allow self-referencing to + inline records) *) + +let approx_kind = function + | Ptype_variant pcds -> + let f pcd = + { + cd_id = Ident.create pcd.pcd_name.txt; + cd_args = + begin match pcd.pcd_args with + | Pcstr_tuple _ -> Cstr_tuple [] + | Pcstr_record _ -> Cstr_record [] + end; + cd_res = None; + cd_loc = pcd.pcd_loc; + cd_attributes = pcd.pcd_attributes; + } + in + Type_variant (List.map f pcds) + | _ -> + Type_abstract let enter_type env sdecl id = let decl = { type_params = List.map (fun _ -> Btype.newgenvar ()) sdecl.ptype_params; type_arity = List.length sdecl.ptype_params; - type_kind = Type_abstract; + type_kind = approx_kind sdecl.ptype_kind; type_private = sdecl.ptype_private; type_manifest = begin match sdecl.ptype_manifest with None -> None @@ -178,16 +199,21 @@ let transl_labels loc env closed lbls = lbls in lbls, lbls' -let transl_constructor_arguments env closed l = - let l = List.map (transl_simple_type env closed) l in - List.map (fun t -> t.ctyp_type) l, - l - -let make_constructor env type_path type_params sargs sret_type = +let transl_constructor_arguments loc env closed = 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 loc env closed l in + Types.Cstr_record lbls', + Cstr_record lbls + +let make_constructor loc env type_path type_params sargs sret_type = match sret_type with | None -> let args, targs = - transl_constructor_arguments env true sargs + transl_constructor_arguments loc env true sargs in targs, None, args, None | Some sret_type -> @@ -196,7 +222,7 @@ let make_constructor env type_path type_params sargs sret_type = let z = narrow () in reset_type_variables (); let args, targs = - transl_constructor_arguments env false sargs + transl_constructor_arguments loc env false sargs in let tret_type = transl_simple_type env false sret_type in let ret_type = tret_type.ctyp_type in @@ -237,13 +263,13 @@ let transl_declaration env sdecl id = all_constrs := StringSet.add name !all_constrs) scstrs; if List.length - (List.filter (fun cd -> cd.pcd_args <> []) scstrs) + (List.filter (fun cd -> cd.pcd_args <> Pcstr_tuple []) scstrs) > (Config.max_tag + 1) then raise(Error(sdecl.ptype_loc, Too_many_constructors)); let make_cstr scstr = let name = Ident.create scstr.pcd_name.txt in let targs, tret_type, args, ret_type = - make_constructor env (Path.Pident id) params + make_constructor scstr.pcd_loc env (Path.Pident id) params scstr.pcd_args scstr.pcd_res in let tcstr = @@ -401,10 +427,16 @@ let check_constraints env sdecl (_, decl) = let {pcd_args; pcd_res; _} = 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) - pcd_args cd_args; + 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 pcd_res, cd_res with | Some sr, Some r -> check_constraints_rec env sr.ptyp_loc visited r @@ -777,12 +809,19 @@ let constrained 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 (_, tyl, _)} -> @@ -802,7 +841,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_extension env check decl ext rloc = @@ -829,11 +868,11 @@ let compute_variance_decl env check decl (required, _ 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 @@ -980,6 +1019,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 @@ -1103,7 +1143,8 @@ let transl_extension_constructor env type_path type_params match sext.pext_kind with Pext_decl(sargs, sret_type) -> let targs, tret_type, args, ret_type = - make_constructor env type_path typext_params sargs sret_type + make_constructor sext.pext_loc env type_path typext_params + sargs sret_type in args, ret_type, Text_decl(targs, tret_type) | Pext_rebind lid -> @@ -1173,7 +1214,27 @@ let transl_extension_constructor env type_path type_params Cstr_extension(path, _) -> path | _ -> assert false in - args, ret_type, Text_rebind(path, lid) + let args = + match cdescr.cstr_inlined with + | None -> + Types.Cstr_tuple args + | Some decl -> + let tl = + match args with + | [ {desc=Tconstr(_, tl, _)} ] -> tl + | _ -> assert false + in + let decl = Ctype.instance_declaration decl in + assert (List.length decl.type_params = List.length tl); + List.iter2 (Ctype.unify env) decl.type_params tl; + let lbls = + match decl.type_kind with + | Type_record (lbls, Record_extension) -> lbls + | _ -> assert false + in + Types.Cstr_record lbls + in + args, ret_type, Text_rebind(path, lid) in let ext = { ext_type_path = type_path; @@ -1246,7 +1307,7 @@ let transl_type_extension check_open env loc styext = List.iter Ctype.generalize type_params; List.iter (fun ext -> - List.iter Ctype.generalize ext.ext_type.ext_args; + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; may Ctype.generalize ext.ext_type.ext_ret_type) constructors; (* Check that all type variable are closed *) @@ -1289,7 +1350,7 @@ let transl_exception env sext = in Ctype.end_def(); (* Generalize types *) - List.iter Ctype.generalize ext.ext_type.ext_args; + Btype.iter_type_expr_cstr_args Ctype.generalize ext.ext_type.ext_args; may Ctype.generalize ext.ext_type.ext_ret_type; (* Check that all type variable are closed *) begin match Ctype.closed_extension_constructor ext.ext_type with @@ -1461,17 +1522,21 @@ let check_recmod_typedecl env loc recmod_ids path decl = open Format -let explain_unbound ppf tv tl typ kwd lab = +let explain_unbound_gen ppf tv tl typ kwd pr = try let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in Printtyp.reset_and_mark_loops_list [typ ti; ty0]; fprintf ppf - ".@.@[<hov2>In %s@ %s%a@;<1 -2>the variable %a is unbound@]" - kwd (lab ti) Printtyp.type_expr (typ ti) Printtyp.type_expr tv + ".@.@[<hov2>In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.type_expr tv with Not_found -> () +let explain_unbound ppf tv tl typ kwd lab = + explain_unbound_gen ppf tv tl typ kwd + (fun ppf ti -> fprintf ppf "%s%a" (lab ti) Printtyp.type_expr (typ ti)) + let explain_unbound_single ppf tv ty = let trivial ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in @@ -1493,6 +1558,11 @@ let explain_unbound_single ppf tv ty = "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty + +let tys_of_constr_args = function + | Types.Cstr_tuple tl -> tl + | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls + let report_error ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" @@ -1551,9 +1621,14 @@ let report_error ppf = function let ty = Ctype.repr ty in 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)) - "case" (fun c -> Ident.name c.Types.cd_id ^ " of ") + explain_unbound_gen ppf ty tl (fun c -> + let tl = tys_of_constr_args c.cd_args in + Btype.newgenty (Ttuple tl) + ) + "case" (fun ppf c -> + fprintf ppf + "%s of %a" (Ident.name c.Types.cd_id) + Printtyp.constructor_arguments c.cd_args) | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) "field" (fun l -> Ident.name l.Types.ld_id ^ ": ") @@ -1563,7 +1638,8 @@ let report_error ppf = function end | Unbound_type_var_ext (ty, ext) -> fprintf ppf "A type variable is unbound in this extension constructor"; - explain_unbound ppf ty ext.ext_args (fun c -> c) "type" (fun _ -> "") + let args = tys_of_constr_args ext.ext_args in + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") | Not_open_type path -> fprintf ppf "@[%s@ %a@]" "Cannot extend type definition" diff --git a/typing/typedtree.ml b/typing/typedtree.ml index ecd0f132ee..52067415cc 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -409,12 +409,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 type_extension = { tyext_path: Path.t; @@ -436,7 +440,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of core_type list * core_type option + Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = diff --git a/typing/typedtree.mli b/typing/typedtree.mli index c4feae1d86..fa36dac8c4 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -409,12 +409,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 type_extension = { tyext_path: Path.t; @@ -436,7 +440,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of core_type list * core_type option + Text_decl of constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index 3d1a19fa8d..28026b5987 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -160,8 +160,12 @@ module MakeIterator(Iter : IteratorArgument) : sig iter_core_type v.val_desc; Iter.leave_value_description v + and iter_constructor_arguments = function + | Cstr_tuple l -> List.iter iter_core_type l + | Cstr_record l -> List.iter (fun ld -> iter_core_type ld.ld_type) l + and iter_constructor_declaration cd = - List.iter iter_core_type cd.cd_args; + iter_constructor_arguments cd.cd_args; option iter_core_type cd.cd_res; and iter_type_parameter (ct, v) = @@ -192,7 +196,7 @@ module MakeIterator(Iter : IteratorArgument) : sig Iter.enter_extension_constructor ext; begin match ext.ext_kind with Text_decl(args, ret) -> - List.iter iter_core_type args; + iter_constructor_arguments args; option iter_core_type ret | Text_rebind _ -> () end; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index b5ca25b178..6b28cc8503 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -190,8 +190,17 @@ module MakeMap(Map : MapArgument) = struct and map_type_parameter (ct, v) = (map_core_type ct, v) + and map_constructor_arguments = function + | 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) + and map_constructor_declaration cd = - {cd with cd_args = List.map map_core_type cd.cd_args; + let cd_args = map_constructor_arguments cd.cd_args in + {cd with cd_args; cd_res = may_map map_core_type cd.cd_res } @@ -208,7 +217,7 @@ module MakeMap(Map : MapArgument) = struct let ext = Map.enter_extension_constructor ext in let ext_kind = match ext.ext_kind with Text_decl(args, ret) -> - let args = List.map map_core_type args in + let args = map_constructor_arguments args in let ret = may_map map_core_type ret in Text_decl(args, ret) | Text_rebind(p, lid) -> Text_rebind(p, lid) diff --git a/typing/typemod.ml b/typing/typemod.ml index 089135472d..bf3e1bfafc 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -442,6 +442,7 @@ type names = types: StringSet.t ref; modules: StringSet.t ref; modtypes: StringSet.t ref; + typexts: StringSet.t ref; } let new_names () = @@ -449,6 +450,7 @@ let new_names () = types = ref StringSet.empty; modules = ref StringSet.empty; modtypes = ref StringSet.empty; + typexts = ref StringSet.empty; } @@ -456,11 +458,14 @@ let check_name check names name = check names name.loc name.txt let check_type names loc s = check "type" loc names.types s let check_module names loc s = check "module" loc names.modules s let check_modtype names loc s = check "module type" loc names.modtypes s +let check_typext names loc s = check "extension constructor" loc names.typexts s + let check_sig_item names loc = function | Sig_type(id, _, _) -> check_type names loc (Ident.name id) | Sig_module(id, _, _) -> check_module names loc (Ident.name id) | Sig_modtype(id, _) -> check_modtype names loc (Ident.name id) + | Sig_typext(id, _, _) -> check_typext names loc (Ident.name id) | _ -> () (* Simplify multiple specifications of a value or an extension in a signature. @@ -470,29 +475,17 @@ let check_sig_item names loc = function let simplify_signature sg = let rec aux = function - | [] -> [], StringSet.empty, StringSet.empty + | [] -> [], StringSet.empty | (Sig_value(id, descr) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in + let (sg, val_names) as k = aux sg in let name = Ident.name id in if StringSet.mem name val_names then k - else (component :: sg, StringSet.add name val_names, ext_names) - | (Sig_typext(id, ext, es) as component) :: sg -> - let (sg, val_names, ext_names) as k = aux sg in - let name = Ident.name id in - if StringSet.mem name ext_names then - (* #6510 *) - match es, sg with - | Text_first, Sig_typext(id2, ext2, Text_next) :: rest -> - (Sig_typext(id2, ext2, Text_first) :: rest, - val_names, ext_names) - | _ -> k - else - (component :: sg, val_names, StringSet.add name ext_names) + else (component :: sg, StringSet.add name val_names) | component :: sg -> - let (sg, val_names, ext_names) = aux sg in - (component :: sg, val_names, ext_names) + let (sg, val_names) = aux sg in + (component :: sg, val_names) in - let (sg, _, _) = aux sg in + let (sg, _) = aux sg in sg (* Check and translate a module type expression *) @@ -567,7 +560,6 @@ let rec transl_modtype env smty = | Pmty_extension ext -> raise (Error_forward (Typetexp.error_of_extension ext)) - and transl_signature env sg = let names = new_names () in let rec transl_sig env sg = @@ -595,6 +587,9 @@ and transl_signature env sg = Sig_type(td.typ_id, td.typ_type, rs)) decls rem, final_env | Psig_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; let (tyext, newenv) = Typedecl.transl_type_extension false env item.psig_loc styext in @@ -605,6 +600,7 @@ and transl_signature env sg = Sig_typext(ext.ext_id, ext.ext_type, es)) constructors rem, final_env | Psig_exception sext -> + check_name check_typext names sext.pext_name; let (ext, newenv) = Typedecl.transl_exception env sext in let (trem, rem, final_env) = transl_sig newenv srem in mksig (Tsig_exception ext) env loc :: trem, @@ -1220,6 +1216,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = decls [], enrich_type_decls anchor decls env newenv | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; let (tyext, newenv) = Typedecl.transl_type_extension true env loc styext in @@ -1229,6 +1228,7 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = tyext.tyext_constructors [], newenv) | Pstr_exception sext -> + check_name check_typext names sext.pext_name; let (ext, newenv) = Typedecl.transl_exception env sext in Tstr_exception ext, [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], diff --git a/typing/types.ml b/typing/types.ml index f8cf460226..1aff7356fa 100644 --- a/typing/types.ml +++ b/typing/types.ml @@ -156,6 +156,8 @@ and type_kind = and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -169,16 +171,20 @@ 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 label_declaration list + type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; - ext_args: type_expr list; + ext_args: constructor_arguments; ext_ret_type: type_expr option; ext_private: private_flag; ext_loc: Location.t; @@ -285,6 +291,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; } and constructor_tag = diff --git a/typing/types.mli b/typing/types.mli index acde28f99f..0438f897b7 100644 --- a/typing/types.mli +++ b/typing/types.mli @@ -144,6 +144,8 @@ and type_kind = and record_representation = Record_regular (* All fields are boxed / tagged *) | Record_float (* All fields are floats *) + | Record_inlined of int (* Inlined record *) + | Record_extension (* Inlined record under extension *) and label_declaration = { @@ -157,17 +159,21 @@ 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 label_declaration list + type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; - ext_args: type_expr list; + ext_args: constructor_arguments; ext_ret_type: type_expr option; ext_private: private_flag; ext_loc: Location.t; @@ -275,6 +281,7 @@ type constructor_description = cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; cstr_attributes: Parsetree.attributes; + cstr_inlined: type_declaration option; } and constructor_tag = diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 523d435bca..23da905060 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -52,6 +52,9 @@ type error = | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module | Access_functor_as_structure of Longident.t + | Not_a_variant_type of Longident.t + | Not_an_inlined_record of Longident.t + | Unbound_constructor_in_type of string * Longident.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -282,6 +285,60 @@ let unbound_label_error env lid = narrow_unbound_lid_error env lid.loc lid.txt (fun lid -> Unbound_label lid) +let find_constructor_in_type env loc ty_id cstr_id = + let err e = raise (Error (loc, env, e)) in + let (ty_path, ty_decl) = find_type env loc ty_id in + match ty_decl.type_kind with + | Type_variant _ -> + let (cstrs, _) = + try Env.find_type_descrs ty_path env + with Not_found -> assert false + in + begin try List.find (fun c -> c.cstr_name = cstr_id) cstrs + with Not_found -> err (Unbound_constructor_in_type (cstr_id, ty_id)) + end + | _ -> + err (Not_a_variant_type ty_id) + +let is_typ_lid lid = + match (Longident.last lid).[0] with + | 'a'..'z' | '_' -> true + | _ -> false + +let find_qual_constructor env loc lid = + match lid with + | Longident.Ldot (ty_id, cstr_id) when is_typ_lid ty_id -> + find_constructor_in_type env loc ty_id cstr_id + | _ -> find_constructor env loc lid + +let find_type env loc lid = + if is_typ_lid lid then + find_type env loc lid + else + let cstr = find_qual_constructor env loc lid in + if cstr.cstr_inlined = None then begin + let full_name = + match cstr with + | {cstr_name; + cstr_tag = Cstr_constant _ | Cstr_block _; + cstr_res = {desc = Tconstr(p, _, _)} } -> + Longident.Ldot (Ctype.lid_of_path p, cstr_name) + | _ -> lid + in + raise (Error (loc, env, Not_an_inlined_record full_name)); + end; + begin match cstr.cstr_args with + | [{desc=Tconstr(path, _, _)}] -> + let decl = + try Env.find_type path env + with Not_found -> + assert false + in + (path, decl) + | _ -> assert false + end + + (* Support for first-class modules. *) let transl_modtype_longident = ref (fun _ -> assert false) @@ -1003,6 +1060,17 @@ let report_error env ppf = function fprintf ppf "Illegal recursive module reference" | Access_functor_as_structure lid -> fprintf ppf "The module %a is a functor, not a structure" longident lid + | Not_a_variant_type lid -> + fprintf ppf + "The type %a is not a regular variant type" + longident lid + | Not_an_inlined_record lid -> + fprintf ppf + "The constructor %a does not have an inline record argument" + longident lid + | Unbound_constructor_in_type (c_lid, t_lid) -> + fprintf ppf "Unbound constructor %s in type %a" c_lid + longident t_lid let () = Location.register_error_of_exn diff --git a/typing/typetexp.mli b/typing/typetexp.mli index 7bff403f0f..fb1ca36652 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -64,6 +64,9 @@ type error = | Ill_typed_functor_application of Longident.t | Illegal_reference_to_recursive_module | Access_functor_as_structure of Longident.t + | Not_a_variant_type of Longident.t + | Not_an_inlined_record of Longident.t + | Unbound_constructor_in_type of string * Longident.t exception Error of Location.t * Env.t * error |