Matching: propagate constructor descriptions in complete_pats_constrs
This simplifies this particular interface boundary between Matching and Parmatch. (Suggested by Florian Angeletti)master
parent
d333ac83ec
commit
bf95a24739
1
.depend
1
.depend
|
@ -811,7 +811,6 @@ typing/parmatch.cmx : \
|
|||
typing/parmatch.cmi : \
|
||||
typing/types.cmi \
|
||||
typing/typedtree.cmi \
|
||||
typing/patterns.cmi \
|
||||
parsing/parsetree.cmi \
|
||||
parsing/location.cmi \
|
||||
typing/env.cmi \
|
||||
|
|
2
Changes
2
Changes
|
@ -76,7 +76,7 @@ Working version
|
|||
|
||||
### Internal/compiler-libs changes:
|
||||
|
||||
- #9493, #9520, #9563: refactor the pattern-matching compiler
|
||||
- #9493, #9520, #9563, #9599: refactor the pattern-matching compiler
|
||||
(Thomas Refis and Gabriel Scherer, review by Florian Angeletti)
|
||||
|
||||
### Build system:
|
||||
|
|
|
@ -2498,16 +2498,14 @@ let rec list_as_pat = function
|
|||
| pat :: rem -> { pat with pat_desc = Tpat_or (pat, list_as_pat rem, None) }
|
||||
|
||||
let complete_pats_constrs = function
|
||||
| p :: _ as pats ->
|
||||
(* We (indirectly) call this function
|
||||
from [combine_constructor], and nowhere else.
|
||||
So we know patterns have been fully simplified. *)
|
||||
let p_simple = match (Patterns.General.view p).pat_desc with
|
||||
| #Patterns.Simple.view as simple -> { p with pat_desc = simple }
|
||||
| _ -> invalid_arg "complete_pats_constrs" in
|
||||
let tag_of_pat p = (get_key_constr p).cstr_tag in
|
||||
List.map (pat_of_constr p)
|
||||
(complete_constrs p_simple (List.map tag_of_pat pats))
|
||||
| constr :: _ as constrs ->
|
||||
let tag_of_constr constr =
|
||||
constr.pat_desc.cstr_tag in
|
||||
let pat_of_constr cstr =
|
||||
let open Patterns.Head in
|
||||
to_omega_pattern { constr with pat_desc = Construct cstr } in
|
||||
List.map pat_of_constr
|
||||
(complete_constrs constr (List.map tag_of_constr constrs))
|
||||
| _ -> assert false
|
||||
|
||||
(*
|
||||
|
@ -2725,10 +2723,14 @@ let combine_constructor loc arg pat_env cstr partial ctx def
|
|||
if sig_complete then
|
||||
(None, [], Jumps.empty)
|
||||
else
|
||||
mk_failaction_pos partial pats ctx def
|
||||
let constrs =
|
||||
List.map2 (fun (constr, _act) p -> { p with pat_desc = constr })
|
||||
descr_lambda_list pats in
|
||||
mk_failaction_pos partial constrs ctx def
|
||||
in
|
||||
let descr_lambda_list = fails @ descr_lambda_list in
|
||||
let consts, nonconsts = split_cases (List.map tag_lambda descr_lambda_list) in
|
||||
let consts, nonconsts =
|
||||
split_cases (List.map tag_lambda descr_lambda_list) in
|
||||
let lambda1 =
|
||||
match (fail_opt, same_actions descr_lambda_list) with
|
||||
| None, Some act -> act (* Identical actions, no failure *)
|
||||
|
|
|
@ -881,11 +881,10 @@ let rec get_variant_constructors env ty =
|
|||
| _ -> fatal_error "Parmatch.get_variant_constructors"
|
||||
|
||||
(* Sends back a pattern that complements constructor tags all_tag *)
|
||||
let complete_constrs p all_tags =
|
||||
let open Patterns.Head in
|
||||
let c = match p.pat_desc with Construct c -> c | _ -> assert false in
|
||||
let complete_constrs constr all_tags =
|
||||
let c = constr.pat_desc in
|
||||
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
|
||||
let constrs = get_variant_constructors p.pat_env c.cstr_res in
|
||||
let constrs = get_variant_constructors constr.pat_env c.cstr_res in
|
||||
let others =
|
||||
List.filter
|
||||
(fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag)
|
||||
|
@ -897,24 +896,16 @@ let complete_constrs p all_tags =
|
|||
let build_other_constrs env p =
|
||||
let open Patterns.Head in
|
||||
match p.pat_desc with
|
||||
| Construct { cstr_tag = Cstr_constant _ | Cstr_block _ } ->
|
||||
| Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) ->
|
||||
let constr = { p with pat_desc = c } in
|
||||
let get_tag q =
|
||||
match q.pat_desc with
|
||||
| Construct c -> c.cstr_tag
|
||||
| _ -> fatal_error "Parmatch.get_tag" in
|
||||
let all_tags = List.map (fun (p,_) -> get_tag p) env in
|
||||
pat_of_constrs p (complete_constrs p all_tags)
|
||||
pat_of_constrs p (complete_constrs constr all_tags)
|
||||
| _ -> extra_pat
|
||||
|
||||
let complete_constrs p all_tags =
|
||||
(* This wrapper is here for [Matching].
|
||||
|
||||
TODO: instead of a simple pattern, it would be nicer to pass
|
||||
a constructor payload directly:
|
||||
[Types.constructor_description pattern_data].
|
||||
*)
|
||||
complete_constrs (fst (Patterns.Head.deconstruct p)) all_tags
|
||||
|
||||
(* Auxiliary for build_other *)
|
||||
|
||||
let build_other_constant proj make first next p env =
|
||||
|
|
|
@ -67,7 +67,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list
|
|||
|
||||
val pat_of_constr : pattern -> constructor_description -> pattern
|
||||
val complete_constrs :
|
||||
Patterns.Simple.pattern ->
|
||||
constructor_description pattern_data ->
|
||||
constructor_tag list ->
|
||||
constructor_description list
|
||||
|
||||
|
|
Loading…
Reference in New Issue