Commit 6ef0273e authored by Guillaume Melquiond's avatar Guillaume Melquiond

Homogenize constructor names.

The pattern-matching construct in the logic is now systematically named
"Tcase" in constructors (Ptree.Tmatch -> Tcase). The one in the
programs (supporting exceptions) is now systematically named "Ematch"
(Expr.Ecase -> Ematch, Dexpr.DEcase -> DEmatch). They are now homogeneous
with the other constructors: Term.Tcase, Dterm.DTcase, Ptree.Ematch,
Mltree.Ematch. Smart constructor Expr.e_case was renamed accordingly.
parent 0b57906c
......@@ -591,37 +591,21 @@ module Translate = struct
let rm_ghost (_, rs, _) = not (rs_ghost rs) in
let al = List.filter rm_ghost al in
ML.e_assign al (Mltree.I e.e_ity) eff lbl
| Ecase (e1, [], xl) when Mxs.is_empty xl ->
| Ematch (e1, [], xl) when Mxs.is_empty xl ->
expr info svar e1.e_mask e1
| Ecase (e1, bl, xl) when e_ghost e1 ->
| Ematch (e1, bl, xl) when e_ghost e1 ->
assert (Mxs.is_empty xl); (* Expr ensures this for the time being *)
(* if [e1] is ghost but the entire [match-with] expression isn't,
it must be the case the first non-absurd branch is irrefutable *)
(match bl with (* FIXME: skip absurd branches *)
| [] -> assert false | (_, e) :: _ -> expr info svar e.e_mask e)
(*
| Ecase (e1, bl) ->
let e1 = expr info svar e1.e_mask e1 in
let bl = List.map (ebranch info svar mask) bl in
ML.e_match e1 bl (Mltree.I e.e_ity) eff lbl
*)
| Ecase (e1, bl, xl) ->
| Ematch (e1, bl, xl) ->
let e1 = expr info svar e1.e_mask e1 in
let bl = List.map (ebranch info svar mask) bl in
(* NOTE: why no pv_list_of_mask here? *)
let mk_xl (xs, (pvl, e)) = xs, pvl, expr info svar mask e in
let xl = List.map mk_xl (Mxs.bindings xl) in
ML.e_match e1 bl xl (Mltree.I e.e_ity) eff lbl
(*
| Etry (etry, _, xl) ->
let etry = expr info svar mask etry in
let mk_xl (xs, (pvl, e)) =
let pvl = pv_list_of_mask pvl xs.xs_mask in
xs, pvl, expr info svar mask e in
let xl = Mxs.bindings xl in
let xl = List.map mk_xl xl in
ML.mk_expr (Mltree.Etry (etry, false, xl)) (Mltree.I e.e_ity) eff lbl
*)
| Eraise (xs, ex) -> let ex = match expr info svar xs.xs_mask ex with
| {Mltree.e_node = Mltree.Eblock []} -> None
| e -> Some e in
......
......@@ -414,7 +414,7 @@ and dexpr_node =
| DEand of dexpr * dexpr
| DEor of dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
| DEcase of dexpr * dreg_branch list * dexn_branch list
| DEmatch of dexpr * dreg_branch list * dexn_branch list
| DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
......@@ -759,9 +759,9 @@ let dexpr ?loc node =
dexpr_expected_type de2 res;
dexpr_expected_type de3 res;
[], res
| DEcase (_,[],[]) ->
invalid_arg "Dexpr.dexpr: empty branch list in DEcase"
| DEcase (de,bl,xl) ->
| DEmatch (_,[],[]) ->
invalid_arg "Dexpr.dexpr: empty branch list in DEmatch"
| DEmatch (de,bl,xl) ->
let res = dity_fresh () in
let ety = if bl = [] then
res else dity_fresh () in
......@@ -1312,7 +1312,7 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
cexp uloc env de (LD (LL old) :: lpl)
| DEvar_pure _ | DEpv_pure _ | DEoptexn _
| DEsym _ | DEconst _ | DEnot _ | DEand _ | DEor _ | DEif _
| DEcase _ | DEassign _ | DEwhile _ | DEfor _ | DEraise _ | DEassert _
| DEmatch _ | DEassign _ | DEwhile _ | DEfor _ | DEraise _ | DEassert _
| DEpure _ | DEabsurd | DEtrue | DEfalse -> assert false (* expr-only *)
| DEcast _ | DEuloc _ | DElabel _ -> assert false (* already stripped *)
......@@ -1381,7 +1381,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
let e = expr uloc env de in
let inv = get_later env dinv in
e_for v e_from dir e_to i (create_invariant inv) e
| DEcase (de1,bl,xl) ->
| DEmatch (de1,bl,xl) ->
let e1 = expr uloc env de1 in
(* regular branches *)
let mask = if env.ghs then MaskGhost else e1.e_mask in
......@@ -1444,8 +1444,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
let bl = if Pattern.is_exhaustive [t] pl then bl else
let _,pp = create_prog_pattern PPwild xs.xs_ity mask in
(pp, e_raise xs e (ity_of_dity res)) :: bl in
vl, e_case e (List.rev bl) Mxs.empty in
e_case e1 (List.rev bl) (Mxs.mapi mk_branch xsm)
vl, e_match e (List.rev bl) Mxs.empty in
e_match e1 (List.rev bl) (Mxs.mapi mk_branch xsm)
| DEraise (xs,de) ->
let {xs_mask = mask} as xs = get_xs env xs in
let env = {env with ugh = mask = MaskGhost} in
......@@ -1473,7 +1473,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
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_case e [] branches)
e_exn xs (e_match e [] branches)
| DEmark (id,de) ->
let env, old = add_label env id.pre_name in
let put _ (ld,_) e = e_let ld e in
......
......@@ -112,7 +112,7 @@ and dexpr_node =
| DEand of dexpr * dexpr
| DEor of dexpr * dexpr
| DEif of dexpr * dexpr * dexpr
| DEcase of dexpr * dreg_branch list * dexn_branch list
| DEmatch of dexpr * dreg_branch list * dexn_branch list
| DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
......
......@@ -322,7 +322,7 @@ and expr_node =
| Eassign of assign list
| Elet of let_defn * expr
| Eif of expr * expr * expr
| Ecase of expr * reg_branch list * exn_branch Mxs.t
| Ematch of expr * reg_branch list * exn_branch Mxs.t
| Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * pvsymbol * invariant list * expr
| Eraise of xsymbol * expr
......@@ -393,7 +393,7 @@ let e_fold fn acc e = match e.e_node with
| Elet ((LDsym _|LDrec _), e) | Eexn (_,e) -> fn acc e
| Elet (LDvar (_,d), e) | Ewhile (d,_,_,e) -> fn (fn acc d) e
| Eif (c,d,e) -> fn (fn (fn acc c) d) e
| Ecase (d,bl,xl) -> Mxs.fold (fun _ (_,e) acc -> fn acc e) xl
| Ematch (d,bl,xl) -> Mxs.fold (fun _ (_,e) acc -> fn acc e) xl
(List.fold_left (fun acc (_,e) -> fn acc e) (fn acc d) bl)
exception FoundExpr of Loc.position option * expr
......@@ -565,7 +565,7 @@ let rec raw_of_expr prop e = match e.e_node with
| _ when ity_equal e.e_ity ity_unit -> t_void
(* we do not check e.e_effect here, since we check the
effects later for the overall expression. The only
effect-hiding construction, Ecase(_,_,xl), is forbidden. *)
effect-hiding construction, Ematch(_,_,xl), is forbidden. *)
| Eassign _ | Ewhile _ | Efor _ | Eassert _ -> assert false
| Evar v -> t_var v.pv_vs
| Econst c -> t_const c (ty_of_ity e.e_ity)
......@@ -596,11 +596,11 @@ let rec raw_of_expr prop e = match e.e_node with
t_or (pure_of_expr true e0) (pure_of_expr true e2)
| Eif (e0,e1,e2) ->
t_if (pure_of_expr true e0) (pure_of_expr prop e1) (pure_of_expr prop e2)
| Ecase (d,bl,xl) when Mxs.is_empty xl ->
| Ematch (d,bl,xl) when Mxs.is_empty xl ->
if bl = [] then pure_of_expr prop d else
let conv (p,e) = t_close_branch p.pp_pat (pure_of_expr prop e) in
t_case (pure_of_expr false d) (List.map conv bl)
| Ecase _ | Eraise _ | Eabsurd -> raise Exit
| Ematch _ | Eraise _ | Eabsurd -> raise Exit
and pure_of_expr prop e = match copy_labels e (raw_of_expr prop e) with
| {t_ty = Some _} as t when prop -> fmla_of_term t
......@@ -653,11 +653,11 @@ let rec post_of_expr res e = match e.e_node with
post_of_term res (pure_of_expr true e)
| Eif (e0,e1,e2) ->
t_if (pure_of_expr true e0) (post_of_expr res e1) (post_of_expr res e2)
| Ecase (d,bl,xl) when Mxs.is_empty xl ->
| Ematch (d,bl,xl) when Mxs.is_empty xl ->
if bl = [] then post_of_expr res d else
let conv (p,e) = t_close_branch p.pp_pat (post_of_expr res e) in
t_case (pure_of_expr false d) (List.map conv bl)
| Ecase _ | Eraise _ -> raise Exit
| Ematch _ | Eraise _ -> raise Exit
| Eabsurd -> copy_labels e t_false
let local_post_of_expr e =
......@@ -935,7 +935,7 @@ let e_while d inv vl e =
(* match-with, try-with, raise *)
let e_case e bl xl =
let e_match e bl xl =
(* return type *)
let ity = match bl with
| (_,d)::_ -> d.e_ity
......@@ -987,7 +987,7 @@ let e_case e bl xl =
let eeff = Mxs.fold (fun xs _ eff -> eff_catch eff xs) xl e.e_effect in
let eff = try_effect (e::dl) eff_union_seq eeff eff in
let eff = try_effect (e::dl) eff_ghostify ghost eff in
mk_expr (Ecase (e,bl,xl)) ity mask eff
mk_expr (Ematch (e,bl,xl)) ity mask eff
let e_raise xs e ity =
ity_equal_check e.e_ity xs.xs_ity;
......@@ -1056,7 +1056,7 @@ let rec e_rs_subst sm e = e_label_copy e (match e.e_node with
| Efor (v,b,i,inv,e) -> e_for_raw v b i inv (e_rs_subst sm e)
| Ewhile (d,inv,vl,e) -> e_while (e_rs_subst sm d) inv vl (e_rs_subst sm e)
| Eraise (xs,d) -> e_raise xs (e_rs_subst sm d) e.e_ity
| Ecase (d,bl,xl) -> e_case (e_rs_subst sm d)
| Ematch (d,bl,xl) -> e_match (e_rs_subst sm d)
(List.map (fun (pp,e) -> pp, e_rs_subst sm e) bl)
(Mxs.map (fun (vl,e) -> vl, e_rs_subst sm e) xl))
......@@ -1387,14 +1387,14 @@ and print_enode pri fmt e = match e.e_node with
fprintf fmt (protect_on (pri > 0) "%a <- %a")
(Pp.print_list Pp.comma print_left) al
(Pp.print_list Pp.comma print_right) al
| Ecase (e,[],xl) ->
| Ematch (e,[],xl) ->
fprintf fmt "try %a with@\n@[<hov>%a@]@\nend" print_expr e
(Pp.print_list Pp.newline (print_xbranch false)) (Mxs.bindings xl)
| Ecase (e0,bl,xl) when Mxs.is_empty xl ->
(* Elet and Ecase are ghost-containers *)
| Ematch (e0,bl,xl) when Mxs.is_empty xl ->
(* Elet and Ematch are ghost-containers *)
fprintf fmt "match %a with@\n@[<hov>%a@]@\nend"
print_expr e0 (Pp.print_list Pp.newline print_branch) bl
| Ecase (e,bl,xl) ->
| Ematch (e,bl,xl) ->
fprintf fmt "match %a with@\n@[<hov>%a@\n%a@]@\nend"
print_expr e (Pp.print_list Pp.newline print_branch) bl
(Pp.print_list Pp.newline (print_xbranch true)) (Mxs.bindings xl)
......
......@@ -129,7 +129,7 @@ and expr_node =
| Eassign of assign list
| Elet of let_defn * expr
| Eif of expr * expr * expr
| Ecase of expr * reg_branch list * exn_branch Mxs.t
| Ematch of expr * reg_branch list * exn_branch Mxs.t
| Ewhile of expr * invariant list * variant list * expr
| Efor of pvsymbol * for_bounds * pvsymbol * invariant list * expr
| Eraise of xsymbol * expr
......@@ -234,7 +234,7 @@ val e_exn : xsymbol -> expr -> expr
val e_raise : xsymbol -> expr -> ity -> expr
val e_case : expr -> reg_branch list -> exn_branch Mxs.t -> expr
val e_match : expr -> reg_branch list -> exn_branch Mxs.t -> expr
val e_while : expr -> invariant list -> variant list -> expr -> expr
......
......@@ -236,7 +236,7 @@ let get_syms node pure =
syms_tl (syms_eity syms d) invl
| Eif (c,d,e) ->
syms_expr (syms_expr (syms_eity syms c) d) e
| Ecase (d,bl,xl) ->
| Ematch (d,bl,xl) ->
(* Dexpr handles this, but not Expr, so we set a failsafe *)
let exhaustive = bl = [] ||
let v = create_vsymbol (id_fresh "x") (ty_of_ity d.e_ity) in
......
......@@ -383,7 +383,7 @@ and p_expr fmt e =
fprintf fmt "@[Elet(%a,@ %a)@]" p_let ldefn p_expr e1
| Erec (_, _) -> fprintf fmt "@[Erec(_,@ _,@ _)@]"
| Eif (_, _, _) -> fprintf fmt "@[Eif(_,@ _,@ _)@]"
| Ecase (_, _) -> fprintf fmt "@[Ecase(_,@ _)@]"
| Ematch (_, _) -> fprintf fmt "@[Ematch(_,@ _)@]"
| Eassign (pls, e1, reg, pvs) ->
fprintf fmt "@[Eassign(%a,@ %a,@ %a,@ %a)@]"
p_pls pls p_expr e1 Ppretty.print_reg reg p_pvs pvs
......@@ -607,7 +607,7 @@ let rec eval_expr env (e : expr) : result =
with
NotNum -> Irred e
end
| Ecase(e0,ebl,el) ->
| Ematch(e0,ebl,el) ->
begin
let r = eval_expr env e0 in
match r with
......
......@@ -764,7 +764,7 @@ let rec clone_expr cl sm e = e_label_copy e (match e.e_node with
e_let ld (clone_expr cl sm e)
| Eif (e1, e2, e3) ->
e_if (clone_expr cl sm e1) (clone_expr cl sm e2) (clone_expr cl sm e3)
| Ecase (d, bl, xl) ->
| Ematch (d, bl, xl) ->
let d = clone_expr cl sm d in
let conv_rbr (pp, e) =
let sm, pp = clone_ppat cl sm pp d.e_mask in
......@@ -773,7 +773,7 @@ let rec clone_expr cl sm e = e_label_copy e (match e.e_node with
let vl' = List.map (clone_pv cl) vl in
let sm = List.fold_left2 sm_save_pv sm vl vl' in
Mxs.add (sm_find_xs sm xs) (vl', clone_expr cl sm e) m in
e_case d (List.map conv_rbr bl) (Mxs.fold conv_xbr xl Mxs.empty)
e_match d (List.map conv_rbr bl) (Mxs.fold conv_xbr xl Mxs.empty)
| Ewhile (c,invl,varl,e) ->
e_while (clone_expr cl sm c) (clone_invl cl sm invl)
(clone_varl cl sm varl) (clone_expr cl sm e)
......
......@@ -695,7 +695,7 @@ let rec k_expr env lps e res xmap =
with Exit -> Ktag (SP, Kif (v, k1, k2))
else Kif (v, k1, k2) in
var_or_proxy e0 kk
| Ecase (e0, bl, xl) ->
| Ematch (e0, bl, xl) ->
(* try-with is just another semicolon *)
let branch xs (vl,e) (xl,xm) =
let i = new_exn env in
......
......@@ -573,7 +573,7 @@ single_term_:
match pat.pat_desc with
| Pvar (id,false) -> Tlet (id, def, $6)
| Pwild -> Tlet (id_anonymous pat.pat_loc, def, $6)
| _ -> Tmatch (def, [pat, $6]) }
| _ -> Tcase (def, [pat, $6]) }
| LET labels(lident_op_id) EQUAL term IN term
{ Tlet ($2, $4, $6) }
| LET labels(lident_nq) mk_term(lam_defn) IN term
......@@ -581,7 +581,7 @@ single_term_:
| LET labels(lident_op_id) mk_term(lam_defn) IN term
{ Tlet ($2, $3, $5) }
| MATCH term WITH match_cases(term) END
{ Tmatch ($2, $4) }
{ Tcase ($2, $4) }
| quant comma_list1(quant_vars) triggers DOT term
{ let l = List.map add_model_labels (List.concat $2) in
Tquant ($1, l, $3, $5) }
......
......@@ -80,7 +80,7 @@ and term_desc =
| Tquant of Dterm.dquant * binder list * term list list * term
| Tnamed of label * term
| Tlet of ident * term * term
| Tmatch of term * (pattern * term) list
| Tcase of term * (pattern * term) list
| Tcast of term * pty
| Ttuple of term list
| Trecord of (qualid * term) list
......
......@@ -290,7 +290,7 @@ let rec dterm ns km crcmap gvars at denv {term_desc = desc; term_loc = loc} =
let denv = denv_add_let denv e1 id in
let e2 = dterm ns km crcmap gvars at denv e2 in
DTlet (e1, id, e2)
| Ptree.Tmatch (e1, bl) ->
| Ptree.Tcase (e1, bl) ->
let e1 = dterm ns km crcmap gvars at denv e1 in
let branch (p, e) =
let p = dpattern ns km p in
......@@ -559,7 +559,7 @@ let dpost muc ql lvm old ity =
let v = create_pvsymbol (id_fresh "result") ity in
let i = { id_str = "(null)"; id_loc = loc; id_lab = [] } in
let t = { term_desc = Tident (Qident i); term_loc = loc } in
let f = { term_desc = Tmatch (t, pfl); term_loc = loc } in
let f = { term_desc = Ptree.Tcase (t, pfl); term_loc = loc } in
let lvm = Mstr.add "(null)" v lvm in
v, Loc.try3 ~loc type_fmla muc lvm old f in
List.map dpost ql
......@@ -690,7 +690,7 @@ let rec eff_dterm muc denv {term_desc = desc; term_loc = loc} =
DEcast (d1, dity_of_pty muc pty)
| Ptree.Tat _ -> Loc.errorm ~loc "`at' and `old' cannot be used here"
| Ptree.Tidapp _ | Ptree.Tconst _ | Ptree.Tinfix _ | Ptree.Tinnfix _
| Ptree.Ttuple _ | Ptree.Tlet _ | Ptree.Tmatch _ | Ptree.Tif _
| Ptree.Ttuple _ | Ptree.Tlet _ | Ptree.Tcase _ | Ptree.Tif _
| Ptree.Ttrue | Ptree.Tfalse | Ptree.Tnot _ | Ptree.Tbinop _ | Ptree.Tbinnop _
| Ptree.Tquant _ | Ptree.Trecord _ | Ptree.Tupdate _ ->
Loc.errorm ~loc "unsupported effect expression")
......@@ -848,7 +848,7 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
let denv = denv_add_pat denv pp in
let e = dexpr muc denv e in
xs, pp, e in
DEcase (e1, List.map rbranch bl, List.map xbranch xl)
DEmatch (e1, List.map rbranch bl, List.map xbranch xl)
| Ptree.Eif (e1, e2, e3) ->
let e1 = dexpr muc denv e1 in
let e2 = dexpr muc denv e2 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