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

allow exceptions under or-patterns

master
Thomas Refis 2018-01-15 11:11:06 +00:00
parent 4cb30bb7e9
commit 369ea5f432
15 changed files with 276 additions and 132 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
bytecomp/matching.ml
View File

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

107
bytecomp/translcore.ml
View File

@ -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
match arg, exn_cases with
| {exp_desc = Texp_tuple argl}, [] ->
Matching.for_multiple_match e.exp_loc (transl_list argl) 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)
| arg, [] ->
Matching.for_function e.exp_loc None (transl_exp arg) cases partial
| arg, _ :: _ ->
let val_id = Typecore.name_pattern "val" pat_expr_list in
static_catch [transl_exp arg] [val_id]
(Matching.for_function e.exp_loc None (Lvar val_id) cases partial)
let classic =
match arg, exn_cases with
| {exp_desc = Texp_tuple argl}, [] ->
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 val_cases partial)
| arg, [] ->
assert (static_handlers = []);
Matching.for_function e.exp_loc None (transl_exp arg) val_cases partial
| arg, _ :: _ ->
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) 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 *)

5
tools/cmt2annot.ml
View File

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

28
typing/parmatch.ml
View File

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

2
typing/printpat.ml
View File

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

8
typing/printtyped.ml
View File

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

8
typing/rec_check.ml
View File

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

4
typing/tast_mapper.ml
View File

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

159
typing/typecore.ml
View File

@ -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,11 +2090,14 @@ let proper_exp_loc exp =
let rec name_pattern default = function
[] -> Ident.create default
| {c_lhs=p; _} :: rem ->
match p.pat_desc with
Tpat_var (id, _) -> id
| Tpat_alias(_, id, _) -> id
| _ -> name_pattern default 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 *)
@ -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 \

7
typing/typecore.mli
View File

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

33
typing/typedtree.ml
View File

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

14
typing/typedtree.mli
View File

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

8
typing/typedtreeIter.ml
View File

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

6
typing/typedtreeMap.ml
View File

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

15
typing/untypeast.ml
View File

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