Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Keep inlined records in Typedtree and Types. Synthesize record types when inserting in the environment and module components, as for labels and constructors. Following features are not supported: inline record for exceptions, GADTs, polymorphic fields. 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/constructors_with_record3@14553 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Alain Frisch 2014-04-07 14:53:30 +00:00
parent 73742ea9f3
commit 1d4e1364bd
28 changed files with 419 additions and 467 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
asmcomp/cmmgen.ml
View File

@ -633,7 +633,7 @@ let rec expr_size env = function
RHS_block (List.length args)
| Uprim(Pmakearray(Pfloatarray), args, _) ->
RHS_floatblock (List.length args)
| Uprim (Pduprecord (Record_regular | Record_inlined _, sz), _, _) ->
| Uprim (Pduprecord ((Record_regular | Record_inlined _), sz), _, _) ->
RHS_block sz
| Uprim (Pduprecord (Record_exception _, sz), _, _) ->
RHS_block (sz + 1)

BIN
boot/ocamlc
View File

Binary file not shown.

BIN
boot/ocamldep
View File

Binary file not shown.

BIN
boot/ocamllex
View File

Binary file not shown.

5
bytecomp/typeopt.ml
View File

@ -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

5
tools/tast_iter.ml
View File

@ -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 =

22
tools/untypeast.ml
View File

@ -123,13 +123,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;
@ -137,10 +131,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 = Pcstr_tuple (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;

84
toplevel/genprintval.ml
View File

@ -248,7 +248,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
let {cd_id;cd_args;cd_res;cd_inlined} =
let {cd_id;cd_args;cd_res} =
Datarepr.find_constr_by_tag tag constr_list in
let type_params =
match cd_res with
@ -259,46 +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) cd_inlined 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
in
let pos =
match rep with
| Record_exception _ -> 1
| _ -> 0
in
Oval_record (tree_of_fields pos 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 *)
@ -343,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
| [] -> []

39
typing/btype.ml
View File

@ -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)
@ -305,15 +321,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 +449,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

2
typing/btype.mli
View File

@ -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)

76
typing/ctype.ml
View File

@ -546,7 +546,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
@ -1156,25 +1160,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 l ->
let field l = {l with ld_type = f l.ld_type} in
Cstr_record (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 ();
@ -2125,7 +2140,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 [])
@ -4273,27 +4293,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

72
typing/datarepr.ml
View File

@ -39,16 +39,18 @@ let free_vars ty =
unmark_type ty;
!ret
let constructor_descrs ty_res cstrs priv =
let constructor_descrs ty_path decl cstrs =
let ty_res = newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)) 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; cd_inlined} :: rem ->
| {cd_id; cd_args; cd_res; cd_loc; cd_attributes} :: rem ->
let ty_res =
match cd_res with
| Some ty_res' -> ty_res'
@ -56,7 +58,7 @@ 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
@ -65,27 +67,73 @@ let constructor_descrs ty_res cstrs priv =
| None -> []
| 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
(* TODO: handle Tpoly *)
let arg_vars = free_vars (newgenty (Ttuple tyl)) in
TypeSet.elements (TypeSet.diff arg_vars res_vars)
in
let cstr_args, cstr_inlined =
match cd_args with
| Cstr_tuple l -> l, false
| Cstr_record lbls ->
let name = Path.last ty_path ^ "." ^ Ident.name cd_id in
let id = Ident.create name in
let path =
match ty_path with
| Path.Pdot(m, _, _) -> Path.Pdot(m, name, Path.nopos)
| Path.Pident _ -> Path.Pident id
| Path.Papply _ -> assert false
in
let type_manifest =
match decl.type_manifest with
| Some {desc = Tconstr(Path.Pdot (m, _, _), args, _)} ->
let p = Path.Pdot (m, name, Path.nopos) in
Some (newgenty (Tconstr (p, args, ref Mnil)))
| Some {desc = Tconstr(Path.Pident _, args, _)} ->
None (* looses the identity! *)
(* could we retrieve it in the current environment? *)
| _ -> None
in
let tdecl =
{
type_params = decl.type_params; (* TODO: add existentials *)
type_arity = decl.type_arity;
type_kind = Type_record (lbls, Record_inlined idx_nonconst);
type_private = Public;
type_manifest;
type_variance = decl.type_variance;
type_newtype_level = None;
type_loc = Location.none;
type_attributes = [];
}
in
tdecls := (id, path, tdecl) :: !tdecls;
[ newgenty (Tconstr(path, decl.type_params, ref Mnil)) ],
true
in
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 = cd_inlined;
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 =
{ cstr_name = Path.last path_exc;
@ -101,7 +149,7 @@ let exception_descr path_exc decl =
cstr_generalized = false;
cstr_loc = decl.exn_loc;
cstr_attributes = decl.exn_attributes;
cstr_inlined = decl.exn_inlined;
cstr_inlined = false;
}
let none = {desc = Ttuple []; level = -1; id = -1}
@ -140,7 +188,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

