Commit 7c101ffd authored by Andrei Paskevich's avatar Andrei Paskevich

Mlw: type program declarations

parent 5cde5b03
...@@ -886,13 +886,6 @@ let tuple_theory = Hint.memo 17 (fun n -> ...@@ -886,13 +886,6 @@ let tuple_theory = Hint.memo 17 (fun n ->
let uc = add_data_decl uc [ts, [fs,pl]] in let uc = add_data_decl uc [ts, [fs,pl]] in
close_theory uc) close_theory uc)
let unit_theory =
let uc = empty_theory (id_fresh "Unit") ["why3";"Unit"] in
let ts = create_tysymbol (id_fresh "unit") [] (Some (ty_tuple [])) in
let uc = use_export uc (tuple_theory 0) in
let uc = add_ty_decl uc ts in
close_theory uc
let tuple_theory_name s = let tuple_theory_name s =
let l = String.length s in let l = String.length s in
if l < 6 then None else if l < 6 then None else
......
...@@ -316,15 +316,15 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a ...@@ -316,15 +316,15 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type dspec_final = { type dspec_final = {
ds_pre : term list; ds_pre : term list;
ds_post : (vsymbol option * term) list; ds_post : (pvsymbol * term) list;
ds_xpost : (vsymbol option * term) list Mexn.t; ds_xpost : (pvsymbol * term) list Mexn.t;
ds_reads : vsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
ds_checkrw : bool; ds_checkrw : bool;
} }
type dspec = ty -> dspec_final type dspec = ity -> dspec_final
(* Computation specification is also parametrized by the result type. (* Computation specification is also parametrized by the result type.
All vsymbols in the postcondition clauses in the [ds_post] field All vsymbols in the postcondition clauses in the [ds_post] field
must have this type. All vsymbols in the exceptional postcondition must have this type. All vsymbols in the exceptional postcondition
...@@ -714,13 +714,10 @@ let create_assert = to_fmla ...@@ -714,13 +714,10 @@ let create_assert = to_fmla
let create_invariant pl = List.map to_fmla pl let create_invariant pl = List.map to_fmla pl
let create_post ty ql = List.map (fun (v,f) -> let create_post ity ql = List.map (fun (v,f) ->
let f = to_fmla f in match v with ity_equal_check ity v.pv_ity; Ity.create_post v.pv_vs (to_fmla f)) ql
| None -> Ity.create_post (create_vsymbol (id_fresh "result") ty) f
| Some v -> Ty.ty_equal_check ty v.vs_ty; Ity.create_post v f) ql
let create_xpost xql = let create_xpost xql = Mexn.mapi (fun xs ql -> create_post xs.xs_ity ql) xql
Mexn.mapi (fun xs ql -> create_post (ty_of_ity xs.xs_ity) ql) xql
(** User effects *) (** User effects *)
...@@ -746,9 +743,7 @@ let rec effect_of_term t = ...@@ -746,9 +743,7 @@ let rec effect_of_term t =
| _ -> quit () | _ -> quit ()
let effect_of_dspec dsp = let effect_of_dspec dsp =
let add_read s v = Spv.add (try restore_pv v with Not_found -> let pvs = Spv.of_list dsp.ds_reads in
Loc.errorm "unsupported effect expression") s in
let pvs = List.fold_left add_read Spv.empty dsp.ds_reads in
let add_write (l,eff) t = match effect_of_term t with let add_write (l,eff) t = match effect_of_term t with
| v, {ity_node = Ityreg reg}, fd -> | v, {ity_node = Ityreg reg}, fd ->
let fs = match fd with let fs = match fd with
...@@ -926,16 +921,15 @@ let add_binders env pvl = List.fold_left add_pvsymbol env pvl ...@@ -926,16 +921,15 @@ let add_binders env pvl = List.fold_left add_pvsymbol env pvl
let cty_of_spec env bl dsp dity = let cty_of_spec env bl dsp dity =
let ity = ity_of_dity dity in let ity = ity_of_dity dity in
let ty = ty_of_ity ity in
let bl = binders bl in let bl = binders bl in
let env = add_binders env bl in let env = add_binders env bl in
let preold = Mstr.find_opt "'0" env.old in let preold = Mstr.find_opt "'0" env.old in
let env, old = add_label env "'0" in let env, old = add_label env "'0" in
let dsp = get_later env dsp ty in let dsp = get_later env dsp ity in
let _, eff = effect_of_dspec dsp in let _, eff = effect_of_dspec dsp in
let eff = eff_strong eff in let eff = eff_strong eff in
let p = rebase_pre env preold old dsp.ds_pre in let p = rebase_pre env preold old dsp.ds_pre in
let q = create_post ty dsp.ds_post in let q = create_post ity dsp.ds_post in
let xq = create_xpost dsp.ds_xpost in let xq = create_xpost dsp.ds_xpost in
create_cty bl p q xq (get_oldies old) eff ity create_cty bl p q xq (get_oldies old) eff ity
...@@ -1200,14 +1194,13 @@ and rec_defn uloc env ghost {fds = dfdl} = ...@@ -1200,14 +1194,13 @@ and rec_defn uloc env ghost {fds = dfdl} =
and lambda uloc env pvl dsp dvl de = and lambda uloc env pvl dsp dvl de =
let env = add_binders env pvl in let env = add_binders env pvl in
let e = expr uloc env de in let e = expr uloc env de in
let ty = ty_of_ity e.e_ity in
let preold = Mstr.find_opt "'0" env.old in let preold = Mstr.find_opt "'0" env.old in
let env, old = add_label env "'0" in let env, old = add_label env "'0" in
let dsp = get_later env dsp ty in let dsp = get_later env dsp e.e_ity in
let dvl = get_later env dvl in let dvl = get_later env dvl in
let dvl = rebase_variant env preold old dvl in let dvl = rebase_variant env preold old dvl in
let p = rebase_pre env preold old dsp.ds_pre in let p = rebase_pre env preold old dsp.ds_pre in
let q = create_post ty dsp.ds_post in let q = create_post e.e_ity dsp.ds_post in
let xq = create_xpost dsp.ds_xpost in let xq = create_xpost dsp.ds_xpost in
c_fun pvl p q xq (get_oldies old) e, dsp, dvl c_fun pvl p q xq (get_oldies old) e, dsp, dvl
......
...@@ -11,7 +11,6 @@ ...@@ -11,7 +11,6 @@
open Stdlib open Stdlib
open Ident open Ident
open Ty
open Term open Term
open Ity open Ity
open Expr open Expr
...@@ -68,15 +67,15 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a ...@@ -68,15 +67,15 @@ type 'a later = pvsymbol Mstr.t -> register_old -> 'a
type dspec_final = { type dspec_final = {
ds_pre : term list; ds_pre : term list;
ds_post : (vsymbol option * term) list; ds_post : (pvsymbol * term) list;
ds_xpost : (vsymbol option * term) list Mexn.t; ds_xpost : (pvsymbol * term) list Mexn.t;
ds_reads : vsymbol list; ds_reads : pvsymbol list;
ds_writes : term list; ds_writes : term list;
ds_diverge : bool; ds_diverge : bool;
ds_checkrw : bool; ds_checkrw : bool;
} }
type dspec = ty -> dspec_final type dspec = ity -> dspec_final
(* Computation specification is also parametrized by the result type. (* Computation specification is also parametrized by the result type.
All vsymbols in the postcondition clauses in the [ds_post] field All vsymbols in the postcondition clauses in the [ds_post] field
must have this type. All vsymbols in the exceptional postcondition must have this type. All vsymbols in the exceptional postcondition
......
...@@ -578,7 +578,8 @@ let is_e_false e = match e.e_node with ...@@ -578,7 +578,8 @@ let is_e_false e = match e.e_node with
| Eexec {c_node = Capp (s,[])} -> rs_equal s rs_false | Eexec {c_node = Capp (s,[])} -> rs_equal s rs_false
| _ -> false | _ -> false
let rs_tuple = Hint.memo 17 (fun n -> rs_of_ls (fs_tuple n)) let rs_tuple = Hint.memo 17 (fun n ->
ignore (its_tuple n); rs_of_ls (fs_tuple n))
let is_rs_tuple rs = rs_equal rs (rs_tuple (List.length rs.rs_cty.cty_args)) let is_rs_tuple rs = rs_equal rs (rs_tuple (List.length rs.rs_cty.cty_args))
......
...@@ -421,6 +421,18 @@ let known_add_decl kn0 d = ...@@ -421,6 +421,18 @@ let known_add_decl kn0 d =
if Sid.is_empty unk then kn else if Sid.is_empty unk then kn else
raise (UnknownIdent (Sid.choose unk)) raise (UnknownIdent (Sid.choose unk))
(** {2 Records/algebraics handling} *)
let find_its_defn kn s =
match (Mid.find s.its_ts.ts_name kn).pd_node with
| PDtype dl ->
let rec search = function
| d::_ when its_equal s d.itd_its -> d
| _::dl -> search dl
| [] -> assert false in
search dl
| _ -> assert false
(** {2 Pretty-printing} *) (** {2 Pretty-printing} *)
open Format open Format
......
...@@ -82,6 +82,8 @@ val known_id : known_map -> ident -> unit ...@@ -82,6 +82,8 @@ val known_id : known_map -> ident -> unit
val known_add_decl : known_map -> pdecl -> known_map val known_add_decl : known_map -> pdecl -> known_map
val merge_known : known_map -> known_map -> known_map val merge_known : known_map -> known_map -> known_map
val find_its_defn : known_map -> itysymbol -> its_defn
(** {2 Pretty-printing *) (** {2 Pretty-printing *)
val print_pdecl : Format.formatter -> pdecl -> unit val print_pdecl : Format.formatter -> pdecl -> unit
...@@ -579,30 +579,24 @@ top_ghost: ...@@ -579,30 +579,24 @@ top_ghost:
(* Function declarations *) (* Function declarations *)
type_v: type_v:
| arrow_type_v { $1 } | params cast spec { ($1, $2, $3) }
| cast { PTpure $1 }
arrow_type_v:
| param params tail_type_c { PTfunc ($1 @ $2, $3) }
tail_type_c:
| single_spec spec arrow_type_v { $3, spec_union $1 $2 }
| COLON simple_type_c { $2 }
(*
simple_type_c: simple_type_c:
| ty spec { PTpure $1, $2 } | ty spec { PTpure $1, $2 }
*)
(* Function definitions *) (* Function definitions *)
rec_defn: rec_defn:
| top_ghost labels(lident_rich) binders cast? spec EQUAL spec seq_expr | top_ghost labels(lident_rich) binders cast? spec EQUAL spec seq_expr
{ $2, $1, ($3, $4, $8, spec_union $5 $7) } { $2, $1, ($3, $4, spec_union $5 $7, $8) }
fun_defn: fun_defn:
| binders cast? spec EQUAL spec seq_expr { ($1, $2, $6, spec_union $3 $5) } | binders cast? spec EQUAL spec seq_expr { ($1, $2, spec_union $3 $5, $6) }
fun_expr: fun_expr:
| FUN binders spec ARROW spec seq_expr { ($2, None, $6, spec_union $3 $5) } | FUN binders spec ARROW spec seq_expr { ($2, None, spec_union $3 $5, $6) }
(* Program expressions *) (* Program expressions *)
...@@ -619,12 +613,14 @@ expr_: ...@@ -619,12 +613,14 @@ expr_:
| expr_arg_ | expr_arg_
{ match $1 with (* break the infix relation chain *) { match $1 with (* break the infix relation chain *)
| Einfix (l,o,r) -> Einnfix (l,o,r) | d -> d } | Einfix (l,o,r) -> Einnfix (l,o,r) | d -> d }
| expr AMPAMP expr
{ Eand ($1, $3) }
| expr BARBAR expr
{ Eor ($1, $3) }
| NOT expr %prec prec_prefix_op | NOT expr %prec prec_prefix_op
{ Enot $2 } { Enot $2 }
| prefix_op expr %prec prec_prefix_op | prefix_op expr %prec prec_prefix_op
{ Eidapp (Qident $1, [$2]) } { Eidapp (Qident $1, [$2]) }
| l = expr ; o = lazy_op ; r = expr
{ Elazy (l,o,r) }
| l = expr ; o = infix_op ; r = expr | l = expr ; o = infix_op ; r = expr
{ Einfix (l,o,r) } { Einfix (l,o,r) }
| expr_arg located(expr_arg)+ (* FIXME/TODO: "expr expr_arg" *) | expr_arg located(expr_arg)+ (* FIXME/TODO: "expr expr_arg" *)
...@@ -677,9 +673,9 @@ expr_: ...@@ -677,9 +673,9 @@ expr_:
| quote_uident COLON seq_expr | quote_uident COLON seq_expr
{ Emark ($1, $3) } { Emark ($1, $3) }
| LOOP loop_annotation seq_expr END | LOOP loop_annotation seq_expr END
{ Eloop ($2, $3) } { let inv, var = $2 in Eloop (inv, var, $3) }
| WHILE seq_expr DO loop_annotation seq_expr DONE | WHILE seq_expr DO loop_annotation seq_expr DONE
{ Ewhile ($2, $4, $5) } { let inv, var = $4 in Ewhile ($2, inv, var, $5) }
| FOR lident EQUAL seq_expr for_direction seq_expr DO invariant* seq_expr DONE | FOR lident EQUAL seq_expr for_direction seq_expr DO invariant* seq_expr DONE
{ Efor ($2, $4, $5, $6, $8, $9) } { Efor ($2, $4, $5, $6, $8, $9) }
| ABSURD | ABSURD
...@@ -690,12 +686,12 @@ expr_: ...@@ -690,12 +686,12 @@ expr_:
{ Eraise ($3, Some $4) } { Eraise ($3, Some $4) }
| TRY seq_expr WITH bar_list1(exn_handler) END | TRY seq_expr WITH bar_list1(exn_handler) END
{ Etry ($2, $4) } { Etry ($2, $4) }
| ANY simple_type_c | ANY ty spec
{ Eany $2 } { Eany ([], $2, $3) }
| GHOST expr | GHOST expr
{ Eghost $2 } { Eghost $2 }
| ABSTRACT spec seq_expr END | ABSTRACT spec seq_expr END
{ Eabstract($3, $2) } { Eabstract($2, $3) }
| assertion_kind LEFTBRC term RIGHTBRC | assertion_kind LEFTBRC term RIGHTBRC
{ Eassert ($1, $3) } { Eassert ($1, $3) }
| label expr %prec prec_named | label expr %prec prec_named
...@@ -741,30 +737,26 @@ expr_sub: ...@@ -741,30 +737,26 @@ expr_sub:
loop_annotation: loop_annotation:
| (* epsilon *) | (* epsilon *)
{ { loop_invariant = []; loop_variant = [] } } { [], [] }
| invariant loop_annotation | invariant loop_annotation
{ let a = $2 in { a with loop_invariant = $1 :: a.loop_invariant } } { let inv, var = $2 in $1 :: inv, var }
| variant loop_annotation | variant loop_annotation
{ let a = $2 in { a with loop_variant = variant_union $1 a.loop_variant } } { let inv, var = $2 in inv, variant_union $1 var }
exn_handler: exn_handler:
| uqualid pat_arg? ARROW seq_expr { $1, $2, $4 } | uqualid pat_arg? ARROW seq_expr { $1, $2, $4 }
val_expr: val_expr:
| tail_type_c { Eany $1 } | type_v { Eany $1 }
%inline lazy_op:
| AMPAMP { LazyAnd }
| BARBAR { LazyOr }
assertion_kind: assertion_kind:
| ASSERT { Aassert } | ASSERT { Expr.Assert }
| ASSUME { Aassume } | ASSUME { Expr.Assume }
| CHECK { Acheck } | CHECK { Expr.Check }
for_direction: for_direction:
| TO { To } | TO { Expr.To }
| DOWNTO { Downto } | DOWNTO { Expr.DownTo }
(* Specification *) (* Specification *)
......
...@@ -166,18 +166,7 @@ type use_clone = use * clone_subst list option ...@@ -166,18 +166,7 @@ type use_clone = use * clone_subst list option
(* program files *) (* program files *)
type assertion_kind = Aassert | Aassume | Acheck type variant = (term * qualid option) list
type lazy_op = LazyAnd | LazyOr
type variant = term * qualid option
type loop_annotation = {
loop_invariant : invariant;
loop_variant : variant list;
}
type for_direction = To | Downto
type pre = term type pre = term
type post = loc * (pattern * term) list type post = loc * (pattern * term) list
...@@ -189,17 +178,11 @@ type spec = { ...@@ -189,17 +178,11 @@ type spec = {
sp_xpost : xpost list; sp_xpost : xpost list;
sp_reads : qualid list; sp_reads : qualid list;
sp_writes : term list; sp_writes : term list;
sp_variant : variant list; sp_variant : variant;
sp_checkrw : bool; sp_checkrw : bool;
sp_diverge : bool; sp_diverge : bool;
} }
type type_v =
| PTpure of pty
| PTfunc of param list * type_c
and type_c = type_v * spec
type top_ghost = Gnone | Gghost | Glemma type top_ghost = Gnone | Gghost | Glemma
type expr = { type expr = {
...@@ -228,27 +211,30 @@ and expr_desc = ...@@ -228,27 +211,30 @@ and expr_desc =
(* control *) (* control *)
| Esequence of expr * expr | Esequence of expr * expr
| Eif of expr * expr * expr | Eif of expr * expr * expr
| Eloop of loop_annotation * expr | Eloop of invariant * variant * expr
| Ewhile of expr * loop_annotation * expr | Ewhile of expr * invariant * variant * expr
| Elazy of expr * lazy_op * expr | Eand of expr * expr
| Eor of expr * expr
| Enot of expr | Enot of expr
| Ematch of expr * (pattern * expr) list | Ematch of expr * (pattern * expr) list
| Eabsurd | Eabsurd
| Eraise of qualid * expr option | Eraise of qualid * expr option
| Etry of expr * (qualid * pattern option * expr) list | Etry of expr * (qualid * pattern option * expr) list
| Efor of ident * expr * for_direction * expr * invariant * expr | Efor of ident * expr * Expr.for_direction * expr * invariant * expr
(* annotations *) (* annotations *)
| Eassert of assertion_kind * term | Eassert of Expr.assertion_kind * term
| Emark of ident * expr | Emark of ident * expr
| Ecast of expr * pty | Ecast of expr * pty
| Eany of type_c | Eany of any
| Eghost of expr | Eghost of expr
| Eabstract of expr * spec | Eabstract of spec * expr
| Enamed of label * expr | Enamed of label * expr
and fundef = ident * top_ghost * lambda and fundef = ident * top_ghost * lambda
and lambda = binder list * pty option * expr * spec and lambda = binder list * pty option * spec * expr
and any = param list * pty * spec
type decl = type decl =
| Dtype of type_decl list | Dtype of type_decl list
...@@ -256,7 +242,7 @@ type decl = ...@@ -256,7 +242,7 @@ type decl =
| Dind of Decl.ind_sign * ind_decl list | Dind of Decl.ind_sign * ind_decl list
| Dprop of Decl.prop_kind * ident * term | Dprop of Decl.prop_kind * ident * term
| Dmeta of ident * metarg list | Dmeta of ident * metarg list
| Dval of ident * top_ghost * type_v | Dval of ident * top_ghost * any
| Dlet of ident * top_ghost * expr | Dlet of ident * top_ghost * expr
| Dfun of ident * top_ghost * lambda | Dfun of ident * top_ghost * lambda
| Drec of fundef list | Drec of fundef list
......
This diff is collapsed.
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