├── bin ├── cli.mli ├── dune └── cli.ml ├── .ocp-indent ├── .gitignore ├── dune-project ├── examples ├── loc_count.sh ├── exercises │ ├── replay-log │ ├── binary_search_tree │ │ └── why3shapes.gz │ ├── solutions │ │ ├── binary_search_tree │ │ │ ├── why3shapes.gz │ │ │ └── why3session.xml │ │ ├── binary_search_tree_alt │ │ │ ├── why3shapes.gz │ │ │ └── why3session.xml │ │ ├── power_2_above.ml │ │ ├── binary_search_tree_alt.ml │ │ └── binary_search_tree.ml │ ├── power_2_above.ml │ └── binary_search_tree.ml ├── arith │ └── why3shapes.gz ├── fact │ ├── why3shapes.gz │ └── why3session.xml ├── find │ ├── why3shapes.gz │ └── why3session.xml ├── imp │ ├── why3shapes.gz │ └── why3session.xml ├── isqrt │ ├── why3shapes.gz │ └── why3session.xml ├── mjrty │ └── why3shapes.gz ├── set │ └── why3shapes.gz ├── stack │ ├── why3shapes.gz │ └── why3session.xml ├── xor │ ├── why3shapes.gz │ └── why3session.xml ├── CCHeap │ └── why3shapes.gz ├── duplicates │ ├── why3shapes.gz │ └── why3session.xml ├── even_odd │ ├── why3shapes.gz │ └── why3session.xml ├── fibonacci │ ├── why3shapes.gz │ └── why3session.xml ├── mergesort │ └── why3shapes.gz ├── ocaml_fold │ ├── why3shapes.gz │ └── why3session.xml ├── union_find │ └── why3shapes.gz ├── leftist_heap │ └── why3shapes.gz ├── ocaml_stack │ ├── why3shapes.gz │ └── why3session.xml ├── pairing_heap │ └── why3shapes.gz ├── same_fringe │ ├── why3shapes.gz │ └── why3session.xml ├── binary_search │ └── why3shapes.gz ├── cnf_conversion │ └── why3shapes.gz ├── ephemeral_queue │ └── why3shapes.gz ├── max_elt_array │ ├── why3shapes.gz │ └── why3session.xml ├── most_frequent │ └── why3shapes.gz ├── program_proofs │ ├── why3shapes.gz │ └── why3shapes.gz.bak ├── tree_height_cps │ ├── why3shapes.gz │ └── why3session.xml ├── applicative_queue │ ├── why3shapes.gz │ └── why3session.xml ├── in_progress │ ├── tezos │ │ └── why3shapes.gz │ ├── timsort │ │ └── why3shapes.gz │ ├── vector │ │ ├── why3shapes.gz │ │ └── why3session.xml │ ├── zipper │ │ ├── why3shapes.gz │ │ └── why3session.xml │ ├── toy_compiler │ │ ├── why3shapes.gz │ │ └── why3session.xml │ ├── zipper.ml │ ├── toy_compiler.ml │ ├── vector.ml │ └── tree_of_an_array.ml ├── binary_search_tree │ ├── why3shapes.gz │ └── why3session.xml ├── fast_exponentiation │ ├── why3shapes.gz │ └── why3session.xml ├── insertion_sort_list │ ├── why3shapes.gz │ └── why3session.xml ├── small_step_iterator │ └── why3shapes.gz ├── binary_multiplication │ ├── why3shapes.gz │ └── why3session.xml ├── checking_a_large_routine │ ├── why3shapes.gz │ └── why3session.xml ├── fast_exponentiation.ml ├── even_odd.ml ├── binary_multiplication.ml ├── fact.ml ├── max_elt_array.ml ├── tree_height_cps.ml ├── find.ml ├── session.sh ├── replay.sh ├── duplicates.ml ├── isqrt.ml ├── fibonacci.ml ├── checking_a_large_routine.ml ├── ocaml_fold.ml ├── inductive_predicates.ml ├── same_fringe.ml ├── applicative_queue.ml ├── insertion_sort_list.ml ├── binary_search_tree.ml ├── ocaml_stack.ml ├── ephemeral_queue.ml ├── xor.ml ├── mjrty.ml ├── mergesort.ml ├── union_find.ml ├── small_step_iterator.ml ├── binary_search.ml ├── most_frequent.ml ├── program_proofs.ml └── cnf_conversion.ml ├── doc ├── mathpartir.sty ├── examples_table.pdf ├── working_doc_translation.pdf ├── gospel.sty └── why3lang.sty ├── src ├── ocamlstdlib │ ├── why3shapes.gz │ └── why3session.xml ├── declaration.mli ├── dune ├── vspec.mli ├── expression.mli ├── uterm.mli ├── mod_subst.mli ├── why3ocaml_driver.ml ├── odecl.mli ├── odecl.ml ├── vspec.ml └── mod_subst.ml ├── .gitmodules ├── .ocamlformat ├── Makefile ├── plugin └── dune ├── stdlib ├── arrayPermut.mli ├── sum.ml ├── power.ml └── setCameleer.mli ├── LICENSE ├── cameleer.opam ├── Vagrantfile ├── TODO.md └── README.md /bin/cli.mli: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause = 4 -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.bak 2 | *~ 3 | .merlin 4 | _build/* -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 2.4) 2 | (name cameleer) 3 | -------------------------------------------------------------------------------- /examples/loc_count.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | gospel wc *.ml 4 | -------------------------------------------------------------------------------- /examples/exercises/replay-log: -------------------------------------------------------------------------------- 1 | bash: ./replay.sh: No such file or directory 2 | -------------------------------------------------------------------------------- /doc/mathpartir.sty: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/doc/mathpartir.sty -------------------------------------------------------------------------------- /doc/examples_table.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/doc/examples_table.pdf -------------------------------------------------------------------------------- /examples/arith/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/arith/why3shapes.gz -------------------------------------------------------------------------------- /examples/fact/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/fact/why3shapes.gz -------------------------------------------------------------------------------- /examples/find/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/find/why3shapes.gz -------------------------------------------------------------------------------- /examples/imp/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/imp/why3shapes.gz -------------------------------------------------------------------------------- /examples/isqrt/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/isqrt/why3shapes.gz -------------------------------------------------------------------------------- /examples/mjrty/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/mjrty/why3shapes.gz -------------------------------------------------------------------------------- /examples/set/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/set/why3shapes.gz -------------------------------------------------------------------------------- /examples/stack/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/stack/why3shapes.gz -------------------------------------------------------------------------------- /examples/xor/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/xor/why3shapes.gz -------------------------------------------------------------------------------- /examples/CCHeap/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/CCHeap/why3shapes.gz -------------------------------------------------------------------------------- /src/ocamlstdlib/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/src/ocamlstdlib/why3shapes.gz -------------------------------------------------------------------------------- /doc/working_doc_translation.pdf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/doc/working_doc_translation.pdf -------------------------------------------------------------------------------- /examples/duplicates/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/duplicates/why3shapes.gz -------------------------------------------------------------------------------- /examples/even_odd/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/even_odd/why3shapes.gz -------------------------------------------------------------------------------- /examples/fibonacci/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/fibonacci/why3shapes.gz -------------------------------------------------------------------------------- /examples/mergesort/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/mergesort/why3shapes.gz -------------------------------------------------------------------------------- /examples/ocaml_fold/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/ocaml_fold/why3shapes.gz -------------------------------------------------------------------------------- /examples/union_find/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/union_find/why3shapes.gz -------------------------------------------------------------------------------- /examples/leftist_heap/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/leftist_heap/why3shapes.gz -------------------------------------------------------------------------------- /examples/ocaml_stack/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/ocaml_stack/why3shapes.gz -------------------------------------------------------------------------------- /examples/pairing_heap/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/pairing_heap/why3shapes.gz -------------------------------------------------------------------------------- /examples/same_fringe/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/same_fringe/why3shapes.gz -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (libraries gospel why3 cameleer) 3 | (name cli) 4 | (public_name cameleer) 5 | (package cameleer)) 6 | -------------------------------------------------------------------------------- /examples/binary_search/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/binary_search/why3shapes.gz -------------------------------------------------------------------------------- /examples/cnf_conversion/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/cnf_conversion/why3shapes.gz -------------------------------------------------------------------------------- /examples/ephemeral_queue/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/ephemeral_queue/why3shapes.gz -------------------------------------------------------------------------------- /examples/max_elt_array/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/max_elt_array/why3shapes.gz -------------------------------------------------------------------------------- /examples/most_frequent/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/most_frequent/why3shapes.gz -------------------------------------------------------------------------------- /examples/program_proofs/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/program_proofs/why3shapes.gz -------------------------------------------------------------------------------- /examples/tree_height_cps/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/tree_height_cps/why3shapes.gz -------------------------------------------------------------------------------- /examples/applicative_queue/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/applicative_queue/why3shapes.gz -------------------------------------------------------------------------------- /examples/in_progress/tezos/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/in_progress/tezos/why3shapes.gz -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "vocal"] 2 | path = vocal 3 | url = https://github.com/vocal-project/vocal 4 | branch = gospel_implementations -------------------------------------------------------------------------------- /examples/binary_search_tree/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/binary_search_tree/why3shapes.gz -------------------------------------------------------------------------------- /examples/fast_exponentiation/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/fast_exponentiation/why3shapes.gz -------------------------------------------------------------------------------- /examples/in_progress/timsort/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/in_progress/timsort/why3shapes.gz -------------------------------------------------------------------------------- /examples/in_progress/vector/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/in_progress/vector/why3shapes.gz -------------------------------------------------------------------------------- /examples/in_progress/zipper/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/in_progress/zipper/why3shapes.gz -------------------------------------------------------------------------------- /examples/insertion_sort_list/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/insertion_sort_list/why3shapes.gz -------------------------------------------------------------------------------- /examples/program_proofs/why3shapes.gz.bak: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/program_proofs/why3shapes.gz.bak -------------------------------------------------------------------------------- /examples/small_step_iterator/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/small_step_iterator/why3shapes.gz -------------------------------------------------------------------------------- /examples/binary_multiplication/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/binary_multiplication/why3shapes.gz -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.24.1 3 | parse-docstrings = true 4 | break-infix = fit-or-vertical 5 | module-item-spacing = compact 6 | -------------------------------------------------------------------------------- /examples/checking_a_large_routine/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/checking_a_large_routine/why3shapes.gz -------------------------------------------------------------------------------- /examples/in_progress/toy_compiler/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/in_progress/toy_compiler/why3shapes.gz -------------------------------------------------------------------------------- /examples/exercises/binary_search_tree/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/exercises/binary_search_tree/why3shapes.gz -------------------------------------------------------------------------------- /src/declaration.mli: -------------------------------------------------------------------------------- 1 | open Gospel 2 | open Odecl 3 | 4 | val s_structure : info -> Uast.s_structure -> odecl list 5 | val s_signature : info -> Uast.s_signature -> odecl list 6 | -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/exercises/solutions/binary_search_tree/why3shapes.gz -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree_alt/why3shapes.gz: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/ocaml-gospel/cameleer/HEAD/examples/exercises/solutions/binary_search_tree_alt/why3shapes.gz -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | all: 2 | dune build @install 3 | 4 | install: 5 | dune build @install && dune install 6 | 7 | clean: 8 | dune clean 9 | rm -f *~ 10 | 11 | .PHONY: all clean install 12 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name cameleer) 3 | (libraries ppxlib gospel why3)) 4 | 5 | (install 6 | (section share_root) 7 | (files 8 | (ocamlstdlib.mlw as why3/stdlib/ocamlstdlib.mlw)) 9 | (package cameleer)) 10 | -------------------------------------------------------------------------------- /examples/fast_exponentiation.ml: -------------------------------------------------------------------------------- 1 | (*@ open Power *) 2 | 3 | let rec fast_exp x n = 4 | if n = 0 then 1 5 | else 6 | let r = fast_exp x (n / 2) in 7 | if n mod 2 = 0 then r * r else r * r * x 8 | (*@ r = fast_exp x n 9 | requires 0 <= n 10 | variant n 11 | ensures r = x ^ n *) 12 | -------------------------------------------------------------------------------- /examples/exercises/power_2_above.ml: -------------------------------------------------------------------------------- 1 | (*@ open Power *) 2 | 3 | let rec power_2_above x n = if x >= n then x else power_2_above (x * 2) n 4 | (*@ r = power_2_above x n 5 | requires x > 0 6 | requires exists k. k >= 0 && x = 2 ^ k 7 | diverges 8 | ensures exists k. k >= 0 && r = 2 ^ k && r >= n *) 9 | -------------------------------------------------------------------------------- /examples/exercises/solutions/power_2_above.ml: -------------------------------------------------------------------------------- 1 | (*@ open Power *) 2 | 3 | let rec power_2_above x n = if x >= n then x else power_2_above (x * 2) n 4 | (*@ r = power_2_above x n 5 | requires x > 0 6 | requires exists k. k >= 0 && x = 2 ^ k 7 | variant n - x 8 | ensures exists k. k >= 0 && r = 2 ^ k && r >= n *) 9 | -------------------------------------------------------------------------------- /examples/even_odd.ml: -------------------------------------------------------------------------------- 1 | let rec even x = if x = 0 then true else odd (x - 1) 2 | 3 | (*@ b = even x 4 | requires x >= 0 5 | variant x 6 | ensures b <-> mod x 2 = 0 *) 7 | and odd y = if y = 0 then false else even (y - 1) 8 | (*@ b = odd y 9 | requires y >= 0 10 | variant y 11 | ensures b <-> mod y 2 = 1 *) 12 | -------------------------------------------------------------------------------- /src/vspec.mli: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Gospel 3 | 4 | val loc_of_lb_arg : Uast.labelled_arg -> Loc.position 5 | val ident_of_lb_arg : Uast.labelled_arg -> Ptree.ident 6 | val empty_spec : Ptree.spec 7 | val vspec : Uast.val_spec -> Ptree.spec 8 | val fun_spec : Uast.fun_spec -> Ptree.spec 9 | val spec_union : Ptree.spec -> Ptree.spec -> Ptree.spec 10 | -------------------------------------------------------------------------------- /plugin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (libraries ppxlib gospel why3 cameleer) 3 | (name plugin_cameleer) 4 | (modes plugin) 5 | (embed_in_plugin_libraries compiler-libs.common ocaml-compiler-libs.shadow 6 | ppxlib.astlib ppxlib.stdppx ppxlib.ast ppxlib fmt gospel cameleer)) 7 | 8 | (install 9 | (section lib_root) 10 | (files 11 | (plugin_cameleer.cmxs as why3/plugins/plugin_cameleer.cmxs)) 12 | (package cameleer)) 13 | -------------------------------------------------------------------------------- /examples/binary_multiplication.ml: -------------------------------------------------------------------------------- 1 | let binary_mult a b = 2 | let x = ref a in 3 | let y = ref b in 4 | let r = ref 0 in 5 | while not (!y = 0) do 6 | (*@ variant !y 7 | invariant 0 <= !y 8 | invariant !r + !x * !y = a * b *) 9 | if !y mod 2 = 1 then r := !r + !x; 10 | x := 2 * !x; 11 | y := !y / 2 12 | done; 13 | !r 14 | (*@ r = binary_mult a b 15 | requires b >= 0 16 | ensures r = a * b *) 17 | -------------------------------------------------------------------------------- /examples/fact.ml: -------------------------------------------------------------------------------- 1 | (** Two implementations of factorial. *) 2 | 3 | let[@logic] rec fact x = if x = 0 then 1 else x * fact (x - 1) 4 | (*@ r = fact_rec x 5 | requires x >= 0 6 | variant x *) 7 | 8 | let fact_imp x = 9 | let y = ref 0 in 10 | let r = ref 1 in 11 | while !y < x do 12 | (*@ invariant 0 <= !y <= x 13 | invariant !r = fact !y 14 | variant x - !y *) 15 | y := !y + 1; 16 | r := !r * !y 17 | done; 18 | !r 19 | (*@ r = fact_imp x 20 | requires x >= 0 21 | ensures r = fact x *) 22 | -------------------------------------------------------------------------------- /stdlib/arrayPermut.mli: -------------------------------------------------------------------------------- 1 | (*@ open SeqPerm *) 2 | 3 | (*@ predicate occ_eq (a1: 'a array) (a2: 'a array) (l: integer) (u: integer) = 4 | forall v: 'a. SeqPerm.occ v a1 l u = SeqPerm.occ v a2 l u *) 5 | 6 | (*@ predicate permut (a1: 'a array) (a2: 'a array) (l: integer) (u: integer) = 7 | Array.length a1 = Array.length a2 /\ 0 <= l <= Array.length a1 /\ 8 | 0 <= u <= Array.length a1 /\ occ_eq a1 a2 l u *) 9 | 10 | (*@ predicate permut_all (a1: 'a array) (a2: 'a array) = 11 | Array.length a1 = Array.length a2 /\ 12 | permut a1 a2 0 (Array.length a1) *) 13 | -------------------------------------------------------------------------------- /examples/max_elt_array.ml: -------------------------------------------------------------------------------- 1 | let max a = 2 | let x = ref 0 in 3 | let y = ref (Array.length a - 1) in 4 | while !x <> !y do 5 | (*@ variant !y - !x 6 | invariant 0 <= !x <= !y < Array.length a 7 | invariant forall i. (0 <= i < !x \/ !y < i < Array.length a) -> 8 | (a.(i) <= a.(!y) \/ a.(i) <= a.(!x)) *) 9 | if a.(!x) <= a.(!y) then incr x else decr y 10 | done; 11 | !x 12 | (*@ r = max a 13 | requires Array.length a > 0 14 | ensures 0 <= r < Array.length a 15 | ensures forall i. 0 <= i < Array.length a -> a.(i) <= a.(r) *) 16 | -------------------------------------------------------------------------------- /examples/tree_height_cps.ml: -------------------------------------------------------------------------------- 1 | type 'a tree = Empty | Node of 'a tree * 'a * 'a tree 2 | 3 | (*@ function height (t: 'a tree) : integer = match t with 4 | | Empty -> 0 5 | | Node l _ r -> 1 + max (height l) (height r) *) 6 | 7 | let rec height_cps t k = 8 | match t with 9 | | Empty -> k 0 10 | | Node (l, _, r) -> 11 | height_cps l (fun hl -> height_cps r (fun hr -> k (1 + max hl hr))) 12 | (*@ r = height_cps t k 13 | variant t 14 | ensures r = k (height t) *) 15 | 16 | let height_tree t = height_cps t (fun x -> x) 17 | (*@ r = height_tree t 18 | ensures r = height t *) 19 | -------------------------------------------------------------------------------- /examples/find.ml: -------------------------------------------------------------------------------- 1 | module type EQUAL = sig 2 | type t 3 | 4 | val eq : t -> t -> bool 5 | (*@ b = eq x y 6 | ensures b <-> x = y *) 7 | end 8 | 9 | module Make (E : EQUAL) = struct 10 | type elt = E.t 11 | 12 | let find x a = 13 | let exception Found of int in 14 | try 15 | for i = 0 to Array.length a - 1 do 16 | (*@ invariant forall j. 0 <= j < i -> a.(j) <> x *) 17 | if E.eq a.(i) x then raise (Found i) 18 | done; 19 | raise Not_found 20 | with Found i -> i 21 | (*@ i = find x a 22 | ensures a.(i) = x 23 | raises Not_found -> forall i. 0 <= i < Array.length a -> a.(i) <> x *) 24 | end 25 | -------------------------------------------------------------------------------- /examples/session.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ml_files=(applicative_queue arith binary_multiplication binary_search \ 4 | binary_search_tree checking_a_large_routine \ 5 | cnf_conversion duplicates \ 6 | ephemeral_queue even_odd fact fast_exponentiation \ 7 | fibonacci find insertion_sort_list isqrt \ 8 | leftist_heap mjrty ocaml_fold ocaml_stack \ 9 | pairing_heap program_proofs same_fringe \ 10 | small_step_iterator tree_height_cps union_find) 11 | 12 | for f in "${ml_files[@]}" 13 | do 14 | echo "Session of $f" 15 | why3 session info --stats -L ../stdlib $f 16 | done 17 | -------------------------------------------------------------------------------- /src/expression.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Gospel 3 | open Why3 4 | open Odecl 5 | module P = Parsetree 6 | 7 | val string_of_longident : Longident.t -> string 8 | val empty_spec : Ptree.spec 9 | val mk_expr : ?expr_loc:Loc.position -> Ptree.expr_desc -> Ptree.expr 10 | 11 | val mk_fun_def : 12 | Ptree.ghost -> Expr.rs_kind -> Ptree.ident * Ptree.expr -> Ptree.fundef 13 | 14 | val is_ghost : P.attributes -> Ptree.ghost 15 | 16 | val longident : 17 | ?id_loc:Loc.position -> ?prefix:string -> Longident.t -> Ptree.qualid 18 | 19 | val core_type : P.core_type -> Ptree.pty 20 | 21 | val exception_constructor : 22 | P.extension_constructor -> Ptree.ident * Ptree.pty * Ity.mask 23 | 24 | val s_value_binding : info -> Uast.s_value_binding -> Ptree.ident * Ptree.expr 25 | -------------------------------------------------------------------------------- /examples/replay.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | ml_files=(applicative_queue arith binary_multiplication binary_search \ 4 | binary_search_tree checking_a_large_routine \ 5 | cnf_conversion duplicates \ 6 | ephemeral_queue even_odd fact fast_exponentiation \ 7 | fibonacci find insertion_sort_list isqrt \ 8 | leftist_heap mjrty ocaml_fold ocaml_stack \ 9 | pairing_heap program_proofs same_fringe \ 10 | small_step_iterator tree_height_cps union_find) 11 | 12 | for f in "${ml_files[@]}" 13 | do 14 | echo "Replaying session of $f" 15 | hyperfine -w 3 -m $1 "why3 replay --quiet $f" 16 | done 17 | -------------------------------------------------------------------------------- /examples/duplicates.ml: -------------------------------------------------------------------------------- 1 | let all_distinct a m = 2 | let exception Duplicate in 3 | let dejavu = Array.make m false in 4 | try 5 | for k = 0 to Array.length a - 1 do 6 | (*@ invariant forall i j. 0 <= i < k -> 0 <= j < k -> i <> j -> 7 | a.(i) <> a.(j) 8 | invariant forall x. 0 <= x < m -> dejavu.(x) <-> 9 | exists i. 0 <= i < k && a.(i) = x *) 10 | let v = a.(k) in 11 | if dejavu.(v) then raise Duplicate; 12 | dejavu.(v) <- true 13 | done; 14 | true 15 | with Duplicate -> false 16 | (*@ b = all_distinct a m 17 | requires 0 <= m 18 | requires forall i. 0 <= i < Array.length a -> 0 <= a.(i) < m 19 | ensures b <-> forall i j. 0 <= i < Array.length a -> 20 | 0 <= j < Array.length a -> i <> j -> a.(i) <> a.(j) *) 21 | -------------------------------------------------------------------------------- /examples/isqrt.ml: -------------------------------------------------------------------------------- 1 | (*@ function sqr (x: integer) : integer = x * x *) 2 | 3 | (*@ lemma sqr_non_neg: forall x: integer. sqr x >= 0 *) 4 | 5 | (*@ lemma sqr_increasing: 6 | forall x y:integer. 0 <= x <= y -> sqr x <= sqr y *) 7 | 8 | (*@ lemma sqr_sum : 9 | forall x y : integer. sqr(x+y) = sqr x + 2*x*y + sqr y *) 10 | 11 | (*@ predicate int_sqrt_spec (x res:integer) = 12 | res >= 0 /\ sqr res <= x < sqr (res + 1) *) 13 | 14 | let int_sqrt x = 15 | let count = ref 0 in 16 | let sum = ref 1 in 17 | while !sum <= x do 18 | (*@ invariant !count >= 0 19 | invariant x >= sqr !count 20 | invariant !sum = sqr (!count + 1) 21 | variant x - !count *) 22 | count := !count + 1; 23 | sum := !sum + ((2 * !count) + 1) 24 | done; 25 | !count 26 | (*@ r = int_sqrt x 27 | requires x >= 0 28 | ensures int_sqrt_spec x r *) 29 | -------------------------------------------------------------------------------- /src/ocamlstdlib/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | -------------------------------------------------------------------------------- /src/uterm.mli: -------------------------------------------------------------------------------- 1 | open Ppxlib 2 | open Gospel 3 | open Why3 4 | module P = Parsetree 5 | 6 | val dummy_loc : Loc.position 7 | val location : Location.t -> Loc.position 8 | 9 | val mk_id : 10 | ?id_ats:Ptree.attr list -> ?id_loc:Loc.position -> string -> Ptree.ident 11 | 12 | val mk_term : ?term_loc:Loc.position -> Ptree.term_desc -> Ptree.term 13 | val ident_of_tvsymbol : Ttypes.tvsymbol -> Ptree.ident 14 | val ident_of_lsymbol : Symbols.lsymbol -> Ptree.ident 15 | val mk_pattern : ?pat_loc:Loc.position -> Ptree.pat_desc -> Ptree.pattern 16 | val constant : P.constant -> Constant.constant 17 | val preid : Identifier.Preid.t -> Ptree.ident 18 | val qualid : Uast.qualid -> Ptree.qualid 19 | val pty : Uast.pty -> Ptree.pty 20 | val ty : Ttypes.ty -> Ptree.pty 21 | val pattern : Uast.pattern -> Ptree.pattern 22 | val term : bool -> Uast.term -> Ptree.term 23 | val expr : Uast.term -> Ptree.expr 24 | -------------------------------------------------------------------------------- /examples/fibonacci.ml: -------------------------------------------------------------------------------- 1 | let[@ghost] [@logic] rec fib n = if n <= 1 then n else fib (n - 1) + fib (n - 2) 2 | (*@ r = fib n 3 | requires n >= 0 4 | variant n *) 5 | 6 | let fibonacci n = 7 | let y = ref 0 in 8 | let x = ref 1 in 9 | for i = 0 to n - 1 do 10 | (*@ invariant !y = fib i && !x = fib (i+1) *) 11 | let aux = !y in 12 | y := !x; 13 | x := !x + aux 14 | done; 15 | !y 16 | (*@ r = fibonacci n 17 | requires n >= 0 18 | ensures r = fib n *) 19 | 20 | let fib_main k = 21 | let rec fib_rec_aux (n [@ghost]) a b k = 22 | if k = 0 then a else fib_rec_aux (n + 1) b (a + b) (k - 1) 23 | (*@ r = fib_rec_aux n a b k 24 | requires k >= 0 25 | requires 0 <= n && a = fib n && b = fib (n+1) 26 | variant k 27 | ensures r = fib (n+k) *) 28 | in 29 | fib_rec_aux 0 0 1 k 30 | (*@ r = fib_main k 31 | requires k >= 0 32 | ensures r = fib k *) 33 | -------------------------------------------------------------------------------- /examples/checking_a_large_routine.ml: -------------------------------------------------------------------------------- 1 | let[@logic] rec fact x = if x = 0 then 1 else x * fact (x - 1) 2 | (*@ r = fact x 3 | requires x >= 0 4 | variant x *) 5 | 6 | let routine n = 7 | let r = ref 0 in 8 | let u = ref 1 in 9 | while !r < n do 10 | (*@ invariant 0 <= !r <= n /\ !u = fact !r 11 | variant n - !r *) 12 | let s = ref 1 in 13 | let v = !u in 14 | while !s <= !r do 15 | (*@ invariant 1 <= !s <= !r + 1 /\ !u = !s * fact !r 16 | variant !r - !s *) 17 | u := !u + v; 18 | s := !s + 1 19 | done; 20 | r := !r + 1 21 | done; 22 | !u 23 | (*@ r = routine n 24 | requires n >= 0 25 | ensures r = fact n *) 26 | 27 | let routine2 n = 28 | let u = ref 1 in 29 | for r = 0 to n - 1 do 30 | (*@ invariant !u = fact r *) 31 | let v = !u in 32 | for s = 1 to r do 33 | (*@ invariant !u = s * fact r *) 34 | u := !u + v 35 | done 36 | done; 37 | !u 38 | (*@ r = routine2 n 39 | requires n >= 0 40 | ensures r = fact n *) 41 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2020 mariojppereira 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /cameleer.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | name: "cameleer" 3 | synopsis: "A Deductive Verification Tool for OCaml Programs" 4 | description: "A Deductive Verification Tool for OCaml Programs" 5 | version: "0.1" 6 | maintainer: "mjp.pereira@fct.unl.t" 7 | authors: [ 8 | "Mário Pereira" 9 | ] 10 | license: "MIT" 11 | homepage: "https://github.com/mariojppereira/cameleer" 12 | dev-repo: "git://github.com/mariojppereira/cameleer" 13 | bug-reports: "https://github.com/mariojppereira/cameleer/issues" 14 | doc: "https://github.com/mariojppereira/cameleer/blob/master/README.md" 15 | build: [ 16 | ["dune" "build" "-p" name "-j" jobs] 17 | ["dune" "runtest" "-p" name] {with-test} 18 | ] 19 | depends: [ 20 | "dune" {>= "2.4.0"} 21 | "why3" {>= "1.4.0"} 22 | "why3-ide" {>= "1.5.0"} 23 | "gospel" 24 | "fmt" 25 | "ocaml" {>= "4.07"} 26 | "ppxlib" {>= "0.26.0"} 27 | "sexplib" 28 | "ppx_deriving" 29 | "ppx_sexp_conv" 30 | ("lablgtk3" & "lablgtk3-sourceview3") 31 | ] 32 | 33 | conflicts: [ 34 | "lablgtk" {< "2.14.2"} 35 | ] 36 | 37 | pin-depends: [ 38 | "gospel.dev" "git+https://github.com/ocaml-gospel/gospel.git#c20125aeb2154b3853e0e5411c4548f568541096" 39 | ] 40 | -------------------------------------------------------------------------------- /examples/ocaml_fold.ml: -------------------------------------------------------------------------------- 1 | (*@ open Seq *) 2 | 3 | (*@ function seq_of_list (l: 'a list): 'a seq = match l with 4 | | [] -> empty 5 | | x :: r -> cons x (seq_of_list r) *) 6 | (*@ coercion *) 7 | 8 | (*@ lemma seq_of_list_append: forall l1 l2: 'a list. 9 | seq_of_list (List.append l1 l2) == seq_of_list l1 ++ seq_of_list l2 *) 10 | 11 | (*@ predicate permitted (v: 'a seq) (s: 'a seq) = 12 | length v <= length s && 13 | forall i. 0 <= i < length v -> v[i] = s[i] *) 14 | 15 | (*@ predicate complete (l: 'a seq) (v: 'a seq) = 16 | length v = length l *) 17 | 18 | let rec fold_left (v : 'a list) ((inv : 'b -> 'a seq -> bool) [@ghost]) 19 | ((l0 : 'a list) [@ghost]) f (acc : 'b) = function 20 | | [] -> (acc, v) 21 | | x :: l -> fold_left (v @ [ x ]) inv l0 f (f acc x) l 22 | (*@ r, vres = fold_left v inv l0 f acc param 23 | requires permitted v l0 24 | requires l0 == v ++ param 25 | requires inv acc v 26 | requires forall v acc x. 27 | inv acc v -> permitted (snoc v x) l0 -> not (complete v l0) -> 28 | inv (f acc x) (snoc v x) 29 | variant param 30 | ensures permitted vres l0 && vres == v ++ param && inv r vres *) 31 | -------------------------------------------------------------------------------- /src/mod_subst.mli: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Wstdlib 3 | 4 | type mod_constraint = 5 | | MCtype_sharing of Ptree.type_decl 6 | | MCtype_destructive of Ptree.type_decl 7 | | MCfunction_sharing of Ptree.qualid 8 | | MCfunction_destructive of Ptree.qualid 9 | | MCprop of Decl.prop_kind 10 | 11 | module Mqual : Map.S with type key = Ptree.qualid 12 | 13 | type subst = private { 14 | subst_ts : Ptree.type_decl Mstr.t; 15 | subst_td : Ptree.type_decl Mstr.t; 16 | subst_fs : Ptree.qualid Mstr.t; 17 | subst_fd : Ptree.qualid Mqual.t; 18 | subst_ps : Ptree.qualid Mstr.t; 19 | subst_pd : Ptree.qualid Mqual.t; 20 | subst_pr : Decl.prop_kind Mqual.t; 21 | } 22 | 23 | val empty_subst : subst 24 | val add_ts_subst : Mstr.key -> subst -> Ptree.type_decl -> subst 25 | val add_td_subst : Mstr.key -> subst -> Ptree.type_decl -> subst 26 | val add_fs_subst : Mstr.key -> subst -> Ptree.qualid -> subst 27 | val add_fd_subst : Mqual.key -> subst -> Ptree.qualid -> subst 28 | val add_ps_subst : Mstr.key -> subst -> Ptree.qualid -> subst 29 | val add_pd_subst : Mqual.key -> subst -> Ptree.qualid -> subst 30 | val add_pr_subst : Mqual.key -> subst -> Decl.prop_kind -> subst 31 | 32 | (* val subst_decl : subst -> Ptree.decl -> Ptree.decl list *) 33 | -------------------------------------------------------------------------------- /examples/in_progress/vector/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | -------------------------------------------------------------------------------- /examples/in_progress/zipper.ml: -------------------------------------------------------------------------------- 1 | (*@ open Sequence *) 2 | 3 | (*@ function seq_of_list (l: 'a list): 'a sequence = match l with 4 | | [] -> empty 5 | | x :: r -> cons x (seq_of_list r) 6 | coercion *) 7 | 8 | type 'a t = { 9 | self : 'a list * 'a list; 10 | seq : 'a sequence; [@ghost] 11 | idx : int; [@ghost] 12 | } 13 | 14 | (*@ invariant let (l, r) = self in seq == List.rev_append l r *) 15 | (*@ invariant let (l, _) = self in idx = length l *) 16 | 17 | let[@logic] empty : 'a t = { self = ([], []); idx = 0; seq = empty } 18 | (*@ r = empty 19 | ensures r.seq == empty *) 20 | 21 | let is_empty (t : 'a t) = match t.self with [], [] -> true | _ -> false 22 | (*@ b = is_empty t 23 | ensures b <-> t.seq == Sequence.empty *) 24 | 25 | let to_list (t : 'a t) = 26 | let l, r = t.self in 27 | List.rev_append l r 28 | (*@ r = to_list t 29 | ensures r == t.seq *) 30 | 31 | let to_rev_list (t : 'a t) = 32 | let l, r = t.self in 33 | List.rev_append r l 34 | (* @ r = to_rev_list t 35 | ensures r = List.rev t.seq *) 36 | 37 | let make (l : 'a list) : 'a t = 38 | { self = ([], l); idx = 0; seq = Sequence.empty } 39 | (*@ r = make l 40 | ensures r.seq == l *) 41 | 42 | let left = function x :: l, r -> (l, x :: r) | [], r -> ([], r) 43 | (* @ r = left param *) 44 | -------------------------------------------------------------------------------- /examples/in_progress/toy_compiler.ml: -------------------------------------------------------------------------------- 1 | type expr = 2 | | Ecte of int 3 | | Eplus of expr * expr 4 | | Eminus of expr * expr 5 | | Emult of expr * expr 6 | 7 | (*@ function eval_expr (e: expr) : integer = 8 | match e with 9 | | Ecte n -> n 10 | | Eplus e1 e2 -> eval_expr e1 + eval_expr e2 11 | | Eminus e1 e2 -> eval_expr e1 - eval_expr e2 12 | | Emult e1 e2 -> eval_expr e1 * eval_expr e2 *) 13 | 14 | type asm = Apush of int | Aadd | Asub | Amul 15 | 16 | (*@ function compute (s: int list) (a: asm list) : integer list = 17 | match a with 18 | | [] -> s 19 | | a :: r -> 20 | match a, s with 21 | | Apush n, _ -> compute (n :: s) r 22 | | Aadd, (n1 :: (n2 :: s)) -> compute ((n2+n1) :: s) r 23 | | Asub, (n1 :: (n2 :: s)) -> compute ((n2-n1) :: s) r 24 | | Amul, (n1 :: (n2 :: s)) -> compute ((n2*n1) :: s) r 25 | | _ -> s *) 26 | 27 | let rec compile = function 28 | | Ecte n -> [ Apush n ] 29 | | Eplus (e1, e2) -> compile e1 @ compile e2 @ [ Aadd ] 30 | | Eminus (e1, e2) -> compile e1 @ compile e2 @ [ Asub ] 31 | | Emult (e1, e2) -> compile e1 @ compile e2 @ [ Amul ] 32 | (*@ r = compile param 33 | variant param 34 | ensures let r_eval = eval_expr param in 35 | compute (r_eval :: []) [] = compute [] r*) 36 | -------------------------------------------------------------------------------- /Vagrantfile: -------------------------------------------------------------------------------- 1 | # -*- mode: ruby -*- 2 | # vi: set ft=ruby : 3 | 4 | Vagrant.configure("2") do |config| 5 | config.vm.box = "generic/ubuntu2010" 6 | 7 | # general configuration 8 | config.vm.provision "shell", inline: <<-SHELL 9 | apt-get update 10 | apt-get install -y git 11 | apt-get install -y emacs 12 | apt-get install -y autoconf libgmp-dev pkg-config 13 | apt-get install -y zlib1g-dev 14 | apt-get install -y libexpat1-dev libgtk2.0-dev libgtksourceview2.0-dev 15 | apt upgrade -y 16 | apt-get install -y opam 17 | SHELL 18 | 19 | # configuring the why3 framework 20 | config.vm.provision "shell", privileged: false, inline: <<-SHELL 21 | opam init -y 22 | opam switch create 4.12.0 23 | opam install -y alt-ergo 24 | opam install -y why3 25 | SHELL 26 | 27 | # installing cameleer and the gospel dependency 28 | config.vm.provision "shell", privileged: false, inline: <<-SHELL 29 | eval `opam config env` 30 | git clone -b implementations_gospel https://github.com/ocaml-gospel/gospel 31 | git clone https://github.com/ocaml-gospel/cameleer 32 | opam pin add -y gospel 33 | opam pin add -y cameleer 34 | why3 config detect 35 | echo "let succ x = x + 1 (*@ r = succ x ensures r > x *)" > test.ml 36 | eval `opam config env` 37 | cameleer --batch --prover alt-ergo test.ml 38 | SHELL 39 | end 40 | -------------------------------------------------------------------------------- /examples/in_progress/vector.ml: -------------------------------------------------------------------------------- 1 | (*@ open Sequence *) 2 | 3 | type 'a t = { 4 | dummy : 'a; 5 | mutable size : int; 6 | mutable data : 'a array; 7 | (* 0 <= size <= Array.length data *) 8 | mutable view : 'a sequence; [@ghost] 9 | } 10 | 11 | let make ?dummy n d = 12 | if n < 0 || n > Sys.max_array_length then invalid_arg "Vector.make"; 13 | let dummy = match dummy with None -> d | Some x -> x in 14 | { dummy; size = n; data = Array.make n dummy; view = empty } 15 | (*@ t = make ?dummy n d 16 | requires 0 <= n <= Sys.max_array_length 17 | raises Invalid_argument _ -> not (0 <= n < Sys.max_array_length) 18 | ensures t.size = n *) 19 | 20 | (* let create ?(capacity=0) ~dummy = 21 | * if capacity < 0 || capacity > Sys.max_array_length then 22 | * invalid_arg "Vector.create"; 23 | * { dummy = dummy; size = 0; data = Array.make capacity dummy; } 24 | * (\*@ t = create ?capacity ~dummy 25 | * requires let capacity = match capacity with 26 | * | None -> 0 | Some c -> c in 27 | * 0 <= capacity <= Sys.max_array_length 28 | * raises Invalid_argument _ -> false *\) *) 29 | 30 | let init n ~dummy f = 31 | if n < 0 || n > Sys.max_array_length then invalid_arg "Vector.init"; 32 | { dummy; size = n; data = Array.init n f; view = empty } 33 | (*@ t = init n ~dummy f 34 | raises Invalid_argument _ -> not (0 <= n < Sys.max_array_length) *) 35 | -------------------------------------------------------------------------------- /examples/inductive_predicates.ml: -------------------------------------------------------------------------------- 1 | module Arith (X : sig 2 | type elt 3 | 4 | val eq : elt -> elt -> bool 5 | end) = 6 | struct 7 | type arith = 8 | | AConst of int 9 | | AVar of X.elt 10 | | AMul of arith * arith 11 | | APlus of arith * arith 12 | | AMinus of arith * arith 13 | 14 | type store = X.elt -> int 15 | 16 | (*@ inductive sems_arith (a: arith) (s: store) (n: int) = 17 | | const: forall s n. sems_arith (AConst n) s n 18 | | var: forall s x. sems_arith (AVar x) s (s x) 19 | | mul: forall s: store, a1: arith, a2: arith, n1 n2. 20 | sems_arith a1 s n1 -> sems_arith a2 s n2 -> 21 | sems_arith (AMul a1 a2) s (n1 * n2) 22 | | plus: forall s a1 a2 n1 n2. 23 | sems_arith a1 s n1 -> sems_arith a2 s n2 -> 24 | sems_arith (APlus a1 a2) s (n1 + n2) 25 | | minus: forall s a1 a2 n1 n2. 26 | sems_arith a1 s n1 -> sems_arith a2 s n2 -> 27 | sems_arith (AMinus a1 a2) s (n1 - n2) *) 28 | 29 | let rec interpreter store = function 30 | | AConst n -> n 31 | | AVar x -> store x 32 | | AMul (a1, a2) -> interpreter store a1 * interpreter store a2 33 | | APlus (a1, a2) -> interpreter store a1 + interpreter store a2 34 | | AMinus (a1, a2) -> interpreter store a1 - interpreter store a2 35 | (*@ r = interpreter s a 36 | variant a 37 | ensures sems_arith a s r *) 38 | end 39 | -------------------------------------------------------------------------------- /examples/same_fringe.ml: -------------------------------------------------------------------------------- 1 | module type EQUAL = sig 2 | type elt 3 | 4 | val eq : elt -> elt -> bool 5 | (*@ b = eq x y 6 | ensures b <-> x = y *) 7 | end 8 | 9 | module Make (Eq : EQUAL) = struct 10 | type tree = Empty | Node of tree * Eq.elt * tree 11 | 12 | (*@ function elements (t: tree) : Eq.elt list = match t with 13 | | Empty -> [] 14 | | Node l x r -> (elements l) @ (x :: elements r) *) 15 | 16 | type enum = (Eq.elt * tree) list 17 | 18 | (*@ function enum_elements (e : enum) : Eq.elt list = match e with 19 | | [] -> [] 20 | | (x, r) :: e -> x :: (elements r @ enum_elements e) *) 21 | 22 | let rec mk_zipper (t : tree) (e : enum) = 23 | match t with Empty -> e | Node (l, x, r) -> mk_zipper l ((x, r) :: e) 24 | (*@ r = mk_zipper t e 25 | variant t 26 | ensures enum_elements r = elements t @ enum_elements e *) 27 | 28 | let rec eq_enum (e1 : enum) (e2 : enum) = 29 | match (e1, e2) with 30 | | [], [] -> true 31 | | (x1, r1) :: e1, (x2, r2) :: e2 -> 32 | Eq.eq x1 x2 && eq_enum (mk_zipper r1 e1) (mk_zipper r2 e2) 33 | | _ -> false 34 | (*@ b = eq_num e1 e2 35 | variant List.length (enum_elements e1) 36 | ensures b <-> enum_elements e1 = enum_elements e2 *) 37 | 38 | let same_fringe (t1 : tree) (t2 : tree) = 39 | eq_enum (mk_zipper t1 []) (mk_zipper t2 []) 40 | (*@ b = same_fringe t1 t2 41 | ensures b <-> elements t1 = elements t2 *) 42 | end 43 | -------------------------------------------------------------------------------- /examples/fast_exponentiation/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | -------------------------------------------------------------------------------- /examples/applicative_queue.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { self : 'a list * 'a list; view : 'a list [@ghost] } 2 | (*@ invariant let (prefix, xiffus) = self in 3 | (prefix=[] -> xiffus=[]) && view = prefix @ List.rev xiffus *) 4 | 5 | let empty = { self = ([], []); view = [] } 6 | (*@ t = empty 7 | ensures t.view = [] *) 8 | 9 | let[@logic] is_empty { self; _ } = match self with [], _ -> true | _ -> false 10 | (*@ b = is_empty q 11 | ensures b <-> q.view = [] *) 12 | 13 | let add elt { self; view } = 14 | match self with 15 | | [], [] -> { self = ([ elt ], []); view = [ elt ] } 16 | | prefix, xiffus -> { self = (prefix, elt :: xiffus); view = view @ [ elt ] } 17 | (*@ r = add elt queue 18 | ensures r.view = queue.view @ (elt :: []) *) 19 | 20 | let head { self; _ } = 21 | match self with head :: _, _ -> head | [], _ -> raise Not_found 22 | (*@ x = head param 23 | raises Not_found -> is_empty param 24 | ensures match param.view with [] -> false | y :: _ -> x = y *) 25 | 26 | let[@ghost] [@logic] tail_list = function [] -> assert false | _ :: l -> l 27 | (*@ r = tail_list q 28 | requires q <> [] 29 | ensures match q with [] -> false | _ :: l -> r = l *) 30 | 31 | let tail { self; view } = 32 | match self with 33 | | [ _ ], xiffus -> { self = (List.rev xiffus, []); view = tail_list view } 34 | | _ :: prefix, xiffus -> { self = (prefix, xiffus); view = tail_list view } 35 | | [], _ -> raise Not_found 36 | (*@ r = tail t 37 | raises Not_found -> is_empty t 38 | ensures r.view = tail_list t.view *) 39 | -------------------------------------------------------------------------------- /stdlib/sum.ml: -------------------------------------------------------------------------------- 1 | (*@ function logic_sum (f: int -> int) (l: int) (u: int) : integer *) 2 | 3 | (*@ axiom logic_sum_0: forall f l u. u <= l -> logic_sum f l u = 0 *) 4 | (*@ axiom logic_sum_n: forall f l u. u > l -> 5 | logic_sum f l u = logic_sum f l (u-1) + f (u-1) *) 6 | 7 | (*@ lemma logic_sum_left: 8 | forall f: (int -> int), a b: int. 9 | a < b -> logic_sum f a b = f a + logic_sum f (a + 1) b *) 10 | 11 | (*@ lemma logic_sum_ext: 12 | forall f g: (int -> int), a b: int. 13 | (forall i. a <= i < b -> f i = g i) -> 14 | logic_sum f a b = logic_sum g a b *) 15 | 16 | (*@ lemma logic_sum_le: 17 | forall f g: (int -> int), a b: int. 18 | (forall i. a <= i < b -> f i <= g i) -> 19 | logic_sum f a b <= logic_sum g a b *) 20 | 21 | (*@ lemma logic_sum_zero: 22 | forall f: (int -> int), a b: int. 23 | (forall i. a <= i < b -> f i = 0) -> 24 | logic_sum f a b = 0 *) 25 | 26 | (*@ lemma logic_sum_nonneg: 27 | forall f: (int -> int), a b: int. 28 | (forall i. a <= i < b -> 0 <= f i) -> 29 | 0 <= logic_sum f a b *) 30 | 31 | (*@ lemma logic_sum_decomp: 32 | forall f: (int -> int), a b c: int. a <= b <= c -> 33 | logic_sum f a c = logic_sum f a b + logic_sum f b c *) 34 | 35 | let[@lemma] rec shift_left (f : int -> int) (g : int -> int) a b c (d : int) = 36 | if a < b then shift_left f g (a + 1) b (c + 1) d 37 | (*@ shift_left f g a b c d 38 | requires b - a = d - c 39 | requires forall i. a <= i < b -> f i = g (c + i - a) 40 | variant b - a 41 | ensures logic_sum f a b = logic_sum g c d *) 42 | -------------------------------------------------------------------------------- /examples/in_progress/toy_compiler/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | -------------------------------------------------------------------------------- /examples/imp/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | -------------------------------------------------------------------------------- /examples/insertion_sort_list.ml: -------------------------------------------------------------------------------- 1 | (* @ open Permut *) 2 | 3 | module type PRE_ORD = sig 4 | type t 5 | 6 | (*@ function le: t -> t -> bool *) 7 | 8 | (*@ predicate total_preorder (leq: t -> t -> bool) = 9 | (forall x. leq x x) /\ 10 | (forall x y. leq x y \/ leq y x) /\ 11 | (forall x y z. (leq x y -> leq y z -> leq x z)) *) 12 | 13 | (*@ axiom is_total_preorder: total_preorder le *) 14 | 15 | val leq : t -> t -> bool 16 | (*@ b = leq x y 17 | ensures b <-> le x y *) 18 | end 19 | 20 | module InsertionSort (E : PRE_ORD) = struct 21 | type elt = E.t 22 | 23 | let[@logic] rec sorted_list = function 24 | | [] | [ _ ] -> true 25 | | x :: y :: r -> E.leq x y && sorted_list (y :: r) 26 | (*@ sorted_list l 27 | variant l *) 28 | 29 | (*@ lemma sorted_mem: forall x l. 30 | (forall y. List.mem y l -> E.le x y) /\ sorted_list l <-> 31 | sorted_list (x :: l) *) 32 | 33 | (*@ lemma sorted_append: forall l1 l2. 34 | (sorted_list l1 && sorted_list l2 && 35 | (forall x y. List.mem x l1 -> List.mem y l2 -> E.le x y)) <-> 36 | sorted_list (l1 ++ l2) *) 37 | 38 | let[@logic] rec insert x = function 39 | | [] -> [ x ] 40 | | y :: l -> if E.leq x y then x :: y :: l else y :: insert x l 41 | (*@ l = insert x param 42 | requires sorted_list param 43 | variant param 44 | (* ensures permut (x :: param) l *) 45 | ensures sorted_list l *) 46 | 47 | let rec insertion_sort = function 48 | | [] -> [] 49 | | x :: l -> insert x (insertion_sort l) 50 | (*@ l = insertion_sort param 51 | variant param 52 | (* ensures permut param l *) 53 | ensures sorted_list l *) 54 | end 55 | -------------------------------------------------------------------------------- /examples/even_odd/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | -------------------------------------------------------------------------------- /examples/find/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | -------------------------------------------------------------------------------- /examples/binary_search_tree.ml: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int [@@logic] 5 | (*@ axiom is_pre_order: is_pre_order compare *) 6 | end 7 | 8 | module Make (Ord : OrderedType) = struct 9 | type elt = Ord.t 10 | type t = E | T of t * elt * t 11 | 12 | (*@ function occ (x: elt) (t: t) : integer = match t with 13 | | E -> 0 14 | | T l v r -> 15 | occ x l + occ x r + (if Ord.compare x v = 0 then 1 else 0) *) 16 | 17 | (*@ lemma occ_nonneg: forall x: elt, t: t. occ x t >= 0 *) 18 | 19 | (*@ predicate mem (x: elt) (t: t) = occ x t > 0 *) 20 | 21 | (*@ predicate bst (t: t) = match t with 22 | | E -> true 23 | | T l v r -> 24 | (forall lv. mem lv l -> Ord.compare lv v < 0) && 25 | (forall rv. mem rv r -> Ord.compare rv v > 0) && 26 | bst l && bst r *) 27 | 28 | let empty = E 29 | (*@ r = empty 30 | ensures forall x. occ x r = 0 31 | ensures bst r *) 32 | 33 | let rec insert x = function 34 | | E -> T (E, x, E) 35 | | T (l, y, r) -> 36 | if Ord.compare x y = 0 then T (l, y, r) 37 | else if Ord.compare x y < 0 then T (insert x l, y, r) 38 | else T (l, y, insert x r) 39 | (*@ t = insert x param 40 | requires bst param 41 | variant param 42 | ensures forall y. y <> x -> occ y t = occ y param 43 | ensures occ x t = occ x param || occ x t = 1 + occ x param 44 | ensures bst t *) 45 | 46 | let rec mem x = function 47 | | E -> false 48 | | T (l, v, r) -> 49 | let c = Ord.compare x v in 50 | c = 0 || mem x (if c < 0 then l else r) 51 | (*@ b = mem x param 52 | requires bst param 53 | variant param 54 | ensures b <-> mem x param *) 55 | end 56 | -------------------------------------------------------------------------------- /examples/tree_height_cps/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /examples/in_progress/tree_of_an_array.ml: -------------------------------------------------------------------------------- 1 | type 'a t = Empty | Node of 'a t * 'a * 'a t 2 | 3 | (*@ function inorder (t: 'a t) : 'a list = match t with 4 | | Empty -> [] 5 | | Node l x r -> (inorder l) @ (x :: (inorder r)) *) 6 | 7 | (*@ function size (t: 'a t) : integer = match t with 8 | | Empty -> 0 9 | | Node l _ r -> 1 + size l + size r *) 10 | 11 | (*@ function height (t: 'a t) : integer = match t with 12 | | Empty -> 0 13 | | Node l _ r -> 1 + max (height l) (height r) *) 14 | 15 | let[@logic] rec to_list a l u = 16 | if u <= l then [] else a.(l) :: to_list a (l + 1) u 17 | (*@ to_list a l u 18 | requires l >= 0 /\ u <= Array.length a 19 | variant u - l *) 20 | 21 | let[@lemma] rec to_list_append (a : 'a array) (l : int) (m : int) (u : int) = 22 | if l < m then to_list_append a (l + 1) m u 23 | (*@ to_list_append a l m u 24 | requires 0 <= l <= m <= u <= Array.length a 25 | variant m - l 26 | ensures to_list a l m @ to_list a m u = to_list a l u *) 27 | 28 | (*@ open Power *) 29 | 30 | let rec tree_of_array_aux a lo hi = 31 | if lo = hi then Empty 32 | else 33 | let mid = lo + ((hi - lo) / 2) in 34 | let left = tree_of_array_aux a lo mid in 35 | let right = tree_of_array_aux a (mid + 1) hi in 36 | Node (left, a.(mid), right) 37 | (*@ r = tree_of_array_aux a lo hi 38 | requires 0 <= lo <= hi <= Array.length a 39 | variant hi - lo 40 | ensures inorder r = to_list a lo hi 41 | ensures let n = hi - lo in n = size r && 42 | (n > 0 -> 43 | let h = height r in 44 | 2 ^ (h - 1) <= n < 2 ^ h) *) 45 | 46 | let rec tree_of_array a = tree_of_array_aux a 0 (Array.length a) 47 | (*@ r = tree_of_array a 48 | ensures inorder r = to_list a 0 (Array.length a) 49 | ensures size r = Array.length a *) 50 | -------------------------------------------------------------------------------- /doc/gospel.sty: -------------------------------------------------------------------------------- 1 | 2 | \RequirePackage{listings} 3 | \RequirePackage{amssymb} 4 | \RequirePackage{xcolor} 5 | \RequirePackage{bold-extra} 6 | 7 | \definecolor{thegraygray}{rgb}{0.5,0.5,0.5} 8 | 9 | \lstdefinelanguage{gospel} 10 | { 11 | basicstyle=\ttfamily,% 12 | morekeywords=[1]{predicate,constant,consumes,function,goal,type,use,% 13 | import,theory,end,module,in,syntax,old,scope,functor,struct,sig,to,% 14 | mutable,invariant,model,requires,ensures,raises,returns,reads,writes,diverges,% 15 | variant,let,val,while,for,loop,abstract,private,any,assume,check,assert,% 16 | begin,rec,clone,if,then,else,ghost,true,false,do,done,try,raise,absurd,% 17 | axiom,lemma,export,forall,exists,match,with,and,inductive,coinductive,fun,% 18 | ephemeral,modifies},% 19 | keywordstyle=[1]{\color{thered}},% 20 | %keywordstyle=\bfseries,% 21 | otherkeywords={},% 22 | commentstyle=\itshape\color{thegraygray},% 23 | columns=[l]fullflexible,% 24 | sensitive=true,% 25 | escapeinside={*?}{?*},% 26 | keepspaces=true, 27 | literate=% 28 | {-}{\raisebox{0.08em}{-}}{1}% for nicer -> 29 | % {'a}{$\alpha$}{1}% 30 | % {'b}{$\beta$}{1}% 31 | % {<}{$<$}{1}% 32 | % {>}{$>$}{1}% 33 | % {<=}{$\le$}{1}% 34 | % {>=}{$\ge$}{1}% 35 | % {<>}{$\ne$}{1}% 36 | % {/\\}{$\land$}{1}% 37 | % {\\/}{ $\lor$ }{3}% 38 | % {\ or(}{ $\lor$(}{3}% 39 | % {not\ }{$\lnot$ }{2}% 40 | % {not(}{$\lnot$(}{2}% 41 | % {+->}{\texttt{+->}}{3}% 42 | % {+->}{$\mapsto$}{2}% 43 | % {-->}{\texttt{-\relax->}}{3}% 44 | % {-->}{$\longrightarrow$}{2}% 45 | % {->}{$\rightarrow$}{2}% 46 | % {<-}{$\leftarrow$}{2}% 47 | % {<->}{$\leftrightarrow$}{2}% 48 | } 49 | 50 | \lstnewenvironment{gospel}{\lstset{language=gospel,aboveskip=5pt,belowskip=5pt}}{} 51 | \lstnewenvironment{gospelsmall} 52 | {\lstset{language=gospel,basicstyle=\ttfamily\footnotesize}}{} 53 | 54 | \def\gosp{\lstinline[language=gospel, basicstyle=\ttfamily]} %normalsize 55 | \def\gosprm{\lstinline[language=gospel, basicstyle=\normalsize]} 56 | \let\of\gosp 57 | -------------------------------------------------------------------------------- /src/why3ocaml_driver.ml: -------------------------------------------------------------------------------- 1 | (** Temporary "driver" from OCaml symbols into WhyML. 2 | 3 | This is a very simple workaround, in order to support translation of very 4 | simple OCaml programs. In the future, this should resemble the drivers 5 | technology of Why3, i.e., one should be able to provide a driver file 6 | mapping OCaml symbols into a corresponding counterpart from the Why3 7 | standard library. The translation plugin should then consume such file, 8 | similarly to how Why3 extraction mechanism deals with drivers. *) 9 | 10 | open Gospel.Utils 11 | 12 | type syntax_map = string Hstr.t 13 | 14 | let driver : syntax_map = Hstr.create 16 15 | 16 | let () = 17 | List.iter 18 | (fun (x, y) -> Hstr.add driver x y) 19 | [ 20 | ("integer", "int"); 21 | ("int", "int"); 22 | ("+", "infix +"); 23 | ("*", "infix *"); 24 | ("-", "infix -"); 25 | ("/", "infix /"); 26 | ("infix mod", "infix %"); 27 | ("<=", "infix <="); 28 | (">=", "infix >="); 29 | ("<", "infix <"); 30 | (">", "infix >"); 31 | ("<>", "infix <>"); 32 | ("=", "infix ="); 33 | (* FIXME: this is only true for integers *) 34 | ("==", "infix =="); 35 | ("!=", "infix !="); 36 | (* FIXME: this is only true for integers *) 37 | ("mixfix {}", "empty"); 38 | ("mixfix {:_:}", "singleton"); 39 | ("mixfix [_]", "mixfix []"); 40 | ("mixfix [_.._]", "mixfix [..]"); 41 | ("mixfix [.._]", "mixfix [.._]"); 42 | ("mixfix [_..]", "mixfix [_..]"); 43 | ("[]", "Nil"); 44 | ("infix ::", "Cons"); 45 | ("::", "Cons"); 46 | (* FIXME: understand why this happens in program symbols *) 47 | ("infix @", "infix +++"); 48 | ("@", "infix +++"); 49 | ("!", "prefix !"); 50 | (":=", "infix :="); 51 | ("|>", "infix |>"); 52 | ("<>", "infix ~="); 53 | ("mixfix ([<-])", "mixfix ([<-])"); 54 | ("~-", "prefix ~-"); 55 | ] 56 | 57 | let query_syntax str = Hstr.find_opt driver str 58 | -------------------------------------------------------------------------------- /examples/ocaml_stack.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { 2 | mutable c : 'a list; 3 | mutable len : int; 4 | mutable view : 'a list; [@ghost] 5 | } 6 | (*@ invariant List.length view = len /\ c = view *) 7 | 8 | exception Empty 9 | 10 | let create () = { c = []; len = 0; view = [] } 11 | (*@ r = create () 12 | ensures r.view = [] *) 13 | 14 | let clear s = 15 | s.c <- []; 16 | s.len <- 0; 17 | s.view <- [] 18 | (*@ clear s 19 | ensures s.view = [] *) 20 | 21 | let copy s = { c = s.c; len = s.len; view = s.view } 22 | (*@ r = copy s 23 | ensures r.view = s.view *) 24 | 25 | let push x s = 26 | s.c <- x :: s.c; 27 | s.len <- s.len + 1; 28 | s.view <- x :: s.view 29 | (*@ push x s 30 | ensures s.view = x :: (old s.view) *) 31 | 32 | let pop s = 33 | match s.c with 34 | | hd :: tl -> 35 | s.c <- tl; 36 | s.len <- s.len - 1; 37 | s.view <- tl; 38 | hd 39 | | [] -> raise Empty 40 | (*@ r = pop s 41 | raises Empty -> (old s.view) = [] 42 | ensures match (old s.view) with 43 | | [] -> false 44 | | hd :: tl -> r = hd && s.view = tl *) 45 | 46 | let pop_opt s = 47 | match s.c with 48 | | hd :: tl -> 49 | s.c <- tl; 50 | s.len <- s.len - 1; 51 | s.view <- tl; 52 | Some hd 53 | | [] -> None 54 | 55 | (*@ r = pop_opt s 56 | ensures match (old s.view) with 57 | | [] -> r = None 58 | | hd :: tl -> r = Some hd && s.view = tl *) 59 | let top s = match s.c with hd :: _ -> hd | [] -> raise Empty 60 | (*@ r = top s 61 | raises Empty -> s.view = [] 62 | ensures match s.view with [] -> false | hd::_ -> r = hd *) 63 | 64 | let top_opt s = match s.c with hd :: _ -> Some hd | [] -> None 65 | (*@ r = top s 66 | ensures match s.view with [] -> r = None | hd::_ -> r = r = Some hd *) 67 | 68 | let is_empty s = match s.c with [] -> true | _ -> false 69 | (*@ b = is_empty s 70 | ensures b <-> s.view = [] *) 71 | 72 | let length s = s.len 73 | (*@ r = length s 74 | ensures r = List.length s.view *) 75 | -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree_alt/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /examples/in_progress/zipper/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | -------------------------------------------------------------------------------- /examples/xor/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | -------------------------------------------------------------------------------- /examples/ephemeral_queue.ml: -------------------------------------------------------------------------------- 1 | type 'a t = { 2 | mutable front : 'a list; 3 | mutable rear : 'a list; 4 | mutable size : int; 5 | mutable view : 'a list; [@ghost] 6 | } 7 | (*@ invariant size = List.length view 8 | invariant (front = [] -> rear = []) && view = front @ List.rev rear *) 9 | 10 | let create () = { front = []; rear = []; size = 0; view = [] } 11 | (*@ q = create () 12 | ensures q.view = [] *) 13 | 14 | let[@logic] is_empty q = q.size = 0 15 | (*@ b = is_empty q 16 | ensures b <-> q.view = [] *) 17 | 18 | let push x q = 19 | if is_empty q then q.front <- [ x ] else q.rear <- x :: q.rear; 20 | q.size <- q.size + 1; 21 | q.view <- q.view @ [ x ] 22 | (*@ push x q 23 | ensures q.view = (old q.view) @ (x :: []) *) 24 | 25 | let[@ghost] tail_list = function [] -> assert false | _ :: l -> l 26 | (*@ r = tail_list param 27 | requires param <> [] 28 | ensures match param with [] -> false | _ :: l -> r = l *) 29 | 30 | let pop q = 31 | let x = 32 | match q.front with 33 | | [] -> raise Not_found 34 | | [ x ] -> 35 | q.front <- List.rev q.rear; 36 | q.rear <- []; 37 | x 38 | | x :: f -> 39 | q.front <- f; 40 | x 41 | in 42 | q.view <- tail_list q.view; 43 | q.size <- q.size - 1; 44 | x 45 | (*@ raises Not_found -> is_empty (old q) 46 | ensures result :: q.view = (old q).view *) 47 | 48 | let transfer q1 q2 = 49 | while not (is_empty q1) do 50 | (*@ variant List.length q1.view 51 | invariant q1.size = List.length q1.view && 52 | q2.size = List.length q2.view 53 | invariant (q1.front = [] -> q1.rear = []) && 54 | (q2.front = [] -> q2.rear = []) 55 | invariant q1.view = q1.front @ List.rev q1.rear && 56 | q2.view = q2.front @ List.rev q2.rear 57 | invariant q2.view @ q1.view = (old q2).view @ (old q1).view *) 58 | push (pop q1) q2 59 | done 60 | (*@ transfer q1 q2 61 | raises Not_found -> false 62 | ensures q1.view = [] 63 | ensures q2.view = (old q2.view) @ (old q1.view) *) 64 | -------------------------------------------------------------------------------- /examples/xor.ml: -------------------------------------------------------------------------------- 1 | (*@ open Seq *) 2 | (* @ open SeqOfList *) 3 | 4 | (*@ predicate map (f: 'a -> 'a -> 'b) (a1 a2: 'a seq) (r: 'b seq) = 5 | length a1 = length a2 = length r && 6 | forall i. 0 <= i < length a1 -> r[i] = f a1[i] a2[i] *) 7 | 8 | module type XOR = sig 9 | type t 10 | 11 | val xor : t -> t -> t [@@logic] 12 | 13 | (*@ axiom com_xor: forall x y. xor x y = xor y x *) 14 | (*@ axiom inv_xor: forall x y. xor (xor x y) y = x *) 15 | end 16 | 17 | module type CIPHER = sig 18 | type elt 19 | (*@ function xor (x y: elt) : elt *) 20 | 21 | type t 22 | (*@ function to_seq (t: t) : elt seq *) 23 | 24 | val cipher : t -> t -> t 25 | (*@ r = cipher k m 26 | requires length (to_seq k) = length (to_seq m) 27 | ensures map (fun x y -> xor x y) (to_seq m) (to_seq k) (to_seq r) *) 28 | end 29 | 30 | module Make (X : XOR) : CIPHER with type elt = X.t = struct 31 | type elt = X.t 32 | type t = elt list 33 | 34 | (*@ function xor (x y: elt) : elt = X.xor x y *) 35 | 36 | (* @ function to_seq (t: t) : elt seq = of_list t *) 37 | 38 | let rec cipher key msg = 39 | match (key, msg) with 40 | | [], [] -> [] 41 | | x :: xs, y :: ys -> X.xor x y :: cipher xs ys 42 | | _ -> assert false 43 | (*@ r = cipher m k 44 | requires List.length m = List.length k 45 | ensures map (fun x y -> X.xor x y) k m r 46 | variant m *) 47 | 48 | let correct msg key = 49 | let r = cipher key msg in 50 | cipher r key 51 | (*@ res = correct msg key 52 | requires length msg = length key 53 | ensures res == msg *) 54 | end 55 | 56 | module XBool : XOR with type t = bool = struct 57 | type t = bool 58 | 59 | let[@logic] xor t1 t2 = ((not t1) && t2) || (t1 && not t2) 60 | end 61 | 62 | module XBool2 : XOR with type t = bool = struct 63 | type t = bool 64 | 65 | let[@logic] xor t1 t2 = if t1 then not t2 else t2 66 | end 67 | 68 | module XBit : XOR = struct 69 | type t = Zero | One 70 | 71 | let[@logic] xor t1 t2 = 72 | match (t1, t2) with Zero, Zero | One, One -> Zero | _ -> One 73 | end 74 | -------------------------------------------------------------------------------- /TODO.md: -------------------------------------------------------------------------------- 1 | Things to Think About 2 | ===================== 3 | 4 | 1. Order of evaluation of arguments --> not-specified in OCaml, right-to-left in 5 | WhyML. 6 | For now, I should think about writing OCaml code in A-normal form. 7 | 8 | 2. Equality. 9 | We have polymorphic equality in OCaml, but we have no 10 | such thing in WhyML! One solution would be to write my OCaml code as a 11 | functor with equality on objects as an argument. Example: same fringe. 12 | 13 | 3. Records extended with ghost fields. An example: 14 | ``` 15 | type 'a t = { 16 | front: 'a list; 17 | rear : 'a list; 18 | } (*@ model view: 'a seq; 19 | invariant view == front @ List.rev rear *) 20 | ``` 21 | Now, we have the problem of building inhabitants of type `t`: 22 | ``` 23 | let mk_t (front: 'a list) (rear: 'a list) = 24 | { front; rear } 25 | ``` 26 | Field `view` is missing in such a definition. 27 | 28 | I can think of some solutions, none is perfect: 29 | * extend GOSPEL with an annotation to initialize ghost fields: 30 | ``` 31 | { front; rear; (*@ view = front @ List.rev rear *) } 32 | ``` 33 | What about accessing fields? Would we have something like 34 | ``` 35 | match q.front, (*@ q.view *) with 36 | | Cons (_, tl), (*@ Cons (_, tlv) *) -> ... 37 | ``` 38 | The above code is only "partially" ghost. What if we have a whole block 39 | that deals only with ghost code? 40 | ``` 41 | (*@ match q.view with 42 | | Cons (x, _) -> x 43 | ... *) 44 | ``` 45 | This means that GOSPEL should, in fact, be extended to support arbitrary 46 | OCaml expressions? 47 | 48 | * Use an OCaml attribte to state that a field is ghost: 49 | ``` 50 | type 'a t = { 51 | front: 'a list; 52 | rear : 'a list; 53 | [@ghost] view: 'a list; 54 | } (*@ invariant ... *) 55 | ``` 56 | But now, all hell breaks loose: field `view` will be visible to the 57 | compiler, and we can only use types that are defined by OCaml (not 58 | GOSPEL-related ones, such as `seq`). 59 | -------------------------------------------------------------------------------- /examples/fact/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | -------------------------------------------------------------------------------- /bin/cli.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | 3 | let fname = ref None 4 | let debug = ref false 5 | let batch = ref false 6 | let extract = ref false 7 | let prover = ref None 8 | let path = Queue.create () 9 | let version = "0.1~dev" 10 | 11 | let spec = 12 | [ 13 | ( "-L", 14 | Arg.String (fun s -> Queue.add s path), 15 | "add to the search path" ); 16 | ("--debug", Arg.Unit (fun () -> debug := true), "print debug information"); 17 | ("--batch", Arg.Unit (fun () -> batch := true), "activate batch mode"); 18 | ( "--extract", 19 | Arg.Unit (fun () -> extract := true), 20 | "activate extraction mode" ); 21 | ( "--prover", 22 | Arg.String (fun s -> prover := Some s), 23 | "set prover for batch mode" ); 24 | ( "--version", 25 | Arg.Unit 26 | (fun () -> 27 | printf "Cameleer %s@." version; 28 | exit 0), 29 | " print version information" ); 30 | ] 31 | 32 | let usage_msg = sprintf "%s .ml\nVerify OCaml program\n" Sys.argv.(0) 33 | 34 | let usage () = 35 | Arg.usage spec usage_msg; 36 | exit 1 37 | 38 | let set_file f = 39 | match !fname with 40 | | None when Filename.check_suffix f ".ml" -> fname := Some f 41 | | _ -> usage () 42 | 43 | let () = Arg.parse spec set_file usage_msg 44 | let fname = match !fname with None -> usage () | Some f -> f 45 | let debug = if !debug then "--debug=print_modules" else "" 46 | let path = Queue.fold (fun acc s -> sprintf "-L %s %s" s acc) "" path 47 | 48 | let execute_ide fname path debug = 49 | Sys.command (sprintf "why3 ide %s %s %s" fname path debug) 50 | 51 | let execute_extract fname = 52 | Sys.command (sprintf "why3 extract -D ocaml64 %s" fname) 53 | 54 | let execute_batch fname path debug prover = 55 | Sys.command 56 | (sprintf "why3 prove %s %s %s -P %s -a split_vc" fname path debug prover) 57 | 58 | let batch = !batch 59 | let extract = !extract 60 | 61 | let _ = 62 | if batch then 63 | let p = match !prover with None -> usage () | Some s -> s in 64 | exit (execute_batch fname path debug p) 65 | else if extract then exit (execute_extract fname) 66 | else exit (execute_ide fname path debug) 67 | -------------------------------------------------------------------------------- /doc/why3lang.sty: -------------------------------------------------------------------------------- 1 | 2 | \RequirePackage{listings} 3 | \RequirePackage{amssymb} 4 | \RequirePackage{xcolor} 5 | \RequirePackage{bold-extra} 6 | 7 | \definecolor{thegraygray}{rgb}{0.5,0.5,0.5} 8 | 9 | \lstdefinelanguage{why3} 10 | { 11 | basicstyle=\ttfamily,% 12 | morekeywords=[1]{predicate,constant,function,goal,type,use,scope,as,% 13 | import,theory,end,module,in,syntax,old,% 14 | mutable,invariant,model,requires,ensures,raises,returns,reads,writes,diverges,% 15 | variant,let,val,while,for,loop,abstract,private,any,assume,check,assert,% 16 | begin,rec,clone,if,then,else,ghost,true,false,do,done,try,raise,absurd,% 17 | axiom,lemma,export,forall,exists,match,with,and,inductive,coinductive,fun},% 18 | %keywordstyle=[1]{\color{thered}},% 19 | keywordstyle=[1]{\bfseries},% 20 | otherkeywords={},% 21 | commentstyle=\itshape\color{thegraygray},% 22 | columns=[l]fullflexible,% 23 | sensitive=true,% 24 | morecomment=[s]{(*}{*)},% 25 | escapeinside={*?}{?*},% 26 | keepspaces=true, 27 | literate=% 28 | } 29 | 30 | \lstnewenvironment{why3}{\lstset{language=why3}}{} 31 | \lstnewenvironment{why3small} 32 | {\lstset{language=why3,basicstyle=\ttfamily\footnotesize}}{} 33 | 34 | 35 | \lstdefinelanguage{mli} 36 | { 37 | basicstyle=\ttfamily,% 38 | morekeywords=[1]{predicate,constant,function,goal,type,use,% 39 | import,theory,end,module,in,syntax,old,% 40 | mutable,invariant,model,requires,ensures,raises,returns,reads,writes,diverges,% 41 | variant,let,val,while,for,loop,abstract,private,any,assume,check,assert,% 42 | begin,rec,clone,if,then,else,ghost,true,false,do,done,try,raise,absurd,% 43 | axiom,lemma,export,forall,exists,match,with,and,inductive,coinductive,fun,% 44 | ephemeral,modifies,checks},% 45 | %keywordstyle=[1]{\color{thered}},% 46 | keywordstyle=[1]{\bfseries},% 47 | otherkeywords={},% 48 | commentstyle=\itshape\color{thegraygray},% 49 | columns=[l]fullflexible,% 50 | sensitive=true,% 51 | escapeinside={*?}{?*},% 52 | morecomment=[s]{(**}{*)},% 53 | keepspaces=true, 54 | literate=% 55 | } 56 | 57 | \lstnewenvironment{mli}{\lstset{language=mli}}{} 58 | \lstnewenvironment{mlismall} 59 | {\lstset{language=mli,basicstyle=\ttfamily\footnotesize}}{} 60 | 61 | 62 | \lstnewenvironment{C} 63 | {\lstset{language=C,basicstyle=\ttfamily,% 64 | columns=fullflexible,keepspaces=true,% 65 | %keywordstyle=[1]{\color{thered}},% 66 | keywordstyle=[1]{\bfseries},% 67 | morekeywords=[1]{assert,uint32_t}}}{} 68 | 69 | -------------------------------------------------------------------------------- /examples/mjrty.ml: -------------------------------------------------------------------------------- 1 | 2 | (*@ function rec numof (p: integer -> bool) (a b: integer) : integer = 3 | if b <= a then 0 else 4 | if p (b - 1) then 1 + numof p a (b - 1) 5 | else numof p a (b - 1) *) 6 | (*@ variant b - a *) 7 | 8 | (*@ lemma numof_bounds : 9 | forall p : (integer -> bool), a b : int. 10 | a < b -> 0 <= numof p a b <= b - a *) 11 | 12 | (*@ lemma numof_append: 13 | forall p: (integer -> bool), a b c: integer. 14 | a <= b <= c -> numof p a c = numof p a b + numof p b c *) 15 | 16 | (*@ lemma numof_left_no_add: 17 | forall p : (integer -> bool), a b : integer. 18 | a < b -> not p a -> numof p a b = numof p (a+1) b *) 19 | 20 | (*@ lemma numof_left_add : 21 | forall p : (integer -> bool), a b : integer. 22 | a < b -> p a -> numof p a b = 1 + numof p (a+1) b *) 23 | 24 | (*@ function numof_eq (a: 'a array) (v: 'a) (l u: integer) : integer = 25 | numof (fun i -> a.(i) = v) l u *) 26 | 27 | module type EQUAL = sig 28 | type t 29 | 30 | val eq : t -> t -> bool 31 | (*@ b = eq x y 32 | ensures b <-> x = y *) 33 | end 34 | 35 | module Mjrty (Eq : EQUAL) = struct 36 | type candidate = Eq.t 37 | 38 | let mjrty a = 39 | let exception Found of candidate in 40 | let n = Array.length a in 41 | let cand = ref a.(0) in 42 | let k = ref 0 in 43 | try 44 | for i = 0 to n - 1 do 45 | (*@ invariant 0 <= !k <= numof_eq a !cand 0 i 46 | invariant 2 * (numof_eq a !cand 0 i - !k) <= i - !k 47 | invariant forall c. c <> !cand -> 2 * numof_eq a c 0 i <= i - !k *) 48 | if !k = 0 then begin 49 | cand := a.(i); 50 | k := 1 end 51 | else if Eq.eq !cand a.(i) then incr k 52 | else decr k 53 | done; 54 | if !k = 0 then raise Not_found; 55 | if 2 * !k > n then raise (Found !cand); 56 | k := 0; 57 | for i = 0 to n - 1 do 58 | (*@ invariant !k = numof_eq a !cand 0 i /\ 2 * !k <= n *) 59 | if Eq.eq a.(i) !cand then ( 60 | incr k; 61 | if 2 * !k > n then raise (Found !cand)) 62 | done; 63 | raise Not_found 64 | with Found c -> c 65 | (*@ c = mjrty a 66 | requires 1 <= Array.length a 67 | ensures 2 * numof_eq a c 0 (Array.length a) > Array.length a 68 | raises Not_found -> 69 | forall x. 2 * numof_eq a x 0 (Array.length a) <= Array.length a *) 70 | end 71 | -------------------------------------------------------------------------------- /examples/mergesort.ml: -------------------------------------------------------------------------------- 1 | module type PRE_ORD = sig 2 | type t 3 | 4 | (*@ function le: t -> t -> bool *) 5 | 6 | (*@ axiom reflexive : forall x. le x x *) 7 | (*@ axiom total : forall x y. le x y \/ le y x *) 8 | (*@ axiom transitive: forall x y z. le x y -> le y z -> le x z *) 9 | 10 | val leq : t -> t -> bool 11 | (*@ b = leq x y 12 | ensures b <-> le x y *) 13 | end 14 | 15 | module Make (E : PRE_ORD) = struct 16 | type elt = E.t 17 | 18 | (*@ predicate rec sorted_list (l: elt list) = 19 | match l with 20 | | [] | _ :: [] -> true 21 | | x :: (y :: r) -> E.le x y && sorted_list (y :: r) *) 22 | (*@ variant l *) 23 | 24 | (*@ lemma sorted_mem: forall x l. 25 | (forall y. List.mem y l -> E.le x y) /\ sorted_list l <-> 26 | sorted_list (x :: l) *) 27 | 28 | (*@ lemma sorted_append: forall l1 l2. 29 | (sorted_list l1 && sorted_list l2 && 30 | (forall x y. List.mem x l1 -> List.mem y l2 -> E.le x y)) <-> 31 | sorted_list (l1 ++ l2) *) 32 | 33 | let rec merge_aux acc l1 l2 = 34 | match (l1, l2) with 35 | | [], l | l, [] -> List.rev_append acc l 36 | | x :: xs, y :: ys -> 37 | if E.leq x y then merge_aux (x :: acc) xs l2 38 | else merge_aux (y :: acc) l1 ys 39 | (*@ r = merge_aux acc l1 l2 40 | requires sorted_list (List.rev acc) && sorted_list l1 && sorted_list l2 41 | requires forall x y. List.mem x acc -> List.mem y l1 -> E.le x y 42 | requires forall x y. List.mem x acc -> List.mem y l2 -> E.le x y 43 | ensures sorted_list r 44 | (* ensures permut r (acc @ l1 @ l2) *) 45 | variant l1, l2 *) 46 | 47 | let merge l1 l2 = merge_aux [] l1 l2 48 | (*@ r = merge l1 l2 49 | requires sorted_list l1 && sorted_list l2 50 | ensures sorted_list r (* && permut r (l1 @ l2) *) *) 51 | 52 | let rec split l = 53 | match l with 54 | | [] -> ([], []) 55 | | [x] -> ([x], []) 56 | | x :: y :: xs -> 57 | let (l1, l2) = split xs in 58 | (x :: l1, y :: l2) 59 | (*@ (l1, l2) = split l 60 | variant List.length l 61 | ensures List.length l1 <= List.length l 62 | ensures List.length l2 <= List.length l *) 63 | 64 | let rec mergesort l = 65 | match l with 66 | | [] | [ _ ] -> l 67 | | _ -> 68 | let l1, l2 = split l in 69 | merge (mergesort l1) (mergesort l2) 70 | (*@ r = mergesort l 71 | variant List.length l 72 | ensures sorted_list r (* && permut r l *)*) 73 | end 74 | -------------------------------------------------------------------------------- /src/odecl.mli: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Mod_subst 3 | module P = Ptree 4 | 5 | type odecl = private 6 | | Odecl of Loc.position * Ptree.decl 7 | | Omodule of Loc.position * Ptree.ident * odecl list 8 | 9 | type let_function = { 10 | let_func_loc : Loc.position; 11 | let_func_def : let_function_node; 12 | } 13 | 14 | (* FIXME: make this type declaration private, at least *) 15 | and let_function_node = 16 | | RKfunc of 17 | Loc.position 18 | * P.ident 19 | * bool 20 | * P.binder list 21 | * P.pty option 22 | * P.spec 23 | * P.expr 24 | | RKpure of 25 | Loc.position * P.ident * P.param list * P.pty option * P.term option 26 | 27 | val mk_odecl : Loc.position -> Ptree.decl -> odecl 28 | val mk_omodule : Loc.position -> Ptree.ident -> odecl list -> odecl 29 | 30 | type path = string list 31 | 32 | type info_refinement = private { 33 | info_ref_name : Ptree.qualid option; 34 | (* module type name to be refined *) 35 | info_ref_decl : odecl list; 36 | (* list of declarations to be refined *) 37 | info_subst : subst; 38 | (* module constraints *) 39 | info_path : string list; 40 | } 41 | 42 | val mk_info_refinement : 43 | Ptree.qualid option -> odecl list -> subst -> path -> info_refinement 44 | 45 | type info = private { 46 | info_arith_construct : (string, int) Hashtbl.t; 47 | info_refinement : (string, info_refinement) Hashtbl.t; 48 | } 49 | 50 | val empty_info : unit -> info 51 | val add_info : info -> string -> int -> unit 52 | val add_info_refinement : info -> string -> info_refinement -> unit 53 | val mk_function : let_function -> odecl 54 | val mk_dtype : Loc.position -> Ptree.type_decl list -> odecl 55 | 56 | val mk_dlogic : 57 | Loc.position -> Ptree.logic_decl list -> odecl 58 | 59 | val mk_dprop : 60 | Loc.position -> Decl.prop_kind -> Ptree.ident -> Ptree.term -> odecl 61 | 62 | val mk_ind : 63 | Loc.position -> 64 | Ptree.ident -> 65 | Ptree.param list -> 66 | (Loc.position * Ptree.ident * Ptree.term) list -> 67 | odecl 68 | 69 | val mk_dlet : 70 | Loc.position -> Ptree.ident -> bool -> Expr.rs_kind -> Ptree.expr -> odecl 71 | 72 | val mk_drec : Loc.position -> Ptree.fundef list -> odecl 73 | val mk_dexn : Loc.position -> Ptree.ident -> Ptree.pty -> Ity.mask -> odecl 74 | 75 | val mk_duseimport : 76 | Loc.position -> 77 | ?import:bool -> 78 | (Ptree.qualid * Ptree.ident option) list -> 79 | odecl 80 | 81 | val mk_functor : 82 | Loc.position -> Ptree.ident -> odecl list -> odecl list -> odecl list 83 | 84 | val mk_cloneexport : 85 | ?odecl_loc:Loc.position -> Ptree.qualid -> Ptree.clone_subst list -> odecl 86 | -------------------------------------------------------------------------------- /examples/duplicates/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | -------------------------------------------------------------------------------- /examples/max_elt_array/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /examples/binary_multiplication/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | -------------------------------------------------------------------------------- /examples/union_find.ml: -------------------------------------------------------------------------------- 1 | 2 | (** The following is used to prove validity of the [uf] type invariant. *) 3 | let[@ghost] [@logic] init () = Array.init 0 (fun x -> x) 4 | (*@ a = init () 5 | ensures Array.length a = 0 *) 6 | 7 | (*@ predicate mem (i: int) (a: int array) = 8 | 0 <= i < Array.length a *) 9 | 10 | type uf = { 11 | link : int array; 12 | rank : int array; 13 | mutable rep : int -> int; [@ghost] 14 | mutable dst : int -> int; [@ghost] 15 | mutable maxd : int; [@ghost] 16 | } 17 | (*@ invariant 0 <= maxd 18 | invariant Array.length rank = Array.length link 19 | invariant forall i. mem i link -> 0 <= link.(i) < Array.length link 20 | invariant forall i. mem i link -> rep (rep i) = rep i 21 | invariant forall i. mem i link -> 0 <= rep i < Array.length link 22 | invariant forall i. mem i link -> link.(i) <> i -> rep i = rep link.(i) 23 | invariant forall i. mem i link -> (link.(i) = i <-> rep i = i) 24 | invariant forall i. mem i link -> 0 <= dst i <= maxd 25 | invariant forall i. mem i link -> link.(i) <> i -> dst i < dst link.(i) *) 26 | 27 | let rec find i uf = 28 | let p = uf.link.(i) in 29 | if p = i then i 30 | else 31 | let rep = find p uf in 32 | uf.link.(i) <- rep; 33 | rep 34 | (*@ r = find i uf 35 | requires 0 <= i < Array.length uf.link 36 | variant uf.maxd - uf.dst i 37 | ensures 0 <= r < Array.length uf.link 38 | ensures r = uf.rep i 39 | ensures uf.dst r >= uf.dst i *) 40 | 41 | (*@ predicate equiv (i j: int) (uf: uf) = 42 | mem i uf.link -> mem j uf.link -> uf.rep i = uf.rep j *) 43 | 44 | let[@ghost] set (f : 'a -> 'b) (x : 'a) (v : 'b) : 'a -> 'b = 45 | fun y -> if (y = x) [@pure] then v else f y 46 | 47 | let union i j uf = 48 | let rep_i = find i uf in 49 | let rep_j = find j uf in 50 | if not (rep_i = rep_j) then 51 | if uf.rank.(rep_i) > uf.rank.(rep_j) then ( 52 | uf.link.(rep_j) <- rep_i; 53 | uf.rep <- 54 | (fun [@pure] k -> if uf.rep k = uf.rep rep_j then rep_i else uf.rep k); 55 | uf.maxd <- uf.maxd + 1; 56 | uf.dst <- set uf.dst rep_i (1 + max (uf.dst rep_i) (uf.dst rep_j))) 57 | else ( 58 | uf.link.(rep_i) <- rep_j; 59 | uf.rep <- 60 | (fun [@pure] k -> if uf.rep k = uf.rep rep_i then rep_j else uf.rep k); 61 | uf.maxd <- uf.maxd + 1; 62 | uf.dst <- set uf.dst rep_j (1 + max (uf.dst rep_i) (uf.dst rep_j)); 63 | if uf.rank.(rep_i) = uf.rank.(rep_j) then 64 | uf.rank.(rep_i) <- uf.rank.(rep_i) + 1) 65 | (*@ union i j uf 66 | requires 0 <= i < Array.length uf.link 67 | requires 0 <= j < Array.length uf.link 68 | ensures exists r. (r = (old uf).rep i || r = (old uf).rep j) && 69 | forall k. 0 <= k < Array.length uf.link -> 70 | uf.rep k = if old (equiv k i uf || equiv k j uf) then r 71 | else old (uf.rep k) *) 72 | -------------------------------------------------------------------------------- /examples/isqrt/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | -------------------------------------------------------------------------------- /examples/same_fringe/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | -------------------------------------------------------------------------------- /stdlib/power.ml: -------------------------------------------------------------------------------- 1 | module type Exponentiation = sig 2 | type t 3 | 4 | (*@ function one: t *) 5 | 6 | (*@ function mul (x y: t) : t *) 7 | 8 | (*@ axiom assoc: forall x y z. mul (mul x y) z = mul x (mul y z) *) 9 | 10 | (*@ axiom unit_def_l: forall x: t. mul one x = x *) 11 | (*@ axiom unit_def_r: forall x: t. mul x one = x *) 12 | 13 | (*@ function power (t: t) (x: integer) : t *) 14 | 15 | (*@ axiom power_0 : forall x: t. power x 0 = one *) 16 | 17 | (*@ axiom power_s : forall x: t, n: integer. n >= 0 -> 18 | power x (n+1) = mul x (power x n) *) 19 | 20 | (*@ lemma power_s_alt: forall x: t, n: int. n > 0 -> 21 | power x n = mul x (power x (n-1)) *) 22 | 23 | (*@ lemma power_1 : forall x : t. power x 1 = x *) 24 | 25 | (*@ lemma power_sum : forall x: t, n m: int. 0 <= n -> 0 <= m -> 26 | power x (n+m) = mul (power x n) (power x m) *) 27 | 28 | (*@ lemma power_mult : forall x:t, n m : int. 0 <= n -> 0 <= m -> 29 | power x (n * m) = power (power x n) m *) 30 | 31 | (*@ lemma power_comm1 : forall x y: t. mul x y = mul y x -> 32 | forall n:int. 0 <= n -> 33 | mul (power x n) y = mul y (power x n) *) 34 | 35 | (*@ lemma power_comm2 : forall x y: t. mul x y = mul y x -> 36 | forall n:int. 0 <= n -> 37 | power (mul x y) n = mul (power x n) (power y n) *) 38 | end 39 | 40 | module type Power = sig 41 | type t = int 42 | 43 | val power : int -> int -> int [@@logic] 44 | 45 | (*@ function one : int = 1 *) 46 | 47 | (*@ function mul (x y: t) : t = x * y *) 48 | 49 | (*@ axiom assoc: forall x y z. mul (mul x y) z = mul x (mul y z) *) 50 | 51 | (*@ axiom unit_def_l: forall x: t. mul one x = x *) 52 | (*@ axiom unit_def_r: forall x: t. mul x one = x *) 53 | 54 | (*@ axiom power_0 : forall x: t. power x 0 = one *) 55 | 56 | (*@ axiom power_s : forall x: t, n: integer. n >= 0 -> 57 | power x (n+1) = mul x (power x n) *) 58 | 59 | (*@ lemma power_s_alt: forall x: t, n: int. n > 0 -> 60 | power x n = mul x (power x (n-1)) *) 61 | 62 | (*@ lemma power_1 : forall x : t. power x 1 = x *) 63 | 64 | (*@ lemma power_sum : forall x: t, n m: int. 0 <= n -> 0 <= m -> 65 | power x (n+m) = mul (power x n) (power x m) *) 66 | 67 | (*@ lemma power_mult : forall x:t, n m : int. 0 <= n -> 0 <= m -> 68 | power x (n * m) = power (power x n) m *) 69 | 70 | (*@ lemma power_comm1 : forall x y: t. mul x y = mul y x -> 71 | forall n:int. 0 <= n -> 72 | mul (power x n) y = mul y (power x n) *) 73 | 74 | (*@ lemma power_comm2 : forall x y: t. mul x y = mul y x -> 75 | forall n:int. 0 <= n -> 76 | power (mul x y) n = mul (power x n) (power y n) *) 77 | 78 | (*@ lemma power_non_neg: 79 | forall x y. x >= 0 /\ y >= 0 -> power x y >= 0 *) 80 | 81 | (*@ lemma power_pos: 82 | forall x y. x > 0 /\ y >= 0 -> power x y > 0 *) 83 | 84 | (*@ lemma aux: forall x y z. x > 0 -> 0 <= y <= z -> 85 | x * y <= x * z *) 86 | 87 | (*@ lemma power_monotonic: 88 | forall x n m:int. 0 < x /\ 0 <= n <= m -> power x n <= power x m *) 89 | end 90 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Cameleer 2 | ======== 3 | A Deductive Verification Tool for OCaml Programs 4 | 5 | Install 6 | ------- 7 | First, start by cloning the Cameleer project: 8 | ``` 9 | $ git clone https://github.com/ocaml-gospel/cameleer 10 | ``` 11 | This will clone the Cameleer repository into a directory named `cameleer`. 12 | 13 | Next, pin add the `cameleer` package: 14 | ``` 15 | $ opam pin add path/to/cameleer 16 | ``` 17 | Press `RET` or type `y` to accept both the pin add procedure and again to 18 | install `cameleer`. 19 | Cameleer depends on the GOSPEL specification language (https://github.com/ocaml-gospel/gospel). Since the GOSPEL opam 20 | package is yet to be released, this will pin that too for you (using a commit on the `implementations_gospel` branch). 21 | 22 | After installation succeeds, you can try `cameleer` by doing 23 | ``` 24 | $ cameleer --version 25 | ``` 26 | 27 | Installing external provers 28 | --------------------------- 29 | Consider installing some external provers, in order to conduct proofs via 30 | Why3. Check [here](https://www.lri.fr/~marche/MPRI-2-36-1/install.html) for a 31 | detailed explanation on how to install automated provers Alt-Ergo, CVC4, and Z3, 32 | as well as the Coq proof assistant. 33 | 34 | Do not forget to run `why3 config detect` after installing all the provers. 35 | 36 | Running Cameleer 37 | ---------------- 38 | Consider an OCaml file `example.ml` with the following content: 39 | ``` 40 | let succ x = x + 1 41 | (*@ r = succ x 42 | ensures r > x *) 43 | ``` 44 | In order to start a proof of correctness of the `succ` function, simply type 45 | ``` 46 | $ cameleer example.ml 47 | ``` 48 | This will launch the Why3 ide on the (translated) `succ` program. From there, 49 | one can chose different theorem provers, in order to discharge the generated 50 | proof obligation. 51 | 52 | The `examples/` directory contains several case studies verified with Cameleer. 53 | 54 | Using Vagrantfile 55 | ----------------- 56 | We have included a `Vagrantfile`, in order to allow one to easily start a 57 | Virtual Machine with all the required dependencies of the Cameleer 58 | project. Simply to 59 | ``` 60 | vagrant up 61 | ``` 62 | in the `cameleer` folder in order to start the Virtual Machine. This will take 63 | several minutes. This will install `opam`, the `why3` framework, the `alt-ergo` 64 | solver, the `gospel` specification language, and finally the `cameleer` tool 65 | itself. If it succeeds, expect to see the following message at the end of the 66 | whole process: 67 | ``` 68 | default: File "test.ml", line 1, characters 39-44: 69 | default: Goal Postcondition from verification condition succ'vc. 70 | default: Prover result is: Valid (0.02s, 2 steps). 71 | ``` 72 | Then, one can do 73 | ``` 74 | vagrant ssh 75 | ``` 76 | to log into the Virtual Machine. We have not included a graphical interface and 77 | we have only installed the `alt-ergo` solver in this setting. Hence, any use of 78 | Cameleer should be performed using the `batch` mode. For instance: 79 | ``` 80 | cameleer --batch --prover alt-ergo applicative_queue 81 | ``` 82 | inside the `examples` folder. If you have any trouble running the `cameleer` 83 | after `vagrant ssh`, please run `eval $(opam env)`. 84 | -------------------------------------------------------------------------------- /src/odecl.ml: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Ptree 3 | open Mod_subst 4 | module P = Ptree 5 | module T = Uterm 6 | 7 | type odecl = 8 | | Odecl of Loc.position * decl 9 | | Omodule of Loc.position * ident * odecl list 10 | 11 | type let_function = { 12 | let_func_loc : Loc.position; 13 | let_func_def : let_function_node; 14 | } 15 | 16 | and let_function_node = 17 | | RKfunc of 18 | Loc.position * ident * bool * binder list * pty option * spec * expr 19 | | RKpure of Loc.position * ident * param list * pty option * term option 20 | 21 | let mk_odecl loc d = Odecl (loc, d) 22 | let mk_omodule loc id mod_expr = Omodule (loc, id, mod_expr) 23 | 24 | type path = string list 25 | 26 | type info_refinement = { 27 | info_ref_name : qualid option; 28 | info_ref_decl : odecl list; 29 | info_subst : subst; 30 | info_path : path; 31 | } 32 | 33 | let mk_info_refinement info_ref_name info_ref_decl info_subst info_path = 34 | { info_ref_name; info_ref_decl; info_subst; info_path } 35 | 36 | type info = { 37 | (* to be completed as needed *) 38 | info_arith_construct : (string, int) Hashtbl.t; 39 | info_refinement : (string, info_refinement) Hashtbl.t; 40 | } 41 | 42 | let empty_info () = 43 | { 44 | info_arith_construct = Hashtbl.create 32; 45 | info_refinement = Hashtbl.create 32; 46 | } 47 | 48 | let add_info info id arith = Hashtbl.add info.info_arith_construct id arith 49 | 50 | let add_info_refinement info id info_refinement = 51 | Hashtbl.add info.info_refinement id info_refinement 52 | 53 | let mk_dtype loc td_list = mk_odecl loc (Dtype td_list) 54 | (* let mk_coercion loc f = mk_odecl loc (Dmeta (T.mk_id "coercion", [ Mfs f ])) *) 55 | 56 | let mk_dlogic loc f = 57 | (* let coerc = match coerc with None -> [] | Some c -> [ mk_coercion loc c ] in *) 58 | mk_odecl loc (Dlogic f) 59 | 60 | let mk_dprop loc prop_kind id t = mk_odecl loc (Dprop (prop_kind, id, t)) 61 | 62 | let mk_ind loc in_ident in_params in_def = 63 | let ind_decl = { in_loc = loc; in_ident; in_params; in_def } in 64 | mk_odecl loc (Dind (Decl.Ind, [ ind_decl ])) 65 | 66 | let mk_dlet loc id ghost rs_kind expr = 67 | mk_odecl loc (Dlet (id, ghost, rs_kind, expr)) 68 | 69 | let mk_drec loc fd_list = mk_odecl loc (Drec fd_list) 70 | 71 | let mk_function { let_func_loc = loc; let_func_def } = 72 | match let_func_def with 73 | | RKfunc (expr_loc, id, drec, binders, dtype, spec, expr) -> 74 | let ret = T.mk_pattern Pwild in 75 | let mask = Ity.MaskVisible in 76 | if drec then 77 | let fundef = 78 | (id, true, Expr.RKfunc, binders, dtype, ret, mask, spec, expr) 79 | in 80 | mk_drec loc [ fundef ] 81 | else 82 | let expr_desc = Efun (binders, dtype, ret, mask, spec, expr) in 83 | let efun = { expr_loc; expr_desc } in 84 | mk_dlet loc id true Expr.RKfunc efun 85 | | RKpure (ld_loc, ld_ident, ld_params, ld_type, ld_def) -> 86 | let f = { ld_loc; ld_ident; ld_params; ld_type; ld_def } in 87 | mk_dlogic loc [ f ] 88 | 89 | let mk_dexn loc id pty mask = mk_odecl loc (Dexn (id, pty, mask)) 90 | 91 | let mk_duseimport loc ?(import = true) q_list = 92 | mk_odecl loc (Duseimport (loc, import, q_list)) 93 | 94 | let mk_functor loc id arg body = mk_omodule loc id arg :: body 95 | 96 | let mk_cloneexport ?odecl_loc id clone_subst = 97 | let loc = match odecl_loc with Some l -> l | None -> Loc.dummy_position in 98 | mk_odecl loc (Dcloneexport (loc, id, clone_subst)) 99 | -------------------------------------------------------------------------------- /examples/fibonacci/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree_alt.ml: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int [@@logic] 5 | (*@ axiom is_pre_order: is_pre_order compare *) 6 | end 7 | 8 | module Make (Ord : OrderedType) = struct 9 | type elt = Ord.t 10 | type t = E | T of t * elt * t 11 | 12 | (*@ function occ (x: elt) (t: t) : integer = match t with 13 | | E -> 0 14 | | T l v r -> 15 | occ x l + occ x r + (if Ord.compare x v = 0 then 1 else 0) *) 16 | 17 | (*@ lemma occ_nonneg: forall x: elt, t: t. occ x t >= 0 *) 18 | 19 | (*@ predicate mem (x: elt) (t: t) = occ x t > 0 *) 20 | 21 | (*@ predicate bst (t: t) = match t with 22 | | E -> true 23 | | T l v r -> 24 | (forall lv. mem lv l -> Ord.compare lv v < 0) && 25 | (forall rv. mem rv r -> Ord.compare rv v > 0) && 26 | bst l && bst r *) 27 | 28 | let empty = E 29 | (*@ r = empty 30 | ensures forall x. occ x r = 0 31 | ensures bst r *) 32 | 33 | let rec insert x = function 34 | | E -> T (E, x, E) 35 | | T (l, y, r) -> 36 | if Ord.compare x y = 0 then T (l, y, r) 37 | else if Ord.compare x y < 0 then T (insert x l, y, r) 38 | else T (l, y, insert x r) 39 | (*@ t = insert x param 40 | requires bst param 41 | variant param 42 | ensures forall y. y <> x -> occ y t = occ y param 43 | ensures occ x t = occ x param || occ x t = 1 + occ x param 44 | ensures bst t *) 45 | 46 | let rec mem x = function 47 | | E -> false 48 | | T (l, v, r) -> 49 | let c = Ord.compare x v in 50 | c = 0 || mem x (if c < 0 then l else r) 51 | (*@ b = mem x param 52 | requires bst param 53 | variant param 54 | ensures b <-> mem x param *) 55 | 56 | (*@ function min (t: t) : elt *) 57 | (*@ axiom is_min_empty: forall x r. min (T E x r) = x *) 58 | (*@ axiom is_min_left: forall l x r. l <> E -> min (T l x r) = min l *) 59 | 60 | let[@lemma] rec occ_min (t : t) = 61 | match t with 62 | | E -> assert false 63 | | T (E, _, _) -> () 64 | | T (l, _, r) -> occ_min l 65 | (*@ occ_min t 66 | requires t <> E 67 | requires bst t 68 | variant t 69 | ensures occ (min t) t = 1 *) 70 | 71 | let rec remove_min = function 72 | | E -> assert false 73 | | T (E, v, r) -> (v, r) 74 | | T (l, v, r) -> 75 | let m, l = remove_min l in 76 | (m, T (l, v, r)) 77 | (*@ m, r = remove_min t 78 | requires t <> E 79 | requires bst t 80 | variant t 81 | ensures bst r 82 | ensures forall x. x <> min t -> occ x t = occ x r 83 | ensures occ (min t) r = 0 84 | ensures m = min t *) 85 | 86 | let rec remove x = function 87 | | E -> E 88 | | T (l, v, r) -> ( 89 | if Ord.compare x v < 0 then T (remove x l, v, r) 90 | else if Ord.compare x v > 0 then T (l, v, remove x r) 91 | else 92 | match r with 93 | | E -> l 94 | | r -> 95 | let min_elt, new_r = remove_min r in 96 | T (l, min_elt, new_r)) 97 | (*@ r = remove x t 98 | requires bst t 99 | variant t 100 | ensures bst t 101 | ensures forall y. y <> x -> occ y r = occ y t 102 | ensures occ x r = 0 *) 103 | end 104 | -------------------------------------------------------------------------------- /examples/exercises/binary_search_tree.ml: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int [@@logic] 5 | (*@ axiom is_pre_order: is_pre_order compare *) 6 | end 7 | 8 | module Make (Ord : OrderedType) = struct 9 | type elt = Ord.t 10 | type t = E | T of t * elt * t 11 | 12 | (*@ function occ (x: elt) (t: t) : integer = match t with 13 | | E -> 0 14 | | T l v r -> 15 | occ x l + occ x r + (if Ord.compare x v = 0 then 1 else 0) *) 16 | 17 | (*@ lemma occ_nonneg: forall x: elt, t: t. occ x t >= 0 *) 18 | 19 | (*@ predicate mem (x: elt) (t: t) = occ x t > 0 *) 20 | 21 | (*@ predicate bst (t: t) = match t with 22 | | E -> true 23 | | T l v r -> 24 | (forall lv. mem lv l -> Ord.compare lv v < 0) && 25 | (forall rv. mem rv r -> Ord.compare rv v > 0) && 26 | bst l && bst r *) 27 | 28 | let empty = E 29 | (*@ r = empty 30 | ensures forall x. occ x r = 0 31 | ensures bst r *) 32 | 33 | let rec insert x = function 34 | | E -> T (E, x, E) 35 | | T (l, y, r) -> 36 | if Ord.compare x y = 0 then T (l, y, r) 37 | else if Ord.compare x y < 0 then T (insert x l, y, r) 38 | else T (l, y, insert x r) 39 | (*@ t = insert x param 40 | requires bst param 41 | variant param 42 | ensures forall y. y <> x -> occ y t = occ y param 43 | ensures occ x t = occ x param || occ x t = 1 + occ x param 44 | ensures bst t *) 45 | 46 | let rec mem x = function 47 | | E -> false 48 | | T (l, v, r) -> 49 | let c = Ord.compare x v in 50 | c = 0 || mem x (if c < 0 then l else r) 51 | (*@ b = mem x param 52 | requires bst param 53 | variant param 54 | ensures b <-> mem x param *) 55 | 56 | (*@ function min (t: t) : elt *) 57 | (*@ axiom is_min_empty: forall x r. min (T E x r) = x *) 58 | (*@ axiom is_min_left: forall l x r. l <> E -> min (T l x r) = min l *) 59 | 60 | let[@lemma] rec occ_min (t : t) = 61 | match t with 62 | | E -> assert false 63 | | T (E, _, _) -> () 64 | | T (l, _, r) -> occ_min l 65 | (*@ occ_min t 66 | requires t <> E 67 | requires bst t 68 | variant t 69 | ensures occ (min t) t = 1 *) 70 | 71 | let rec min_elt = function 72 | | E -> assert false 73 | | T (E, v, _) -> v 74 | | T (l, _, _) -> min_elt l 75 | (*@ r = min_elt t 76 | requires t <> E 77 | variant t 78 | ensures r = min t *) 79 | 80 | let rec remove_min = function 81 | | E -> E 82 | | T (E, _, r) -> r 83 | | T (l, v, r) -> T (remove_min l, v, r) 84 | (*@ r = remove_min t 85 | requires bst t 86 | variant t 87 | ensures bst r 88 | ensures forall x. x <> min t -> occ x t = occ x r 89 | ensures occ (min t) r = 0 *) 90 | 91 | let rec remove x = function 92 | | E -> E 93 | | T (l, v, r) -> ( 94 | if Ord.compare x v < 0 then T (remove x l, v, r) 95 | else if Ord.compare x v > 0 then T (l, v, remove x r) 96 | else 97 | match r with 98 | | E -> l 99 | | r -> 100 | let min_value = min_elt r in 101 | let new_r = remove_min r in 102 | T (l, min_value, new_r)) 103 | (*@ r = remove x t 104 | requires bst t 105 | variant t 106 | ensures bst t *) 107 | end 108 | -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree.ml: -------------------------------------------------------------------------------- 1 | module type OrderedType = sig 2 | type t 3 | 4 | val compare : t -> t -> int [@@logic] 5 | (*@ axiom is_pre_order: is_pre_order compare *) 6 | end 7 | 8 | module Make (Ord : OrderedType) = struct 9 | type elt = Ord.t 10 | type t = E | T of t * elt * t 11 | 12 | (*@ function occ (x: elt) (t: t) : integer = match t with 13 | | E -> 0 14 | | T l v r -> 15 | occ x l + occ x r + (if Ord.compare x v = 0 then 1 else 0) *) 16 | 17 | (*@ lemma occ_nonneg: forall x: elt, t: t. occ x t >= 0 *) 18 | 19 | (*@ predicate mem (x: elt) (t: t) = occ x t > 0 *) 20 | 21 | (*@ predicate bst (t: t) = match t with 22 | | E -> true 23 | | T l v r -> 24 | (forall lv. mem lv l -> Ord.compare lv v < 0) && 25 | (forall rv. mem rv r -> Ord.compare rv v > 0) && 26 | bst l && bst r *) 27 | 28 | let empty = E 29 | (*@ r = empty 30 | ensures forall x. occ x r = 0 31 | ensures bst r *) 32 | 33 | let rec insert x = function 34 | | E -> T (E, x, E) 35 | | T (l, y, r) -> 36 | if Ord.compare x y = 0 then T (l, y, r) 37 | else if Ord.compare x y < 0 then T (insert x l, y, r) 38 | else T (l, y, insert x r) 39 | (*@ t = insert x param 40 | requires bst param 41 | variant param 42 | ensures forall y. y <> x -> occ y t = occ y param 43 | ensures occ x t = occ x param || occ x t = 1 + occ x param 44 | ensures bst t *) 45 | 46 | let rec mem x = function 47 | | E -> false 48 | | T (l, v, r) -> 49 | let c = Ord.compare x v in 50 | c = 0 || mem x (if c < 0 then l else r) 51 | (*@ b = mem x param 52 | requires bst param 53 | variant param 54 | ensures b <-> mem x param *) 55 | 56 | (*@ function min (t: t) : elt *) 57 | (*@ axiom is_min_empty: forall x r. min (T E x r) = x *) 58 | (*@ axiom is_min_left: forall l x r. l <> E -> min (T l x r) = min l *) 59 | 60 | let[@lemma] rec occ_min (t : t) = 61 | match t with 62 | | E -> assert false 63 | | T (E, _, _) -> () 64 | | T (l, _, r) -> occ_min l 65 | (*@ occ_min t 66 | requires t <> E 67 | requires bst t 68 | variant t 69 | ensures occ (min t) t = 1 *) 70 | 71 | let rec min_elt = function 72 | | E -> assert false 73 | | T (E, v, _) -> v 74 | | T (l, _, _) -> min_elt l 75 | (*@ r = min_elt t 76 | requires t <> E 77 | variant t 78 | ensures r = min t *) 79 | 80 | let rec remove_min = function 81 | | E -> E 82 | | T (E, _, r) -> r 83 | | T (l, v, r) -> T (remove_min l, v, r) 84 | (*@ r = remove_min t 85 | requires bst t 86 | variant t 87 | ensures bst r 88 | ensures forall x. x <> min t -> occ x t = occ x r 89 | ensures occ (min t) r = 0 *) 90 | 91 | let rec remove x = function 92 | | E -> E 93 | | T (l, v, r) -> ( 94 | if Ord.compare x v < 0 then T (remove x l, v, r) 95 | else if Ord.compare x v > 0 then T (l, v, remove x r) 96 | else 97 | match r with 98 | | E -> l 99 | | r -> 100 | let min_value = min_elt r in 101 | let new_r = remove_min r in 102 | T (l, min_value, new_r)) 103 | (*@ r = remove x t 104 | requires bst t 105 | variant t 106 | ensures bst t 107 | ensures forall y. y <> x -> occ y r = occ y t 108 | ensures occ x r = 0 *) 109 | end 110 | -------------------------------------------------------------------------------- /examples/checking_a_large_routine/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | -------------------------------------------------------------------------------- /examples/small_step_iterator.ml: -------------------------------------------------------------------------------- 1 | (*@ open Sum *) 2 | (*@ open Seq *) 3 | 4 | module type Cursor = sig 5 | type 'a t 6 | (*@ mutable model visited: 'a seq *) 7 | 8 | (*@ predicate permitted (t: 'a t) *) 9 | (*@ axiom permitted_empty: forall t: 'a t. t.visited = empty -> permitted t *) 10 | 11 | (*@ predicate complete (t: 'a t) *) 12 | 13 | val next : 'a t -> 'a 14 | (*@ r = next c 15 | requires permitted c && not (complete c) 16 | modifies c.visited 17 | ensures c.visited = snoc (old c).visited r 18 | ensures permitted c *) 19 | 20 | val has_next : 'a t -> bool 21 | (*@ b = has_next c 22 | requires permitted c 23 | ensures b <-> not (complete c) *) 24 | end 25 | 26 | module CursorList (* : Cursor *) = struct 27 | (*@ function seq_of_list (l: 'a list): 'a seq = match l with 28 | | [] -> empty 29 | | x :: r -> cons x (seq_of_list r) *) 30 | 31 | type 'a t = { 32 | mutable visited : 'a seq; [@ghost] 33 | collection : 'a list; [@ghost] 34 | mutable to_visit : 'a list; 35 | } 36 | (*@ invariant seq_of_list collection = visited ++ seq_of_list to_visit *) 37 | 38 | (*@ lemma seq_of_list_append: forall l1 l2: 'a list. 39 | seq_of_list (List.append l1 l2) == seq_of_list l1 ++ seq_of_list l2 *) 40 | 41 | (*@ lemma seq_of_list_length: forall l: 'a list. 42 | length (seq_of_list l) = List.length l *) 43 | 44 | (*@ lemma seq_of_list_mem: forall l: 'a list, x: 'a. 45 | List.mem x l <-> Seq.mem x (seq_of_list l) *) 46 | 47 | (*@ predicate permitted (t: 'a t) = 48 | length t.visited <= length (seq_of_list t.collection) && 49 | forall i. 0 <= i < length t.visited -> 50 | t.visited[i] = (seq_of_list t.collection)[i] *) 51 | 52 | (*@ predicate complete (t: 'a t) = 53 | length t.visited = length (seq_of_list t.collection) *) 54 | 55 | let next c = 56 | match c.to_visit with 57 | | [] -> assert false 58 | | x :: r -> 59 | c.visited <- snoc c.visited x; 60 | c.to_visit <- r; 61 | x 62 | (*@ r = next c 63 | requires permitted c && not (complete c) 64 | ensures permitted c 65 | ensures c.visited = snoc (old c).visited r *) 66 | 67 | let has_next c = match c.to_visit with [] -> false | _ -> true 68 | (*@ b = has_next c 69 | requires permitted c 70 | ensures b <-> not (complete c) *) 71 | 72 | let create l = { visited = empty; collection = l; to_visit = l } 73 | (*@ r = create l 74 | ensures r.visited = empty 75 | ensures r.collection = l *) 76 | end 77 | 78 | let sum_cursor l = 79 | let s = ref 0 in 80 | let c = CursorList.create l in 81 | while CursorList.has_next c do 82 | (*@ variant length (seq_of_list l) - length c.visited 83 | invariant permitted c 84 | invariant !s = sum (fun i -> c.visited[i]) 0 (length c.visited) *) 85 | let x = CursorList.next c in 86 | s := !s + x 87 | done; 88 | !s 89 | (*@ r = sum_cursor l 90 | ensures r = sum (fun i -> (seq_of_list l)[i]) 0 (List.length l) *) 91 | 92 | module Mem (Eq : sig 93 | type elt 94 | 95 | val eq : elt -> elt -> bool 96 | (*@ b = eq x y 97 | ensures b <-> x = y *) 98 | end) = 99 | struct 100 | let mem_cursor l x = 101 | let c = CursorList.create l in 102 | let exception Found in 103 | try 104 | while CursorList.has_next c do 105 | (*@ variant length (seq_of_list l) - length c.visited 106 | invariant permitted c 107 | invariant forall i. 0 <= i < length c.visited -> c.visited[i] <> x *) 108 | if Eq.eq (CursorList.next c) x then raise Found 109 | done; 110 | false 111 | with Found -> true 112 | (*@ b = mem_cursor l x 113 | ensures b <-> List.mem x l *) 114 | end 115 | -------------------------------------------------------------------------------- /examples/binary_search.ml: -------------------------------------------------------------------------------- 1 | (*@ predicate is_sorted (a: int array) = 2 | forall i1 i2. 0 <= i1 <= i2 < Array.length a -> a.(i1) <= a.(i2) *) 3 | 4 | let binary_search a v = 5 | let l = ref 0 in 6 | let u = ref (Array.length a - 1) in 7 | let exception Found of int in 8 | try 9 | while !l <= !u do 10 | (*@ variant !u - !l 11 | invariant 0 <= !l && !u < Array.length a 12 | invariant forall i. 0 <= i < Array.length a -> a.(i) = v -> 13 | !l <= i <= !u *) 14 | let m = !l + ((!u - !l) / 2) in 15 | if a.(m) < v then l := m + 1 16 | else if a.(m) > v then u := m - 1 17 | else raise (Found m) 18 | done; 19 | raise Not_found 20 | with Found i -> i 21 | (*@ i = binary_search a v 22 | requires is_sorted a 23 | raises Not_found -> forall i. 0 <= i < Array.length a -> a.(i) <> v 24 | ensures 0 <= i < Array.length a && a.(i) = v *) 25 | 26 | module BinarySearch = struct 27 | let binary_search (compare : 'a -> 'a -> int) (a : 'a array) (v : 'a) = 28 | let l = ref 0 in 29 | let u = ref (Array.length a - 1) in 30 | let exception Found of int in 31 | try 32 | while !l <= !u do 33 | (*@ variant !u - !l 34 | invariant 0 <= !l && !u < Array.length a 35 | invariant forall i. 0 <= i < Array.length a -> 36 | compare a.(i) v = 0 -> !l <= i <= !u *) 37 | let m = !l + ((!u - !l) / 2) in 38 | let c = compare a.(m) v in 39 | if c < 0 then l := m + 1 40 | else if c > 0 then u := m - 1 41 | else raise (Found m) 42 | done; 43 | raise Not_found 44 | with Found i -> i 45 | (*@ i = binary_search_1 compare a v 46 | requires is_pre_order compare 47 | requires forall i j. 0 <= i <= j < Array.length a -> 48 | compare a.(i) a.(j) <= 0 49 | raises Not_found -> forall i. 0 <= i < Array.length a -> 50 | compare a.(i) v <> 0 51 | ensures 0 <= i < Array.length a && compare a.(i) v = 0 *) 52 | end 53 | 54 | module type OrderedType = sig 55 | type t 56 | 57 | val cmp : t -> t -> int [@@logic] 58 | (*@ axiom is_pre_order_cmp: is_pre_order cmp *) 59 | end 60 | 61 | module type BS = sig 62 | type elt 63 | 64 | (*@ function cmp (x: elt) (y: elt) : int *) 65 | (*@ axiom is_pre_order_cmp : is_pre_order cmp *) 66 | 67 | val binary_search : elt array -> elt -> int 68 | (*@ i = binary_search_2 a v 69 | requires forall i j. 0 <= i <= j < Array.length a -> 70 | cmp a.(i) a.(j) <= 0 71 | raises Not_found -> forall i. 0 <= i < Array.length a -> 72 | cmp a.(i) v <> 0 73 | ensures 0 <= i < Array.length a && cmp a.(i) v = 0 *) 74 | end 75 | 76 | module Make (Ord : OrderedType) : 77 | (BS with type elt = Ord.t [@gospel "with function cmp = Ord.cmp"]) = struct 78 | type elt = Ord.t 79 | 80 | (*@ function cmp (x: elt) (y: elt) : int = Ord.cmp x y *) 81 | 82 | (*@ predicate is_sorted (a: elt array) = forall i1 i2. 83 | 0 <= i1 <= i2 < Array.length a -> cmp a.(i1) a.(i2) <= 0 *) 84 | 85 | let binary_search a v = 86 | let l = ref 0 in 87 | let u = ref (Array.length a - 1) in 88 | let exception Found of int in 89 | try 90 | while !l <= !u do 91 | (*@ variant !u - !l 92 | invariant 0 <= !l && !u < Array.length a 93 | invariant forall i. 0 <= i < Array.length a -> 94 | cmp a.(i) v = 0 -> !l <= i <= !u *) 95 | let m = !l + ((!u - !l) / 2) in 96 | let c = Ord.cmp a.(m) v in 97 | if c < 0 then l := m + 1 98 | else if c > 0 then u := m - 1 99 | else raise (Found m) 100 | done; 101 | raise Not_found 102 | with Found i -> i 103 | (*@ i = binary_search a v 104 | requires is_sorted a 105 | raises Not_found -> forall i. 0 <= i < Array.length a -> 106 | cmp a.(i) v <> 0 107 | ensures 0 <= i < Array.length a && cmp a.(i) v = 0 *) 108 | end 109 | -------------------------------------------------------------------------------- /src/vspec.ml: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Ptree 3 | open Gospel 4 | module T = Uterm 5 | 6 | include struct 7 | open struct 8 | let get_id_of_lb_arg = function 9 | | Uast.Lunit -> assert false 10 | | Uast.Lnone id | Loptional id | Lnamed id | Lghost (id, _) -> id 11 | end 12 | 13 | let loc_of_lb_arg = function 14 | | Uast.Lunit -> T.dummy_loc 15 | | lb -> T.location (get_id_of_lb_arg lb).pid_loc 16 | 17 | let ident_of_lb_arg = function 18 | | Uast.Lunit -> T.mk_id "()" 19 | | lb -> T.preid (get_id_of_lb_arg lb) 20 | end 21 | 22 | (** Converts a GOSPEL postcondition of the form [Uast.term] into a Why3's Ptree 23 | postcondition of the form [Loc.position * (pattern * term)]. It uses the 24 | [sp_hd_ret] field to name the result value of the function. *) 25 | let sp_post sp_hd_ret sp_post = 26 | let term_loc = T.location sp_post.Uast.term_loc in 27 | let mk_pvar lb = 28 | (* create a [Pvar] pattern out of a [Tt.lb_arg] *) 29 | let pat_loc = loc_of_lb_arg lb in 30 | T.mk_pattern (Pvar (ident_of_lb_arg lb)) ~pat_loc 31 | in 32 | let pvar_of_lb_arg_list lb_arg_list = List.map mk_pvar lb_arg_list in 33 | let pat = 34 | match pvar_of_lb_arg_list sp_hd_ret with 35 | | [ p ] -> p 36 | | pl -> T.mk_pattern (Ptuple pl) ~pat_loc:term_loc 37 | in 38 | (term_loc, [ (pat, T.term true sp_post) ]) 39 | 40 | let sp_post_no_ret sp_post = 41 | let term_loc = T.location sp_post.Uast.term_loc in 42 | let id_result = T.mk_id "result" in 43 | (term_loc, [ (T.mk_pattern (Pvar id_result), T.term true sp_post) ]) 44 | 45 | (** Converts a GOSPEL exception postcondition into a Why3's Ptree [xpost]. The 46 | two data types have the same structure, hence this is a morphism. *) 47 | let sp_xpost (loc, q_pat_t_option_list) = 48 | let loc = T.location loc in 49 | let pat_term (q, t) = (T.pattern q, T.term true t) in 50 | let qualid_pat_term_opt (q, pt_opt) = 51 | (T.qualid q, Option.map pat_term pt_opt) 52 | in 53 | (loc, List.map qualid_pat_term_opt q_pat_t_option_list) 54 | 55 | let empty_spec = 56 | { 57 | sp_pre = []; 58 | sp_post = []; 59 | sp_xpost = []; 60 | sp_reads = []; 61 | sp_writes = []; 62 | sp_alias = []; 63 | sp_variant = []; 64 | sp_checkrw = false; 65 | sp_diverge = false; 66 | sp_partial = false; 67 | } 68 | 69 | let vspec spec = 70 | let sp_writes = List.map (T.term false) spec.Uast.sp_writes in 71 | let sp_checkrw = match sp_writes with [] -> false | _ -> true in 72 | let sp_post = 73 | match spec.Uast.sp_header with 74 | | None -> List.map sp_post_no_ret spec.sp_post 75 | | Some hd -> List.map (sp_post hd.sp_hd_ret) spec.sp_post 76 | in 77 | { 78 | sp_pre = List.map (T.term false) spec.Uast.sp_pre; 79 | sp_post; 80 | sp_xpost = List.map sp_xpost spec.sp_xpost; 81 | sp_reads = []; 82 | sp_writes; 83 | sp_alias = []; 84 | sp_variant = List.map (fun t -> (T.term false t, None)) spec.sp_variant; 85 | sp_checkrw; 86 | sp_diverge = spec.sp_diverge; 87 | sp_partial = false; 88 | } 89 | 90 | let fun_spec spec = 91 | { 92 | sp_pre = List.map (T.term false) spec.Uast.fun_req; 93 | sp_post = List.map sp_post_no_ret spec.fun_ens; 94 | sp_xpost = [] (* TODO: cannot be done with [fun_spec] argument *); 95 | sp_reads = []; 96 | sp_writes = []; 97 | sp_alias = []; 98 | sp_variant = List.map (fun t -> (T.term false t, None)) spec.fun_variant; 99 | sp_checkrw = false; 100 | sp_diverge = false; 101 | sp_partial = false; 102 | } 103 | 104 | let spec_union s1 s2 = 105 | { 106 | sp_pre = s1.sp_pre @ s2.sp_pre; 107 | sp_post = s1.sp_post @ s2.sp_post; 108 | sp_xpost = s1.sp_xpost @ s2.sp_xpost; 109 | sp_reads = s1.sp_reads @ s2.sp_reads; 110 | sp_writes = s1.sp_writes @ s2.sp_writes; 111 | sp_alias = s1.sp_alias @ s2.sp_alias; 112 | sp_variant = s1.sp_variant @ s2.sp_variant; 113 | sp_checkrw = s1.sp_checkrw || s2.sp_checkrw; 114 | sp_diverge = s1.sp_diverge || s2.sp_diverge; 115 | sp_partial = s1.sp_partial || s2.sp_partial; 116 | } 117 | -------------------------------------------------------------------------------- /examples/most_frequent.ml: -------------------------------------------------------------------------------- 1 | (** Gospel specification. It includes 2 | - the definition of the [numof] function, where [numof p a b] 3 | returns the number of integer values from [a] (inclusively) to 4 | [b] (exclusively) that satisfy the predicate [p]. 5 | - various auxiliary lemmas about the use of [numof]. 6 | - the definition of the [numof_eq] function, a specialization of 7 | [numof] to count the number of elements within an array that are 8 | logically equal to a given value. *) 9 | 10 | (*@ function rec numof (p: integer -> bool) (a b: integer) : integer = 11 | if b <= a then 0 else 12 | if p (b - 1) then 1 + numof p a (b - 1) 13 | else numof p a (b - 1) *) 14 | (*@ variant b - a *) 15 | 16 | (*@ lemma numof_bounds : 17 | forall p : (integer -> bool), a b : int. 18 | a < b -> 0 <= numof p a b <= b - a *) 19 | 20 | (*@ lemma numof_append: 21 | forall p: (integer -> bool), a b c: integer. 22 | a <= b <= c -> numof p a c = numof p a b + numof p b c *) 23 | 24 | (*@ lemma numof_left_no_add: 25 | forall p : (integer -> bool), a b : integer. 26 | a < b -> not p a -> numof p a b = numof p (a+1) b *) 27 | 28 | (*@ lemma numof_left_add : 29 | forall p : (integer -> bool), a b : integer. 30 | a < b -> p a -> numof p a b = 1 + numof p (a+1) b *) 31 | 32 | (*@ lemma empty : 33 | forall p : (integer -> bool), a b : integer. 34 | (forall n : integer. a <= n < b -> not p n) -> numof p a b = 0 *) 35 | 36 | (*@ function numof_eq (a: 'a array) (v: 'a) (l u: integer) : integer = 37 | numof (fun i -> a.(i) = v) l u *) 38 | 39 | (** Implementation considering only an array of integer values *) 40 | 41 | (*@ predicate is_sorted (a: int array) = forall i j. 42 | 0 <= i <= j < Array.length a -> a.(i) <= a.(j) *) 43 | 44 | let most_frequent (a: int array) = 45 | let r = ref a.(0) in 46 | let c = ref 1 in 47 | let m = ref 1 in 48 | for i = 1 to Array.length a - 1 do 49 | (*@ invariant !c = numof_eq a a.(i-1) 0 i 50 | invariant !m = numof_eq a !r 0 i 51 | invariant forall x. numof_eq a x 0 i <= !m *) 52 | if a.(i) = a.(i-1) then begin 53 | incr c; 54 | if !c > !m then begin m := !c; r := a.(i) end 55 | end else 56 | c := 1 57 | done; 58 | !r 59 | (*@ r = most_frequent a 60 | requires Array.length a > 0 61 | requires is_sorted a 62 | ensures numof_eq a r 0 (Array.length a) > 0 63 | ensures forall x. numof_eq a x 0 (Array.length a) <= 64 | numof_eq a r 0 (Array.length a) *) 65 | 66 | (** Functorial implementation, generalizing the type of elements of 67 | the array. This is achieved by parameterizing functor [Make] with 68 | a type [t], whose values are equipped with a total pre-order 69 | relation. The [is_pre_order] predicate is defined in the Gospel 70 | standard library. *) 71 | 72 | module type COMP = sig 73 | type t 74 | 75 | val [@logic] cmp : t -> t -> int 76 | (*@ axiom is_pre_order_cmp: is_pre_order cmp *) 77 | end 78 | 79 | module Make (C: COMP) = struct 80 | type elt = C.t 81 | 82 | (*@ predicate is_sorted (a: elt array) = forall i j. 83 | 0 <= i <= j < Array.length a -> C.cmp a.(i) a.(j) <= 0 *) 84 | 85 | let most_frequent (a: elt array) : elt = 86 | let r = ref a.(0) in 87 | let c = ref 1 in 88 | let m = ref 1 in 89 | for i = 1 to Array.length a - 1 do 90 | (*@ invariant !c = numof_eq a a.(i-1) 0 i 91 | invariant !m = numof_eq a !r 0 i 92 | invariant forall x. numof_eq a x 0 i <= !m *) 93 | if C.cmp a.(i) a.(i-1) = 0 then begin 94 | incr c; 95 | if !c > !m then begin m := !c; r := a.(i) end 96 | end else 97 | c := 1 98 | done; 99 | !r 100 | (*@ r = most_frequent a 101 | requires Array.length a > 0 102 | requires is_sorted a 103 | ensures numof_eq a r 0 (Array.length a) > 0 104 | ensures forall x. numof_eq a x 0 (Array.length a) <= 105 | numof_eq a r 0 (Array.length a) *) 106 | end 107 | -------------------------------------------------------------------------------- /examples/exercises/solutions/binary_search_tree/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | -------------------------------------------------------------------------------- /examples/applicative_queue/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | -------------------------------------------------------------------------------- /examples/program_proofs.ml: -------------------------------------------------------------------------------- 1 | module Mult = struct 2 | let[@logic] rec mult (x : int) (y : int) : int = 3 | if y = 0 then 0 else x + mult x (y - 1) 4 | (*@ r = mult x y 5 | requires y >= 0 6 | variant y 7 | ensures r = x * y *) 8 | 9 | let[@lemma] rec mult_commutative (x : int) (y : int) = 10 | if x = y then () 11 | else if x = 0 then mult_commutative x (y - 1) 12 | else if y < x then mult_commutative y x 13 | else ( 14 | mult_commutative x (y - 1); 15 | mult_commutative (x - 1) (y - 1); 16 | mult_commutative (x - 1) y) 17 | (*@ mult_commutative x y 18 | requires x >= 0 19 | requires y >= 0 20 | variant x, y 21 | ensures mult x y = mult y x *) 22 | end 23 | 24 | module Mirror = struct 25 | type 'a tree = Empty | Node of 'a tree * 'a * 'a tree 26 | 27 | let[@logic] rec mirror (t : 'a tree) : 'a tree = 28 | match t with 29 | | Empty -> Empty 30 | | Node (l, x, r) -> Node (mirror r, x, mirror l) 31 | 32 | let[@lemma] rec mirror_involutive (t : 'a tree) = 33 | match t with 34 | | Empty -> () 35 | | Node (l, _, r) -> 36 | mirror_involutive l; 37 | mirror_involutive r 38 | (*@ mirror_involutive t 39 | variant t 40 | ensures mirror (mirror t) = t *) 41 | 42 | (*@ function size (t: 'a tree) : integer = 43 | match t with 44 | | Empty -> 0 45 | | Node l _ r -> 1 + size l + size r *) 46 | 47 | let[@lemma] rec mirror_size (t : 'a tree) = 48 | match t with 49 | | Empty -> () 50 | | Node (l, _, r) -> 51 | mirror_size l; 52 | mirror_size r 53 | (*@ mirror_size t 54 | variant t 55 | ensures size (mirror t) = size t *) 56 | end 57 | 58 | module AST = struct 59 | type op = Add | Mul 60 | type expr = Const of int | Var of string | Node of op * expr list 61 | type env = string -> int option 62 | 63 | let[@logic] unit (op : op) : int = match op with Add -> 0 | Mul -> 1 64 | 65 | let[@logic] rec eval (e : expr) (env : env) : int = 66 | match e with 67 | | Const n -> n 68 | | Var s -> ( match env s with Some v -> v | None -> 0) 69 | | Node (op, args) -> eval_list op args env 70 | 71 | (*@ r = eval e env 72 | variant e *) 73 | and[@logic] eval_list (op : op) (args : expr list) (env : env) : int = 74 | match args with 75 | | [] -> unit op 76 | | e :: l -> ( 77 | let v0 = eval e env in 78 | let v1 = eval_list op l env in 79 | match op with Add -> v0 + v1 | Mul -> v0 * v1) 80 | (*@ r = eval_list op args env 81 | variant args *) 82 | 83 | let[@logic] shorten (op : op) (args : expr list) : expr = 84 | match args with [] -> Const (unit op) | [ e ] -> e | _ -> Node (op, args) 85 | (*@ r = shorten op args 86 | ensures forall env. eval r env = eval (Node op args) env *) 87 | 88 | let[@logic] rec optimize (e : expr) : expr = 89 | match e with 90 | | Const _ | Var _ -> e 91 | | Node (op, args) -> shorten op (optimize_and_filter args (unit op)) 92 | 93 | (*@ r = optimize e 94 | variant e 95 | ensures forall env. eval r env = eval e env *) 96 | and[@logic] optimize_and_filter (args : expr list) (u : int) : expr list = 97 | match args with 98 | | [] -> [] 99 | | e :: l -> ( 100 | let e = optimize e in 101 | let l = optimize_and_filter l u in 102 | match e with Const n -> if n = u then l else e :: l | _ -> e :: l) 103 | (*@ r = optimize_and_filter args u 104 | variant args 105 | ensures forall op env. u = unit op -> 106 | eval (Node op r) env = eval (Node op args) env *) 107 | end 108 | 109 | module PeanoNumbers = struct 110 | type unary = Zero | Succ of unary 111 | 112 | (*@ function to_int_logic (u: unary) : integer = 113 | match u with Zero -> 0 | Succ u' -> 1 + to_int_logic u' *) 114 | 115 | let[@logic] rec to_int (u : unary) : int = 116 | match u with Zero -> 0 | Succ u' -> 1 + to_int u' 117 | (*@ r = to_int u 118 | ensures r >= 0 && r = to_int_logic u *) 119 | 120 | (*@ function of_int_logic (n: integer) : unary *) 121 | (*@ axiom of_int_0: of_int_logic 0 = Zero *) 122 | (*@ axiom of_int_S: forall n. n > 0 -> 123 | of_int_logic n = Succ (of_int_logic (n - 1)) *) 124 | 125 | let[@logic] rec of_int (n : int) : unary = 126 | if n = 0 then Zero else Succ (of_int (n - 1)) 127 | (*@ r = of_int n 128 | requires n >= 0 129 | variant n 130 | ensures r = of_int_logic n *) 131 | 132 | let[@lemma] rec to_int_of_int (n : int) = if n > 0 then to_int_of_int (n - 1) 133 | (*@ to_int_of_int n 134 | requires n >= 0 135 | variant n 136 | ensures to_int_logic (of_int_logic n) = n *) 137 | 138 | let[@lemma] rec of_int_to_int (u : unary) = 139 | match u with Zero -> () | Succ u' -> of_int_to_int u' 140 | (*@ of_int_to_int u 141 | ensures of_int_logic (to_int_logic u) = u *) 142 | 143 | let[@logic] rec less (x : unary) (y : unary) = 144 | match (x, y) with 145 | | Zero, Succ _ -> true 146 | | _, Zero -> false 147 | | Succ x', Succ y' -> less x' y' 148 | 149 | let[@lemma] rec less_transitive x y = 150 | match (x, y) with Succ x', Succ y' -> less_transitive x' y' | _ -> () 151 | (*@ less_transitive x y 152 | ensures less x y <-> to_int_logic x < to_int_logic y *) 153 | 154 | let[@logic] rec add x y = 155 | match y with Zero -> x | Succ y' -> Succ (add x y') 156 | (*@ r = add x y 157 | ensures to_int_logic r = to_int_logic x + to_int_logic y *) 158 | end 159 | -------------------------------------------------------------------------------- /examples/stack/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /examples/ocaml_fold/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | -------------------------------------------------------------------------------- /examples/ocaml_stack/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | -------------------------------------------------------------------------------- /examples/binary_search_tree/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /examples/cnf_conversion.ml: -------------------------------------------------------------------------------- 1 | type ident = string 2 | type literal = FVar of ident | FConst of bool 3 | 4 | type formula = 5 | | L of literal 6 | | FAnd of formula * formula 7 | | FOr of formula * formula 8 | | FImpl of formula * formula 9 | | FNeg of formula 10 | 11 | type formula_wi = 12 | | L_wi of literal 13 | | FAnd_wi of formula_wi * formula_wi 14 | | FOr_wi of formula_wi * formula_wi 15 | | FNeg_wi of formula_wi 16 | 17 | type formula_nnf = 18 | | FAnd_nnf of formula_nnf * formula_nnf 19 | | FOr_nnf of formula_nnf * formula_nnf 20 | | FNeg_nnf of literal 21 | | L_nnf of literal 22 | 23 | type disj = FOr_cnf of disj * disj | FNeg_cnf of literal | L_cnf of literal 24 | type formula_cnf = FAnd_cnf of formula_cnf * formula_cnf | D of disj 25 | type valuation = ident -> bool 26 | 27 | let[@logic] eval_literal (v : valuation) (f : literal) : bool = 28 | match f with FVar x -> v x | FConst b -> b 29 | 30 | let[@logic] rec eval (v : valuation) (f : formula) : bool = 31 | match f with 32 | | L phi1 -> eval_literal v phi1 33 | | FAnd (f1, f2) -> eval v f1 && eval v f2 34 | | FOr (f1, f2) -> eval v f1 || eval v f2 35 | | FImpl (f1, f2) -> (not (eval v f1)) || eval v f2 36 | | FNeg f -> not (eval v f) 37 | (*@ r = eval v f 38 | variant f *) 39 | 40 | let[@logic] rec eval_wi (v : valuation) (f : formula_wi) : bool = 41 | match f with 42 | | L_wi phi1 -> eval_literal v phi1 43 | | FAnd_wi (f1, f2) -> eval_wi v f1 && eval_wi v f2 44 | | FOr_wi (f1, f2) -> eval_wi v f1 || eval_wi v f2 45 | | FNeg_wi f -> not (eval_wi v f) 46 | (*@ r = eval_wi v f 47 | variant f *) 48 | 49 | let[@logic] rec eval_nnf (v : valuation) (f : formula_nnf) : bool = 50 | match f with 51 | | FAnd_nnf (f1, f2) -> eval_nnf v f1 && eval_nnf v f2 52 | | FOr_nnf (f1, f2) -> eval_nnf v f1 || eval_nnf v f2 53 | | FNeg_nnf literal -> not (eval_literal v literal) 54 | | L_nnf literal -> eval_literal v literal 55 | (*@ r = eval_nnf v f 56 | variant f *) 57 | 58 | let[@logic] rec eval_disj (v : valuation) (f : disj) : bool = 59 | match f with 60 | | FOr_cnf (f1, f2) -> eval_disj v f1 || eval_disj v f2 61 | | FNeg_cnf literal -> not (eval_literal v literal) 62 | | L_cnf literal -> eval_literal v literal 63 | (*@ r = eval_disj v f 64 | variant f *) 65 | 66 | let[@logic] rec eval_cnf (v : valuation) (f : formula_cnf) : bool = 67 | match f with 68 | | FAnd_cnf (f1, f2) -> eval_cnf v f1 && eval_cnf v f2 69 | | D disj -> eval_disj v disj 70 | (*@ r = eval_cnf v f 71 | variant f *) 72 | 73 | (*@ function size (phi: formula_wi) : integer 74 | = match phi with 75 | | L_wi _ -> 1 76 | | FNeg_wi phi -> 1 + size phi 77 | | FAnd_wi phi1 phi2 | FOr_wi phi1 phi2 -> 1 + size phi1 + size phi2 *) 78 | 79 | (*@ function size_disj (phi: disj) : integer 80 | = match phi with 81 | | FOr_cnf phi1 phi2 -> 1 + size_disj phi1 + size_disj phi2 82 | | FNeg_cnf _ -> 2 83 | | L_cnf _ -> 1 *) 84 | 85 | (*@ function size_cnf (phi: formula_cnf) : integer 86 | = match phi with 87 | | FAnd_cnf phi1 phi2 -> 1 + size_cnf phi1 + size_cnf phi2 88 | | D phi1 -> size_disj phi1 *) 89 | 90 | let[@lemma] rec size_nonneg (phi : formula_wi) = 91 | match phi with 92 | | L_wi _ -> () 93 | | FNeg_wi phi -> size_nonneg phi 94 | | FAnd_wi (phi1, phi2) | FOr_wi (phi1, phi2) -> 95 | size_nonneg phi1; 96 | size_nonneg phi2 97 | (*@ size_nonneg phi 98 | variant phi 99 | ensures size phi >= 0 *) 100 | 101 | let[@lemma] rec size_nonneg_disj (phi : disj) = 102 | match phi with 103 | | FNeg_cnf _ | L_cnf _ -> () 104 | | FOr_cnf (phi1, phi2) -> 105 | size_nonneg_disj phi1; 106 | size_nonneg_disj phi2 107 | (*@ size_nonneg_disj phi 108 | variant phi 109 | ensures size_disj phi >= 0 *) 110 | 111 | let[@lemma] rec size_nonneg_cnf (phi : formula_cnf) = 112 | match phi with 113 | | FAnd_cnf (phi1, phi2) -> 114 | size_nonneg_cnf phi1; 115 | size_nonneg_cnf phi2 116 | | D phi1 -> size_nonneg_disj phi1 117 | (*@ size_nonneg_cnf phi 118 | variant phi 119 | ensures size_cnf phi >= 0 *) 120 | 121 | let[@logic] rec impl_free (phi : formula) : formula_wi = 122 | match phi with 123 | | FNeg phi1 -> FNeg_wi (impl_free phi1) 124 | | FOr (phi1, phi2) -> FOr_wi (impl_free phi1, impl_free phi2) 125 | | FAnd (phi1, phi2) -> FAnd_wi (impl_free phi1, impl_free phi2) 126 | | FImpl (phi1, phi2) -> FOr_wi (FNeg_wi (impl_free phi1), impl_free phi2) 127 | | L phi -> L_wi phi 128 | (*@ r = impl_free phi 129 | variant phi 130 | ensures forall v. eval v phi = eval_wi v r *) 131 | 132 | let[@logic] rec nnfc (phi : formula_wi) = 133 | match phi with 134 | | FNeg_wi (FNeg_wi phi1) -> nnfc phi1 135 | | FNeg_wi (FAnd_wi (phi1, phi2)) -> 136 | FOr_nnf (nnfc (FNeg_wi phi1), nnfc (FNeg_wi phi2)) 137 | | FNeg_wi (FOr_wi (phi1, phi2)) -> 138 | FAnd_nnf (nnfc (FNeg_wi phi1), nnfc (FNeg_wi phi2)) 139 | | FNeg_wi (L_wi phi1) -> FNeg_nnf phi1 140 | | FOr_wi (phi1, phi2) -> FOr_nnf (nnfc phi1, nnfc phi2) 141 | | FAnd_wi (phi1, phi2) -> FAnd_nnf (nnfc phi1, nnfc phi2) 142 | | L_wi phi1 -> L_nnf phi1 143 | (*@ r = nnfc phi 144 | variant size phi 145 | ensures forall v. eval_wi v phi = eval_nnf v r *) 146 | 147 | let[@logic] rec distr (phi1 : formula_cnf) (phi2 : formula_cnf) = 148 | match (phi1, phi2) with 149 | | FAnd_cnf (phi11, phi12), phi2 -> 150 | FAnd_cnf (distr phi11 phi2, distr phi12 phi2) 151 | | phi1, FAnd_cnf (phi21, phi22) -> 152 | FAnd_cnf (distr phi1 phi21, distr phi1 phi22) 153 | | D phi1, D phi2 -> D (FOr_cnf (phi1, phi2)) 154 | (*@ r = distr phi1 phi2 155 | variant size_cnf phi1 + size_cnf phi2 156 | ensures forall v. (eval_cnf v phi1 || eval_cnf v phi2) = eval_cnf v r *) 157 | 158 | let[@logic] rec cnfc (phi : formula_nnf) = 159 | match phi with 160 | | FOr_nnf (phi1, phi2) -> distr (cnfc phi1) (cnfc phi2) 161 | | FAnd_nnf (phi1, phi2) -> FAnd_cnf (cnfc phi1, cnfc phi2) 162 | | FNeg_nnf literal -> D (FNeg_cnf literal) 163 | | L_nnf literal -> D (L_cnf literal) 164 | (*@ r = cnf phi 165 | variant phi 166 | ensures forall v. eval_nnf v phi = eval_cnf v r *) 167 | 168 | let t (phi : formula) : formula_cnf = cnfc (nnfc (impl_free phi)) 169 | (*@ r = t phi 170 | ensures forall v. eval v phi = eval_cnf v r *) 171 | -------------------------------------------------------------------------------- /src/mod_subst.ml: -------------------------------------------------------------------------------- 1 | open Why3 2 | open Ptree 3 | open Wstdlib 4 | 5 | type mod_constraint = 6 | | MCtype_sharing of type_decl 7 | | MCtype_destructive of type_decl 8 | | MCfunction_sharing of qualid 9 | | MCfunction_destructive of qualid 10 | | MCprop of Decl.prop_kind 11 | 12 | module Mqual = Map.Make (struct 13 | type t = Ptree.qualid 14 | 15 | let compare = Stdlib.compare 16 | end) 17 | 18 | type subst = { 19 | subst_ts : Ptree.type_decl Mstr.t; 20 | subst_td : Ptree.type_decl Mstr.t; 21 | subst_fs : Ptree.qualid Mstr.t; 22 | subst_fd : Ptree.qualid Mqual.t; 23 | subst_ps : Ptree.qualid Mstr.t; 24 | subst_pd : Ptree.qualid Mqual.t; 25 | subst_pr : Decl.prop_kind Mqual.t; 26 | } 27 | 28 | let empty_subst = 29 | { 30 | subst_ts = Mstr.empty; 31 | subst_td = Mstr.empty; 32 | subst_fs = Mstr.empty; 33 | subst_fd = Mqual.empty; 34 | subst_ps = Mstr.empty; 35 | subst_pd = Mqual.empty; 36 | subst_pr = Mqual.empty; 37 | } 38 | 39 | let add_ts_subst k subst td = 40 | { subst with subst_ts = Mstr.add k td subst.subst_ts } 41 | 42 | let add_td_subst k subst td = 43 | { subst with subst_td = Mstr.add k td subst.subst_td } 44 | 45 | let add_fs_subst k subst q = 46 | { subst with subst_fs = Mstr.add k q subst.subst_fs } 47 | 48 | let add_fd_subst k subst q = 49 | { subst with subst_fd = Mqual.add k q subst.subst_fd } 50 | 51 | let add_ps_subst k subst q = 52 | { subst with subst_ps = Mstr.add k q subst.subst_ps } 53 | 54 | let add_pd_subst k subst q = 55 | { subst with subst_pd = Mqual.add k q subst.subst_pd } 56 | 57 | let add_pr_subst k subst pr = 58 | { subst with subst_pr = Mqual.add k pr subst.subst_pr } 59 | 60 | (* FIXME: this is so ugly... *) 61 | (* let rec str_of_qualid = function 62 | * | Qident {id_str; _} -> id_str 63 | * | Qdot (q, {id_str; _}) -> (str_of_qualid q) ^ "." ^ id_str 64 | * 65 | * let rec subst_term subst {term_desc; term_loc} = 66 | * let mk_term term_desc = T.mk_term ~term_loc term_desc in 67 | * let term_desc = match term_desc with 68 | * | (Ttrue | Tfalse) as t -> t 69 | * | (Tconst _) as t -> t 70 | * | Tident q -> let id_str = str_of_qualid q in 71 | * let q = Hstr.find_def subst.subst_fd q id_str in 72 | * Tident q 73 | * | Tasref _ -> assert false (\* TODO *\) 74 | * | Tidapp (q, t_list) -> 75 | * let id_str = str_of_qualid q in 76 | * let q = Hstr.find_def subst.subst_fd q id_str in 77 | * Tidapp (q, List.map (subst_term subst) t_list) 78 | * | Tapply (tf, targ) -> 79 | * let tf = subst_term subst tf and targ = subst_term subst targ in 80 | * Tapply (tf, targ) 81 | * | Tinfix (t1, op, t2) -> 82 | * let t1 = subst_term subst t1 and t2 = subst_term subst t2 in 83 | * (\* FIXME: take `op` into account *\) 84 | * Tinfix (t1, op, t2) 85 | * | Tinnfix _ -> assert false (\* TODO *\) 86 | * | Tbinop (t1, op, t2) -> 87 | * let t1 = subst_term subst t1 and t2 = subst_term subst t2 in 88 | * Tbinop (t1, op, t2) 89 | * | Tbinnop _ -> assert false (\* TODO *\) 90 | * | Tnot _ -> assert false (\* TODO *\) 91 | * | Tif _ -> assert false (\* TODO *\) 92 | * | Tquant (q, vars, triggers, t) -> 93 | * let t = subst_term subst t in 94 | * (\* TODO: make substitution inside quantified vars *\) 95 | * Tquant (q, vars, triggers, t) 96 | * | Tattr _ -> assert false (\* TODO *\) 97 | * | Tlet _ -> assert false (\* TODO *\) 98 | * | Tcase _ -> assert false (\* TODO *\) 99 | * | Tcast _ -> assert false (\* TODO *\) 100 | * | Ttuple _ -> assert false (\* TODO *\) 101 | * | Trecord _ -> assert false (\* TODO *\) 102 | * | Tupdate _ -> assert false (\* TODO *\) 103 | * | Tscope _ -> assert false (\* TODO *\) 104 | * | Tat _ -> assert false (\* TODO *\) in 105 | * mk_term term_desc 106 | * 107 | * let subst_type_decl subst ({td_ident; _} as td) = 108 | * let id_str = td_ident.id_str in 109 | * match Hstr.find_opt subst.subst_ts id_str with 110 | * | Some mod_td -> [mod_td] 111 | * | None -> match Hstr.find_opt subst.subst_td id_str with 112 | * | Some _ -> (\* creative indentation *\) 113 | * [] 114 | * | None -> [td] 115 | * 116 | * let subst_logic_decl subst ld = 117 | * let id_str = ld.ld_ident.id_str in 118 | * match Hstr.find_opt subst.subst_fs id_str with 119 | * | Some q -> 120 | * let term_desc = Tident q in 121 | * let term_loc = Loc.dummy_position in 122 | * let term = T.mk_term ~term_loc term_desc in 123 | * [{ ld with ld_def = Some term }] 124 | * | None -> match Hstr.find_opt subst.subst_fd id_str with 125 | * | Some _ -> (\* creative indentation *\) 126 | * [] 127 | * | None -> let ld_def = Utils.opmap (subst_term subst) ld.ld_def in 128 | * [{ ld with ld_def }] 129 | * 130 | * let subst_decl subst = function 131 | * | Dtype td_list -> 132 | * let mk_subst acc ty_decl = subst_type_decl subst ty_decl :: acc in 133 | * let subst_decl = List.fold_left mk_subst [] td_list in 134 | * if subst_decl = [[]] then [] 135 | * else [Dtype (List.rev (List.flatten subst_decl))] 136 | * | Dlogic ld_list -> 137 | * let mk_subst acc l_decl = subst_logic_decl subst l_decl :: acc in 138 | * let subst_decl = List.fold_left mk_subst [] ld_list in 139 | * if subst_decl = [[]] then [] 140 | * else [Dlogic (List.rev (List.flatten subst_decl))] 141 | * | Dind _ -> assert false (\* TODO *\) 142 | * | Dprop (Decl.Plemma, id, t) -> 143 | * (\* FIXME: I am not sure if I can turn each lemma into an axiom *\) 144 | * [Dprop (Decl.Paxiom, id, subst_term subst t)] 145 | * | Dprop (Decl.Paxiom, id, t) -> 146 | * let k = Hstr.find_def subst.subst_pr Decl.Plemma id.id_str in 147 | * [Dprop (k, id, subst_term subst t)] 148 | * | Dprop (Decl.Pgoal, id, t) -> 149 | * [Dprop (Decl.Pgoal, id, subst_term subst t)] 150 | * | Dlet _ -> assert false (\* TODO *\) 151 | * | Drec _ -> assert false (\* TODO *\) 152 | * | Dexn _ -> assert false (\* TODO *\) 153 | * | Dmeta _ -> assert false (\* TODO *\) 154 | * | Dcloneexport _ -> assert false (\* TODO *\) 155 | * | Duseexport _ -> assert false (\* TODO *\) 156 | * | Dcloneimport _ -> assert false (\* TODO *\) 157 | * | Duseimport _ -> assert false (\* TODO *\) 158 | * | Dscope _ -> assert false (\* TODO *\) 159 | * | Dimport _ -> assert false (\* TODO *\) *) 160 | -------------------------------------------------------------------------------- /stdlib/setCameleer.mli: -------------------------------------------------------------------------------- 1 | module Set : sig 2 | (*@ type 'a fset *) 3 | 4 | (*@ predicate mem (x: 'a) (s: 'a fset) (* = s.to_map[x] *) *) 5 | 6 | (** equality *) 7 | (*@ predicate (==) (s1 s2: 'a fset) = forall x: 'a. mem x s1 <-> mem x s2 *) 8 | 9 | (*@ lemma extensionality: 10 | forall s1 s2: 'a fset. s1 == s2 -> s1 = s2 *) 11 | 12 | (** inclusion *) 13 | (*@ predicate subset (s1 s2: 'a fset) = forall x : 'a. mem x s1 -> mem x s2 *) 14 | 15 | (*@ lemma subset_refl: 16 | forall s: 'a fset. subset s s *) 17 | 18 | (*@ lemma subset_trans: 19 | forall s1 s2 s3: 'a fset. subset s1 s2 -> subset s2 s3 -> subset s1 s3 *) 20 | 21 | (** empty set *) 22 | (*@ predicate is_empty (s: 'a fset) = forall x: 'a. not (mem x s) *) 23 | 24 | (*@ function empty: 'a fset *) 25 | 26 | (*@ axiom is_empty_empty: is_empty (empty: 'a fset) *) 27 | 28 | (*@ lemma empty_is_empty: 29 | forall s: 'a fset. is_empty s -> s = empty *) 30 | 31 | (** addition *) 32 | (*@ function add (x: 'a) (s: 'a fset) : 'a fset *) 33 | 34 | (*@ axiom add_def: forall x: 'a, s: 'a fset, y: 'a. 35 | mem y (add x s) <-> (mem y s \/ y = x) *) 36 | 37 | (*@ lemma add_comm: forall x y: 'a, s: 'a fset. 38 | add x (add y s) = add y (add x s) *) 39 | 40 | (*@ function singleton (x: 'a): 'a fset = add x empty *) 41 | 42 | (*@ lemma mem_singleton: 43 | forall x, y: 'a. mem y (singleton x) -> y = x *) 44 | 45 | (** removal *) 46 | 47 | (*@ function remove (x: 'a) (s: 'a fset) : 'a fset *) 48 | (*@ axiom remove_def: forall x: 'a, s: 'a fset, y: 'a. 49 | mem y (remove x s) <-> (mem y s /\ y <> x) *) 50 | 51 | (*@ lemma add_remove: 52 | forall x: 'a, s: 'a fset. mem x s -> add x (remove x s) = s *) 53 | 54 | (*@ lemma remove_add: 55 | forall x: 'a, s: 'a fset. remove x (add x s) = remove x s *) 56 | 57 | (*@ lemma subset_remove: 58 | forall x: 'a, s: 'a fset. subset (remove x s) s *) 59 | 60 | (** union *) 61 | 62 | (*@ function union (s1 s2: 'a fset): 'a fset *) 63 | (*@ axiom union_def: forall s1 s2: 'a fset, x: 'a. 64 | mem x (union s1 s2) <-> mem x s1 \/ mem x s2 *) 65 | 66 | (*@ lemma subset_union_1: 67 | forall s1 s2: 'a fset. subset s1 (union s1 s2) *) 68 | (*@ lemma subset_union_2: 69 | forall s1 s2: 'a fset. subset s2 (union s1 s2) *) 70 | 71 | (*@ lemma union_add_comm1: forall x: 'a, s1 s2: 'a fset. 72 | add x (union s1 s2) = union (add x s1) s2 *) 73 | 74 | (*@ lemma union_add_comm2: forall x: 'a, s1 s2: 'a fset. 75 | add x (union s1 s2) = union s1 (add x s2) *) 76 | 77 | (** intersection *) 78 | 79 | (*@ function inter (s1 s2: 'a fset): 'a fset *) 80 | (*@ axiom inter_def: forall s1 s2: 'a fset, x: 'a. 81 | mem x (inter s1 s2) <-> mem x s1 /\ mem x s2 *) 82 | 83 | (*@ lemma subset_inter_1: 84 | forall s1 s2: 'a fset. subset (inter s1 s2) s1 *) 85 | (*@ lemma subset_inter_2: 86 | forall s1 s2: 'a fset. subset (inter s1 s2) s2 *) 87 | 88 | (** difference *) 89 | 90 | (*@ function diff (s1 s2: 'a fset): 'a fset *) 91 | (*@ axiom diff_def: forall s1 s2: 'a fset, x: 'a. 92 | mem x (diff s1 s2) <-> mem x s1 /\ not (mem x s2) *) 93 | 94 | (*@ lemma subset_diff: 95 | forall s1 s2: 'a fset. subset (diff s1 s2) s1 *) 96 | 97 | (** arbitrary element *) 98 | (*@ function pick (s: 'a fset): 'a *) 99 | 100 | (*@ axiom pick_def: forall s: 'a fset. not (is_empty s) -> mem (pick s) s *) 101 | 102 | (** disjoint sets *) 103 | (*@ predicate disjoint (s1 s2: 'a fset) = 104 | forall x. not (mem x s1) \/ not (mem x s2) *) 105 | 106 | (*@ lemma disjoint_inter_empty: 107 | forall s1 s2: 'a fset. disjoint s1 s2 <-> is_empty (inter s1 s2) *) 108 | 109 | (*@ lemma disjoint_diff_eq: 110 | forall s1 s2: 'a fset. disjoint s1 s2 <-> diff s1 s2 = s1 *) 111 | 112 | (*@ lemma disjoint_diff_s2: 113 | forall s1 s2: 'a fset. disjoint (diff s1 s2) s2 *) 114 | 115 | (** `{ x | x in s /\ p x }` *) 116 | 117 | (*@ function filter (s: 'a fset) (p: 'a -> bool) : 'a fset *) 118 | (*@ axiom filter_def: forall s: 'a fset, p: ('a -> bool), x: 'a. 119 | mem x (filter s p) <-> mem x s /\ p x *) 120 | 121 | (*@ lemma subset_filter: 122 | forall s: 'a fset, p: ('a -> bool). subset (filter s p) s *) 123 | 124 | (** `{ f x | x in U }` *) 125 | 126 | (*@ function map (f: 'a -> 'b) (u: 'a fset) : 'b fset *) 127 | (*@ axiom map_def: 128 | forall f: ('a -> 'b), u: 'a fset, y: 'b. 129 | mem y (map f u) <-> exists x: 'a. mem x u /\ y = f x *) 130 | 131 | (*@ lemma mem_map: 132 | forall f: ('a -> 'b), u: 'a fset. 133 | forall x: 'a. mem x u -> mem (f x) (map f u) *) 134 | 135 | (** cardinal *) 136 | (*@ function cardinal (s: 'a fset) : integer *) 137 | 138 | (*@ axiom cardinal_nonneg: 139 | forall s: 'a fset. cardinal s >= 0 *) 140 | 141 | (*@ axiom cardinal_empty: 142 | forall s: 'a fset. is_empty s <-> cardinal s = 0 *) 143 | 144 | (*@ axiom cardinal_add: 145 | forall x: 'a. forall s: 'a fset. 146 | if mem x s then cardinal (add x s) = cardinal s 147 | else cardinal (add x s) = cardinal s + 1 *) 148 | 149 | (*@ axiom cardinal_remove: 150 | forall x: 'a. forall s: 'a fset. 151 | if mem x s then cardinal (remove x s) = cardinal s - 1 152 | else cardinal (remove x s) = cardinal s *) 153 | 154 | (*@ axiom cardinal_subset: 155 | forall s1 s2: 'a fset. 156 | subset s1 s2 -> cardinal s1 <= cardinal s2 *) 157 | 158 | (*@ lemma subset_eq: 159 | forall s1 s2: 'a fset. 160 | subset s1 s2 -> cardinal s1 = cardinal s2 -> s1 = s2 *) 161 | 162 | (*@ lemma cardinal1: 163 | forall s: 'a fset. cardinal s = 1 -> 164 | forall x: 'a. mem x s -> x = pick s *) 165 | 166 | (*@ axiom cardinal_union: 167 | forall s1 s2: 'a fset. 168 | cardinal (union s1 s2) 169 | = cardinal s1 + cardinal s2 - cardinal (inter s1 s2) *) 170 | 171 | (*@ lemma cardinal_inter_disjoint: 172 | forall s1 s2: 'a fset. disjoint s1 s2 -> cardinal (inter s1 s2) = 0 *) 173 | 174 | (*@ axiom cardinal_diff: 175 | forall s1 s2: 'a fset. 176 | cardinal (diff s1 s2) = cardinal s1 - cardinal (inter s1 s2) *) 177 | 178 | (*@ lemma cardinal_filter: 179 | forall s: 'a fset, p: ('a -> bool). 180 | cardinal (filter s p) <= cardinal s *) 181 | 182 | (*@ lemma cardinal_map: 183 | forall f: ('a -> 'b), s: 'a fset. 184 | cardinal (map f s) <= cardinal s *) 185 | end 186 | -------------------------------------------------------------------------------- /examples/insertion_sort_list/why3session.xml: -------------------------------------------------------------------------------- 1 | 2 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | 15 | 16 | 17 | 18 | 19 | 20 | 21 | 22 | 23 | 24 | 25 | 26 | 27 | 28 | 29 | 30 | 31 | 32 | 33 | 34 | 35 | 36 | 37 | 38 | 39 | 40 | 41 | 42 | 43 | 44 | 45 | 46 | 47 | 48 | 49 | 50 | 51 | 52 | 53 | 54 | 55 | 56 | 57 | 58 | 59 | 60 | 61 | 62 | 63 | 64 | 65 | 66 | 67 | 68 | 69 | 70 | 71 | 72 | 73 | 74 | 75 | 76 | 77 | 78 | 79 | 80 | 81 | 82 | 83 | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 | 92 | 93 | 94 | 95 | 96 | 97 | 98 | 99 | 100 | 101 | 102 | 103 | 104 | 105 | 106 | 107 | 108 | 109 | 110 | 111 | 112 | 113 | 114 | 115 | 116 | 117 | 118 | 119 | 120 | 121 | 122 | 123 | 124 | 125 | 126 | 127 | 128 | 129 | 130 | 131 | 132 | 133 | 134 | 135 | 136 | 137 | 138 | 139 | 140 | 141 | 142 | 143 | 144 | 145 | --------------------------------------------------------------------------------