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
This diff is collapsed.
...@@ -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 | _ -> Loc.errorm ~loc "exception argument expected" in
DEraise (xs, e1) DEraise (xs, e1)
| Ptree.Etry (e1, cl) -> | Ptree.Etry (e1, cl) ->
let e1 = dexpr muc denv e1 in let e1 = dexpr muc denv e1 in
let branch (q, pp, e) = let branch (q, pp, e) =
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 pp = match pp with let pp = match pp with
| Some pp -> dpattern muc pp | Some pp -> dpattern muc pp
| None when ity_equal xs.xs_ity ity_unit -> | None when mb_unit -> Dexpr.dpattern ~loc (DPapp (rs_void, []))
Dexpr.dpattern ~loc (DPapp (rs_void, []))
| _ -> Loc.errorm ~loc "exception argument expected" in | _ -> Loc.errorm ~loc "exception argument expected" in
let denv = denv_add_pat denv pp in let denv = denv_add_pat denv pp in
let e = dexpr muc denv e in let e = dexpr muc denv e in
...@@ -740,9 +754,15 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} = ...@@ -740,9 +754,15 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
DEtry (e1, List.map branch cl) DEtry (e1, List.map branch cl)
| Ptree.Eghost e1 -> | Ptree.Eghost e1 ->
DEghost (dexpr muc denv e1) DEghost (dexpr muc denv e1)
| Ptree.Eabsurd -> DEabsurd | Ptree.Eexn (id, pty, mask, e1) ->
let id = create_user_id id in
let dity = dity_of_ity (ity_of_pty muc pty) in
let denv = denv_add_exn denv id dity in
DEexn (id, dity, mask, dexpr muc denv e1)
| Ptree.Eabsurd ->
DEabsurd
| Ptree.Epure t -> | Ptree.Epure t ->
let get_term lvm old = type_term muc lvm old t in let get_term lvm _xsm old = type_term muc lvm old t in
let gvars _at q = try match find_prog_symbol muc q with let gvars _at q = try match find_prog_symbol muc q with
| PV v -> Some v | _ -> None with _ -> None in | PV v -> Some v | _ -> None with _ -> None in
let get_dty pure_denv = let get_dty pure_denv =
...@@ -757,10 +777,10 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} = ...@@ -757,10 +777,10 @@ let rec dexpr muc denv {expr_desc = desc; expr_loc = loc} =
DEuloc (dexpr muc denv e1, uloc) DEuloc (dexpr muc denv e1, uloc)
| Ptree.Enamed (Lstr lab, e1) -> | Ptree.Enamed (Lstr lab, e1) ->
DElabel (dexpr muc denv e1, Slab.singleton lab) DElabel (dexpr muc denv e1, Slab.singleton lab)
| Ptree.Ecast ({expr_desc = Ptree.Econst c},pty) -> | Ptree.Ecast ({expr_desc = Ptree.Econst c}, pty) ->
let ity = ity_of_pty muc pty in let ity = ity_of_pty muc pty in
DEconst (c, dity_of_ity ity) DEconst (c, dity_of_ity ity)
| Ptree.Ecast (e1,pty) -> | Ptree.Ecast (e1, pty) ->
let d1 = dexpr muc denv e1 in let d1 = dexpr muc denv e1 in
let ity = ity_of_pty muc pty in let ity = ity_of_pty muc pty in
DEcast (d1, ity) DEcast (d1, ity)
......
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