diff options
| -rw-r--r-- | typing/env.ml | 28 | ||||
| -rw-r--r-- | typing/parmatch.ml | 2 | ||||
| -rw-r--r-- | typing/typedtree.ml | 6 | ||||
| -rw-r--r-- | typing/typedtree.mli | 6 |
4 files changed, 29 insertions, 13 deletions
diff --git a/typing/env.ml b/typing/env.ml index 1998a81cb..d59414af4 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -188,18 +188,29 @@ let constructors_of_type ty_path decl = match decl.type_kind with Type_variant cstrs -> let ty_res = Tconstr(ty_path, decl.type_params) in - let num_constrs = List.length cstrs in - let rec describe_constructors num = function + let num_consts = ref 0 and num_nonconsts = ref 0 in + List.iter + (function (name, []) -> incr num_consts + | (name, _) -> incr num_nonconsts) + cstrs; + let rec describe_constructors idx_const idx_nonconst = function [] -> [] - | (name, ty_args) :: rest -> + | (name, ty_args) :: rem -> + let (tag, descr_rem) = + match ty_args with + [] -> (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 cstr = { cstr_res = ty_res; cstr_args = ty_args; cstr_arity = List.length ty_args; - cstr_tag = Cstr_tag num; - cstr_span = num_constrs } in - (name, cstr) :: describe_constructors (num+1) rest in - describe_constructors 0 cstrs + cstr_tag = tag; + cstr_consts = !num_consts; + cstr_nonconsts = !num_nonconsts } in + (name, cstr) :: descr_rem in + describe_constructors 0 0 cstrs | _ -> [] (* Compute a constructor description for an exception *) @@ -209,7 +220,8 @@ let constructor_exception path_exc decl = cstr_args = decl; cstr_arity = List.length decl; cstr_tag = Cstr_exception path_exc; - cstr_span = -1 } + cstr_consts = -1; + cstr_nonconsts = -1 } (* Compute label descriptions *) diff --git a/typing/parmatch.ml b/typing/parmatch.ml index 8d3ee419b..c78058aae 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -155,7 +155,7 @@ let filter_all pat0 pss = let full_match env = match env with ({pat_desc = Tpat_construct(c,_)},_) :: _ -> - List.length env = c.cstr_span + List.length env = c.cstr_consts + c.cstr_nonconsts | ({pat_desc = Tpat_constant(Const_char _)},_) :: _ -> List.length env = 256 | ({pat_desc = Tpat_constant(_)},_) :: _ -> false diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 2390d9fbb..2f170a1c6 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -31,10 +31,12 @@ type constructor_description = cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_span: int } (* Number of constructors in type *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int } (* Number of non-const constructors *) and constructor_tag = - Cstr_tag of int (* Regular constructor *) + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) | Cstr_exception of Path.t (* Exception constructor *) (* Record label descriptions *) diff --git a/typing/typedtree.mli b/typing/typedtree.mli index fc572cd24..d9a8b0fc7 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -30,10 +30,12 @@ type constructor_description = cstr_args: type_expr list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) - cstr_span: int } (* Number of constructors in type *) + cstr_consts: int; (* Number of constant constructors *) + cstr_nonconsts: int } (* Number of non-const constructors *) and constructor_tag = - Cstr_tag of int (* Regular constructor *) + Cstr_constant of int (* Constant constructor (an int) *) + | Cstr_block of int (* Regular constructor (a block) *) | Cstr_exception of Path.t (* Exception constructor *) (* Record label descriptions *) |