6
typing/datarepr.mli
View File

@ -17,8 +17,10 @@ open Asttypes
open Types
val constructor_descrs:
type_expr -> constructor_declaration list ->
private_flag -> (Ident.t * constructor_description) list
Path.t -> type_declaration -> constructor_declaration list ->
(Ident.t * constructor_description) list *
(Ident.t * Path.t * type_declaration) list
val exception_descr:
Path.t -> exception_declaration -> constructor_description
val label_descrs:

34
typing/env.ml
View File

@ -1034,14 +1034,9 @@ 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
match decl.type_kind with
| Type_variant cstrs -> handle_variants cstrs
| Type_record _ | Type_abstract -> []
| Type_variant cstrs -> Datarepr.constructor_descrs ty_path decl cstrs
| Type_record _ | Type_abstract -> [], []
(* Compute label descriptions *)
@ -1176,7 +1171,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
@ -1187,12 +1182,17 @@ 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 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 <-
@ -1234,9 +1234,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;
@ -1286,7 +1287,7 @@ and store_type ~check slot id path info env renv =
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 path info in
let labels = labels_of_type path info in
let descrs = (List.map snd constructors, List.map snd labels) in
@ -1310,6 +1311,13 @@ and store_type ~check slot id path info env renv =
end
constructors
end;
let env =
List.fold_left (fun env (id, path, td) ->
store_type ~check:false slot id path td env renv
)
env
tdecls
in
{ env with
constrs =
List.fold_right

30
typing/includecore.ml
View File

@ -169,25 +169,33 @@ 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 =
match arg1, arg2 with
| Cstr_tuple arg1, Cstr_tuple arg2 ->
if List.length arg1 <> List.length arg2 then [Field_arity cstr1]
else if Misc.for_all2
(fun ty1 ty2 ->
Ctype.equal env true (ty1::decl1.type_params)
(ty2::decl2.type_params))
(arg1) (arg2)
then [] else [Field_type cstr1]
| Cstr_record l1, Cstr_record l2 ->
let r = compare_records env decl1 decl2 0 l1 l2 in
if r <> [] then Field_type cstr1 :: r else r
| _ ->
[Field_type cstr1]
in
if r <> [] then r
else compare_variants env decl1 decl2 (n+1) rem1 rem2
let rec compare_records env decl1 decl2 n labels1 labels2 =
and compare_records env decl1 decl2 n labels1 labels2 =
match labels1, labels2 with
[], [] -> []
| [], l::_ -> [Field_missing (true, l.ld_id)]

7
typing/predef.ml
View File

@ -106,11 +106,10 @@ 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 = [];
cd_inlined = false;
}
let ident_false = ident_create "false"
@ -167,9 +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_inlined = false;
}
{ exn_args = l; exn_loc = Location.none; exn_attributes = [] }
in
add_exception ident_match_failure
[newgenty (Ttuple[type_string; type_int; type_int])] (

91
typing/printtyp.ml
View File

@ -740,44 +740,6 @@ let string_of_mutable = function
| Mutable -> "mutable "
(* Support for inlined records *)
let inlined_records = ref []
(* We don't reset this reference too often, as a hack to make
the error message produced by:
module X : sig type 'a t = A of int end
= struct type 'a t = A of {x:int} end
work as expected (the type declaration is printed after
the signature, and so the definition of the inlined record is
available *)
let register_inlined_record id td =
let td = Ctype.instance_declaration td in
let lbls =
match td.type_kind with
| Type_record(lbls, _) -> lbls
| _ -> assert false
in
inlined_records := (id, (lbls, td.type_params)) :: !inlined_records
let get_inlined_record cd_args =
let id, args =
match cd_args with
| [ {desc = Tconstr(Path.Pident id, args, _)} ] -> id, args
| _ -> assert false
in
try
let lbls, params = List.assoc id !inlined_records in
lbls, params, args
with Not_found -> [], [], []
(* This can happen in an error message, where the
variant type declaration is displayed on its own *)
let rec tree_of_type_decl id decl =
reset();
@ -821,13 +783,10 @@ let rec tree_of_type_decl id decl =
| Type_variant cstrs ->
List.iter
(fun cd ->
if cd.cd_inlined then
let lbls, params, args = get_inlined_record cd.cd_args in
List.iter2 link_type params args;
List.iter (fun l -> mark_loops l.ld_type) lbls
else
List.iter mark_loops cd.cd_args;
may mark_loops cd.cd_res)
match cd.cd_args with
| Cstr_tuple l -> List.iter mark_loops l
| Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l
)
cstrs
| Type_record(l, rep) ->
List.iter (fun l -> mark_loops l.ld_type) l
@ -887,11 +846,9 @@ let rec tree_of_type_decl id decl =
and tree_of_constructor cd =
let name = Ident.name cd.cd_id in
let arg () =
if cd.cd_inlined then
let lbls, _, _ = get_inlined_record cd.cd_args in
[ Otyp_record (List.map tree_of_label lbls) ]
else
tree_of_typlist false cd.cd_args
match cd.cd_args with
| Cstr_tuple l -> tree_of_typlist false l
| Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ]
in
match cd.cd_res with
| None -> (name, arg (), None)
@ -921,19 +878,8 @@ let type_declaration id ppf decl =
(* Print an exception declaration *)
let tree_of_exception_declaration id decl =
let tyl =
if decl.exn_inlined then begin
let lbls, params, args = get_inlined_record decl.exn_args in
reset ();
List.iter2 link_type params args;
List.iter (fun l -> mark_loops l.ld_type) lbls;
[ Otyp_record (List.map tree_of_label lbls) ]
end else begin
reset_and_mark_loops_list decl.exn_args;
let tyl = tree_of_typlist false decl.exn_args in
tyl
end
in
reset_and_mark_loops_list decl.exn_args;
let tyl = tree_of_typlist false decl.exn_args in
Osig_exception (Ident.name id, tyl)
let exception_declaration id ppf decl =
@ -1141,17 +1087,6 @@ let filter_rem_sig item rem =
([ctydecl; tydecl1; tydecl2], rem)
| Sig_class_type _, tydecl1 :: tydecl2 :: rem ->
([tydecl1; tydecl2], rem)
| Sig_type _, rem ->
let rec loop sg = function
| (Sig_type (id,
({type_kind = Type_record (lbls, Record_inlined _)} as td),
Trec_next)) as it :: rem ->
register_inlined_record id td;
loop (it :: sg) rem
| rem ->
List.rev sg, rem
in
loop [] rem
| _ ->
([], rem)
@ -1213,9 +1148,6 @@ and trees_of_sigitem = function
[tree_of_value_description id decl]
| Sig_type(id, _, _) when is_row_name (Ident.name id) ->
[]
| Sig_type(id, ({type_kind=Type_record(_, Record_exception _)} as td), _) ->
register_inlined_record id td;
[]
| Sig_type(id, decl, rs) ->
[tree_of_type_declaration id decl rs]
| Sig_exception(id, decl) ->
@ -1254,11 +1186,6 @@ let rec print_items showval env = function
List.map (fun d -> (d, showval env item)) trees @
print_items showval env rem
let print_items showval env l =
let r = print_items showval env l in
inlined_records := [];
r
(* Print a signature body (used by -i when compiling a .ml) *)
let print_signature ppf tree =

