Commit b9c0ca44 authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: return passes across the abstract blocks

In this way, someone who puts a part of his function
in an abstract block will not have broken "return"s.
parent e132791e
......@@ -1109,6 +1109,21 @@ type let_prexix =
| LD of let_defn
| EA of expr
let vl_of_mask id mask ity =
let mk_res m t = create_pvsymbol id ~ghost:(mask_ghost m) t in
if ity_equal ity ity_unit then [] else
match mask, ity.ity_node with
| MaskTuple ml, Ityapp (_,tl,_) -> List.map2 mk_res ml tl
| _ -> [mk_res mask ity]
let t_of_vl = function
| [] -> t_void | [v] -> t_var v.pv_vs
| vl -> t_tuple (List.map (fun v -> t_var v.pv_vs) vl)
let e_of_vl = function
| [] -> e_void | [v] -> e_var v
| vl -> e_tuple (List.map e_var vl)
let rec expr uloc env ({de_loc = loc} as de) =
let uloc, labs, de = strip uloc Slab.empty de in
let env = {env with lgh = false; cgh = false} in
......@@ -1331,21 +1346,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
List.map2 conv_simple pl (List.combine tyl ghl), e
| bl ->
let mask = if env.ghs then MaskGhost else xs.xs_mask in
let id = id_fresh "q" in
let vl = match mask with
| _ when ity_equal xs.xs_ity ity_unit -> []
| MaskGhost -> [create_pvsymbol id ~ghost:true xs.xs_ity]
| MaskVisible -> [create_pvsymbol id ~ghost:false xs.xs_ity]
| MaskTuple ml ->
let mk_var ity m =
create_pvsymbol id ~ghost:(mask_ghost m) ity in
let tyl = match xs.xs_ity.ity_node with (* tuple *)
| Ityapp (_,tyl,_) -> tyl | _ -> assert false in
List.map2 mk_var tyl ml in
let t, e = match vl with
| [] -> t_void, e_void | [v] -> t_var v.pv_vs, e_var v
| vl -> t_tuple (List.map (fun v -> t_var v.pv_vs) vl),
e_tuple (List.map e_var vl) in
let vl = vl_of_mask (id_fresh "q") mask xs.xs_ity in
let t = t_of_vl vl and e = e_of_vl vl in
let pl = List.rev_map (fun (p,_) -> [p.pp_pat]) bl in
let bl = if Pattern.is_exhaustive [t] pl then bl else
let _,pp = create_prog_pattern PPwild xs.xs_ity mask in
......@@ -1437,21 +1439,14 @@ and lambda uloc env pvl mask dsp dvl de =
let env = add_binders env pvl in
let preold = Mstr.find_opt old_mark env.old in
let env, old = add_label env old_mark in
let ity = ity_of_dity (dity_of_dvty de.de_dvty) in
let xs = create_xsymbol old_mark_id ~mask ity in
let e = expr uloc (add_xsymbol env xs) de in
let e = if Sxs.mem xs e.e_effect.eff_raises then
let mk_res n m ity =
create_pvsymbol (id_fresh n) ~ghost:(mask_ghost m) ity in
let vl = match mask, xs.xs_ity.ity_node with
| MaskTuple ml, Ityapp (_, tyl, _) ->
List.map2 (mk_res "r") ml tyl
| _ -> [mk_res "result" mask ity] in
let el = match vl with
| [v] -> e_var v | _ -> e_tuple (List.map e_var vl) in
(* exception 'Old cannot be catched in the surface language,
so we only declare the exception when 'Old is raised *)
e_exn xs (e_try e (Mxs.singleton xs (vl, el))) else e in
let e = if pvl = [] then expr uloc env de else
let ity = ity_of_dity (dity_of_dvty de.de_dvty) in
let xs = create_xsymbol old_mark_id ~mask ity in
let e = expr uloc (add_xsymbol env xs) de in
if not (Sxs.mem xs e.e_effect.eff_raises) then e else
let vl = vl_of_mask (id_fresh "r") mask xs.xs_ity in
let branches = Mxs.singleton xs (vl, e_of_vl vl) in
e_exn xs (e_try e branches) in
let dsp = get_later env dsp e.e_ity in
let dvl = get_later env dvl in
let dvl = rebase_variant env preold old dvl in
......
......@@ -675,7 +675,8 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
| _ -> dspec muc sp in
let dity = dity_of_opt muc pty in
let denv = denv_add_args denv bl in
let denv = denv_add_exn denv old_mark_id dity in
let denv = if bl = [] then denv else
denv_add_exn denv old_mark_id dity in
DEfun (bl, dity, msk, ds, dexpr muc denv e)
| Ptree.Eany (pl, kind, pty, msk, sp) ->
let pl = List.map (dparam muc) pl in
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment