diff --git a/src/mlw/dexpr.ml b/src/mlw/dexpr.ml index 689565b528fb54512034b760e44b65393abe85a2..6f94da2a0c3a078d3f615e68edfed5e5c97abb5b 100644 --- a/src/mlw/dexpr.ml +++ b/src/mlw/dexpr.ml @@ -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 diff --git a/src/parser/typing.ml b/src/parser/typing.ml index 5803b1e726c4645e6e74583337151f10cdec7e04..919ac0e460516d0eca13a301a844d48577baf3f8 100644 --- a/src/parser/typing.ml +++ b/src/parser/typing.ml @@ -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