5
typing/printtyped.ml
View File

@ -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} =

33
typing/subst.ml
View File

@ -184,6 +184,15 @@ 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 type_declaration s decl =
let decl =
{ type_params = List.map (typexp s) decl.type_params;
@ -195,29 +204,24 @@ let type_declaration s decl =
Type_variant
(List.map
(fun c ->
let cd_args =
match c.cd_args with
| Cstr_tuple l ->
Cstr_tuple (List.map (typexp s) l)
| Cstr_record l ->
Cstr_record (List.map (label_declaration s) l)
in
{
cd_id = c.cd_id;
cd_args = List.map (typexp s) c.cd_args;
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;
cd_inlined = c.cd_inlined;
}
)
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
@ -303,7 +307,6 @@ 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;
exn_inlined = descr.exn_inlined;
}
let rec rename_bound_idents s idents = function

302
typing/typedecl.ml
View File

@ -173,13 +173,35 @@ let freevars bound kind =
ignore (mapper.type_kind mapper kind);
StringMap.bindings !vars
let get_args = function
| Pcstr_tuple l -> l
| _ -> assert false
let is_inline_record = function
| [ {ptyp_attributes = [{txt="#inline#"}, _]} ] -> true
| _ -> false
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_declaration ?exnid env sdecl id =
(* Bind type parameters *)
@ -204,23 +226,32 @@ let transl_declaration ?exnid env sdecl id =
all_constrs := StringSet.add name !all_constrs)
cstrs;
if List.length
(List.filter (fun cd -> get_args 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; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
let name = Ident.create lid.txt in
let args = get_args pcd_args in
let inlined = is_inline_record args in
let args closed =
match pcd_args with
| 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
Types.Cstr_record lbls',
Cstr_record lbls
in
match ret_type with
| None ->
(name, lid, List.map (transl_simple_type env true) args,
None, None, loc, attrs, inlined)
(name, lid, args true,
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 = args false in
let cty = transl_simple_type env false sty in
let ret_type =
let ty = cty.ctyp_type in
@ -232,60 +263,28 @@ let transl_declaration ?exnid env sdecl id =
(ty, Ctype.newconstr p params)))
in
widen z;
(name, lid, args, Some cty, Some ret_type, loc, attrs, inlined)
(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, inlined) ->
{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_inlined = inlined;
}
) 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 =
match sdecl.ptype_attributes with
| [{txt="#tag#"}, PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_constant(Const_int tag)}, _)}]] ->
begin match exnid with
| Some id -> Record_exception (Path.Pident id)
| None -> Record_inlined tag
end
| _ ->
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
@ -345,18 +344,7 @@ let transl_declaration ?exnid 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
@ -390,6 +378,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
@ -407,14 +406,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} ->
(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)
(get_args pcd_args) 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
end;
match sret_type, ret_type with
| Some sr, Some r ->
check_constraints_rec env sr.ptyp_loc visited r
@ -427,15 +432,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 -> ()
@ -760,12 +757,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, _)} ->
@ -785,7 +789,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) =
@ -806,10 +810,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 ->
@ -938,65 +943,6 @@ let name_recursion sdecl id decl =
else decl
| _ -> decl
(* Add fake record declarations for record constructor arguments *)
let inline_record_decls params manifest tag typname pcd =
let open Ast_helper in
match pcd.pcd_args with
| Pcstr_record lbls ->
let ptype_kind = Ptype_record lbls in
let bound =
List.fold_left (fun acc -> function
| Some {txt}, _ -> StringSet.add txt acc
| _ -> acc) StringSet.empty params
in
let extra_params = freevars bound ptype_kind in
let prepare_param (s, loc) = Some (mkloc s loc), Invariant in
let params = params @ List.map prepare_param extra_params in
let mk_arg = function
| (Some {txt;loc}, _) -> Typ.var ~loc txt
| (None, _) -> Typ.any ()
in
let args = List.map mk_arg params in
let name = typname ^ "." ^ pcd.pcd_name.txt in
let ptype_attributes =
[
mknoloc "#tag#",
PStr [ Str.eval (Exp.constant (Const_int !tag)) ]
]
in
let ptype_manifest =
match manifest with
| Some {ptyp_desc=Ptyp_constr(lid, _args)} ->
(* does not make sense with 'as' clause *)
let rec append lid =
let open Longident in
match lid with
| Lident s -> Lident (s ^ "." ^ pcd.pcd_name.txt)
| Ldot (p, s) -> Ldot (p, s ^ "." ^ pcd.pcd_name.txt)
| Lapply (p1, p2) -> Lapply (p1, append p2)
in
Some (Typ.constr (mknoloc (append lid.txt)) args) (* todo: type parameters *)
| _ -> None
in
let decl =
{
ptype_name = mkloc name pcd.pcd_name.loc;
ptype_params = params;
ptype_cstrs = [];
ptype_kind;
ptype_private = Public;
ptype_manifest;
ptype_attributes;
ptype_loc = pcd.pcd_loc;
} in
incr tag;
let lid = mknoloc (Longident.Lident name) in
let attrs = [ mknoloc "#inline#", PStr [] ] in
let pcd_args = Pcstr_tuple [Typ.constr ~attrs lid args] in
{pcd with pcd_args}, [decl]
| Pcstr_tuple [] -> pcd, []
| Pcstr_tuple _ -> incr tag; pcd, []
(* Translate a set of mutually recursive type declarations *)
let transl_type_decl ?exnid env sdecl_list =
(* Add dummy types for fixed rows *)
@ -1009,24 +955,6 @@ let transl_type_decl ?exnid env sdecl_list =
fixed_types
@ sdecl_list
in
let sdecl_list =
List.map
(function
| {ptype_kind = Ptype_variant cstrs} as sdecl ->
let tname = sdecl.ptype_name.txt in
let tag = ref 0 in
let do_cstr =
inline_record_decls sdecl.ptype_params sdecl.ptype_manifest
tag tname
in
let decls = List.map do_cstr cstrs in
let cstrs, more = List.split decls in
{sdecl with ptype_kind=Ptype_variant cstrs} :: List.flatten more
| x -> [ x ]
)
sdecl_list
in
let sdecl_list = List.flatten sdecl_list in
(* Create identifiers. *)
let id_list =
@ -1151,17 +1079,13 @@ let transl_exception env excdecl =
let id = Ident.create excdecl.pcd_name.txt in
if excdecl.pcd_res <> None then
raise (Error (loc, Exception_constructor_with_result));
let excdecl, inlined_records =
inline_record_decls [] None (ref 0) "exn" excdecl
in
let (_, env) as tdecls =
match inlined_records with
| [] -> ([], env)
| decls -> transl_type_decl ~exnid:id env decls
in
reset_type_variables();
Ctype.begin_def();
let args = get_args excdecl.pcd_args in
let args =
match excdecl.pcd_args with
| Pcstr_tuple l -> l
| Pcstr_record _ -> assert false
in
let ttypes = List.map (transl_closed_type env) args in
Ctype.end_def();
let types = List.map (fun cty -> cty.ctyp_type) ttypes in
@ -1170,7 +1094,6 @@ let transl_exception env excdecl =
{
exn_args = types;
exn_attributes = excdecl.pcd_attributes;
exn_inlined = is_inline_record args;
Types.exn_loc = loc;
}
in
@ -1178,13 +1101,13 @@ let transl_exception env excdecl =
let cd =
{ cd_id = id;
cd_name = excdecl.pcd_name;
cd_args = ttypes;
cd_args = Cstr_tuple ttypes;
cd_loc = loc;
cd_res = None;
cd_attributes = excdecl.pcd_attributes;
}
in
tdecls, cd, exn_decl, newenv
cd, exn_decl, newenv
let transl_type_decl = transl_type_decl ?exnid:None
@ -1201,31 +1124,14 @@ let transl_exn_rebind env loc name lid =
| Cstr_exception (path, _) -> path
| _ -> raise(Error(loc, Not_an_exception lid))
in
let tdecls, exn_args =
if cdescr.cstr_inlined then
match cdescr.cstr_args with
| [{desc=Tconstr(p, [], _)} as ty] ->
let tdecl =
try Env.find_type p env
with Not_found -> assert false
in
let tdecl = {tdecl with type_manifest = Some ty} in
let (id, env) =
Env.enter_type ("exn." ^ name) tdecl env
in
([id, tdecl], env), [ Ctype.newconstr (Path.Pident id) [] ]
| _ -> assert false
else
([], env), cdescr.cstr_args
in
let exn_args = cdescr.cstr_args in
let d = {
Types.exn_args;
exn_attributes = [];
exn_inlined = cdescr.cstr_inlined;
exn_loc = loc
}
in
(tdecls, path, d)
(path, d)
(* Translate a value declaration *)
let transl_value_decl env loc valdecl =
@ -1473,7 +1379,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)

