Commit b3a73a61 authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: local exceptions in the surface language

current syntax is

    exception Return (int, ghost bool) in
    ...
    try
      ...
      raise Return (5, false)
      ...
    with
      Return (i, b) -> ...
    ...

These exceptions can carry mutable and non-monomorphic values.
They can be raised from local functions defined in the scope
of the exception declaration.
parent 53b3ec88
...@@ -372,7 +372,7 @@ type dbinder = preid option * ghost * dity ...@@ -372,7 +372,7 @@ type dbinder = preid option * ghost * dity
type register_old = pvsymbol -> string -> pvsymbol type register_old = pvsymbol -> string -> pvsymbol
type 'a later = pvsymbol Mstr.t -> register_old -> 'a type 'a later = pvsymbol Mstr.t -> xsymbol Mstr.t -> register_old -> 'a
(* specification terms are parsed and typechecked after the program (* specification terms are parsed and typechecked after the program
expressions, when the types of locally bound program variables are expressions, when the types of locally bound program variables are
already established. *) already established. *)
...@@ -397,6 +397,10 @@ type dspec = ity -> dspec_final ...@@ -397,6 +397,10 @@ type dspec = ity -> dspec_final
type dinvariant = term list type dinvariant = term list
type dxsymbol =
| DElexn of string * dity
| DEgexn of xsymbol
type dexpr = { type dexpr = {
de_node : dexpr_node; de_node : dexpr_node;
de_dvty : dvty; de_dvty : dvty;
...@@ -421,9 +425,10 @@ and dexpr_node = ...@@ -421,9 +425,10 @@ and dexpr_node =
| DEassign of (dexpr * rsymbol * dexpr) list | DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr | DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr | DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list | DEtry of dexpr * (dxsymbol * dpattern * dexpr) list
| DEraise of xsymbol * dexpr | DEraise of dxsymbol * dexpr
| DEghost of dexpr | DEghost of dexpr
| DEexn of preid * dity * mask * dexpr
| DEassert of assertion_kind * term later | DEassert of assertion_kind * term later
| DEpure of term later * dity | DEpure of term later * dity
| DEabsurd | DEabsurd
...@@ -446,11 +451,12 @@ and dfun_defn = preid * ghost * rs_kind * ...@@ -446,11 +451,12 @@ and dfun_defn = preid * ghost * rs_kind *
type denv = { type denv = {
frozen : dity list; frozen : dity list;
locals : (Stv.t option * dvty) Mstr.t; locals : (Stv.t option * dvty) Mstr.t;
excpts : dxsymbol Mstr.t
} }
let denv_contents d = d.locals let denv_contents d = d.locals
let denv_empty = { frozen = []; locals = Mstr.empty } let denv_empty = { frozen = []; locals = Mstr.empty; excpts = Mstr.empty }
let is_frozen frozen v = let is_frozen frozen v =
try List.iter (occur_check v) frozen; false with Exit -> true try List.iter (occur_check v) frozen; false with Exit -> true
...@@ -473,25 +479,27 @@ let free_vars frozen (argl,res) = ...@@ -473,25 +479,27 @@ let free_vars frozen (argl,res) =
| Dapp (_,tl,_) -> List.fold_left add s tl in | Dapp (_,tl,_) -> List.fold_left add s tl in
List.fold_left add (add Stv.empty res) argl List.fold_left add (add Stv.empty res) argl
let denv_add_mono { frozen = frozen; locals = locals } id dvty = let denv_add_exn { frozen = fz; locals = ls; excpts = xs } id dity =
let locals = Mstr.add id.pre_name (None, dvty) locals in let xs = Mstr.add id.pre_name (DElexn (id.pre_name, dity)) xs in
{ frozen = freeze_dvty frozen dvty; locals = locals } { frozen = freeze_dvty fz ([], dity); locals = ls; excpts = xs }
let denv_add_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let ls = Mstr.add id.pre_name (None, dvty) ls in
{ frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_poly { frozen = frozen; locals = locals } id dvty = let denv_add_poly { frozen = fz; locals = ls; excpts = xs } id dvty =
let ftvs = free_vars frozen dvty in let ls = Mstr.add id.pre_name (Some (free_vars fz dvty), dvty) ls in
let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in { frozen = fz; locals = ls; excpts = xs }
{ frozen = frozen; locals = locals }
let denv_add_rec_mono { frozen = frozen; locals = locals } id dvty = let denv_add_rec_mono { frozen = fz; locals = ls; excpts = xs } id dvty =
let locals = Mstr.add id.pre_name (Some Stv.empty, dvty) locals in let ls = Mstr.add id.pre_name (Some Stv.empty, dvty) ls in
{ frozen = freeze_dvty frozen dvty; locals = locals } { frozen = freeze_dvty fz dvty; locals = ls; excpts = xs }
let denv_add_rec_poly { frozen = frozen; locals = locals } frozen0 id dvty = let denv_add_rec_poly { frozen = fz; locals = ls; excpts = xs } fz0 id dvty =
let ftvs = free_vars frozen0 dvty in let ls = Mstr.add id.pre_name (Some (free_vars fz0 dvty), dvty) ls in
let locals = Mstr.add id.pre_name (Some ftvs, dvty) locals in { frozen = fz; locals = ls; excpts = xs }
{ frozen = frozen; locals = locals }
let denv_add_rec denv frozen0 id ((argl,res) as dvty) = let denv_add_rec denv fz0 id ((argl,res) as dvty) =
let rec is_explicit = function let rec is_explicit = function
| Dvar {contents = (Dval d|Dpur d|Dsim (d,_)|Dreg (d,_))} | Dvar {contents = (Dval d|Dpur d|Dsim (d,_)|Dreg (d,_))}
| Durg (d,_) -> is_explicit d | Durg (d,_) -> is_explicit d
...@@ -499,7 +507,7 @@ let denv_add_rec denv frozen0 id ((argl,res) as dvty) = ...@@ -499,7 +507,7 @@ let denv_add_rec denv frozen0 id ((argl,res) as dvty) =
| Dutv _ -> true | Dutv _ -> true
| Dapp (_,tl,_) -> List.for_all is_explicit tl in | Dapp (_,tl,_) -> List.for_all is_explicit tl in
if List.for_all is_explicit argl && is_explicit res if List.for_all is_explicit argl && is_explicit res
then denv_add_rec_poly denv frozen0 id dvty then denv_add_rec_poly denv fz0 id dvty
else denv_add_rec_mono denv id dvty else denv_add_rec_mono denv id dvty
let denv_add_var denv id dity = denv_add_mono denv id ([], dity) let denv_add_var denv id dity = denv_add_mono denv id ([], dity)
...@@ -514,19 +522,19 @@ let denv_add_let denv (id,_,_,({de_dvty = dvty} as de)) = ...@@ -514,19 +522,19 @@ let denv_add_let denv (id,_,_,({de_dvty = dvty} as de)) =
then denv_add_poly denv id dvty then denv_add_poly denv id dvty
else denv_add_mono denv id dvty else denv_add_mono denv id dvty
let denv_add_args { frozen = frozen; locals = locals } bl = let denv_add_args { frozen = fz; locals = ls; excpts = xs } bl =
let l = List.fold_left (fun l (_,_,t) -> t::l) frozen bl in let l = List.fold_left (fun l (_,_,t) -> t::l) fz bl in
let add s (id,_,t) = match id with let add s (id,_,t) = match id with
| Some {pre_name = n} -> | Some {pre_name = n} ->
Mstr.add_new (Dterm.DuplicateVar n) n (None, ([],t)) s Mstr.add_new (Dterm.DuplicateVar n) n (None, ([],t)) s
| None -> s in | None -> s in
let s = List.fold_left add Mstr.empty bl in let s = List.fold_left add Mstr.empty bl in
{ frozen = l; locals = Mstr.set_union s locals } { frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let denv_add_pat { frozen = frozen; locals = locals } dp = let denv_add_pat { frozen = fz; locals = ls; excpts = xs } dp =
let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars frozen in let l = Mstr.fold (fun _ t l -> t::l) dp.dp_vars fz in
let s = Mstr.map (fun t -> None, ([], t)) dp.dp_vars in let s = Mstr.map (fun t -> None, ([], t)) dp.dp_vars in
{ frozen = l; locals = Mstr.set_union s locals } { frozen = l; locals = Mstr.set_union s ls; excpts = xs }
let mk_node n = function let mk_node n = function
| Some tvs, dvty -> DEvar (n, specialize_scheme tvs dvty) | Some tvs, dvty -> DEvar (n, specialize_scheme tvs dvty)
...@@ -538,6 +546,12 @@ let denv_get denv n = ...@@ -538,6 +546,12 @@ let denv_get denv n =
let denv_get_opt denv n = let denv_get_opt denv n =
Opt.map (mk_node n) (Mstr.find_opt n denv.locals) Opt.map (mk_node n) (Mstr.find_opt n denv.locals)
exception UnboundExn of string
let denv_get_exn denv n = Mstr.find_exn (UnboundExn n) n denv.excpts
let denv_get_exn_opt denv n = Mstr.find_opt n denv.excpts
let denv_pure denv get_dty = let denv_pure denv get_dty =
let ht = Htv.create 3 in let ht = Htv.create 3 in
let hi = Hint.create 3 in let hi = Hint.create 3 in
...@@ -657,6 +671,10 @@ let dpattern ?loc node = ...@@ -657,6 +671,10 @@ let dpattern ?loc node =
in in
Loc.try1 ?loc dpat node Loc.try1 ?loc dpat node
let specialize_dxs = function
| DEgexn xs -> specialize_xs xs
| DElexn (_,dity) -> dity
let dexpr ?loc node = let dexpr ?loc node =
let get_dvty = function let get_dvty = function
| DEvar (_,dvty) -> | DEvar (_,dvty) ->
...@@ -749,12 +767,13 @@ let dexpr ?loc node = ...@@ -749,12 +767,13 @@ let dexpr ?loc node =
let res = dity_fresh () in let res = dity_fresh () in
dexpr_expected_type de res; dexpr_expected_type de res;
List.iter (fun (xs,dp,de) -> List.iter (fun (xs,dp,de) ->
dpat_expected_type dp (specialize_xs xs); dpat_expected_type dp (specialize_dxs xs);
dexpr_expected_type de res) bl; dexpr_expected_type de res) bl;
[], res [], res
| DEraise (xs,de) -> | DEraise (xs,de) ->
dexpr_expected_type de (specialize_xs xs); dexpr_expected_type de (specialize_dxs xs);
[], dity_fresh () [], dity_fresh ()
| DEexn (_,_,_,de)
| DEghost de -> | DEghost de ->
de.de_dvty de.de_dvty
| DEassert _ -> | DEassert _ ->
...@@ -902,10 +921,17 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) = ...@@ -902,10 +921,17 @@ let check_spec inr dsp ecty ({e_loc = loc} as e) =
let check_aliases recu c = let check_aliases recu c =
let rds_regs = c.cty_freeze.isb_reg in let rds_regs = c.cty_freeze.isb_reg in
let report r _ _ = let report r _ _ =
if Mreg.mem r rds_regs then let spv = Spv.filter if Mreg.mem r rds_regs then
let spv = Spv.filter
(fun v -> ity_r_occurs r v.pv_ity) (cty_reads c) in (fun v -> ity_r_occurs r v.pv_ity) (cty_reads c) in
Loc.errorm "The type of this function contains an alias with \ if not (Spv.is_empty spv) then Loc.errorm
external variable %a" print_pv (Spv.choose spv) "The type of this function contains an alias with \
external variable %a" print_pv (Spv.choose spv);
let sxs = Sxs.filter
(fun xs -> ity_r_occurs r xs.xs_ity) (c.cty_effect.eff_raises) in
Loc.errorm
"The type of this function contains an alias with \
external local exception %a" print_xs (Sxs.choose sxs)
else Loc.errorm "The type of this function contains an alias" in else Loc.errorm "The type of this function contains an alias" in
(* we allow the value in a non-recursive function to contain (* we allow the value in a non-recursive function to contain
regions coming the function's arguments, but not from the regions coming the function's arguments, but not from the
...@@ -938,6 +964,7 @@ let check_fun inr rsym dsp e = ...@@ -938,6 +964,7 @@ let check_fun inr rsym dsp e =
type env = { type env = {
rsm : rsymbol Mstr.t; rsm : rsymbol Mstr.t;
pvm : pvsymbol Mstr.t; pvm : pvsymbol Mstr.t;
xsm : xsymbol Mstr.t;
old : (pvsymbol Mstr.t * (let_defn * pvsymbol) Hpv.t) Mstr.t; old : (pvsymbol Mstr.t * (let_defn * pvsymbol) Hpv.t) Mstr.t;
ghs : bool; (* we are under DEghost or in a ghost function *) ghs : bool; (* we are under DEghost or in a ghost function *)
lgh : bool; (* we are under let ghost c = <cexp> *) lgh : bool; (* we are under let ghost c = <cexp> *)
...@@ -948,6 +975,7 @@ type env = { ...@@ -948,6 +975,7 @@ type env = {
let env_empty = { let env_empty = {
rsm = Mstr.empty; rsm = Mstr.empty;
pvm = Mstr.empty; pvm = Mstr.empty;
xsm = Mstr.empty;
old = Mstr.empty; old = Mstr.empty;
ghs = false; ghs = false;
lgh = false; lgh = false;
...@@ -978,7 +1006,7 @@ let find_old pvm (ovm,old) v = ...@@ -978,7 +1006,7 @@ let find_old pvm (ovm,old) v =
let register_old env v l = let register_old env v l =
find_old env.pvm (Mstr.find_exn (UnboundLabel l) l env.old) v find_old env.pvm (Mstr.find_exn (UnboundLabel l) l env.old) v
let get_later env later = later env.pvm (register_old env) let get_later env later = later env.pvm env.xsm (register_old env)
let add_label ({pvm = pvm; old = old} as env) l = let add_label ({pvm = pvm; old = old} as env) l =
let ht = Hpv.create 3 in let ht = Hpv.create 3 in
...@@ -1064,6 +1092,10 @@ let rec strip uloc labs de = match de.de_node with ...@@ -1064,6 +1092,10 @@ let rec strip uloc labs de = match de.de_node with
let get_pv env n = Mstr.find_exn (Dterm.UnboundVar n) n env.pvm let get_pv env n = Mstr.find_exn (Dterm.UnboundVar n) n env.pvm
let get_rs env n = Mstr.find_exn (Dterm.UnboundVar n) n env.rsm let get_rs env n = Mstr.find_exn (Dterm.UnboundVar n) n env.rsm
let get_xs env = function
| DElexn (n,_) -> Mstr.find_exn (UnboundExn n) n env.xsm
| DEgexn xs -> xs
let proxy_labels = Slab.singleton proxy_label let proxy_labels = Slab.singleton proxy_label
type let_prexix = type let_prexix =
...@@ -1156,7 +1188,7 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl = ...@@ -1156,7 +1188,7 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
we must ghostify the let-definitions down from here *) we must ghostify the let-definitions down from here *)
cexp uloc {env with ghs = true; cgh = env.cgh || not env.ghs} de lpl cexp uloc {env with ghs = true; cgh = env.cgh || not env.ghs} de lpl
| DEfun (bl,msk,dsp,de) -> | DEfun (bl,msk,dsp,de) ->
let dvl _ _ = [] in let dvl _ _ _ = [] in
let env = {env with ghs = env.ghs || env.lgh} in let env = {env with ghs = env.ghs || env.lgh} in
let c, dsp, _ = lambda uloc env (binders env.ghs bl) msk dsp dvl de in let c, dsp, _ = lambda uloc env (binders env.ghs bl) msk dsp dvl de in
check_fun env.inr None dsp c; check_fun env.inr None dsp c;
...@@ -1174,8 +1206,12 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl = ...@@ -1174,8 +1206,12 @@ and try_cexp uloc env ({de_dvty = argl,res} as de0) lpl =
| DErec (drdf,de) -> | DErec (drdf,de) ->
let ld, env = rec_defn uloc env drdf in let ld, env = rec_defn uloc env drdf in
cexp uloc env de (LD ld :: lpl) cexp uloc env de (LD ld :: lpl)
| DEexn _ ->
Loc.errorm "Local exception declarations are not allowed \
over higher-order expressions"
| DEmark _ -> | DEmark _ ->
Loc.errorm "Marks are not allowed over higher-order expressions" Loc.errorm "Label declarations are not allowed \
over higher-order expressions"
| DEsym _ | DEconst _ | DEnot _ | DEand _ | DEor _ | DEif _ | DEcase _ | DEsym _ | DEconst _ | DEnot _ | DEand _ | DEor _ | DEif _ | DEcase _
| DEassign _ | DEwhile _ | DEfor _ | DEtry _ | DEraise _ | DEassert _ | DEassign _ | DEwhile _ | DEfor _ | DEtry _ | DEraise _ | DEassert _
| DEpure _ | DEabsurd | DEtrue | DEfalse -> assert false (* expr-only *) | DEpure _ | DEabsurd | DEtrue | DEfalse -> assert false (* expr-only *)
...@@ -1187,8 +1223,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1187,8 +1223,8 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
e_var (get_pv env n) e_var (get_pv env n)
| DEsym (PV v) -> | DEsym (PV v) ->
e_var v e_var v
| DEconst(c,dity) -> | DEconst (c,dity) ->
e_const c (ity_of_dity dity) e_const c (ity_of_dity dity)
| DEapp ({de_dvty = ([],_)} as de1, de2) -> | DEapp ({de_dvty = ([],_)} as de1, de2) ->
let e1 = expr uloc env de1 in let e1 = expr uloc env de1 in
let e2 = expr uloc env de2 in let e2 = expr uloc env de2 in
...@@ -1254,6 +1290,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1254,6 +1290,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
| DEtry (de1,bl) -> | DEtry (de1,bl) ->
let e1 = expr uloc env de1 in let e1 = expr uloc env de1 in
let add_branch m (xs,dp,de) = let add_branch m (xs,dp,de) =
let xs = get_xs env xs in
let mask = if env.ghs then MaskGhost else xs.xs_mask in let mask = if env.ghs then MaskGhost else xs.xs_mask in
let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity mask in let vm, pat = create_prog_pattern dp.dp_pat xs.xs_ity mask in
let e = expr uloc (add_pv_map env vm) de in let e = expr uloc (add_pv_map env vm) de in
...@@ -1309,7 +1346,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1309,7 +1346,7 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
vl, e_case e (List.rev bl) in vl, e_case e (List.rev bl) in
e_try e1 (Mxs.mapi mk_branch xsm) e_try e1 (Mxs.mapi mk_branch xsm)
| DEraise (xs,de) -> | DEraise (xs,de) ->
e_raise xs (expr uloc env de) (ity_of_dity res) e_raise (get_xs env xs) (expr uloc env de) (ity_of_dity res)
| DEghost de -> | DEghost de ->
e_ghostify true (expr uloc {env with ghs = true} de) e_ghostify true (expr uloc {env with ghs = true} de)
| DEassert (ak,f) -> | DEassert (ak,f) ->
...@@ -1322,6 +1359,10 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) = ...@@ -1322,6 +1359,10 @@ and try_expr uloc env ({de_dvty = argl,res} as de0) =
e_true e_true
| DEfalse -> | DEfalse ->
e_false e_false
| DEexn (id,dity,mask,de) ->
let xs = create_xsymbol id ~mask (ity_of_dity dity) in
let env = { env with xsm = Mstr.add id.pre_name xs env.xsm } in
e_exn xs (expr uloc env de)
| DEmark ({pre_name = l},de) -> | DEmark ({pre_name = l},de) ->
let env, old = add_label env l in let env, old = add_label env l in
let put _ (ld,_) e = e_let ld e in let put _ (ld,_) e = e_let ld e in
...@@ -1449,4 +1490,6 @@ let expr ?(keep_loc=true) de = ...@@ -1449,4 +1490,6 @@ let expr ?(keep_loc=true) de =
let () = Exn_printer.register (fun fmt e -> match e with let () = Exn_printer.register (fun fmt e -> match e with
| UnboundLabel s -> | UnboundLabel s ->
Format.fprintf fmt "unbound label %s" s Format.fprintf fmt "unbound label %s" s
| UnboundExn s ->
Format.fprintf fmt "unbound exception %s" s
| _ -> raise e) | _ -> raise e)
...@@ -62,7 +62,7 @@ type register_old = pvsymbol -> string -> pvsymbol ...@@ -62,7 +62,7 @@ type register_old = pvsymbol -> string -> pvsymbol
(** Program variables occurring under [old] or [at] are passed to (** Program variables occurring under [old] or [at] are passed to
a registrar function. The label string must be ["0"] for [old]. *) a registrar function. The label string must be ["0"] for [old]. *)
type 'a later = pvsymbol Mstr.t -> register_old -> 'a type 'a later = pvsymbol Mstr.t -> xsymbol Mstr.t -> register_old -> 'a
(** Specification terms are parsed and typechecked after the program (** Specification terms are parsed and typechecked after the program
expressions, when the types of locally bound program variables are expressions, when the types of locally bound program variables are
already established. *) already established. *)
...@@ -87,6 +87,10 @@ type dspec = ity -> dspec_final ...@@ -87,6 +87,10 @@ type dspec = ity -> dspec_final
type dinvariant = term list type dinvariant = term list
type dxsymbol =
| DElexn of string * dity
| DEgexn of xsymbol
type dexpr = private { type dexpr = private {
de_node : dexpr_node; de_node : dexpr_node;
de_dvty : dvty; de_dvty : dvty;
...@@ -111,9 +115,10 @@ and dexpr_node = ...@@ -111,9 +115,10 @@ and dexpr_node =
| DEassign of (dexpr * rsymbol * dexpr) list | DEassign of (dexpr * rsymbol * dexpr) list
| DEwhile of dexpr * dinvariant later * variant list later * dexpr | DEwhile of dexpr * dinvariant later * variant list later * dexpr
| DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr | DEfor of preid * dexpr * for_direction * dexpr * dinvariant later * dexpr
| DEtry of dexpr * (xsymbol * dpattern * dexpr) list | DEtry of dexpr * (dxsymbol * dpattern * dexpr) list
| DEraise of xsymbol * dexpr | DEraise of dxsymbol * dexpr
| DEghost of dexpr | DEghost of dexpr
| DEexn of preid * dity * mask * dexpr
| DEassert of assertion_kind * term later | DEassert of assertion_kind * term later
| DEpure of term later * dity | DEpure of term later * dity
| DEabsurd | DEabsurd
...@@ -145,10 +150,16 @@ val denv_add_args : denv -> dbinder list -> denv ...@@ -145,10 +150,16 @@ val denv_add_args : denv -> dbinder list -> denv
val denv_add_pat : denv -> dpattern -> denv val denv_add_pat : denv -> dpattern -> denv
val denv_add_exn : denv -> preid -> dity -> denv
val denv_get : denv -> string -> dexpr_node (** raises UnboundVar *) val denv_get : denv -> string -> dexpr_node (** raises UnboundVar *)
val denv_get_opt : denv -> string -> dexpr_node option val denv_get_opt : denv -> string -> dexpr_node option
val denv_get_exn : denv -> string -> dxsymbol (** raises Not_found *)
val denv_get_exn_opt : denv -> string -> dxsymbol option
val denv_contents : denv -> (Ty.Stv.t option * dvty) Mstr.t val denv_contents : denv -> (Ty.Stv.t option * dvty) Mstr.t
val denv_pure : denv -> (Dterm.denv -> Dterm.dty) -> dity val denv_pure : denv -> (Dterm.denv -> Dterm.dty) -> dity
......
...@@ -160,7 +160,7 @@ ...@@ -160,7 +160,7 @@
%nonassoc IN %nonassoc IN
%nonassoc below_SEMI %nonassoc below_SEMI
%nonassoc SEMICOLON %nonassoc SEMICOLON
%nonassoc LET VAL %nonassoc LET VAL EXCEPTION
%nonassoc prec_no_else %nonassoc prec_no_else
%nonassoc DOT ELSE GHOST %nonassoc DOT ELSE GHOST
%nonassoc prec_named %nonassoc prec_named
...@@ -759,6 +759,10 @@ expr_: ...@@ -759,6 +759,10 @@ expr_:
{ Ematch ($2, $4) } { Ematch ($2, $4) }
| MATCH comma_list2(expr) WITH match_cases(seq_expr) END | MATCH comma_list2(expr) WITH match_cases(seq_expr) END
{ Ematch (mk_expr (Etuple $2) $startpos($2) $endpos($2), $4) } { Ematch (mk_expr (Etuple $2) $startpos($2) $endpos($2), $4) }
| EXCEPTION labels(uident) IN seq_expr
{ Eexn ($2, PTtuple [], Ity.MaskVisible, $4) }
| EXCEPTION labels(uident) return IN seq_expr
{ Eexn ($2, fst $3, snd $3, $5) }
| LABEL labels(uident) IN seq_expr | LABEL labels(uident) IN seq_expr
{ Emark ($2, $4) } { Emark ($2, $4) }
| WHILE seq_expr DO loop_annotation seq_expr DONE | WHILE seq_expr DO loop_annotation seq_expr DONE
......
...@@ -141,6 +141,7 @@ and expr_desc = ...@@ -141,6 +141,7 @@ and expr_desc =
| Eabsurd | Eabsurd
| Epure of term | Epure of term
| Eraise of qualid * expr option | Eraise of qualid * expr option
| Eexn of ident * pty * Ity.mask * expr
| Etry of expr * (qualid * pattern option * expr) list | Etry of expr * (qualid * pattern option * expr) list
| Efor of ident * expr * Expr.for_direction * expr * invariant * expr | Efor of ident * expr * Expr.for_direction * expr * invariant * expr
(* annotations *) (* annotations *)
......
...@@ -486,9 +486,13 @@ let dpost muc ql lvm old ity = ...@@ -486,9 +486,13 @@ let dpost muc ql lvm old ity =
v, Loc.try3 ~loc type_fmla muc lvm old f in v, Loc.try3 ~loc type_fmla muc lvm old f in
List.map dpost ql List.map dpost ql
let dxpost muc ql lvm old = let dxpost muc ql lvm xsm old =
let add_exn (q,pf) m = let add_exn (q,pf) m =
let xs = find_xsymbol muc q in let xs = match q with
| Qident i ->
begin try Mstr.find i.id_str xsm with
| Not_found -> find_xsymbol muc q end
| _ -> find_xsymbol muc q in
Mxs.change (fun l -> match pf, l with Mxs.change (fun l -> match pf, l with
| Some pf, Some l -> Some (pf :: l) | Some pf, Some l -> Some (pf :: l)
| Some pf, None -> Some (pf :: []) | Some pf, None -> Some (pf :: [])
...@@ -519,23 +523,23 @@ let find_variant_ls muc q = match find_lsymbol muc.muc_theory q with ...@@ -519,23 +523,23 @@ let find_variant_ls muc q = match find_lsymbol muc.muc_theory q with
| { ls_args = [u;v]; ls_value = None } as ls when ty_equal u v -> ls | { ls_args = [u;v]; ls_value = None } as ls when ty_equal u v -> ls
| s -> Loc.errorm ~loc:(qloc q) "Not an order relation: %a" Pretty.print_ls s | s -> Loc.errorm ~loc:(qloc q) "Not an order relation: %a" Pretty.print_ls s
let dvariant muc varl lvm old = let dvariant muc varl lvm _xsm old =
let dvar t = type_term muc lvm old t in let dvar t = type_term muc lvm old t in
let dvar (t,q) = dvar t, Opt.map (find_variant_ls muc) q in let dvar (t,q) = dvar t, Opt.map (find_variant_ls muc) q in
List.map dvar varl List.map dvar varl
let dspec muc sp lvm old ity = { let dspec muc sp lvm xsm old ity = {
ds_pre = dpre muc sp.sp_pre lvm old; ds_pre = dpre muc sp.sp_pre lvm old;
ds_post = dpost muc sp.sp_post lvm old ity; ds_post = dpost muc sp.sp_post lvm old ity;
ds_xpost = dxpost muc sp.sp_xpost lvm old; ds_xpost = dxpost muc sp.sp_xpost lvm xsm old;
ds_reads = dreads muc sp.sp_reads lvm; ds_reads = dreads muc sp.sp_reads lvm;
ds_writes = dwrites muc sp.sp_writes lvm; ds_writes = dwrites muc sp.sp_writes lvm;
ds_checkrw = sp.sp_checkrw; ds_checkrw = sp.sp_checkrw;
ds_diverge = sp.sp_diverge; } ds_diverge = sp.sp_diverge; }
let dassert muc f lvm old = type_fmla muc lvm old f let dassert muc f lvm _xsm old = type_fmla muc lvm old f
let dinvariant muc f lvm old = dpre muc f lvm old let dinvariant muc f lvm _xsm old = dpre muc f lvm old
(* abstract values *) (* abstract values *)
...@@ -588,6 +592,12 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} = ...@@ -588,6 +592,12 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
| None -> qualid_app loc q el) | None -> qualid_app loc q el)
| _ -> qualid_app loc q el | _ -> qualid_app loc q el
in in
let find_dxsymbol q = match q with
| Qident {id_str = n} ->
(try denv_get_exn denv n with _
-> DEgexn (find_xsymbol muc q))
| _ -> DEgexn (find_xsymbol muc q)
in
Dexpr.dexpr ~loc begin match desc with Dexpr.dexpr ~loc begin match desc with
| Ptree.Eident q -> | Ptree.Eident q ->
qualid_app loc q [] qualid_app loc q []
...@@ -718,21 +728,25 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} = ...@@ -718,21 +728,25 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
dexpr muc denv e1, find_record_field muc q, dexpr muc denv e2 in dexpr muc denv e1, find_record_field muc q, dexpr muc denv e2 in
DEassign (List.map mk_assign asl) DEassign (List.map mk_assign asl)
| Ptree.Eraise (q, e1) -> | Ptree.Eraise (q, e1) ->
let xs = find_xsymbol muc q in let xs = find_dxsymbol q in
let mb_unit = match xs with
| DEgexn xs -> ity_equal xs.xs_ity ity_unit
| DElexn _ -> true in
let e1 = match e1 with let e1 = match e1 with
| Some e1 -> dexpr muc denv e1 | Some e1 -> dexpr muc denv e1
| None when ity_equal xs.xs_ity ity_unit -> | None when mb_unit -> Dexpr.dexpr ~loc (DEsym (RS rs_void))
Dexpr.dexpr ~loc (DEsym (RS rs_void))
| _ -> Loc.errorm ~loc "exception argument expected" in