allow exceptions under or-patterns
parent
4cb30bb7e9
commit
369ea5f432
|
@ -682,6 +682,7 @@ let rec extract_vars r p = match p.pat_desc with
|
|||
| Tpat_lazy p -> extract_vars r p
|
||||
| Tpat_or (p,_,_) -> extract_vars r p
|
||||
| Tpat_constant _|Tpat_any|Tpat_variant (_,None,_) -> r
|
||||
| Tpat_exception _ -> assert false
|
||||
|
||||
exception Cannot_flatten
|
||||
|
||||
|
@ -2853,6 +2854,7 @@ let find_in_pat pred =
|
|||
find_rec p || find_rec q
|
||||
| Tpat_constant _ | Tpat_var _
|
||||
| Tpat_any | Tpat_variant (_,None,_) -> false
|
||||
| Tpat_exception _ -> assert false
|
||||
end in
|
||||
find_rec
|
||||
|
||||
|
@ -2862,6 +2864,7 @@ let is_lazy_pat = function
|
|||
| Tpat_tuple _|Tpat_construct _ | Tpat_array _
|
||||
| Tpat_or _ | Tpat_constant _ | Tpat_var _ | Tpat_any
|
||||
-> false
|
||||
| Tpat_exception _ -> assert false
|
||||
|
||||
let is_lazy p = find_in_pat is_lazy_pat p
|
||||
|
||||
|
@ -2878,6 +2881,7 @@ let have_mutable_field p = match p with
|
|||
| Tpat_or _
|
||||
| Tpat_constant _ | Tpat_var _ | Tpat_any
|
||||
-> false
|
||||
| Tpat_exception _ -> assert false
|
||||
|
||||
let is_mutable p = find_in_pat have_mutable_field p
|
||||
|
||||
|
|
|
@ -121,7 +121,7 @@ let rec push_defaults loc bindings cases partial =
|
|||
in
|
||||
[{case with c_rhs=exp}]
|
||||
| {c_lhs=pat; c_rhs=exp; c_guard=_} :: _ when bindings <> [] ->
|
||||
let param = Typecore.name_pattern "param" cases in
|
||||
let param = Typecore.name_cases "param" cases in
|
||||
let name = Ident.name param in
|
||||
let exp =
|
||||
{ exp with exp_loc = loc; exp_desc =
|
||||
|
@ -132,7 +132,7 @@ let rec push_defaults loc bindings cases partial =
|
|||
val_attributes = [];
|
||||
Types.val_loc = Location.none;
|
||||
})},
|
||||
cases, [], partial) }
|
||||
cases, partial) }
|
||||
in
|
||||
push_defaults loc bindings
|
||||
[{c_lhs={pat with pat_desc = Tpat_var (param, mknoloc name)};
|
||||
|
@ -180,6 +180,14 @@ let rec cut n l =
|
|||
|
||||
(* Translation of expressions *)
|
||||
|
||||
let rec iter_exn_names f pat =
|
||||
match pat.pat_desc with
|
||||
| Tpat_var (id, _) -> f id
|
||||
| Tpat_alias (p, id, _) ->
|
||||
f id;
|
||||
iter_exn_names f p
|
||||
| _ -> ()
|
||||
|
||||
let rec transl_exp e =
|
||||
List.iter (Translattribute.check_attribute e) e.exp_attributes;
|
||||
let eval_once =
|
||||
|
@ -265,10 +273,10 @@ and transl_exp0 e =
|
|||
event_after e
|
||||
(transl_apply ~should_be_tailcall ~inlined ~specialised
|
||||
(transl_exp funct) oargs e.exp_loc)
|
||||
| Texp_match(arg, pat_expr_list, exn_pat_expr_list, partial) ->
|
||||
transl_match e arg pat_expr_list exn_pat_expr_list partial
|
||||
| Texp_match(arg, pat_expr_list, partial) ->
|
||||
transl_match e arg pat_expr_list partial
|
||||
| Texp_try(body, pat_expr_list) ->
|
||||
let id = Typecore.name_pattern "exn" pat_expr_list in
|
||||
let id = Typecore.name_cases "exn" pat_expr_list in
|
||||
Ltrywith(transl_exp body, id,
|
||||
Matching.for_trywith (Lvar id) (transl_cases_try pat_expr_list))
|
||||
| Texp_tuple el ->
|
||||
|
@ -538,14 +546,6 @@ and transl_cases cases =
|
|||
List.map transl_case cases
|
||||
|
||||
and transl_case_try {c_lhs; c_guard; c_rhs} =
|
||||
let rec iter_exn_names f pat =
|
||||
match pat.pat_desc with
|
||||
| Tpat_var (id, _) -> f id
|
||||
| Tpat_alias (p, id, _) ->
|
||||
f id;
|
||||
iter_exn_names f p
|
||||
| _ -> ()
|
||||
in
|
||||
iter_exn_names Translprim.add_exception_ident c_lhs;
|
||||
Misc.try_finally
|
||||
(fun () -> c_lhs, transl_guard c_guard c_rhs)
|
||||
|
@ -806,11 +806,49 @@ and transl_record loc env fields repres opt_init_expr =
|
|||
end
|
||||
end
|
||||
|
||||
and transl_match e arg pat_expr_list exn_pat_expr_list partial =
|
||||
let id = Typecore.name_pattern "exn" exn_pat_expr_list
|
||||
and cases = transl_cases pat_expr_list
|
||||
and exn_cases = transl_cases_try exn_pat_expr_list in
|
||||
and transl_match e arg pat_expr_list partial =
|
||||
let rewrite_case (val_cases, exn_cases, static_handlers as acc)
|
||||
({ c_lhs; c_guard; c_rhs } as case) =
|
||||
if c_rhs.exp_desc = Texp_unreachable then acc else
|
||||
let val_pat, exn_pat = split_pattern c_lhs in
|
||||
match val_pat, exn_pat with
|
||||
| None, None -> assert false
|
||||
| Some pv, None ->
|
||||
let val_case =
|
||||
transl_case { case with c_lhs = pv }
|
||||
in
|
||||
val_case :: val_cases, exn_cases, static_handlers
|
||||
| None, Some pe ->
|
||||
let exn_case = transl_case_try { case with c_lhs = pe } in
|
||||
val_cases, exn_case :: exn_cases, static_handlers
|
||||
| Some pv, Some pe ->
|
||||
assert (c_guard = None);
|
||||
let lbl = next_raise_count () in
|
||||
let static_raise ids =
|
||||
Lstaticraise (lbl, List.map (fun id -> Lvar id) ids)
|
||||
in
|
||||
(* Simplif doesn't like it if binders are not uniq, so we make sure to
|
||||
use different names in the value and the exception branches. *)
|
||||
let ids = Typedtree.pat_bound_idents pv in
|
||||
let vids = List.map Ident.rename ids in
|
||||
let pv = alpha_pat (List.combine ids vids) pv in
|
||||
(* Also register the names of the exception so Re-raise happens. *)
|
||||
iter_exn_names Translprim.add_exception_ident pe;
|
||||
let rhs =
|
||||
Misc.try_finally
|
||||
(fun () -> event_before c_rhs (transl_exp c_rhs))
|
||||
(fun () -> iter_exn_names Translprim.remove_exception_ident pe)
|
||||
in
|
||||
(pv, static_raise vids) :: val_cases,
|
||||
(pe, static_raise ids) :: exn_cases,
|
||||
(lbl, ids, rhs) :: static_handlers
|
||||
in
|
||||
let val_cases, exn_cases, static_handlers =
|
||||
let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
|
||||
List.rev x, List.rev y, List.rev z
|
||||
in
|
||||
let static_catch body val_ids handler =
|
||||
let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in
|
||||
let static_exception_id = next_raise_count () in
|
||||
Lstaticcatch
|
||||
(Ltrywith (Lstaticraise (static_exception_id, body), id,
|
||||
|
@ -818,20 +856,27 @@ and transl_match e arg pat_expr_list exn_pat_expr_list partial =
|
|||
(static_exception_id, val_ids),
|
||||
handler)
|
||||
in
|
||||
let classic =
|
||||
match arg, exn_cases with
|
||||
| {exp_desc = Texp_tuple argl}, [] ->
|
||||
Matching.for_multiple_match e.exp_loc (transl_list argl) cases partial
|
||||
assert (static_handlers = []);
|
||||
Matching.for_multiple_match e.exp_loc (transl_list argl) val_cases partial
|
||||
| {exp_desc = Texp_tuple argl}, _ :: _ ->
|
||||
let val_ids = List.map (fun _ -> Typecore.name_pattern "val" []) argl in
|
||||
let lvars = List.map (fun id -> Lvar id) val_ids in
|
||||
static_catch (transl_list argl) val_ids
|
||||
(Matching.for_multiple_match e.exp_loc lvars cases partial)
|
||||
(Matching.for_multiple_match e.exp_loc lvars val_cases partial)
|
||||
| arg, [] ->
|
||||
Matching.for_function e.exp_loc None (transl_exp arg) cases partial
|
||||
assert (static_handlers = []);
|
||||
Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
|
||||
| arg, _ :: _ ->
|
||||
let val_id = Typecore.name_pattern "val" pat_expr_list in
|
||||
let val_id = Typecore.name_cases "val" pat_expr_list in
|
||||
static_catch [transl_exp arg] [val_id]
|
||||
(Matching.for_function e.exp_loc None (Lvar val_id) cases partial)
|
||||
(Matching.for_function e.exp_loc None (Lvar val_id) val_cases partial)
|
||||
in
|
||||
List.fold_left (fun body (static_exception_id, val_ids, handler) ->
|
||||
Lstaticcatch (body, (static_exception_id, val_ids), handler)
|
||||
) classic static_handlers
|
||||
|
||||
|
||||
(* Wrapper for class compilation *)
|
||||
|
|
|
@ -99,9 +99,8 @@ let rec iterator ~scope rebuild_env =
|
|||
bind_bindings exp.exp_loc bindings
|
||||
| Texp_let (Nonrecursive, bindings, body) ->
|
||||
bind_bindings body.exp_loc bindings
|
||||
| Texp_match (_, f1, f2, _) ->
|
||||
bind_cases f1;
|
||||
bind_cases f2
|
||||
| Texp_match (_, f1, _) ->
|
||||
bind_cases f1
|
||||
| Texp_function { cases = f; }
|
||||
| Texp_try (_, f) ->
|
||||
bind_cases f
|
||||
|
|
|
@ -443,7 +443,8 @@ let rec normalize_pat q = match q.pat_desc with
|
|||
q.pat_type q.pat_env
|
||||
| Tpat_lazy _ ->
|
||||
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
|
||||
| Tpat_or _ -> fatal_error "Parmatch.normalize_pat"
|
||||
| Tpat_or _
|
||||
| Tpat_exception _ -> fatal_error "Parmatch.normalize_pat"
|
||||
|
||||
(* Consider a pattern matrix whose first column has been simplified to contain
|
||||
only _ or a head constructor
|
||||
|
@ -781,7 +782,8 @@ let row_of_pat pat =
|
|||
are simplified, and are not omega/Tpat_any.
|
||||
*)
|
||||
let full_match closing env = match env with
|
||||
| ({pat_desc = (Tpat_any | Tpat_var _ | Tpat_alias _ | Tpat_or _)},_) :: _ ->
|
||||
| ({pat_desc = (Tpat_any | Tpat_var _ | Tpat_alias _
|
||||
| Tpat_or _ | Tpat_exception _)},_) :: _ ->
|
||||
(* discriminating patterns are simplified *)
|
||||
assert false
|
||||
| [] -> false
|
||||
|
@ -837,7 +839,7 @@ let should_extend ext env = match ext with
|
|||
| Tpat_constant _|Tpat_tuple _|Tpat_variant _
|
||||
| Tpat_record _|Tpat_array _ | Tpat_lazy _
|
||||
-> false
|
||||
| Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _
|
||||
| Tpat_any|Tpat_var _|Tpat_alias _|Tpat_or _|Tpat_exception _
|
||||
-> assert false
|
||||
end
|
||||
end
|
||||
|
@ -1107,6 +1109,7 @@ let rec has_instance p = match p.pat_desc with
|
|||
| Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
|
||||
| Tpat_lazy p
|
||||
-> has_instance p
|
||||
| Tpat_exception _ -> assert false
|
||||
|
||||
|
||||
and has_instances = function
|
||||
|
@ -1815,8 +1818,19 @@ and lubs ps qs = match ps,qs with
|
|||
(* Apply pressure to variants *)
|
||||
|
||||
let pressure_variants tdefs patl =
|
||||
let pss = List.map (fun p -> [p;omega]) patl in
|
||||
ignore (pressure_variants (Some tdefs) pss)
|
||||
let add_row pss p_opt =
|
||||
match p_opt with
|
||||
| None -> pss
|
||||
| Some p -> [p; omega] :: pss
|
||||
in
|
||||
let val_pss, exn_pss =
|
||||
List.fold_right (fun pat (vpss, epss)->
|
||||
let (vp, ep) = split_pattern pat in
|
||||
add_row vpss vp, add_row epss ep
|
||||
) patl ([], [])
|
||||
in
|
||||
ignore (pressure_variants (Some tdefs) val_pss);
|
||||
ignore (pressure_variants (Some tdefs) exn_pss)
|
||||
|
||||
(*****************************)
|
||||
(* Utilities for diagnostics *)
|
||||
|
@ -1904,6 +1918,8 @@ module Conv = struct
|
|||
mkpat (Ppat_array (List.map loop lst))
|
||||
| Tpat_lazy p ->
|
||||
mkpat (Ppat_lazy (loop p))
|
||||
| Tpat_exception _ ->
|
||||
assert false
|
||||
in
|
||||
let ps = loop typed in
|
||||
(ps, constrs, labels)
|
||||
|
@ -2030,6 +2046,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with
|
|||
| Tpat_lazy p
|
||||
->
|
||||
collect_paths_from_pat r p
|
||||
| Tpat_exception _ -> assert false
|
||||
|
||||
|
||||
(*
|
||||
|
@ -2161,6 +2178,7 @@ let inactive ~partial pat =
|
|||
ldps
|
||||
| Tpat_or (p,q,_) ->
|
||||
loop p && loop q
|
||||
| Tpat_exception _ -> assert false
|
||||
in
|
||||
loop pat
|
||||
end
|
||||
|
|
|
@ -89,6 +89,8 @@ let rec pretty_val ppf v =
|
|||
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
|
||||
| Tpat_lazy v ->
|
||||
fprintf ppf "@[<2>lazy@ %a@]" pretty_arg v
|
||||
| Tpat_exception v ->
|
||||
fprintf ppf "@[<2>exception@ %a@]" pretty_arg v
|
||||
| Tpat_alias (v, x,_) ->
|
||||
fprintf ppf "@[(%a@ as %a)@]" pretty_val v Ident.print x
|
||||
| Tpat_or (v,w,_) ->
|
||||
|
|
|
@ -267,6 +267,9 @@ and pattern i ppf x =
|
|||
| Tpat_lazy p ->
|
||||
line i ppf "Tpat_lazy\n";
|
||||
pattern i ppf p;
|
||||
| Tpat_exception p ->
|
||||
line i ppf "Tpat_exception\n";
|
||||
pattern i ppf p;
|
||||
|
||||
and expression_extra i ppf x attrs =
|
||||
match x with
|
||||
|
@ -314,11 +317,10 @@ and expression i ppf x =
|
|||
line i ppf "Texp_apply\n";
|
||||
expression i ppf e;
|
||||
list i label_x_expression ppf l;
|
||||
| Texp_match (e, l1, l2, _partial) ->
|
||||
| Texp_match (e, l, _partial) ->
|
||||
line i ppf "Texp_match\n";
|
||||
expression i ppf e;
|
||||
list i case ppf l1;
|
||||
list i case ppf l2;
|
||||
list i case ppf l;
|
||||
| Texp_try (e, l) ->
|
||||
line i ppf "Texp_try\n";
|
||||
expression i ppf e;
|
||||
|
|
|
@ -372,12 +372,9 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t =
|
|||
| Texp_letmodule (x, _, m, e) ->
|
||||
let ty = modexp env m in
|
||||
Use.join (Use.discard ty) (expression (Ident.add x ty env) e)
|
||||
| Texp_match (e, val_cases, exn_cases, _) ->
|
||||
| Texp_match (e, cases, _) ->
|
||||
let t = expression env e in
|
||||
let exn_case env {Typedtree.c_rhs} = expression env c_rhs in
|
||||
let cs = list (case ~scrutinee:t) env val_cases
|
||||
and es = list exn_case env exn_cases in
|
||||
Use.(join cs es)
|
||||
list (case ~scrutinee:t) env cases
|
||||
| Texp_for (_, _, e1, e2, _, e3) ->
|
||||
Use.(join
|
||||
(join
|
||||
|
@ -697,6 +694,7 @@ and is_destructuring_pattern : Typedtree.pattern -> bool =
|
|||
| Tpat_or (l,r,_) ->
|
||||
is_destructuring_pattern l || is_destructuring_pattern r
|
||||
| Tpat_lazy _ -> true
|
||||
| Tpat_exception _ -> false
|
||||
|
||||
let is_valid_recursive_expression idlist expr =
|
||||
let ty = expression (build_unguarded_env idlist) expr in
|
||||
|
|
|
@ -215,6 +215,7 @@ let pat sub x =
|
|||
Tpat_or (sub.pat sub p1, sub.pat sub p2, rd)
|
||||
| Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s)
|
||||
| Tpat_lazy p -> Tpat_lazy (sub.pat sub p)
|
||||
| Tpat_exception p -> Tpat_exception (sub.pat sub p)
|
||||
in
|
||||
{x with pat_extra; pat_desc; pat_env}
|
||||
|
||||
|
@ -246,11 +247,10 @@ let expr sub x =
|
|||
sub.expr sub exp,
|
||||
List.map (tuple2 id (opt (sub.expr sub))) list
|
||||
)
|
||||
| Texp_match (exp, cases, exn_cases, p) ->
|
||||
| Texp_match (exp, cases, p) ->
|
||||
Texp_match (
|
||||
sub.expr sub exp,
|
||||
sub.cases sub cases,
|
||||
sub.cases sub exn_cases,
|
||||
p
|
||||
)
|
||||
| Texp_try (exp, cases) ->
|
||||
|
|
|
@ -94,7 +94,8 @@ type error =
|
|||
| Invalid_interval
|
||||
| Invalid_for_loop_index
|
||||
| No_value_clauses
|
||||
| Exception_pattern_below_toplevel
|
||||
| Exception_pattern_disallowed
|
||||
| Mixed_value_and_exception_patterns_under_guard
|
||||
| Inlined_record_escape
|
||||
| Inlined_record_expected
|
||||
| Unrefuted_pattern of pattern
|
||||
|
@ -598,7 +599,7 @@ let rec build_as_type env p =
|
|||
newty (Tvariant{row with row_closed=false; row_more=newvar()})
|
||||
end
|
||||
| Tpat_any | Tpat_var _ | Tpat_constant _
|
||||
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
|
||||
| Tpat_array _ | Tpat_lazy _ | Tpat_exception _ -> p.pat_type
|
||||
|
||||
let build_or_pat env loc lid =
|
||||
let path, decl = Typetexp.find_type env lid.loc lid.txt
|
||||
|
@ -649,6 +650,19 @@ let build_or_pat env loc lid =
|
|||
pat pats in
|
||||
(path, rp { r with pat_loc = loc },ty)
|
||||
|
||||
let split_cases env cases =
|
||||
let add_case lst case = function
|
||||
| None -> lst
|
||||
| Some c_lhs -> { case with c_lhs } :: lst
|
||||
in
|
||||
List.fold_right (fun ({ c_lhs; c_guard } as case) (vals, exns) ->
|
||||
match split_pattern c_lhs with
|
||||
| Some _, Some _ when c_guard <> None ->
|
||||
raise (Error (c_lhs.pat_loc, env,
|
||||
Mixed_value_and_exception_patterns_under_guard))
|
||||
| vp, ep -> add_case vals case vp, add_case exns case ep
|
||||
) cases ([], [])
|
||||
|
||||
(* Type paths *)
|
||||
|
||||
let rec expand_path env p =
|
||||
|
@ -1054,20 +1068,22 @@ exception Need_backtrack
|
|||
Unification may update the typing environment. *)
|
||||
(* constrs <> None => called from parmatch: backtrack on or-patterns
|
||||
explode > 0 => explode Ppat_any for gadts *)
|
||||
let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
||||
sp expected_ty k =
|
||||
let rec type_pat ?(exception_allowed=false) ~constrs ~labels ~no_existentials
|
||||
~mode ~explode ~env sp expected_ty k =
|
||||
Builtin_attributes.warning_scope sp.ppat_attributes
|
||||
(fun () ->
|
||||
type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
||||
sp expected_ty k
|
||||
type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
|
||||
~explode ~env sp expected_ty k
|
||||
)
|
||||
|
||||
and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
||||
sp expected_ty k =
|
||||
and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
|
||||
~explode ~env sp expected_ty k =
|
||||
let mode' = if mode = Splitting_or then Normal else mode in
|
||||
let type_pat ?(constrs=constrs) ?(labels=labels) ?(mode=mode')
|
||||
?(explode=explode) ?(env=env) =
|
||||
type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env in
|
||||
let type_pat ?(exception_allowed=false) ?(constrs=constrs) ?(labels=labels)
|
||||
?(mode=mode') ?(explode=explode) ?(env=env) =
|
||||
type_pat ~exception_allowed ~constrs ~labels ~no_existentials ~mode ~explode
|
||||
~env
|
||||
in
|
||||
let loc = sp.ppat_loc in
|
||||
let rp k x : pattern = if constrs = None then k (rp x) else k x in
|
||||
match sp.ppat_desc with
|
||||
|
@ -1369,14 +1385,16 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
|||
let initial_pattern_variables = !pattern_variables in
|
||||
let initial_module_variables = !module_variables in
|
||||
let p1 =
|
||||
try Some (type_pat ~mode:Inside_or sp1 expected_ty (fun x -> x))
|
||||
try Some (type_pat ~exception_allowed ~mode:Inside_or sp1 expected_ty
|
||||
(fun x -> x))
|
||||
with Need_backtrack -> None in
|
||||
let p1_variables = !pattern_variables in
|
||||
let p1_module_variables = !module_variables in
|
||||
pattern_variables := initial_pattern_variables;
|
||||
module_variables := initial_module_variables;
|
||||
let p2 =
|
||||
try Some (type_pat ~mode:Inside_or sp2 expected_ty (fun x -> x))
|
||||
try Some (type_pat ~exception_allowed ~mode:Inside_or sp2 expected_ty
|
||||
(fun x -> x))
|
||||
with Need_backtrack -> None in
|
||||
let p2_variables = !pattern_variables in
|
||||
match p1, p2 with
|
||||
|
@ -1399,9 +1417,10 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
|||
set_state state env;
|
||||
let mode =
|
||||
if mode = Split_or then mode else Splitting_or in
|
||||
try type_pat ~mode sp1 expected_ty k with Error _ ->
|
||||
try type_pat ~exception_allowed ~mode sp1 expected_ty k
|
||||
with Error _ ->
|
||||
set_state state env;
|
||||
type_pat ~mode sp2 expected_ty k
|
||||
type_pat ~exception_allowed ~mode sp2 expected_ty k
|
||||
end
|
||||
| Ppat_lazy sp1 ->
|
||||
let nv = newvar () in
|
||||
|
@ -1429,7 +1448,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
|||
end else ty, ty
|
||||
in
|
||||
unify_pat_types loc !env ty expected_ty;
|
||||
type_pat sp expected_ty' (fun p ->
|
||||
type_pat ~exception_allowed sp expected_ty' (fun p ->
|
||||
(*Format.printf "%a@.%a@."
|
||||
Printtyp.raw_type_expr ty
|
||||
Printtyp.raw_type_expr p.pat_type;*)
|
||||
|
@ -1456,23 +1475,36 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env
|
|||
let path, new_env =
|
||||
!type_open Asttypes.Fresh !env sp.ppat_loc lid in
|
||||
let new_env = ref new_env in
|
||||
type_pat ~env:new_env p expected_ty ( fun p ->
|
||||
type_pat ~exception_allowed ~env:new_env p expected_ty ( fun p ->
|
||||
env := Env.copy_local !env ~from:!new_env;
|
||||
k { p with pat_extra =( Tpat_open (path,lid,!new_env),
|
||||
loc, sp.ppat_attributes) :: p.pat_extra }
|
||||
)
|
||||
| Ppat_exception _ ->
|
||||
raise (Error (loc, !env, Exception_pattern_below_toplevel))
|
||||
| Ppat_exception p ->
|
||||
if not exception_allowed then
|
||||
raise (Error (loc, !env, Exception_pattern_disallowed))
|
||||
else begin
|
||||
let p_exn = type_pat p Predef.type_exn k in
|
||||
rp k {
|
||||
pat_desc = Tpat_exception p_exn;
|
||||
pat_loc = sp.ppat_loc;
|
||||
pat_extra = [];
|
||||
pat_type = expected_ty;
|
||||
pat_env = !env;
|
||||
pat_attributes = sp.ppat_attributes;
|
||||
}
|
||||
end
|
||||
| Ppat_extension ext ->
|
||||
raise (Error_forward (Builtin_attributes.error_of_extension ext))
|
||||
|
||||
let type_pat ?no_existentials ?constrs ?labels ?(mode=Normal)
|
||||
let type_pat ?exception_allowed ?no_existentials ?constrs ?labels ?(mode=Normal)
|
||||
?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
|
||||
gadt_equations_level := Some lev;
|
||||
try
|
||||
let r =
|
||||
type_pat ~no_existentials ~constrs ~labels ~mode ~explode ~env sp
|
||||
expected_ty (fun x -> x) in
|
||||
type_pat ?exception_allowed ~no_existentials ~constrs ~labels ~mode
|
||||
~explode ~env sp expected_ty (fun x -> x)
|
||||
in
|
||||
iter_pattern (fun p -> p.pat_env <- !env) r;
|
||||
gadt_equations_level := None;
|
||||
r
|
||||
|
@ -1531,10 +1563,10 @@ let add_pattern_variables ?check ?check_as env pv =
|
|||
)
|
||||
pv env
|
||||
|
||||
let type_pattern ~lev env spat scope expected_ty =
|
||||
let type_pattern ?exception_allowed ~lev env spat scope expected_ty =
|
||||
reset_pattern scope true;
|
||||
let new_env = ref env in
|
||||
let pat = type_pat ~lev new_env spat expected_ty in
|
||||
let pat = type_pat ?exception_allowed ~lev new_env spat expected_ty in
|
||||
let pvs = get_ref pattern_variables in
|
||||
let unpacks = get_ref module_variables in
|
||||
(pat, !new_env, get_ref pattern_force, pvs, unpacks)
|
||||
|
@ -1664,11 +1696,24 @@ let rec is_nonexpansive exp =
|
|||
| Texp_function _ -> true
|
||||
| Texp_apply(e, (_,None)::el) ->
|
||||
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd el)
|
||||
| Texp_match(e, cases, [], _) ->
|
||||
| Texp_match(e, cases, _) ->
|
||||
(* Not sure this is necessary, if [e] is nonexpansive then we shouldn't
|
||||
care if there are exception patterns. But the previous version enforced
|
||||
that there be none, so... *)
|
||||
let contains_exception_pat p =
|
||||
let res = ref false in
|
||||
iter_pattern (fun p ->
|
||||
match p.pat_desc with
|
||||
| Tpat_exception _ -> res := true
|
||||
| _ -> ()
|
||||
) p;
|
||||
!res
|
||||
in
|
||||
is_nonexpansive e &&
|
||||
List.for_all
|
||||
(fun {c_lhs = _; c_guard; c_rhs} ->
|
||||
(fun {c_lhs; c_guard; c_rhs} ->
|
||||
is_nonexpansive_opt c_guard && is_nonexpansive c_rhs
|
||||
&& not (contains_exception_pat c_lhs)
|
||||
) cases
|
||||
| Texp_tuple el ->
|
||||
List.for_all is_nonexpansive el
|
||||
|
@ -2045,12 +2090,15 @@ let proper_exp_loc exp =
|
|||
|
||||
let rec name_pattern default = function
|
||||
[] -> Ident.create default
|
||||
| {c_lhs=p; _} :: rem ->
|
||||
| p :: rem ->
|
||||
match p.pat_desc with
|
||||
Tpat_var (id, _) -> id
|
||||
| Tpat_alias(_, id, _) -> id
|
||||
| _ -> name_pattern default rem
|
||||
|
||||
let name_cases default lst =
|
||||
name_pattern default (List.map (fun c -> c.c_lhs) lst)
|
||||
|
||||
(* Typing of expressions *)
|
||||
|
||||
let unify_exp env exp expected_ty =
|
||||
|
@ -2317,25 +2365,12 @@ and type_expect_
|
|||
end_def ();
|
||||
if not (is_nonexpansive arg) then generalize_expansive env arg.exp_type;
|
||||
generalize arg.exp_type;
|
||||
let rec split_cases vc ec = function
|
||||
| [] -> List.rev vc, List.rev ec
|
||||
| {pc_lhs = {ppat_desc=Ppat_exception p}} as c :: rest ->
|
||||
split_cases vc ({c with pc_lhs = p} :: ec) rest
|
||||
| c :: rest ->
|
||||
split_cases (c :: vc) ec rest
|
||||
let cases, partial =
|
||||
type_cases ~exception_allowed:true env arg.exp_type ty_expected true loc
|
||||
caselist
|
||||
in
|
||||
let val_caselist, exn_caselist = split_cases [] [] caselist in
|
||||
if val_caselist = [] && exn_caselist <> [] then
|
||||
raise (Error (loc, env, No_value_clauses));
|
||||
(* Note: val_caselist = [] and exn_caselist = [], i.e. a fully
|
||||
empty pattern matching can be generated by Camlp4 with its
|
||||
revised syntax. Let's accept it for backward compatibility. *)
|
||||
let val_cases, partial =
|
||||
type_cases env arg.exp_type ty_expected true loc val_caselist in
|
||||
let exn_cases, _ =
|
||||
type_cases env Predef.type_exn ty_expected false loc exn_caselist in
|
||||
re {
|
||||
exp_desc = Texp_match(arg, val_cases, exn_cases, partial);
|
||||
exp_desc = Texp_match(arg, cases, partial);
|
||||
exp_loc = loc; exp_extra = [];
|
||||
exp_type = instance ty_expected;
|
||||
exp_attributes = sexp.pexp_attributes;
|
||||
|
@ -3233,7 +3268,7 @@ and type_function ?in_function loc attrs env ty_expected_explained l caselist =
|
|||
if is_optional l && not_function ty_res then
|
||||
Location.prerr_warning (List.hd cases).c_lhs.pat_loc
|
||||
Warnings.Unerasable_optional_argument;
|
||||
let param = name_pattern "param" cases in
|
||||
let param = name_cases "param" cases in
|
||||
re {
|
||||
exp_desc = Texp_function { arg_label = l; param; cases; partial; };
|
||||
exp_loc = loc; exp_extra = [];
|
||||
|
@ -3635,7 +3670,7 @@ and type_argument ?recarg env sarg ty_expected' ty_expected =
|
|||
args @ [Nolabel, Some eta_var])}
|
||||
in
|
||||
let cases = [case eta_pat e] in
|
||||
let param = name_pattern "param" cases in
|
||||
let param = name_cases "param" cases in
|
||||
{ texp with exp_type = ty_fun; exp_desc =
|
||||
Texp_function { arg_label = Nolabel; param; cases;
|
||||
partial = Total; } }
|
||||
|
@ -3971,7 +4006,8 @@ and check_scope_escape loc env level ty =
|
|||
with Unify trace ->
|
||||
raise(Error(loc, env, Pattern_type_clash(trace)))
|
||||
|
||||
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
|
||||
and type_cases ?exception_allowed ?in_function env ty_arg ty_res partial_flag
|
||||
loc caselist =
|
||||
(* ty_arg is _fully_ generalized *)
|
||||
let patterns = List.map (fun {pc_lhs=p} -> p) caselist in
|
||||
let contains_polyvars = List.exists contains_polymorphic_variant patterns in
|
||||
|
@ -4029,7 +4065,7 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
|
|||
generalize_structure ty_arg;
|
||||
let expected_ty_arg = instance ty_arg in
|
||||
let (pat, ext_env, force, pvs, unpacks) =
|
||||
type_pattern ~lev env pc_lhs scope expected_ty_arg
|
||||
type_pattern ?exception_allowed ~lev env pc_lhs scope expected_ty_arg
|
||||
in
|
||||
pattern_force := force @ !pattern_force;
|
||||
let pat =
|
||||
|
@ -4152,9 +4188,12 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
|
|||
Subst.type_expr (Subst.for_saving Subst.identity) ty_arg'
|
||||
else ty_arg'
|
||||
in
|
||||
let val_cases, exn_cases = split_cases env cases in
|
||||
if val_cases = [] && exn_cases <> [] then
|
||||
raise (Error (loc, env, No_value_clauses));
|
||||
let partial =
|
||||
if partial_flag then
|
||||
check_partial ~lev env (instance ty_arg_check) loc cases
|
||||
check_partial ~lev env (instance ty_arg_check) loc val_cases
|
||||
else
|
||||
Partial
|
||||
in
|
||||
|
@ -4165,9 +4204,11 @@ and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
|
|||
List.iter (fun { typed_pat; branch_env; _ } ->
|
||||
check_absent_variant branch_env typed_pat
|
||||
) half_typed_cases;
|
||||
check_unused ~lev env (instance ty_arg_check) cases ;
|
||||
check_unused ~lev env (instance ty_arg_check) val_cases ;
|
||||
check_unused ~lev env Predef.type_exn exn_cases ;
|
||||
if do_init then end_def ();
|
||||
Parmatch.check_ambiguous_bindings cases
|
||||
Parmatch.check_ambiguous_bindings val_cases ;
|
||||
Parmatch.check_ambiguous_bindings exn_cases
|
||||
in
|
||||
if contains_polyvars || do_init then
|
||||
add_delayed_check (fun () -> unused_check do_init)
|
||||
|
@ -4743,9 +4784,13 @@ let report_error env ppf = function
|
|||
| No_value_clauses ->
|
||||
fprintf ppf
|
||||
"None of the patterns in this 'match' expression match values."
|
||||
| Exception_pattern_below_toplevel ->
|
||||
| Exception_pattern_disallowed ->
|
||||
fprintf ppf
|
||||
"@[Exception patterns must be at the top level of a match case.@]"
|
||||
"@[Exception patterns are not allowed in this position.@]"
|
||||
| Mixed_value_and_exception_patterns_under_guard ->
|
||||
fprintf ppf
|
||||
"@[Mixing value and exception patterns under when-guards is not \
|
||||
supported.@]"
|
||||
| Inlined_record_escape ->
|
||||
fprintf ppf
|
||||
"@[This form is not allowed as the type of the inlined record could \
|
||||
|
|
|
@ -110,7 +110,9 @@ val generalizable: int -> type_expr -> bool
|
|||
val reset_delayed_checks: unit -> unit
|
||||
val force_delayed_checks: unit -> unit
|
||||
|
||||
val name_pattern : string -> Typedtree.case list -> Ident.t
|
||||
val name_pattern : string -> Typedtree.pattern list -> Ident.t
|
||||
|
||||
val name_cases : string -> Typedtree.case list -> Ident.t
|
||||
|
||||
val self_coercion : (Path.t * Location.t list ref) list ref
|
||||
|
||||
|
@ -159,7 +161,8 @@ type error =
|
|||
| Invalid_interval
|
||||
| Invalid_for_loop_index
|
||||
| No_value_clauses
|
||||
| Exception_pattern_below_toplevel
|
||||
| Exception_pattern_disallowed
|
||||
| Mixed_value_and_exception_patterns_under_guard
|
||||
| Inlined_record_escape
|
||||
| Inlined_record_expected
|
||||
| Unrefuted_pattern of Typedtree.pattern
|
||||
|
|
|
@ -56,6 +56,7 @@ and pattern_desc =
|
|||
| Tpat_array of pattern list
|
||||
| Tpat_or of pattern * pattern * row_desc option
|
||||
| Tpat_lazy of pattern
|
||||
| Tpat_exception of pattern
|
||||
|
||||
and expression =
|
||||
{ exp_desc: expression_desc;
|
||||
|
@ -80,7 +81,7 @@ and expression_desc =
|
|||
| Texp_function of { arg_label : arg_label; param : Ident.t;
|
||||
cases : case list; partial : partial; }
|
||||
| Texp_apply of expression * (arg_label * expression option) list
|
||||
| Texp_match of expression * case list * case list * partial
|
||||
| Texp_match of expression * case list * partial
|
||||
| Texp_try of expression * case list
|
||||
| Texp_tuple of expression list
|
||||
| Texp_construct of
|
||||
|
@ -546,6 +547,7 @@ let iter_pattern_desc f = function
|
|||
| Tpat_array patl -> List.iter f patl
|
||||
| Tpat_or(p1, p2, _) -> f p1; f p2
|
||||
| Tpat_lazy p -> f p
|
||||
| Tpat_exception p -> f p
|
||||
| Tpat_any
|
||||
| Tpat_var _
|
||||
| Tpat_constant _ -> ()
|
||||
|
@ -563,6 +565,7 @@ let map_pattern_desc f d =
|
|||
| Tpat_array pats ->
|
||||
Tpat_array (List.map f pats)
|
||||
| Tpat_lazy p1 -> Tpat_lazy (f p1)
|
||||
| Tpat_exception p1 -> Tpat_exception (f p1)
|
||||
| Tpat_variant (x1, Some p1, x2) ->
|
||||
Tpat_variant (x1, Some (f p1), x2)
|
||||
| Tpat_or (p1,p2,path) ->
|
||||
|
@ -626,3 +629,31 @@ let rec alpha_pat env p = match p.pat_desc with
|
|||
|
||||
let mkloc = Location.mkloc
|
||||
let mknoloc = Location.mknoloc
|
||||
|
||||
let split_pattern pat =
|
||||
let combine_pattern_desc_opts ~into p1 p2 =
|
||||
match p1, p2 with
|
||||
| None, None -> None
|
||||
| Some p, None
|
||||
| None, Some p ->
|
||||
Some p
|
||||
| Some p1, Some p2 ->
|
||||
(* The third parameter of [Tpat_or] is [Some _] only for "#typ"
|
||||
patterns, which we do *not* expand. Hence we can put [None] here. *)
|
||||
Some { into with pat_desc = Tpat_or (p1, p2, None) }
|
||||
in
|
||||
let rec split_pattern pat =
|
||||
match pat.pat_desc with
|
||||
| Tpat_or (p1, p2, None) ->
|
||||
let vals1, exns1 = split_pattern p1 in
|
||||
let vals2, exns2 = split_pattern p2 in
|
||||
combine_pattern_desc_opts ~into:pat vals1 vals2,
|
||||
(* We could change the pattern type for exception patterns to
|
||||
[Predef.exn], but it doesn't really matter. *)
|
||||
combine_pattern_desc_opts ~into:pat exns1 exns2
|
||||
| Tpat_exception p ->
|
||||
None, Some p
|
||||
| _ ->
|
||||
Some pat, None
|
||||
in
|
||||
split_pattern pat
|
||||
|
|
|
@ -106,6 +106,8 @@ and pattern_desc =
|
|||
*)
|
||||
| Tpat_lazy of pattern
|
||||
(** lazy P *)
|
||||
| Tpat_exception of pattern
|
||||
(** exception P *)
|
||||
|
||||
and expression =
|
||||
{ exp_desc: expression_desc;
|
||||
|
@ -171,13 +173,14 @@ and expression_desc =
|
|||
(Labelled "y", Some (Texp_constant Const_int 3))
|
||||
])
|
||||
*)
|
||||
| Texp_match of expression * case list * case list * partial
|
||||
| Texp_match of expression * case list * partial
|
||||
(** match E0 with
|
||||
| P1 -> E1
|
||||
| P2 -> E2
|
||||
| exception P3 -> E3
|
||||
| P2 | exception P3 -> E2
|
||||
| exception P4 -> E3
|
||||
|
||||
[Texp_match (E0, [(P1, E1); (P2, E2)], [(P3, E3)], _)]
|
||||
[Texp_match (E0, [(P1, E1); (P2 | exception P3, E2);
|
||||
(exception P4, E3)], _)]
|
||||
*)
|
||||
| Texp_try of expression * case list
|
||||
(** try E with P1 -> E1 | ... | PN -> EN *)
|
||||
|
@ -675,3 +678,6 @@ val mkloc: 'a -> Location.t -> 'a Asttypes.loc
|
|||
|
||||
val pat_bound_idents: pattern -> Ident.t list
|
||||
val pat_bound_idents_with_loc: pattern -> (Ident.t * string loc) list
|
||||
|
||||
(** Splits an or pattern into its value (left) and exception (right) parts. *)
|
||||
val split_pattern : pattern -> pattern option * pattern option
|
||||
|
|
|
@ -252,7 +252,8 @@ module MakeIterator(Iter : IteratorArgument) : sig
|
|||
List.iter (fun (_, _, pat) -> iter_pattern pat) list
|
||||
| Tpat_array list -> List.iter iter_pattern list
|
||||
| Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
|
||||
| Tpat_lazy p -> iter_pattern p
|
||||
| Tpat_lazy p
|
||||
| Tpat_exception p -> iter_pattern p
|
||||
end;
|
||||
Iter.leave_pattern pat
|
||||
|
||||
|
@ -286,10 +287,9 @@ module MakeIterator(Iter : IteratorArgument) : sig
|
|||
None -> ()
|
||||
| Some exp -> iter_expression exp
|
||||
) list
|
||||
| Texp_match (exp, list1, list2, _) ->
|
||||
| Texp_match (exp, list, _) ->
|
||||
iter_expression exp;
|
||||
iter_cases list1;
|
||||
iter_cases list2;
|
||||
iter_cases list
|
||||
| Texp_try (exp, list) ->
|
||||
iter_expression exp;
|
||||
iter_cases list
|
||||
|
|
|
@ -257,6 +257,7 @@ module MakeMap(Map : MapArgument) = struct
|
|||
| Tpat_or (p1, p2, rowo) ->
|
||||
Tpat_or (map_pattern p1, map_pattern p2, rowo)
|
||||
| Tpat_lazy p -> Tpat_lazy (map_pattern p)
|
||||
| Tpat_exception p -> Tpat_exception (map_pattern p)
|
||||
| Tpat_constant _
|
||||
| Tpat_any
|
||||
| Tpat_var _ -> pat.pat_desc
|
||||
|
@ -293,11 +294,10 @@ module MakeMap(Map : MapArgument) = struct
|
|||
in
|
||||
(label, expo)
|
||||
) list )
|
||||
| Texp_match (exp, list1, list2, partial) ->
|
||||
| Texp_match (exp, list, partial) ->
|
||||
Texp_match (
|
||||
map_expression exp,
|
||||
map_cases list1,
|
||||
map_cases list2,
|
||||
map_cases list,
|
||||
partial
|
||||
)
|
||||
| Texp_try (exp, list) ->
|
||||
|
|
|
@ -321,6 +321,7 @@ let pattern sub pat =
|
|||
| Tpat_array list -> Ppat_array (List.map (sub.pat sub) list)
|
||||
| Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2)
|
||||
| Tpat_lazy p -> Ppat_lazy (sub.pat sub p)
|
||||
| Tpat_exception p -> Ppat_exception (sub.pat sub p)
|
||||
in
|
||||
Pat.mk ~loc ~attrs desc
|
||||
|
||||
|
@ -392,18 +393,8 @@ let expression sub exp =
|
|||
None -> list
|
||||
| Some exp -> (label, sub.expr sub exp) :: list
|
||||
) list [])
|
||||
| Texp_match (exp, cases, exn_cases, _) ->
|
||||
let merged_cases = sub.cases sub cases
|
||||
@ List.map
|
||||
(fun c ->
|
||||
let uc = sub.case sub c in
|
||||
let pat = { uc.pc_lhs
|
||||
with ppat_desc = Ppat_exception uc.pc_lhs }
|
||||
in
|
||||
{ uc with pc_lhs = pat })
|
||||
exn_cases
|
||||
in
|
||||
Pexp_match (sub.expr sub exp, merged_cases)
|
||||
| Texp_match (exp, cases, _) ->
|
||||
Pexp_match (sub.expr sub exp, sub.cases sub cases)
|
||||
| Texp_try (exp, cases) ->
|
||||
Pexp_try (sub.expr sub exp, sub.cases sub cases)
|
||||
| Texp_tuple list ->
|
||||
|
|
Loading…
Reference in New Issue