5
typing/typedecl.mli
View File

@ -21,10 +21,11 @@ val transl_type_decl:
val transl_exception:
Env.t ->
Parsetree.constructor_declaration -> (Typedtree.type_declaration list * Env.t) * 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 -> string -> Longident.t -> ((Ident.t * Types.type_declaration) list * Env.t) * Path.t * exception_declaration
Env.t -> Location.t -> string -> Longident.t -> Path.t * exception_declaration
val transl_value_decl:
Env.t -> Location.t ->

6
typing/typedtree.ml
View File

@ -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;

6
typing/typedtree.mli
View File

@ -384,12 +384,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;

5
typing/typedtreeIter.ml
View File

@ -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 =

11
typing/typedtreeMap.ml
View File

@ -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
}

23
typing/typemod.ml
View File

@ -552,19 +552,13 @@ and transl_signature env sg =
prepend_sig_types decls rem,
final_env
| Psig_exception sarg ->
let ((tdecls, tenv), arg, decl, newenv) =
Typedecl.transl_exception env sarg
in
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
let trem = mksig (Tsig_exception arg) tenv loc :: trem in
let trem =
if tdecls = [] then trem else
mksig (Tsig_type tdecls) env loc :: trem
in
let trem = mksig (Tsig_exception arg) env loc :: trem in
trem,
(if List.exists (Ident.equal id) (get_exceptions rem) then rem
else prepend_sig_types tdecls (Sig_exception(id, decl) :: rem)),
else Sig_exception(id, decl) :: rem),
final_env
| Psig_module pmd ->
check "module" item.psig_loc module_names pmd.pmd_name.txt;
@ -1163,20 +1157,17 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope =
prepend_sig_types decls [],
enrich_type_decls anchor decls env newenv
| Pstr_exception sarg ->
let ((tdecls, tenv), arg, decl, newenv) =
Typedecl.transl_exception env sarg
in
(* Note: we should keep tdecls in the typedtree *)
let (arg, decl, newenv) = Typedecl.transl_exception env sarg in
Tstr_exception arg,
prepend_sig_types tdecls [Sig_exception(arg.cd_id, decl)],
[Sig_exception(arg.cd_id, decl)],
newenv
| Pstr_exn_rebind(name, longid, attrs) ->
let ((tdecls, env), path, arg) =
let (path, arg) =
Typedecl.transl_exn_rebind env loc name.txt longid.txt
in
let (id, newenv) = Env.enter_exception name.txt arg env in
Tstr_exn_rebind(id, name, path, longid, attrs),
prepend_sig_types' tdecls [Sig_exception(id, arg)],
[Sig_exception(id, arg)],
newenv
| Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs;
pmb_loc;

7
typing/types.ml
View File

@ -209,13 +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;
cd_inlined: bool;
}
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of label_declaration list
and type_transparence =
Type_public (* unrestricted expansion *)
@ -226,7 +228,6 @@ type exception_declaration =
{ exn_args: type_expr list;
exn_loc: Location.t;
exn_attributes: Parsetree.attributes;
exn_inlined: bool; (* merge with constructor_declaration? *)
}
(* Type expressions for the class language *)

8
typing/types.mli
View File

@ -197,13 +197,16 @@ 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;
cd_inlined: bool;
}
and constructor_arguments =
| Cstr_tuple of type_expr list
| Cstr_record of label_declaration list
and type_transparence =
Type_public (* unrestricted expansion *)
| Type_new (* "new" type *)
@ -213,7 +216,6 @@ type exception_declaration =
{ exn_args: type_expr list;
exn_loc: Location.t;
exn_attributes: Parsetree.attributes;
exn_inlined: bool; (* merge with constructor_declaration? *)
}
(* Type expressions for the class language *)