diff options
Diffstat (limited to 'src/lfsc')
74 files changed, 9963 insertions, 0 deletions
diff --git a/src/lfsc/Makefile b/src/lfsc/Makefile new file mode 100644 index 0000000..6a101c4 --- /dev/null +++ b/src/lfsc/Makefile @@ -0,0 +1,12 @@ +native: + ocamlbuild -r -tags annot,bin_annot,rectypes -libs nums,unix -no-hygiene lfsctosmtcoq.native + +byte: + ocamlbuild -r -tags annot,bin_annot,rectypes -libs nums,unix -no-hygiene lfsctosmtcoq.d.byte + +prof: + ocamlbuild -r -tags annot,bin_annot,profile,rectypes -tag profile -libs nums,unix -no-hygiene lfsctosmtcoq.native + +clean: + ocamlbuild -clean + rm *.cm* *.o *.ml*.d lfscLexer.ml lfscParser.mli lfscParser.ml diff --git a/src/lfsc/Readme.md b/src/lfsc/Readme.md new file mode 100644 index 0000000..353fbb0 --- /dev/null +++ b/src/lfsc/Readme.md @@ -0,0 +1,5 @@ +# lfsctosmtcoq + +Conversion of LFSC proofs produced by CVC4 to the proof traces format of veriT +for SMTCoq. + diff --git a/src/lfsc/ast.ml b/src/lfsc/ast.ml new file mode 100644 index 0000000..29a4afc --- /dev/null +++ b/src/lfsc/ast.ml @@ -0,0 +1,961 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Format + +exception CVC4Sat + +let debug = + (* true *) + false + +(********************************) +(* Type definitions for the AST *) +(********************************) + +type mpz = Big_int.big_int +type mpq = Num.num + + +type name = Name of Hstring.t | S_Hole of int +type symbol = { sname : name; stype : term } + +and dterm = + | Type + | Kind + | Mpz + | Mpq + | Const of symbol + | App of term * term list + | Int of mpz + | Rat of mpq + | Pi of symbol * term + | Lambda of symbol * term + | Hole of int + | Ptr of term + | SideCond of Hstring.t * term list * term * term + +and term = { mutable value: dterm; ttype: term } +(* TODO: remove type annotations in terms *) + +type command = + | Check of term + | Define of Hstring.t * term + | Declare of Hstring.t * term + + +type proof = command list + + +module H = struct + let holds = Hstring.make "holds" + let th_holds = Hstring.make "th_holds" + let mp_add = Hstring.make "mp_add" + let mp_mul = Hstring.make "mp_mul" + let uminus = Hstring.make "~" + let eq = Hstring.make "=" +end + + +let is_rule t = + match t.ttype.value with + | App ({value=Const{sname=Name n}}, _) -> n == H.holds || n == H.th_holds + | _ -> false + + +let rec deref t = match t.value with + | Ptr t -> deref t + | _ -> t + + +let value t = (deref t).value + + +let ttype t = deref (deref t).ttype + + +let rec name c = match value c with + | Const {sname=Name n} -> Some n + | _ -> None + + +let rec app_name r = match value r with + | App ({value=Const{sname=Name n}}, args) -> Some (n, args) + | _ -> None + + +(*******************) +(* Pretty printing *) +(*******************) + +let address_of (x:'a) : nativeint = + if Obj.is_block (Obj.repr x) then + Nativeint.shift_left (Nativeint.of_int (Obj.magic x)) 1 (* magic *) + else + invalid_arg "Can only find address of boxed values." + +let rec print_symbol fmt { sname } = match sname with + | Name n -> Hstring.print fmt n + | S_Hole i -> fprintf fmt "_s%d" i + +and print_tval pty fmt t = match t.value with + | Type -> fprintf fmt "type" + | Kind -> fprintf fmt "kind" + | Mpz -> fprintf fmt "mpz" + | Mpq -> fprintf fmt "mpz" + | Const s -> print_symbol fmt s + | App (f, args) when pty && is_rule t -> + let color = (Hashtbl.hash f.value mod 216) + 16 in + let op, cl = sprintf "\x1b[38;5;%dm" color, "\x1b[0m" in + fprintf fmt "@[@<0>%s(%a@<0>%s%a@<0>%s)@,@<0>%s@]" + op + (print_tval false) f + cl + (fun fmt -> List.iter (fprintf fmt "@ %a" (print_term pty))) args + op cl + | App (f, args) -> + fprintf fmt "@[(%a%a)@,@]" + (print_tval false) f + (fun fmt -> List.iter (fprintf fmt "@ %a" (print_term pty))) args + + | Int n -> pp_print_string fmt (Big_int.string_of_big_int n) + | Rat q -> pp_print_string fmt (Num.string_of_num q) + | Pi (s, t) -> + fprintf fmt "(! %a@ %a@ %a)@," + print_symbol s + (print_term false) s.stype + (print_term pty) t + | Lambda (s, t) -> + fprintf fmt "(%% %a@ %a@ %a)@," print_symbol s (print_term pty) s.stype + (print_term pty) t + | Hole i -> + if false && debug then + fprintf fmt "_%d[%nx]" i (address_of t) + else + fprintf fmt "_%d" i + + | Ptr t when (* true || *) debug -> fprintf fmt "*%a" (print_term pty) t + + | Ptr t -> print_term pty fmt t + + | SideCond (name, args, expected, t) -> + fprintf fmt "(! _ (^ (%a%a)@ %a)@ %a)" + Hstring.print name + (fun fmt -> List.iter (fprintf fmt "@ %a" (print_term pty))) args + (print_term pty) expected + (print_term pty) t + + +and print_term pty fmt t = match t with + | {value = Type | Kind | Ptr _ | Const _} + | {ttype = {value = Type | Kind | Const _ | Ptr _}} -> + print_tval pty fmt t + | _ when t.ttype == t -> + print_tval pty fmt t + (* | _ when pty -> *) + (* fprintf fmt "[@[%a:%a@]]" (print_tval pty) t (print_term pty) t.ttype *) + | _ when pty && is_rule t -> + let op, cl = "\x1b[30m", "\x1b[0m" in + fprintf fmt "@\n@[@<0>%s(: %a@<0>%s@\n%a@<0>%s)@<0>%s@,@]" + op (print_term false) t.ttype cl (print_tval pty) t op cl + (* | _ when pty -> *) + (* fprintf fmt "@[(:@ %a@ %a)@]" *) + (* (print_term false) t.ttype (print_tval pty) t *) + (* | _ when pty -> *) + (* fprintf fmt "@[%a\x1b[30m:%a\x1b[0m)@]" *) + (* (print_tval pty) t (print_term false) t.ttype *) + | _ -> + fprintf fmt "@[%a@]" (print_tval pty) t + + +let print_term_type = print_term true +let print_term = print_term false + +let print_command fmt = function + | Check t -> + fprintf fmt "(check@ (:@\n@\n %a@ @\n@\n%a))" + print_term t.ttype print_term_type t + | Define (s, t) -> + fprintf fmt "(define %a@ %a)" Hstring.print s print_term t + | Declare (s, t) -> + fprintf fmt "(declare %a@ %a)" Hstring.print s print_term t + +let print_proof fmt = + List.iter (fprintf fmt "@[<1>%a@]@\n@." print_command) + + + +let compare_symbol s1 s2 = match s1.sname, s2.sname with + | Name n1, Name n2 -> Hstring.compare n1 n2 + | Name _, _ -> -1 + | _, Name _ -> 1 + | S_Hole i1, S_Hole i2 -> Pervasives.compare i1 i2 + + +let rec compare_term ?(mod_eq=false) t1 t2 = match t1.value, t2.value with + | Ptr t1, _ -> compare_term ~mod_eq t1 t2 + | _, Ptr t2 -> compare_term ~mod_eq t1 t2 + | Type, Type | Kind, Kind | Mpz, Mpz | Mpq, Mpz -> 0 + | Type, _ -> -1 | _, Type -> 1 + | Kind, _ -> -1 | _, Kind -> 1 + | Mpz, _ -> -1 | _, Mpz -> 1 + | Mpq, _ -> -1 | _, Mpq -> 1 + | Int n1, Int n2 -> Big_int.compare_big_int n1 n2 + | Int _, _ -> -1 | _, Int _ -> 1 + | Rat q1, Rat q2 -> Num.compare_num q1 q2 + | Rat _, _ -> -1 | _, Rat _ -> 1 + | Const s1, Const s2 -> compare_symbol s1 s2 + | Const _, _ -> -1 | _, Const _ -> 1 + | App ({value=Const{sname=Name n1}}, [ty1; a1; b1]), + App ({value=Const{sname=Name n2}}, [ty2; a2; b2]) + when n1 == H.eq && n2 == H.eq && mod_eq -> + let c = compare_term ~mod_eq ty1 ty2 in + if c <> 0 then c + else + let ca1a2 = compare_term ~mod_eq a1 a2 in + let ca1b2 = compare_term ~mod_eq a1 b2 in + let cb1b2 = compare_term ~mod_eq b1 b2 in + let cb1a2 = compare_term ~mod_eq b1 a2 in + if ca1a2 = 0 && cb1b2 = 0 then 0 + else if ca1b2 = 0 && cb1a2 = 0 then 0 + else if ca1a2 <> 0 then ca1a2 else cb1b2 + | App (f1, l1), App (f2, l2) -> + let c = compare_term ~mod_eq f1 f2 in + if c <> 0 then c else + compare_term_list ~mod_eq l1 l2 + | App _, _ -> -1 | _, App _ -> 1 + + | Pi (s1, t1), Pi (s2, t2) -> + let c = compare_symbol s1 s2 in + if c <> 0 then c + else compare_term ~mod_eq t1 t2 + | Pi _, _ -> -1 | _, Pi _ -> 1 + + | Lambda (s1, t1), Lambda (s2, t2) -> + let c = compare_symbol s1 s2 in + if c <> 0 then c + else compare_term ~mod_eq t1 t2 + | Lambda _, _ -> -1 | _, Lambda _ -> 1 + + (* ignore side conditions *) + | SideCond (_, _, _, t), _ -> compare_term ~mod_eq t t2 + | _, SideCond (_, _, _, t) -> compare_term ~mod_eq t1 t + + | Hole i1, Hole i2 -> Pervasives.compare i1 i2 + + +and compare_term_list ?(mod_eq=false) l1 l2 = match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | t1 :: r1, t2 :: r2 -> + let c = compare_term ~mod_eq t1 t2 in + if c <> 0 then c + else compare_term_list ~mod_eq r1 r2 + + +let rec hash_term t = match t.value with + | Ptr t -> hash_term t + | v -> Hashtbl.hash_param 100 500 v + + +module Term = struct + type t = term + let compare = compare_term ~mod_eq:false + let equal x y = compare_term x y = 0 + let hash t = Hashtbl.hash_param 10 100 t.value (* hash_term *) + (* let hasht = Hashtbl.hash *) + (* let rec hash = *) + (* let cpt = ref 0 in *) + (* fun hh t -> *) + (* incr cpt; *) + (* if !cpt > 10 then hh else *) + (* hh + *) + (* let v = t.value in *) + (* match v with *) + (* | Hole _ | Type | Kind | Mpz | Mpq | Int _ | Rat _ | Const _ -> hasht v *) + (* | SideCond (_, args, exp, t) -> *) + (* List.fold_left (fun acc t -> hash hh t + 31*acc) (hash hh t) args *) + (* | App (f, args) -> *) + (* List.fold_left (fun acc t -> hash hh t + 31*acc) (hash hh f) args *) + (* | Pi (s, x) -> ((Hashtbl.hash s) + 31*(hash hh x)) * 7 *) + (* | Lambda (s, x) -> ((Hashtbl.hash s) + 31*(hash hh x)) * 9 *) + (* | Ptr t' -> 0 *) + (* (\* t.value <- t'.value; *\) *) + (* (\* hash hh (deref t') *\) *) + (* let hash = hash 0 *) +end + + + + +let rec holes_address acc t = match t.value with + | Hole i -> (i, t) :: acc + | Type | Kind | Mpz | Mpq | Int _ | Rat _ -> acc + | SideCond (name, args, exp, t) -> acc + | Const _ -> acc + | App (f, args) -> + List.fold_left holes_address acc args + | Pi (s, x) -> holes_address acc x + | Lambda (s, x) -> holes_address acc x + | Ptr t -> holes_address acc t + +let holes_address = holes_address [] + + +let check_holes_integrity where h1 h2 = + List.iter (fun (i, a) -> + List.iter (fun (j, b) -> + if j = i && a != b then + ( + eprintf "\n%s: Hole _%d was at %nx, now at %nx\n@." where i + (address_of a) (address_of b); + (* eprintf "\n%s: Hole _%d has changed\n@." where i; *) + assert false) + ) h2 + ) h1 + +let check_term_integrity where t = + let h = holes_address t in + check_holes_integrity (where ^ "term has != _") h h + + + +let eq_name s1 s2 = match s1, s2 with + | S_Hole i1, S_Hole i2 -> i1 == i2 + | Name n1, Name n2 -> n1 == n2 + | _ -> false + +module HN = Hashtbl.Make (struct + type t = name + let equal = eq_name + let hash = function + | S_Hole i -> i * 7 + | Name n -> Hstring.hash n * 9 + end) + +let symbols = HN.create 21 +let register_symbol s = HN.add symbols s.sname s.stype +let remove_symbol s = HN.remove symbols s.sname + +let definitions = HN.create 21 +let add_definition n t = HN.add definitions n t +let remove_definition n = HN.remove definitions n + + +exception TypingError of term * term + + +(**************************) +(* Predefined terms/types *) +(**************************) + + +let rec kind = { value = Kind; ttype = kind } + +let lfsc_type = { value = Type; ttype = kind } + +let mpz = { value = Mpz; ttype = lfsc_type } + +let mpq = { value = Mpq; ttype = lfsc_type } + +let mk_mpz n = { value = Int n; ttype = mpz } + +let mpz_of_int n = { value = Int (Big_int.big_int_of_int n); ttype = mpz } + +let mk_mpq n = { value = Rat n; ttype = mpq } + + +let mk_symbol s stype = + { sname = Name (Hstring.make s) ; stype } + (* { sname = Name (String.concat "." (List.rev (n :: scope))) ; stype } *) + +let mk_symbol_hole = + let cpt = ref 0 in + fun stype -> + incr cpt; + { sname = S_Hole !cpt; stype } + +let is_hole = function { value = Hole _ } -> true | _ -> false + +let is_hole_symbol = function { sname = S_Hole _ } -> true | _ -> false + +let mk_hole = + let cpt = ref 0 in + fun ttype -> + incr cpt; + { value = Hole !cpt; ttype } + +(* let mk_rec_hole () = *) +(* let rec h = { value = Hole !cpt; ttype = h } in *) +(* h *) + +let mk_hole_hole () = + mk_hole (mk_hole lfsc_type) + + +(*****************************) +(* Side conditions callbacks *) +(*****************************) + +let callbacks_table = Hstring.H.create 7 + + +let mp_add x y = + (* eprintf "mp_add %a %a@." print_term x print_term y; *) + match value x, value y with + | Int xi, Int yi -> mk_mpz (Big_int.add_big_int xi yi) + | _ -> assert false + +let mp_mul x y = match value x, value y with + | Int xi, Int yi -> mk_mpz (Big_int.mult_big_int xi yi) + | _ -> assert false + +let uminus x = match value x with + | Int xi -> mk_mpz (Big_int.minus_big_int xi) + | _ -> assert false + + +let rec eval_arg x = match app_name x with + | Some (n, [x]) when n == H.uminus -> uminus (eval_arg x) + | Some (n, [x; y]) when n == H.mp_add -> mp_add (eval_arg x) (eval_arg y) + | Some (n, [x; y]) when n == H.mp_mul -> mp_mul (eval_arg x) (eval_arg y) + | _ -> x + + +let callback name l = + try + let f = Hstring.H.find callbacks_table name in + (* eprintf "apply %s ... @." name; *) + let l = List.map eval_arg l in + f l + with Not_found -> + failwith ("No side condition for " ^ Hstring.view name) + + + +(* type sc_check = String * term list * term *) + + +(* type sc_tree = *) +(* | SCEmpty *) +(* (\* | SCLeaf of sc_check *\) *) +(* | SCBranches of sc_check * sc_tree list *) + + +(* let sct = ref (SCEmpty) *) + + +let sc_to_check = ref [] + + + +(**********************************) +(* Smart constructors for the AST *) +(**********************************) + +module MSym = Map.Make (struct + type t = symbol + let compare = compare_symbol + end) + + +let empty_subst = MSym.empty + +let fresh_alpha = + let cpt = ref 0 in + fun ty -> incr cpt; + mk_symbol ("'a"^string_of_int !cpt) ty + + +let get_t ?(gen=true) sigma s = + try + let x = MSym.find s sigma in + if not gen && is_hole x then raise Not_found; + x + with Not_found -> try + HN.find definitions s.sname + with Not_found -> + { value = Const s; ttype = s.stype } + + +type substres = T of term | V of dterm | Same + + +let apply_subst_sym sigma s = + try + let x = MSym.find s sigma in + T x + with Not_found -> Same + (* try *) + (* T (Hashtbl.find definitions s) *) + (* with Not_found -> Same *) + + +let print_subst fmt sigma = + fprintf fmt "@[<v 1>["; + MSym.iter (fun s t -> + fprintf fmt "@ %a -> %a;" print_symbol s print_term t) sigma; + fprintf fmt " ]@]" + + +let rec apply_subst_val sigma tval = match tval with + | Type | Kind | Mpz | Mpq | Int _ | Rat _ | Hole _ -> Same + + (* | Ptr t -> *) + (* V (Ptr (apply_subst sigma t)) *) + (* | Ptr t -> apply_subst_val sigma t.value *) + + | Ptr t -> + T (apply_subst sigma t) + + | Const s when is_hole_symbol s -> Same (* raise Exit *) + | Const s -> apply_subst_sym sigma s + | App (f, args) -> + let nf = apply_subst sigma f in + let nargs = List.rev_map (apply_subst sigma) args |> List.rev in + if nf == f && List.for_all2 (==) nargs args then (* V tval *) Same + else + V (App(nf, nargs)) + + | Pi (s, x) -> + let s = { s with stype = apply_subst sigma s.stype } in + let sigma = MSym.remove s sigma in + let newx = apply_subst sigma x in + if x == newx then (* V tval *) Same + else + V (Pi (s, newx)) + + | Lambda (s, x) -> + let s = { s with stype = apply_subst sigma s.stype } in + let sigma = MSym.remove s sigma in + let newx = apply_subst sigma x in + if x == newx then (* V tval *) Same + else + V (Lambda (s, newx)) + + | SideCond (name, args, exp, t) -> + let nt = apply_subst sigma t in + let nexp = apply_subst sigma exp in + let nargs = List.rev_map (apply_subst sigma) args |> List.rev in + if nt == t && nexp == exp && List.for_all2 (==) nargs args then (* V tval *) Same + else + V (SideCond (name, nargs, nexp, nt)) + + + +and apply_subst sigma t = + match apply_subst_val sigma t.value with + | Same -> t + | T t -> t + | V value -> + let ttype = apply_subst sigma t.ttype in + if value == t.value && ttype == t.ttype then t + else { value; ttype } + + + +let get_real t = apply_subst MSym.empty t + + +let rec flatten_term_value t = match t.value with + | Hole _ | Type | Kind | Mpz | Mpq | Int _ | Rat _ -> () + | SideCond (_, args, exp, t) -> + List.iter flatten_term args; + flatten_term exp; + flatten_term t + | Const s -> flatten_term s.stype + | App (f, args) -> + flatten_term f; + List.iter flatten_term args + | Pi (s, x) | Lambda (s, x) -> + flatten_term s.stype; + flatten_term x + | Ptr t' -> + t.value <- (deref t').value + (* flatten_term t *) + + +and flatten_term t = + flatten_term_value t + (* ; *) + (* match t.value with *) + (* | Type | Kind -> () *) + (* | _ -> flatten_term t.ttype *) + + +let rec has_ptr_val t = match t.value with + | Hole _ | Type | Kind | Mpz | Mpq | Int _ | Rat _ -> false + | SideCond (_, args, exp, t) -> + List.exists has_ptr args || has_ptr exp || has_ptr t + | Const s -> has_ptr s.stype + | App (f, args) -> has_ptr f || List.exists has_ptr args + | Pi (s, x) | Lambda (s, x) -> has_ptr s.stype || has_ptr x + | Ptr _ -> true + +and has_ptr t = + has_ptr_val t || + match t.value with + | Type | Kind -> false + | _ -> has_ptr t.ttype + + +let add_subst x v sigma = MSym.add x v sigma + (* let sigma = List.rev_map (fun (y, w) -> y, apply_subst [x,v] w) sigma |> List.rev in *) + (* (x, apply_subst sigma v) :: sigma *) + + + +let rec occur_check subt t = + compare_term t subt = 0 + || + match t.value with + | Type | Kind | Mpz | Mpq | Int _ | Rat _ | Hole _ | Const _ -> false + + | Ptr t -> occur_check subt t + + | App (f, args) -> + occur_check subt f || + List.exists (occur_check subt) args + + | Pi (s, x) -> occur_check subt x + + | Lambda (s, x) -> occur_check subt x + + | SideCond (name, args, exp, t) -> + occur_check subt exp || + occur_check subt t || + List.exists (occur_check subt) args + + + + +let rec fill_hole sigma h t = + match h.value with + | Hole _ -> + if debug then + eprintf ">>>>> Fill hole @[%a@] with @[%a@]@." + print_term h print_term t; + let t' = apply_subst sigma t in + (* h.value <- t'.value; (\* KLUDGE *\) *) + if not (occur_check h t') then h.value <- Ptr (deref t'); + if debug then + eprintf ">>>>>>>>> @[%a@]@." print_term_type h; + fill_hole sigma h.ttype t'.ttype; + (* (try compat_with sigma t'.ttype h.ttype with _ -> ()); *) + | _ -> () + + + + +(* Raise TypingError if t2 is not compatible with t1 *) +(* apsub is false if we want to prevent application of substitutions *) +and compat_with1 ?(apsub=true) sigma t1 t2 = + if debug then ( + eprintf "compat_with(%b): @[<hov>%a@] and @[<hov>%a@]@." + apsub print_term t1 print_term t2; + eprintf " with sigma = %a@." print_subst sigma + ); + + match t1.value, t2.value with + | Type, Type + | Kind, Kind + | Mpz, Mpz + | Mpq, Mpz -> () + + | Int z1, Int z2 -> if not (Big_int.eq_big_int z1 z2) then raise Exit + | Rat q1, Rat q2 -> if not (Num.eq_num q1 q2) then raise Exit + + | Ptr t, _ -> compat_with1 ~apsub sigma t t2 + | _, Ptr t -> compat_with1 ~apsub sigma t1 t + + | Const s1, Const s2 -> + if apsub then + let a2 = get_t sigma s2 in + let a1 = get_t ~gen:(not (is_hole a2)) sigma s1 in + compat_with1 sigma ~apsub:false a1 a2 + else + if not (eq_name s1.sname s2.sname) then raise Exit + + | App (f1, args1), App (f2, args2) -> + compat_with1 sigma f1 f2; + List.iter2 (compat_with sigma) args1 args2 + + | Pi (s1, t1), Pi (s2, t2) -> + compat_with1 sigma s1.stype s2.stype; + let a = s2 in + let ta = { value = Const a; ttype = a.stype } in + compat_with1 (add_subst s1 ta sigma) t1 t2; + + | Lambda (s1, t1), Lambda (s2, t2) -> + compat_with sigma s1.stype s2.stype; + let a = s2 in + let ta = { value = Const a; ttype = a.stype } in + compat_with1 (add_subst s1 ta sigma) t1 t2; + + + | SideCond (name, args, expected, t1), _ -> + check_side_condition name + (List.rev_map (apply_subst sigma) args |> List.rev) + (apply_subst sigma expected); + compat_with1 sigma t1 t2 + + (* ignore side conditions on the right *) + | _, SideCond (name, args, expected, t2) -> + compat_with1 sigma t1 t2 + + | Hole i, Hole j when i = j -> () + (* failwith ("Cannot infer type of holes, too many holes.") *) + + | _, Hole _ -> fill_hole sigma t2 t1 + | Hole _, _ -> fill_hole sigma t1 t2 + + + | Const s, _ -> + if apsub then + let a = get_t sigma s in + compat_with1 sigma ~apsub:false a t2 + else + raise Exit + + | _, Const s -> + if apsub then + let a = get_t sigma s in + compat_with1 sigma ~apsub:false a t1 + else + raise Exit + + | _ -> raise Exit + + +and compat_with sigma t1 t2 = + try compat_with1 sigma t1 t2 + with Exit -> + raise (TypingError (apply_subst sigma t1, apply_subst sigma t2)) + + + +and term_equal t1 t2 = + try + compat_with empty_subst t1 t2; + true + with + | TypingError _ | Failure _ -> false + + + +and check_side_condition name l expected = + if debug then + eprintf "Adding side condition : (%a%a) =?= %a@." + Hstring.print name + (fun fmt -> List.iter (fprintf fmt "@ %a" print_term)) l + print_term expected; + (* if not (term_equal (callback name l) expected) then *) + (* failwith ("Side condition " ^ name ^ " failed"); *) + sc_to_check := (name, l, expected) :: !sc_to_check + + + +let rec ty_of_app sigma ty args = match ty.value, args with + | Pi (s, t), a :: rargs -> + let sigma = add_subst s a sigma in + compat_with sigma s.stype a.ttype; + ty_of_app sigma t rargs + + | SideCond (name, scargs, expected, t), args -> + check_side_condition name + (List.rev_map (apply_subst sigma) scargs |> List.rev) + (apply_subst sigma expected); + ty_of_app sigma t args + + | _, [] -> apply_subst sigma ty + | _ -> failwith ("Type of function not a pi-type.") + + +let mk_const x = + if debug then eprintf "mk_const %s@." x; + try + let stype = HN.find symbols (Name (Hstring.make x)) in + let s = mk_symbol x stype in + try + HN.find definitions s.sname + with Not_found -> { value = Const s; ttype = stype } + with Not_found -> failwith ("Symbol " ^ x ^ " is not declared.") + + +let symbol_to_const s = { value = Const s; ttype = s.stype } + + +let rec mk_app ?(lookup=true) sigma f args = + if debug then + eprintf "mk_App : %a@." (print_tval false) + { value = App (f, args); ttype = lfsc_type } ; + + match f.value, args with + | Lambda (x, r), a :: rargs -> + let sigma = MSym.remove x sigma in + mk_app (add_subst x a sigma) r rargs + + (* | Const {sname = Name "mp_add"}, [x; y] -> mp_add x y *) + + (* | Const {sname = Name "mp_mul"}, [x; y] -> mp_mul x y *) + + | Const s, _ when lookup -> + (* find the definition if it has one *) + let f = get_t sigma s in + mk_app ~lookup:false sigma f args + + | x, [] -> + (* Delayed beta-reduction *) + apply_subst sigma f + + | _ -> + (* TODO: check if empty_subst or sigma *) + { value = App (f, args); ttype = ty_of_app empty_subst f.ttype args } + + +let mk_app = mk_app empty_subst + + +let rec hole_nbs acc t = match value t with + | Hole nb -> nb :: acc + | App (f, args) -> List.fold_left hole_nbs (hole_nbs acc f) args + | Pi (s, x) | Lambda (s, x) -> hole_nbs acc x + | Ptr t -> hole_nbs acc t + | _ -> acc + + +let rec min_hole acc t = match value t with + | Hole nb -> + (match acc with Some n when nb < n -> Some nb | None -> Some nb | _ -> acc) + | App (f, args) -> List.fold_left min_hole (min_hole acc f) args + | Pi (s, x) | Lambda (s, x) -> min_hole acc x + | Ptr t -> min_hole acc t + | _ -> acc + + +let compare_int_opt m1 m2 = match m1, m2 with + | None, None -> 0 + | Some _, None -> -1 + | None, Some _ -> 1 + | Some n1, Some n2 -> compare n1 n2 + + +let compare_sc_checks (_, args1, exp1) (_, args2, exp2) = + let el1 = hole_nbs [] exp1 in + let el2 = hole_nbs [] exp2 in + + let al1 = List.fold_left hole_nbs [] args1 in + let al2 = List.fold_left hole_nbs [] args2 in + + if List.exists (fun n -> List.mem n al1) el2 then 1 + else if List.exists (fun n -> List.mem n al2) el1 then -1 + else if el1 = [] then 1 + else if el2 = [] then -1 + else compare el1 el2 + + +let sort_sc_checks l = List.fast_sort compare_sc_checks l + + +let run_side_conditions () = + (* List.iter (fun (name, l, expected) -> *) + (* eprintf "\nSorted side condition : (%s%a) =?= %a@." *) + (* name *) + (* (fun fmt -> List.iter (fprintf fmt "@ %a" print_term)) l *) + (* print_term expected; *) + (* ) (List.flatten !all_scs |> sort_sc_checks); *) + + List.iter (fun (name, l, expected) -> + let res = callback name l in + if not (term_equal res expected) then + failwith (asprintf "Side condition %a failed: Got %a, expected %a" + Hstring.print name print_term res print_term expected); + ) (sort_sc_checks !sc_to_check); + sc_to_check := []; + () + + +let mk_pi s t = + (* let s = if is_hole_symbol s then fresh_alpha s.stype else s in *) + { value = Pi (s, t); ttype = lfsc_type } + +let mk_lambda s t = + (* sc_to_check := List.rev !sc_to_check; *) + (* run_side_conditions (); *) + (* let s = if is_hole_symbol s then fresh_alpha s.stype else s in *) + { value = Lambda (s, t); + ttype = mk_pi s t.ttype } + + +let mk_ascr ty t = + if debug then + eprintf "\nMK ASCR:: should have type %a, has type %a\n@." + print_term ty print_term t.ttype; + compat_with empty_subst ty t.ttype; t + (* { t with ttype = ty } *) + + +let add_sc name args expected t = + { value = SideCond (Hstring.make name, args, expected, t); + ttype = t.ttype } + + +let mk_declare n ty = + let s = mk_symbol n ty in + register_symbol s + +let mk_define n t = + let s = mk_symbol n t.ttype in + register_symbol s; + add_definition s.sname t + + + +let mk_check t = run_side_conditions () + + +let clear_sc () = sc_to_check := [] + + + +let rec hash_term_mod_eq p = match p.value with + | App ({value=Const{sname=Name n}} as f, [ty; a; b]) + when n == H.eq && + compare_term ~mod_eq:true a b > 0 -> + Term.hash (mk_app f [ty; b; a]) + | App (f, args) -> + List.fold_left + (fun acc t -> 7*(acc + hash_term_mod_eq f)) 1 (f:: args) + | Pi (s, x) -> + (Hashtbl.hash_param 100 500 s + hash_term_mod_eq x) * 11 + | Lambda (s, x) -> + (Hashtbl.hash_param 100 500 s + hash_term_mod_eq x) * 13 + | _ -> Hashtbl.hash_param 100 500 p + + +module Term_modeq = struct + type t = term + let compare = compare_term ~mod_eq:true + let equal x y = compare_term ~mod_eq:true x y = 0 + let hash t = + (* eprintf "HASH: %a@." print_term t; *) + hash_term_mod_eq t +end + + +(* + Local Variables: + compile-command: "make" + indent-tabs-mode: nil + End: +*) diff --git a/src/lfsc/ast.mli b/src/lfsc/ast.mli new file mode 100644 index 0000000..0e5d5bf --- /dev/null +++ b/src/lfsc/ast.mli @@ -0,0 +1,239 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(** Construction and internal representation of LFSC proofs and rules with type + checking. +*) + +exception CVC4Sat + +(** {2 Structures for LFSC proofs, terms and types } *) + + +(** Implementation of the LFSC type [mpz] for integers. *) +type mpz = Big_int.big_int + +(** Implementation of the LFSC type [mpq] for rationnals. *) +type mpq = Num.num + + +type name = Name of Hstring.t | S_Hole of int + +(** Type of symbols used in lambda/pi abstractions. *) +type symbol = { sname : name; stype : term } + +(** Types of terms *) +and dterm = + | Type (** The type [type] *) + | Kind (** The type [kind] *) + | Mpz (** The type [mpz] *) + | Mpq (** The type [mpq] *) + | Const of symbol (** Constants *) + | App of term * term list (** Functions *) + | Int of mpz (** Integers *) + | Rat of mpq (** Rationals *) + | Pi of symbol * term (** Pi-abstractions *) + | Lambda of symbol * term (** Lambda-abstractions *) + | Hole of int (** Hole/Variable (to be filled) *) + | Ptr of term (** Pointer to another term (used to fill holes + and keep physical equality). Pointers can be + removed with {!flatten}. *) + | SideCond of Hstring.t * term list * term * term + (** Side conditions. The last argument is the term + to which the side-condition expression + evaluates. *) + +(** LFSC terms and types (same thing). Terms are annotated with their types. *) +and term = { mutable value: dterm; ttype: term } + +(** Equality over terms (performs unification). To compare terms for equality + use [compare_tem t1 t2 = 0] instead. *) +val term_equal : term -> term -> bool + +(** Comparision between terms *) +val compare_term : ?mod_eq:bool -> term -> term -> int +val compare_term_list : ?mod_eq:bool -> term list -> term list -> int + +val hash_term : term -> int + +(** The type of LFSC top-level commands *) +type command = + | Check of term + | Define of Hstring.t * term + | Declare of Hstring.t * term + +(** The type of LFSC proofs *) +type proof = command list + + +(** Term module to build structures over terms. *) +module Term : sig + type t = term + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + +module Term_modeq : sig + type t = term + val compare : t -> t -> int + val equal : t -> t -> bool + val hash : t -> int +end + + +(** {2 Pretty printing } *) + +val print_term : Format.formatter -> term -> unit + +val print_term_type : Format.formatter -> term -> unit + +val print_symbol : Format.formatter -> symbol -> unit + +val print_command : Format.formatter -> command -> unit + +val print_proof : Format.formatter -> proof -> unit + + +(** {2 Predefined LFSC types } *) + +(** The LFSC type [type]. *) +val lfsc_type : term + +(** The LFSC type [kind] (of type [type]). *) +val kind : term + +(** The LFSC type [mpz]. *) +val mpz : term + +(** The LFSC type [mpq]. *) +val mpq : term + +(** Constructor for LFSC integers. *) +val mk_mpz : mpz -> term + +val mpz_of_int : int -> term + +(** Constructor for LFSC rationals. *) +val mk_mpq : mpq -> term + + + +(** {2 Utilities functions } *) + +(* val unify : term -> term -> unit *) + +(** @deprecated *) +val get_real : term -> term + +(** Remove pointers in term and type *) +val flatten_term : term -> unit + +(** Returs [true] if the term contains pointers.*) +val has_ptr : term -> bool + + +(** follow pointers *) +val deref : term -> term + +(** derefenced value *) +val value : term -> dterm + +(** derefenced type *) +val ttype : term -> term + +(** get dereferenced constant name (None if it's not a constant or it has no + name) *) +val name : term -> Hstring.t option + +(** get dereferenced application name and its arguments (None if it's not a + function application or the function symbol has no name) *) +val app_name : term -> (Hstring.t * term list) option + + + +(** {2 Smart constructors with type checking and unification } *) + + +(** Exception raised when the proof does not type check. *) +exception TypingError of term * term + +(** Constructor for symbols, given their name and their type. *) +val mk_symbol : string -> term -> symbol + +(** Create a hole symbol to be filled later on. *) +val mk_symbol_hole : term -> symbol + +(** Create a constant term of a predeclared name. *) +val mk_const : string -> term + +(** Create a constant term from a symbol. *) +val symbol_to_const : symbol -> term + +(** Constructor for function application. This performs type inference and + destructive unfification of type variables (holes), as well as + beta-reduction. *) +val mk_app : term -> term list -> term + +(** Constructor for a (fresh) unspecified hole term (i.e. a variable) given its + type. *) +val mk_hole : term -> term + +(** Create and unspecified term of unspecified type. *) +val mk_hole_hole : unit -> term + +(** Create a pi-abstraction. [mk_pi s t] returns Πs : s.stype. t. *) +val mk_pi : symbol -> term -> term + +(** Create a lambda-abstraction. [mk_lambda s t] returns λ s : s.stype. t. *) +val mk_lambda : symbol -> term -> term + +(** Ascription, or type check. [mk_ascr ty t] checks that t has type ty, while + performing all type checking operations decribed in {!mk_app}. *) +val mk_ascr : term -> term -> term + + +(** [mk_declare s ty] registers declaration of symbol [s] as having type + [ty]. *) +val mk_declare : string -> term -> unit + + +(** [mk_define s t] registers [s] to be a definition for the term [t]. It is + inlined in the subsequent terms. *) +val mk_define : string -> term -> unit + +(** Create a check command. *) +val mk_check : term -> unit + + +(** {2 Auxiliary functions} *) + +val register_symbol : symbol -> unit + +val remove_symbol : symbol -> unit + +val add_definition : name -> term -> unit + +val remove_definition : name -> unit + + +(** {2 Side-conditions} *) + +(** Table for callback functions of side conditions. *) +val callbacks_table : (term list -> term) Hstring.H.t + +(** Add a side-condition to the callback table, and returns the continuation of + the side condition in LFSC terms. See {!Builtin}. *) +val add_sc : string -> term list -> term -> term -> term + +(** Remove pending side-conditions evaluations *) +val clear_sc : unit -> unit diff --git a/src/lfsc/builtin.ml b/src/lfsc/builtin.ml new file mode 100644 index 0000000..7d0151b --- /dev/null +++ b/src/lfsc/builtin.ml @@ -0,0 +1,1313 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Ast +open Format + + +module H = struct + let mp_add = Hstring.make "mp_add" + let mp_mul = Hstring.make "mp_mul" + let mp_is_neg = Hstring.make "mp_is_neg" + let mp_is_zero = Hstring.make "mp_is_zero" + + let uminus = Hstring.make "~" + + let bool_lfsc = Hstring.make "bool_lfsc" + let tt = Hstring.make "tt" + let ff = Hstring.make "ff" + + let var = Hstring.make "var" + let lit = Hstring.make "lit" + let clause = Hstring.make "clause" + let cln = Hstring.make "cln" + + let okay = Hstring.make "okay" + let ok = Hstring.make "ok" + + let pos = Hstring.make "pos" + let neg = Hstring.make "neg" + let clc = Hstring.make "clc" + + let concat_cl = Hstring.make "concat_cl" + + let clr = Hstring.make "clr" + + let formula = Hstring.make "formula" + + + let not_ = Hstring.make "not" + let and_ = Hstring.make "and" + let or_ = Hstring.make "or" + let impl_ = Hstring.make "impl" + let iff_ = Hstring.make "iff" + let xor_ = Hstring.make "xor" + let ifte_ = Hstring.make "ifte" + + let ite = Hstring.make "ite" + let iff = Hstring.make "iff" + let flet = Hstring.make "flet" + let impl = Hstring.make "impl" + let gt_Int = Hstring.make ">_Int" + let ge_Int = Hstring.make ">=_Int" + let lt_Int = Hstring.make "<_Int" + let le_Int = Hstring.make "<=_Int" + let plus_Int = Hstring.make "+_Int" + let minus_Int = Hstring.make "-_Int" + let times_Int = Hstring.make "*_Int" + let div_Int = Hstring.make "/_Int" + let uminus_Int = Hstring.make "u-_Int" + + let sort = Hstring.make "sort" + let term = Hstring.make "term" + let tBool = Hstring.make "Bool" + let p_app = Hstring.make "p_app" + let arrow = Hstring.make "arrow" + let apply = Hstring.make "apply" + + let bitVec = Hstring.make "BitVec" + + let bit = Hstring.make "bit" + let b0 = Hstring.make "b0" + let b1 = Hstring.make "b1" + + let bv = Hstring.make "bv" + let bvn = Hstring.make "bvn" + let bvc = Hstring.make "bvc" + + let bblt = Hstring.make "bblt" + let bbltn = Hstring.make "bbltn" + let bbltc = Hstring.make "bbltc" + + let var_bv = Hstring.make "var_bv" + + let a_var_bv = Hstring.make "a_var_bv" + let a_bv = Hstring.make "a_bv" + let a_int = Hstring.make "a_int" + + + let bitof = Hstring.make "bitof" + let bblast_term = Hstring.make "bblast_term" + + let eq = Hstring.make "=" + let bvand = Hstring.make "bvand" + let bvor = Hstring.make "bvor" + let bvxor = Hstring.make "bvxor" + let bvnand = Hstring.make "bvnand" + let bvnor = Hstring.make "bvnor" + let bvxnor = Hstring.make "bvxnor" + let bvmul = Hstring.make "bvmul" + let bvadd = Hstring.make "bvadd" + let bvsub = Hstring.make "bvsub" + let bvudiv = Hstring.make "bvudiv" + let bvurem = Hstring.make "bvurem" + let bvsdiv = Hstring.make "bvsdiv" + let bvsrem = Hstring.make "bvsrem" + let bvsmod = Hstring.make "bvsmod" + let bvshl = Hstring.make "bvshl" + let bvlshr = Hstring.make "bvlshr" + let bvashr = Hstring.make "bvashr" + + + let bvnot = Hstring.make "bvnot" + let bvneg = Hstring.make "bvneg" + let bvult = Hstring.make "bvult" + let bvslt = Hstring.make "bvslt" + let bvule = Hstring.make "bvule" + let bvsle = Hstring.make "bvsle" + let concat = Hstring.make "concat" + let extract = Hstring.make "extract" + let zero_extend = Hstring.make "zero_extend" + let sign_extend = Hstring.make "sign_extend" + let array = Hstring.make "Array" + let read = Hstring.make "read" + let write = Hstring.make "write" + + let diff = Hstring.make "diff" + + let append = Hstring.make "append" + let simplify_clause = Hstring.make "simplify_clause" + let bv_constants_are_disequal = Hstring.make "bv_constants_are_disequal" + let bblt_len = Hstring.make "bblt_len" + let bblast_const = Hstring.make "bblast_const" + let bblast_var = Hstring.make "bblast_var" + let bblast_concat = Hstring.make "bblast_concat" + let bblast_extract = Hstring.make "bblast_extract" + let bblast_zextend = Hstring.make "bblast_zextend" + let bblast_sextend = Hstring.make "bblast_sextend" + let bblast_bvand = Hstring.make "bblast_bvand" + let bblast_bvnot = Hstring.make "bblast_bvnot" + let bblast_bvor = Hstring.make "bblast_bvor" + let bblast_bvxor = Hstring.make "bblast_bvxor" + let bblast_bvadd = Hstring.make "bblast_bvadd" + let bblast_zero = Hstring.make "bblast_zero" + let bblast_bvneg = Hstring.make "bblast_bvneg" + let bblast_bvmul = Hstring.make "bblast_bvmul" + let bblast_eq = Hstring.make "bblast_eq" + let bblast_bvult = Hstring.make "bblast_bvult" + let bblast_bvslt = Hstring.make "bblast_bvslt" + + + let th_let_pf = Hstring.make "th_let_pf" + let th_holds = Hstring.make "th_holds" + let ttrue = Hstring.make "true" + let tfalse = Hstring.make "false" + let a_var_bv = Hstring.make "a_var_bv" + let eq = Hstring.make "=" + let trust_f = Hstring.make "trust_f" + let ext = Hstring.make "ext" + let decl_atom = Hstring.make "decl_atom" + let asf = Hstring.make "asf" + let ast = Hstring.make "ast" + let cong = Hstring.make "cong" + let symm = Hstring.make "symm" + let negsymm = Hstring.make "negsymm" + let trans = Hstring.make "trans" + let negtrans = Hstring.make "negtrans" + let negtrans1 = Hstring.make "negtrans1" + let negtrans2 = Hstring.make "negtrans2" + let refl = Hstring.make "refl" + let or_elim_1 = Hstring.make "or_elim_1" + let or_elim_2 = Hstring.make "or_elim_2" + let iff_elim_1 = Hstring.make "iff_elim_1" + let iff_elim_2 = Hstring.make "iff_elim_2" + let impl_elim = Hstring.make "impl_elim" + let not_and_elim = Hstring.make "not_and_elim" + let xor_elim_1 = Hstring.make "xor_elim_1" + let xor_elim_2 = Hstring.make "xor_elim_2" + let ite_elim_1 = Hstring.make "ite_elim_1" + let ite_elim_2 = Hstring.make "ite_elim_2" + let ite_elim_3 = Hstring.make "ite_elim_3" + let not_ite_elim_1 = Hstring.make "not_ite_elim_1" + let not_ite_elim_2 = Hstring.make "not_ite_elim_2" + let not_ite_elim_3 = Hstring.make "not_ite_elim_3" + let not_iff_elim = Hstring.make "not_iff_elim" + let not_xor_elim = Hstring.make "not_xor_elim" + let iff_elim_2 = Hstring.make "iff_elim_2" + let and_elim_1 = Hstring.make "and_elim_1" + let not_impl_elim = Hstring.make "not_impl_elim" + let not_or_elim = Hstring.make "not_or_elim" + let and_elim_2 = Hstring.make "and_elim_2" + let not_not_elim = Hstring.make "not_not_elim" + let not_not_intro = Hstring.make "not_not_intro" + let pred_eq_t = Hstring.make "pred_eq_t" + let pred_eq_f = Hstring.make "pred_eq_f" + let trust_f = Hstring.make "trust_f" + + let tInt = Hstring.make "Int" + let eq_transitive = Hstring.make "eq_transitive" + let row1 = Hstring.make "row1" + let row = Hstring.make "row" + let negativerow = Hstring.make "negativerow" + let bv_disequal_constants = Hstring.make "bv_disequal_constants" + let truth = Hstring.make "truth" + let holds = Hstring.make "holds" + let q = Hstring.make "Q" + let r = Hstring.make "R" + let satlem_simplify = Hstring.make "satlem_simplify" + let intro_assump_f = Hstring.make "intro_assump_f" + let intro_assump_t = Hstring.make "intro_assump_t" + let clausify_false = Hstring.make "clausify_false" + let trust = Hstring.make "trust" + let contra = Hstring.make "contra" + let bb_cl = Hstring.make "bb.cl" + + let satlem = Hstring.make "satlem" + + let bv_bbl_var = Hstring.make "bv_bbl_var" + let bv_bbl_const = Hstring.make "bv_bbl_const" + let bv_bbl_bvand = Hstring.make "bv_bbl_bvand" + let bv_bbl_bvor = Hstring.make "bv_bbl_bvor" + let bv_bbl_bvxor = Hstring.make "bv_bbl_bvxor" + let bv_bbl_bvnot = Hstring.make "bv_bbl_bvnot" + let bv_bbl_bvneg = Hstring.make "bv_bbl_bvneg" + let bv_bbl_bvadd = Hstring.make "bv_bbl_bvadd" + let bv_bbl_bvmul = Hstring.make "bv_bbl_bvmul" + let bv_bbl_bvult = Hstring.make "bv_bbl_bvult" + let bv_bbl_bvslt = Hstring.make "bv_bbl_bvslt" + let bv_bbl_concat = Hstring.make "bv_bbl_concat" + let bv_bbl_extract = Hstring.make "bv_bbl_extract" + let bv_bbl_zero_extend = Hstring.make "bv_bbl_zero_extend" + let bv_bbl_sign_extend = Hstring.make "bv_bbl_sign_extend" + + let decl_bblast = Hstring.make "decl_bblast" + let decl_bblast_with_alias = Hstring.make "decl_bblast_with_alias" + let bv_bbl_eq = Hstring.make "bv_bbl_=" + let bv_bbl_eq_swap = Hstring.make "bv_bbl_=_swap" + let bv_bbl_bvult = Hstring.make "bv_bbl_bvult" + let bv_bbl_bvslt = Hstring.make "bv_bbl_bvslt" + + +end + +let scope = ref [] + + +let declare_get s = + scope := [s]; + fun ty -> + mk_declare s ty; + let c = mk_const s in + scope := []; + c + + +let define s = + scope := [s]; + fun t -> + mk_define s t; + scope := [] + + +let pi n ty = + let n = String.concat "." (List.rev (n :: !scope)) in + let s = mk_symbol n ty in + register_symbol s; + fun t -> + let pi_abstr = mk_pi s t in + remove_symbol s; + pi_abstr + + +let pi_d n ty ft = + let n = String.concat "." (List.rev (n :: !scope)) in + let s = mk_symbol n ty in + register_symbol s; + let pi_abstr = mk_pi s (ft (symbol_to_const s)) in + remove_symbol s; + pi_abstr + + +let mp_add_s = declare_get "mp_add" (pi "a" mpz (pi "b" mpz mpz)) +let mp_add x y = match value x, value y with + | Int xi, Int yi -> mk_mpz (Big_int.add_big_int xi yi) + | _ -> mk_app mp_add_s [x; y] + +let mp_mul_s = declare_get "mp_mul" (pi "a" mpz (pi "b" mpz mpz)) +let mp_mul x y = match value x, value y with + | Int xi, Int yi -> mk_mpz (Big_int.mult_big_int xi yi) + | _ -> mk_app mp_add_s [x; y] + + + +let rec eval_arg x = match app_name x with + | Some (n, [x; y]) when n == H.mp_add -> mp_add (eval_arg x) (eval_arg y) + | Some (n, [x; y]) when n == H.mp_mul -> mp_mul (eval_arg x) (eval_arg y) + | _ -> x + + +let mp_isneg x = + (* eprintf "mp_isneg %a .@." print_term x; *) + match value x with + | Int n -> Big_int.sign_big_int n < 0 + | _ -> failwith ("mp_isneg") + +let mp_iszero x = match value x with + | Int n -> Big_int.sign_big_int n = 0 + | _ -> failwith ("mp_iszero") + + +let uminus = declare_get "~" (pi "a" mpz mpz) + +let bool_lfsc = declare_get "bool_lfsc" lfsc_type +let tt = declare_get "tt" bool_lfsc +let ff = declare_get "ff" bool_lfsc + +let var = declare_get "var" lfsc_type +let lit = declare_get "lit" lfsc_type +let clause = declare_get "clause" lfsc_type +let cln = declare_get "cln" clause + +let okay = declare_get "okay" lfsc_type +let ok = declare_get "ok" okay + +let pos_s = declare_get "pos" (pi "x" var lit) +let neg_s = declare_get "neg" (pi "x" var lit) +let clc_s = declare_get "clc" (pi "x" lit (pi "c" clause clause)) + +let concat_cl_s = declare_get "concat_cl" + (pi "c1" clause (pi "c2" clause clause)) + +let clr_s = declare_get "clr" (pi "l" lit (pi "c" clause clause)) + +let formula = declare_get "formula" lfsc_type +let th_holds_s = declare_get "th_holds" (pi "f" formula lfsc_type) + +let th_holds f = mk_app th_holds_s [f] + +let ttrue = declare_get "true" formula +let tfalse = declare_get "false" formula + +(* some definitions *) +let _ = + define "formula_op1" (pi "f" formula formula); + define "formula_op2" + (pi "f1" formula + (pi "f2" formula formula)); + define "formula_op3" + (pi "f1" formula + (pi "f2" formula + (pi "f3" formula formula))) + +let not_s = declare_get "not" (mk_const "formula_op1") +let and_s = declare_get "and" (mk_const "formula_op2") +let or_s = declare_get "or" (mk_const "formula_op2") +let impl_s = declare_get "impl" (mk_const "formula_op2") +let iff_s = declare_get "iff" (mk_const "formula_op2") +let xor_s = declare_get "xor" (mk_const "formula_op2") +let ifte_s = declare_get "ifte" (mk_const "formula_op3") + + +let sort = declare_get "sort" lfsc_type +let term_s = declare_get "term" (pi "t" sort lfsc_type) +let term x = mk_app term_s [x] +let tBool = declare_get "Bool" sort +let p_app_s = declare_get "p_app" (pi "x" (term tBool) formula) +let p_app b = mk_app p_app_s [b] +let arrow_s = declare_get "arrow" (pi "s1" sort (pi "s2" sort sort)) +let arrow s1 s2 = mk_app arrow_s [s1; s2] +let apply_s = declare_get "apply" + (pi_d "s1" sort (fun s1 -> + (pi_d "s2" sort (fun s2 -> + (pi "t1" (term (arrow s1 s2)) + (pi "t2" (term s1) + (term s2))))))) +let apply s1 s2 f x = mk_app apply_s [s1; s2; f; x] + + +let eq_s = declare_get "=" + (pi_d "s" sort (fun s -> + (pi "x" (term s) + (pi "y" (term s) formula)))) + +let eq ty x y = mk_app eq_s [ty; x; y] + +let pos v = mk_app pos_s [v] +let neg v = mk_app neg_s [v] +let clc x c = mk_app clc_s [x; c] +let clr l c = mk_app clr_s [l; c] +let concat_cl c1 c2 = mk_app concat_cl_s [c1; c2] + + +let not_ a = mk_app not_s [a] +let and_ a b = mk_app and_s [a; b] +let or_ a b = mk_app or_s [a; b] +let impl_ a b = mk_app impl_s [a; b] +let iff_ a b = mk_app iff_s [a; b] +let xor_ a b = mk_app xor_s [a; b] +let ifte_ a b c = mk_app ifte_s [a; b; c] + +(* Bit vector syntax / symbols *) + +let bitVec_s = declare_get "BitVec" (pi "n" mpz sort) +let bitVec n = mk_app bitVec_s [n] + +let bit = declare_get "bit" lfsc_type +let b0 = declare_get "b0" bit +let b1 = declare_get "b1" bit + +let bv = declare_get "bv" lfsc_type +let bvn = declare_get "bvn" bv +let bvc_s = declare_get "bvc" (pi "b" bit (pi "v" bv bv)) +let bvc b v = mk_app bvc_s [b; v] + + +let bblt = declare_get "bblt" lfsc_type +let bbltn = declare_get "bbltn" bblt +let bbltc_s = declare_get "bbltc" (pi "f" formula (pi "v" bblt bblt)) +let bbltc f v = mk_app bbltc_s [f; v] + +let var_bv = declare_get "var_bv" lfsc_type + +let a_var_bv_s = declare_get "a_var_bv" + (pi_d "n" mpz (fun n -> + (pi "v" var_bv (term (bitVec n))))) +let a_var_bv n v = mk_app a_var_bv_s [n; v] + +let a_bv_s = declare_get "a_bv" + (pi_d "n" mpz (fun n -> + (pi "v" bv (term (bitVec n))))) +let a_bv n v = mk_app a_bv_s [n; v] + + + +let bitof_s = declare_get "bitof" (pi "x" var_bv (pi "n" mpz formula)) +let bitof x n = mk_app bitof_s [x; n] + +let bblast_term_s = declare_get "bblast_term" + (pi_d "n" mpz (fun n -> + (pi "x" (term (bitVec n)) + (pi "y" bblt lfsc_type)))) +let bblast_term n x y = mk_app bblast_term_s [n; x; y] + +let _ = + define "bvop2" + (pi_d "n" mpz (fun n -> + (pi "x" (term (bitVec n)) + (pi "y" (term (bitVec n)) + (term (bitVec n)))))) + +let bvand_s = declare_get "bvand" (mk_const "bvop2") +let bvor_s = declare_get "bvor" (mk_const "bvop2") +let bvxor_s = declare_get "bvxor" (mk_const "bvop2") +let bvnand_s = declare_get "bvnand" (mk_const "bvop2") +let bvnor_s = declare_get "bvnor" (mk_const "bvop2") +let bvxnor_s = declare_get "bvxnor" (mk_const "bvop2") +let bvmul_s = declare_get "bvmul" (mk_const "bvop2") +let bvadd_s = declare_get "bvadd" (mk_const "bvop2") +let bvsub_s = declare_get "bvsub" (mk_const "bvop2") +let bvudiv_s = declare_get "bvudiv" (mk_const "bvop2") +let bvurem_s = declare_get "bvurem" (mk_const "bvop2") +let bvsdiv_s = declare_get "bvsdiv" (mk_const "bvop2") +let bvsrem_s = declare_get "bvsrem" (mk_const "bvop2") +let bvsmod_s = declare_get "bvsmod" (mk_const "bvop2") +let bvshl_s = declare_get "bvshl" (mk_const "bvop2") +let bvlshr_s = declare_get "bvlshr" (mk_const "bvop2") +let bvashr_s = declare_get "bvashr" (mk_const "bvop2") + +let bvand n a b = mk_app bvand_s [n; a; b] +let bvor n a b = mk_app bvor_s [n; a; b] +let bvxor n a b = mk_app bvxor_s [n; a; b] +let bvnand n a b = mk_app bvnand_s [n; a; b] +let bvnor n a b = mk_app bvnor_s [n; a; b] +let bvxnor n a b = mk_app bvxnor_s [n; a; b] +let bvmul n a b = mk_app bvmul_s [n; a; b] +let bvadd n a b = mk_app bvadd_s [n; a; b] +let bvsub n a b = mk_app bvsub_s [n; a; b] +let bvudiv n a b = mk_app bvudiv_s [n; a; b] +let bvurem n a b = mk_app bvurem_s [n; a; b] +let bvsdiv n a b = mk_app bvsdiv_s [n; a; b] +let bvsrem n a b = mk_app bvsrem_s [n; a; b] +let bvsmod n a b = mk_app bvsmod_s [n; a; b] +let bvshl n a b = mk_app bvshl_s [n; a; b] +let bvlshr n a b = mk_app bvlshr_s [n; a; b] +let bvashr n a b = mk_app bvashr_s [n; a; b] + +let _ = + define "bvop1" + (pi_d "n" mpz (fun n -> + (pi "x" (term (bitVec n)) + (term (bitVec n))))) + +let bvnot_s = declare_get "bvnot" (mk_const "bvop1") +let bvneg_s = declare_get "bvneg" (mk_const "bvop1") + +let bvnot n a = mk_app bvnot_s [n; a] +let bvneg n a = mk_app bvneg_s [n; a] + + +let _ = + define "bvpred" + (pi_d "n" mpz (fun n -> + (pi "x" (term (bitVec n)) + (pi "y" (term (bitVec n)) + formula)))) + +let bvult_s = declare_get "bvult" (mk_const "bvpred") +let bvslt_s = declare_get "bvslt" (mk_const "bvpred") + +let bvult n a b = mk_app bvult_s [n; a; b] +let bvslt n a b = mk_app bvslt_s [n; a; b] + + +let concat_s = declare_get "concat" + (pi_d "n" mpz (fun n -> + (pi_d "m" mpz (fun m -> + (pi_d "m'" mpz (fun m' -> + (pi "t1" (term (bitVec m)) + (pi "t2" (term (bitVec m')) + (term (bitVec n)))))))))) + +let concat n m m' a b = mk_app concat_s [n; m; m'; a; b] + + +let extract_s = declare_get "extract" + (pi_d "n" mpz (fun n -> + (pi "i" mpz + (pi "j" mpz + (pi_d "m" mpz (fun m -> + (pi "t2" (term (bitVec m)) + (term (bitVec n))))))))) + +let extract n i j m b = mk_app extract_s [n; i; j; m; b] + + +let zero_extend_s = declare_get "zero_extend" + (pi_d "n" mpz (fun n -> + (pi "i" mpz + (pi_d "m" mpz (fun m -> + (pi "t2" (term (bitVec m)) + (term (bitVec n)))))))) + +let zero_extend n i m b = mk_app zero_extend_s [n; i; m; b] + +let sign_extend_s = declare_get "sign_extend" + (pi_d "n" mpz (fun n -> + (pi "i" mpz + (pi_d "m" mpz (fun m -> + (pi "t2" (term (bitVec m)) + (term (bitVec n)))))))) + +let sign_extend n i m b = mk_app sign_extend_s [n; i; m; b] + + +(* arrays constructors and functions *) + +let array_s = declare_get "Array" (pi "s1" sort (pi "s2" sort sort)) +let array s1 s2 = mk_app array_s [s1; s2] +let read_s = declare_get "read" + (pi_d "s1" sort (fun s1 -> + (pi_d "s2" sort (fun s2 -> + (term (arrow (array s1 s2) (arrow s1 s2))))))) +let read s1 s2 = mk_app read_s [s1; s2] +let write_s = declare_get "write" + (pi_d "s1" sort (fun s1 -> + (pi_d "s2" sort (fun s2 -> + (term (arrow (array s1 s2) (arrow s1 (arrow s2 (array s1 s2))))))))) +let write s1 s2 = mk_app write_s [s1; s2] +let diff_s = declare_get "diff" + (pi_d "s1" sort (fun s1 -> + (pi_d "s2" sort (fun s2 -> + (term (arrow (array s1 s2) (arrow (array s1 s2) s1))))))) +let diff s1 s2 = mk_app diff_s [s1; s2] + +(* sortcuts *) +let apply_read s1 s2 a i = + apply s1 s2 (apply (array s1 s2) (arrow s1 s2) (read s1 s2) a) i +let apply_write s1 s2 a i v = + apply s2 (array s1 s2) + (apply s1 (arrow s2 (array s1 s2)) + (apply (array s1 s2) (arrow s1 (arrow s2 (array s1 s2))) (write s1 s2) a) + i) v +let apply_diff s1 s2 a b = + apply (array s1 s2) s1 + (apply (array s1 s2) (arrow (array s1 s2) s1) (diff s1 s2) a) b + + +let refl_s = declare_get "refl" + (pi_d "s" sort (fun s -> + (pi_d "t" (term s) (fun t -> + (th_holds (eq s t t)))))) + +let refl s t = mk_app refl_s [s; t] + +let cong_s = declare_get "cong" + (pi_d "s1" sort (fun s1 -> + (pi_d "s2" sort (fun s2 -> + (pi_d "a1" (term (arrow s1 s2)) (fun a1 -> + (pi_d "b1" (term (arrow s1 s2)) (fun b1 -> + (pi_d "a2" (term s1) (fun a2 -> + (pi_d "b2" (term s1) (fun b2 -> + (pi_d "u1" (th_holds (eq (arrow s1 s2) a1 b1)) (fun u1 -> + (pi_d "u2" (th_holds (eq s1 a2 b2)) (fun u2 -> + (th_holds (eq s2 (apply s1 s2 a1 a2) (apply s1 s2 b1 b2))))))))))))))))))) + +let cong s1 s2 a1 b1 a2 b2 u1 u2 = + mk_app cong_s [s1; s2; a1; b1; a2; b2; u1; u2] + + +module MInt = Map.Make (struct + type t = int + let compare = Pervasives.compare + end) + +module STerm = Set.Make (Term) + +type mark_map = STerm.t MInt.t + +let empty_marks = MInt.empty + +let is_marked i m v = + try + STerm.mem v (MInt.find i m) + with Not_found -> false + +let if_marked_do i m v then_v else_v = + if is_marked i m v then (then_v m) else (else_v m) + +let markvar_with i m v = + let set = try MInt.find i m with Not_found -> STerm.empty in + MInt.add i (STerm.add v set) m + + +let ifmarked m v = if_marked_do 1 m v +let ifmarked1 m v = ifmarked m v +let ifmarked2 m v = if_marked_do 2 m v +let ifmarked3 m v = if_marked_do 3 m v +let ifmarked4 m v = if_marked_do 4 m v + +let markvar m v = markvar_with 1 m v +let markvar1 m v = markvar m v +let markvar2 m v = markvar_with 2 m v +let markvar3 m v = markvar_with 3 m v +let markvar4 m v = markvar_with 4 m v + + +(*******************) +(* Side conditions *) +(*******************) + + +let rec append c1 c2 = + match value c1 with + | Const _ when term_equal c1 cln -> c2 + | App (f, [l; c1']) when term_equal f clc_s -> + clc l (append c1' c2) + | _ -> failwith "Match failure" + + + +(* we use marks as follows: + - mark 1 to record if we are supposed to remove a positive occurrence of + the variable. + - mark 2 to record if we are supposed to remove a negative occurrence of + the variable. + - mark 3 if we did indeed remove the variable positively + - mark 4 if we did indeed remove the variable negatively *) +let rec simplify_clause mark_map c = + (* eprintf "simplify_clause[rec] %a@." print_term c; *) + match value c with + | Const _ when term_equal c cln -> cln, mark_map + + | App(f, [l; c1]) when term_equal f clc_s -> + + begin match value l with + (* Set mark 1 on v if it is not set, to indicate we should remove it. + After processing the rest of the clause, set mark 3 if we were already + supposed to remove v (so if mark 1 was set when we began). Clear mark3 + if we were not supposed to be removing v when we began this call. *) + + | App (f, [v]) when term_equal f pos_s -> let v = deref v in + + let m, mark_map = ifmarked mark_map v + (fun mark_map -> tt, mark_map) + (fun mark_map -> ff, markvar mark_map v) in + + let c', mark_map = simplify_clause mark_map c1 in + + begin match value m with + | Const _ when term_equal m tt -> + let mark_map = ifmarked3 mark_map v + (fun mark_map -> mark_map) + (fun mark_map -> markvar3 mark_map v) in + c', mark_map + + | Const _ when term_equal m ff -> + let mark_map = ifmarked3 mark_map v + (fun mark_map -> markvar3 mark_map v) + (fun mark_map -> mark_map) in + let mark_map = markvar mark_map v in + clc l c', mark_map + + | _ -> failwith "Match failure1" + end + + + | App (f, [v]) when term_equal f neg_s -> let v = deref v in + + let m, mark_map = ifmarked2 mark_map v + (fun mark_map -> tt, mark_map) + (fun mark_map -> ff, markvar2 mark_map v) in + + let c', mark_map = simplify_clause mark_map c1 in + + begin match value m with + | Const _ when term_equal m tt -> + let mark_map = ifmarked4 mark_map v + (fun mark_map -> mark_map) + (fun mark_map -> markvar4 mark_map v) in + c', mark_map + + | Const _ when term_equal m ff -> + let mark_map = ifmarked4 mark_map v + (fun mark_map -> markvar4 mark_map v) + (fun mark_map -> mark_map) in + let mark_map = markvar2 mark_map v in + clc l c', mark_map + + | _ -> failwith "Match failure2" + end + + | _ -> failwith "Match failure3" + + end + + | App(f, [c1; c2]) when term_equal f concat_cl_s -> + let new_c1, mark_map = simplify_clause mark_map c1 in + let new_c2, mark_map = simplify_clause mark_map c2 in + append new_c1 new_c2, mark_map + + | App(f, [l; c1]) when term_equal f clr_s -> + + begin match value l with + (* set mark 1 to indicate we should remove v, and fail if + mark 3 is not set after processing the rest of the clause + (we will set mark 3 if we remove a positive occurrence of v). *) + + | App (f, [v]) when term_equal f pos_s -> let v = deref v in + + let m, mark_map = ifmarked mark_map v + (fun mark_map -> tt, mark_map) + (fun mark_map -> ff, markvar mark_map v) in + + let m3, mark_map = ifmarked3 mark_map v + (fun mark_map -> tt, markvar3 mark_map v) + (fun mark_map -> ff, mark_map) in + + let c', mark_map = simplify_clause mark_map c1 in + + let mark_map = ifmarked3 mark_map v + (fun mark_map -> + let mark_map = match value m3 with + | Const _ when term_equal m3 tt -> mark_map + | Const _ when term_equal m3 ff -> markvar3 mark_map v + | _ -> failwith "Match failure4" + in + let mark_map = match value m with + | Const _ when term_equal m tt -> mark_map + | Const _ when term_equal m ff -> markvar mark_map v + | _ -> failwith "Match failure5" + in + mark_map + ) + (fun _ -> failwith "Match failure6") + in + + c', mark_map + + | App (f, [v]) when term_equal f neg_s -> let v = deref v in + + let m2, mark_map = ifmarked2 mark_map v + (fun mark_map -> tt, mark_map) + (fun mark_map -> ff, markvar2 mark_map v) in + + let m4, mark_map = ifmarked4 mark_map v + (fun mark_map -> tt, markvar4 mark_map v) + (fun mark_map -> ff, mark_map) in + + let c', mark_map = simplify_clause mark_map c1 in + + let mark_map = ifmarked4 mark_map v + (fun mark_map -> + let mark_map = match value m4 with + | Const _ when term_equal m4 tt -> mark_map + | Const _ when term_equal m4 ff -> markvar4 mark_map v + | _ -> failwith "Match failure7" + in + let mark_map = match value m2 with + | Const _ when term_equal m2 tt -> mark_map + | Const _ when term_equal m2 ff -> markvar2 mark_map v + | _ -> failwith "Match failure8" + in + mark_map + ) + (fun _ -> failwith "Match failure9") + in + + c', mark_map + + | _ -> failwith "Match failure10" + + end + + | _ -> failwith "Match failure11" + + +let simplify_clause c = + let c', _ = simplify_clause empty_marks c in + c' + + + +let () = + List.iter (fun (s, f) -> Hstring.H.add callbacks_table s f) + [ + + H.append, + (function + | [c1; c2] -> append c1 c2 + | _ -> failwith "append: Wrong number of arguments"); + + H.simplify_clause, + (function + | [c] -> simplify_clause c + | _ -> failwith "simplify_clause: Wrong number of arguments"); + + ] + + + + +let mpz_sub x y = mp_add x (mp_mul (mpz_of_int (-1)) y) + + + +let rec bv_constants_are_disequal x y = + match value x with + | Const _ when term_equal x bvn -> failwith "bv_constants_are_disequal" + | App (f, [bx; x']) when term_equal f bvc_s -> + (match value y with + | Const _ when term_equal y bvn -> failwith "bv_constants_are_disequal" + | App (f, [by; y']) when term_equal f bvc_s -> + if term_equal bx b0 then + if term_equal by b0 then + bv_constants_are_disequal x' y' + else ttrue + else if term_equal bx b1 then + if term_equal by b1 then + bv_constants_are_disequal x' y' + else ttrue + else failwith "bv_constants_are_disequal" + | _ -> failwith "bv_constants_are_disequal") + | _ -> failwith "bv_constants_are_disequal" + + + +(* calculate the length of a bit-blasted term *) +let rec bblt_len v = + (* eprintf "bblt_len %a@." print_term v; *) + match value v with + | Const _ when term_equal v bbltn -> mpz_of_int 0 + | App (f, [b; v']) when term_equal f bbltc_s -> + mp_add (bblt_len v') (mpz_of_int 1) + | _ -> failwith "bblt_len" + + +let rec bblast_const v n = + if mp_isneg n then + match value v with + | Const _ when term_equal v bvn -> bbltn + | _ -> failwith "blast_const" + else + match value v with + | App (f, [b; v']) when term_equal f bvc_s -> + bbltc + (match value b with + | Const _ when term_equal b b0 -> tfalse + | Const _ when term_equal b b1 -> ttrue + | _ -> failwith "bblast_const") + (bblast_const v' (mp_add n (mpz_of_int (-1)))) + | _ -> failwith "bblast_const" + + +let rec bblast_var x n = + if mp_isneg n then bbltn + else + bbltc (bitof x n) (bblast_var x (mp_add n (mpz_of_int (-1)))) + + +let rec bblast_concat x y = + match value x with + | Const _ when term_equal x bbltn -> + (match value y with + | App (f, [by; y']) when term_equal f bbltc_s -> + bbltc by (bblast_concat x y') + | Const _ when term_equal y bbltn -> bbltn + | _ -> failwith "bblast_concat: wrong application") + | App (f, [bx; x']) when term_equal f bbltc_s -> + bbltc bx (bblast_concat x' y) + | _ -> failwith "bblast_concat: wrong application" + + +let rec bblast_extract_rec x i j n = + match value x with + | App (f, [bx; x']) when term_equal f bbltc_s -> + if mp_isneg (mpz_sub (mpz_sub j n) (mpz_of_int 1)) then + if mp_isneg (mpz_sub (mpz_sub n i) (mpz_of_int 1)) then + bbltc bx (bblast_extract_rec x' i j (mpz_sub n (mpz_of_int 1))) + else bblast_extract_rec x' i j (mpz_sub n (mpz_of_int 1)) + else bbltn + | Const _ when term_equal x bbltn -> bbltn + | _ -> failwith "bblast_extract_rec: wrong application" + + +let bblast_extract x i j n = bblast_extract_rec x i j (mpz_sub n (mpz_of_int 1)) + + +let rec extend_rec x i b = + if mp_isneg i then x + else bbltc b (extend_rec x (mpz_sub i (mpz_of_int 1)) b) + + +let bblast_zextend x i = extend_rec x (mpz_sub i (mpz_of_int 1)) tfalse + + +let bblast_sextend x i = + match value x with + | App (f, [xb; x']) when term_equal f bbltc_s -> + extend_rec x (mpz_sub i (mpz_of_int 1)) xb + | _ -> failwith "bblast_sextend" + + +let rec bblast_bvand x y = + (* eprintf "bblast_bvand %a %a@." print_term x print_term y; *) + match value x with + | Const _ when term_equal x bbltn -> + (match value y with + | Const _ when term_equal y bbltn -> bbltn + | _ -> failwith "bblast_bvand1") + | App (f, [bx; x']) when term_equal f bbltc_s -> + (match value y with + | App (f, [by; y']) when term_equal f bbltc_s -> + bbltc (and_ bx by) (bblast_bvand x' y') + | _ -> failwith "bblast_bvand2") + | _ -> failwith "bblast_bvand3" + + +let rec bblast_bvnot x = + match value x with + | Const _ when term_equal x bbltn -> bbltn + | App (f, [bx; x']) when term_equal f bbltc_s -> + bbltc (not_ bx) (bblast_bvnot x') + | _ -> failwith "bblast_bnot" + + +let rec bblast_bvor x y = + match value x with + | Const _ when term_equal x bbltn -> + (match value y with + | Const _ when term_equal y bbltn -> bbltn + | _ -> failwith "bblast_bvor") + | App (f, [bx; x']) when term_equal f bbltc_s -> + (match value y with + | App (f, [by; y']) when term_equal f bbltc_s -> + bbltc (or_ bx by) (bblast_bvor x' y') + | _ -> failwith "bblast_bvor") + | _ -> failwith "bblast_bvor" + + +let rec bblast_bvxor x y = + match value x with + | Const _ when term_equal x bbltn -> + (match value y with + | Const _ when term_equal y bbltn -> bbltn + | _ -> failwith "bblast_bvxor") + | App (f, [bx; x']) when term_equal f bbltc_s -> + (match value y with + | App (f, [by; y']) when term_equal f bbltc_s -> + bbltc (xor_ bx by) (bblast_bvxor x' y') + | _ -> failwith "bblast_bvxor") + | _ -> failwith "bblast_bvxor" + + +(* +;; return the carry bit after adding x y +;; FIXME: not the most efficient thing in the world +*) + +let rec bblast_bvadd_carry a b carry = + match value a with + | Const _ when term_equal a bbltn -> + (match value b with + | Const _ when term_equal b bbltn -> carry + | _ -> failwith "bblast_bvadd_carry") + | App (f, [ai; a']) when term_equal f bbltc_s -> + (match value b with + | App (f, [bi; b']) when term_equal f bbltc_s -> + (or_ (and_ ai bi) (and_ (xor_ ai bi) (bblast_bvadd_carry a' b' carry))) + | _ -> failwith "bblast_bvadd_carry") + | _ -> failwith "bblast_bvadd_carry" + + +let rec bblast_bvadd a b carry = + match value a with + | Const _ when term_equal a bbltn -> + (match value b with + | Const _ when term_equal b bbltn -> bbltn + | _ -> failwith "bblast_bvadd") + | App (f, [ai; a']) when term_equal f bbltc_s -> + (match value b with + | App (f, [bi; b']) when term_equal f bbltc_s -> + bbltc + (xor_ (xor_ ai bi) (bblast_bvadd_carry a' b' carry)) + (bblast_bvadd a' b' carry) + | _ -> failwith "bblast_bvadd") + | _ -> failwith "bblast_bvadd" + + +let rec bblast_zero n = + if mp_iszero n then bbltn + else bbltc tfalse (bblast_zero (mp_add n (mpz_of_int (-1)))) + + +let bblast_bvneg x n = bblast_bvadd (bblast_bvnot x) (bblast_zero n) ttrue + + +let rec reverse_help x acc = + match value x with + | Const _ when term_equal x bbltn -> acc + | App (f, [xi; x']) when term_equal f bbltc_s -> + reverse_help x' (bbltc xi acc) + | _ -> failwith "reverse_help" + +let reverseb x = reverse_help x bbltn + + +let rec top_k_bits a k = + if mp_iszero k then bbltn + else match value a with + | App (f, [ai; a']) when term_equal f bbltc_s -> + bbltc ai (top_k_bits a' (mpz_sub k (mpz_of_int 1))) + | _ -> failwith "top_k_bits" + + +let bottom_k_bits a k = reverseb (top_k_bits (reverseb a) k) + + +(* assumes the least signigicant bit is at the beginning of the list *) +let rec k_bit a k = + if mp_isneg k then failwith "k_bit" + else match value a with + | App (f, [ai; a']) when term_equal f bbltc_s -> + if mp_iszero k then ai else k_bit a' (mpz_sub k (mpz_of_int 1)) + | _ -> failwith "k_bit" + + +let rec and_with_bit a bt = + match value a with + | Const _ when term_equal a bbltn -> bbltn + | App (f, [ai; a']) when term_equal f bbltc_s -> + bbltc (and_ bt ai) (and_with_bit a' bt) + | _ -> failwith "add_with_bit" + + +(* +;; a is going to be the current result +;; carry is going to be false initially +;; b is the and of a and b[k] +;; res is going to be bbltn initially +*) +let rec mult_step_k_h a b res carry k = + match value a with + | Const _ when term_equal a bbltn -> + (match value b with + | Const _ when term_equal b bbltn -> res + | _ -> failwith "mult_step_k_h") + | App (f, [ai; a']) when term_equal f bbltc_s -> + (match value b with + | App (f, [bi; b']) when term_equal f bbltc_s -> + if mp_isneg (mpz_sub k (mpz_of_int 1)) then + let carry_out = (or_ (and_ ai bi) (and_ (xor_ ai bi) carry)) in + let curr = (xor_ (xor_ ai bi) carry) in + mult_step_k_h a' b' + (bbltc curr res) carry_out (mpz_sub k (mpz_of_int 1)) + else + mult_step_k_h a' b (bbltc ai res) carry (mpz_sub k (mpz_of_int 1)) + | _ -> failwith "mult_step_k_h") + | _ -> failwith "mult_step_k_h" + + + +(* assumes that a, b and res have already been reversed *) +let rec mult_step a b res n k = + let k' = mpz_sub n k in + let ak = top_k_bits a k' in + let b' = and_with_bit ak (k_bit b k) in + if mp_iszero (mpz_sub k' (mpz_of_int 1)) then + mult_step_k_h res b' bbltn tfalse k + else + let res' = mult_step_k_h res b' bbltn tfalse k in + mult_step a b (reverseb res') n (mp_add k (mpz_of_int 1)) + + +let bblast_bvmul a b n = + let ar = reverseb a in (* reverse a and b so that we can build the circuit *) + let br = reverseb b in (* from the least significant bit up *) + let res = and_with_bit ar (k_bit br (mpz_of_int 0)) in + if mp_iszero (mpz_sub n (mpz_of_int 1)) then res + else + (* if multiplying 1 bit numbers no need to call mult_step *) + mult_step ar br res n (mpz_of_int 1) + + +(* +; bit blast x = y +; for x,y of size n, it will return a conjuction (x.0 = y.0 ^ ( ... ^ (x.{n-1} = y.{n-1}))) +; f is the accumulator formula that builds the equality in the right order +*) +let rec bblast_eq_rec x y f = + match value x with + | Const _ when term_equal x bbltn -> + (match value y with + | Const _ when term_equal x bbltn -> f + | _ -> failwith "bblast_eq_rec") + | App (ff, [fx; x']) when term_equal ff bbltc_s -> + (match value y with + | App (ff, [fy; y']) when term_equal ff bbltc_s -> + bblast_eq_rec x' y' (and_ (iff_ fx fy) f) + | _ -> failwith "bblast_eq_rec") + | _ -> failwith "bblast_eq_rec" + + + +let bblast_eq x y = + match value x with + | App (ff, [bx; x']) when term_equal ff bbltc_s -> + (match value y with + | App (ff, [by; y']) when term_equal ff bbltc_s -> + bblast_eq_rec x' y' (iff_ bx by) + | _ -> failwith "sc1: bblast_eq") + | _ -> failwith "sc2: bblast_eq" + + +let rec bblast_bvult x y n = + match value x with + | App (ff, [xi; x']) when term_equal ff bbltc_s -> + (match value y with + | App (ff, [yi; y']) when term_equal ff bbltc_s -> + if mp_iszero n then (and_ (not_ xi) yi) + else (or_ (and_ (iff_ xi yi) + (bblast_bvult x' y' (mp_add n (mpz_of_int (-1))))) + (and_ (not_ xi) yi)) + | _ -> failwith "bblast_bvult") + | _ -> failwith "bblast_bvult" + + +let rec bblast_bvslt x y n = + match value x with + | App (ff, [xi; x']) when term_equal ff bbltc_s -> + (match value y with + | App (ff, [yi; y']) when term_equal ff bbltc_s -> + if mp_iszero (mpz_sub n (mpz_of_int 1)) then (and_ xi (not_ yi)) + else (or_ (and_ (iff_ xi yi) + (bblast_bvult x' y' (mpz_sub n (mpz_of_int 2)))) + (and_ xi (not_ yi))) + | _ -> failwith "bblast_bvslt") + | _ -> failwith "bblast_bvslt" + + +let rec mk_ones n = + if mp_iszero n then bvn + else bvc b1 (mk_ones (mpz_sub n (mpz_of_int 1))) + + +let rec mk_zero n = + if mp_iszero n then bvn + else bvc b0 (mk_zero (mpz_sub n (mpz_of_int 1))) + + + + + +(** Registering callbacks for side conditions *) + + +let () = + List.iter (fun (s, f) -> Hstring.H.add callbacks_table s f) + [ + + H.append, + (function + | [c1; c2] -> append c1 c2 + | _ -> failwith "append: Wrong number of arguments"); + + H.simplify_clause, + (function + | [c] -> simplify_clause c + | _ -> failwith "simplify_clause: Wrong number of arguments"); + + H.bv_constants_are_disequal, + (function + | [x; y] -> bv_constants_are_disequal x y + | _ -> failwith "bv_constants_are_disequal: Wrong number of arguments"); + + H.bblt_len, + (function + | [v] -> bblt_len v + | _ -> failwith "bblt_len: Wrong number of arguments"); + + H.bblast_const, + (function + | [v; n] -> bblast_const v n + | _ -> failwith "bblast_const: Wrong number of arguments"); + + H.bblast_var, + (function + | [v; n] -> bblast_var v n + | _ -> failwith "bblast_var: Wrong number of arguments"); + + H.bblast_concat, + (function + | [x; y] -> bblast_concat x y + | _ -> failwith "bblast_concat: Wrong number of arguments"); + + H.bblast_extract, + (function + | [x; i; j; n] -> bblast_extract x i j n + | _ -> failwith "bblast_extract: Wrong number of arguments"); + + H.bblast_zextend, + (function + | [x; i] -> bblast_zextend x i + | _ -> failwith "bblast_zextend: Wrong number of arguments"); + + H.bblast_sextend, + (function + | [x; i] -> bblast_sextend x i + | _ -> failwith "bblast_sextend: Wrong number of arguments"); + + H.bblast_bvand, + (function + | [x; y] -> bblast_bvand x y + | _ -> failwith "bblast_bvand: Wrong number of arguments"); + + H.bblast_bvnot, + (function + | [x] -> bblast_bvnot x + | _ -> failwith "bblast_bvnot: Wrong number of arguments"); + + H.bblast_bvor, + (function + | [x; y] -> bblast_bvor x y + | _ -> failwith "bblast_bvor: Wrong number of arguments"); + + H.bblast_bvxor, + (function + | [x; y] -> bblast_bvxor x y + | _ -> failwith "bblast_bvxor: Wrong number of arguments"); + + H.bblast_bvadd, + (function + | [x; y; c] -> bblast_bvadd x y c + | _ -> failwith "bblast_bvadd: Wrong number of arguments"); + + H.bblast_zero, + (function + | [n] -> bblast_zero n + | _ -> failwith "bblast_zero: Wrong number of arguments"); + + H.bblast_bvneg, + (function + | [v; n] -> bblast_bvneg v n + | _ -> failwith "bblast_bvneg: Wrong number of arguments"); + + H.bblast_bvmul, + (function + | [x; y; n] -> bblast_bvmul x y n + | _ -> failwith "bblast_bvmul: Wrong number of arguments"); + + H.bblast_eq, + (function + | [x; y] -> bblast_eq x y + | _ -> failwith "bblast_eq: Wrong number of arguments"); + + H.bblast_bvult, + (function + | [x; y; n] -> bblast_bvult x y n + | _ -> failwith "bblast_bvult: Wrong number of arguments"); + + H.bblast_bvslt, + (function + | [x; y; n] -> bblast_bvslt x y n + | _ -> failwith "bblast_bvslt: Wrong number of arguments"); + + ] diff --git a/src/lfsc/converter.ml b/src/lfsc/converter.ml new file mode 100644 index 0000000..d586e37 --- /dev/null +++ b/src/lfsc/converter.ml @@ -0,0 +1,1302 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Ast +open Builtin +open Format +open Translator_sig + + +module Make (T : Translator_sig.S) = struct + + open T + + module MTerm = Map.Make (Term) + + + (** Environment for {!lem} *) + type env = { + clauses : int list; (** Accumulated clauses *) + ax : bool; (** Force use of axiomatic rules? *) + mpred : bool MTerm.t; (** map for positivity of predicates in cong *) + assum : Hstring.t list; (** Assumptions that were not used *) + } + + + (** Empty environment *) + let empty = { + clauses = []; + ax = false; + mpred = MTerm.empty; + assum = []; + } + + + (** Returns the formula of which p is a proof of *) + let th_res p = match app_name (deref p).ttype with + | Some (n, [r]) when n == H.th_holds -> r + | _ -> assert false + + + (** Ignore declarations at begining of proof *) + let rec ignore_all_decls p = match value p with + | Lambda (s, p) -> ignore_all_decls p + | _ -> p + + + (** Ignore declarations but keep assumptions *) + let rec ignore_decls p = match value p with + | Lambda (s, pr) -> + (match s.sname with + | Name n when (Hstring.view n).[0] = 'A' -> p + | _ -> ignore_decls pr + ) + | _ -> p + + + (** Ignore result of preprocessing *) + let rec ignore_preproc p = match app_name p with + | Some (n, [_; _; p]) when n == H.th_let_pf -> + begin match value p with + | Lambda (_, p) -> ignore_preproc p + | _ -> assert false + end + | _ -> p + + + (** Produce input clauses from the result of CVC4's pre-processing. This may + not match the actual inputs in the original SMT2 file but they correspond + to what the proof uses. *) + let rec produce_inputs_preproc p = match app_name p with + | Some (n, [_; _; p]) when n == H.th_let_pf -> + begin match value p with + | Lambda ({sname = Name h; stype}, p) -> + begin match app_name stype with + | Some (n, [formula]) when n == H.th_holds -> + mk_input h formula; + produce_inputs_preproc p + | _ -> assert false + end + | _ -> assert false + end + | _ -> p + + + (** Produce inputs from the assumptions *) + let rec produce_inputs p = match value p with + | Lambda ({sname = Name h; stype}, p) -> + begin match app_name stype with + | Some (n, [formula]) + when n == H.th_holds && + (match name formula with + | Some f when f == H.ttrue -> false | _ -> true) + -> + mk_input h formula; + produce_inputs p + | _ -> produce_inputs p + end + | _ -> p + + + let dvar_of_v t = match app_name t with + | Some (n, [_; v]) when n == H.a_var_bv -> v + | _ -> t + + + let trust_vareq_as_alias formula = match app_name formula with + | Some (n, [ty; alias; t]) when n == H.eq -> + (match name (dvar_of_v alias) with + | Some n -> register_alias n t; true + | None -> false) + | _ -> false + + + let rec admit_preproc p = match app_name p with + | Some (n, [_; tr; p]) when n == H.th_let_pf -> + begin match app_name tr with + | Some (n, _) when n == H.trust_f -> + eprintf "Warning: hole for trust_f.@." + | Some (rule, _) -> + eprintf "Warning: hole for unsupported rule %a.@." Hstring.print rule + | None -> eprintf "Warning: hole@." + end; + let formula = th_res tr in + begin match value p with + | Lambda ({sname = Name h}, p) -> + if not (trust_vareq_as_alias formula) then + mk_admit_preproc h formula; + admit_preproc p + | _ -> assert false + end + | _ -> p + + + + (** Handle deferred declarations in LFSC (for extensionality rule atm.) *) + let rec deferred p = match app_name p with + | Some (n, [ty_i; ty_e; a; b; p]) when n == H.ext -> + begin match value p with + | Lambda ({sname = Name index_diff}, p) -> + begin match value p with + | Lambda ({sname = Name h}, p) -> + let diff_a_b = (apply_diff ty_i ty_e a b) in + register_alias index_diff diff_a_b; + let f = + or_ (eq (array ty_i ty_e) a b) + (not_ (eq ty_e + (apply_read ty_i ty_e a diff_a_b) + (apply_read ty_i ty_e b diff_a_b))) in + let cid = mk_clause_cl Exte [f] [] in + register_decl_id h cid; + deferred p + | _ -> assert false + end + | _ -> assert false + end + | _ -> p + + + + (** Registers a propositional variable as an abstraction for a + formula. Proofs in SMTCoq have to be given in terms of formulas. *) + let rec register_prop_vars p = match app_name p with + | Some (n, [formula; p]) when n == H.decl_atom -> + begin match value p with + | Lambda (v, p) -> + let vt = (symbol_to_const v) in + (* eprintf "register prop var: %a@." print_term_type vt; *) + register_prop_abstr vt formula; + begin match value p with + | Lambda (_, p) -> register_prop_vars p + | _ -> assert false + end + | _ -> assert false + end + | _ -> p + + + (** Returns the name of the local assumptions made in [satlem] *) + let rec get_assumptions acc p = match app_name p with + | Some (n, [_; _; _; _; p]) when n == H.ast || n == H.asf -> + begin match value p with + | Lambda ({sname = Name n}, p) -> get_assumptions (n :: acc) p + | _ -> assert false + end + | _ -> acc, p + + + + let rec rm_used' assumptions t = match name t with + | Some x -> List.filter (fun y -> y != x) assumptions + | None -> match app_name t with + | Some (_, l) -> List.fold_left rm_used' assumptions l + | None -> assumptions + + (** Remove used assumptions from the environment *) + let rm_used env t = { env with assum = rm_used' env.assum t } + + + let rm_duplicates eq l = + let rec aux acc = function + | x :: r -> if List.exists (eq x) acc then aux acc r else aux (x :: acc) r + | [] -> acc in + aux [] (List.rev l) + + (** Create an intermediate resolution step in [satlem] with the accumulated + clauses. {!Reso} ignores the resulting clause so we can just give the + empty clause here. *) + let mk_inter_resolution clauses = match clauses with + | [] -> (* not false *) + mk_clause_cl Fals [not_ tfalse] [] + (* assert false *) + | [id] -> id + | _ -> mk_clause ~reuse:false Reso [] clauses + + + + let is_ty_Bool ty = match name ty with + | Some n -> n == H.tBool + | _ -> false + + + (** Accumulates equalities for congruence. This is useful for when [f] takes + multiples arguments. *) + let rec cong neqs env p = match app_name p with + | Some (n, [ty; rty; f; f'; x; y; p_f_eq_f'; r]) when n == H.cong -> + + let ne = not_ (eq ty x y) in + let neqs, env = + if List.exists (Term.equal ne) neqs then neqs, env + else ne :: neqs, lem env r in + + begin match name f, name f' with + | Some n, Some n' when n == n' -> neqs, env + | None, None -> cong neqs env p_f_eq_f' + | _ -> assert false + end + + | Some (n, [_; _; _; r]) + when n == H.symm || n == H.negsymm -> + cong neqs (rm_used env r) r + + (* | Some (n, [t; x; y; z; r1; r2]) when n == H.trans *) + (* | Some (n, [t; x; z; y; r1; r2]) when n == H.negtrans || n == H.negtrans1 *) + (* | Some (n, [t; y; x; z; r1; r2]) when n == H.negtrans2 *) + + | Some (n, [t; x1; x2; x3; r1; r2]) + when n == H.trans || n == H.negtrans || + n == H.negtrans1 || n == H.negtrans2 -> + + let x, y, z = + if n == H.trans then x1, x2, x3 + else if n == H.negtrans || n == H.negtrans1 then x1, x3, x2 + else if n == H.negtrans2 then x2, x1, x3 + else assert false + in + + (* ignore useless transitivity *) + if term_equal x z then + match app_name x with + | Some (n, [t; _; _; x]) when n == H.apply -> + let x_x = eq t x x in + not_ x_x :: neqs, + { env with clauses = mk_clause_cl Eqre [x_x] [] :: env.clauses } + | _ -> + let x_x = eq t x x in + not_ x_x :: neqs, + { env with clauses = mk_clause_cl Eqre [x_x] [] :: env.clauses } + else if term_equal x y then cong neqs (rm_used env r2) r2 + else if term_equal y z then cong neqs (rm_used env r1) r1 + else + let neqs1, env1 = cong neqs (rm_used env r1) r1 in + cong neqs1 (rm_used env1 r2) r2 + + (* | Some ("refl", [_; r]) -> neqs, rm_used env r *) + + | _ -> neqs, env + (* eprintf "something went wrong in congruence@."; *) + (* neqs, lem env p (\* env *\) *) + + + (** Accumulates equalities for transitivity to chain them together. *) + and trans neqs env p = match app_name p with + + | Some (n, [ty; x; y; z; p1; p2]) when n == H.trans -> + (* | Some (("negtrans"|"negtrans1") as r, [ty; x; z; y; p1; p2]) *) + (* | Some ("negtrans2" as r, [ty; y; x; z; p1; p2]) *) + + let merge = true in + + (* let clauses = lem mpred assum (lem mpred assum clauses p1) p2 in *) + + (* let x_y = th_res p1 in *) + (* let y_z = th_res p2 in *) + (* let x_y = match r with "negtrans2" -> eq ty y x | _ -> eq ty x y in *) + (* let y_z = match r with "negtrans"|"negtrans1" -> eq ty z y | _ -> eq ty y z in *) + let n_x_y = not_ (eq ty x y) in + let n_y_z = not_ (eq ty y z) in + + let neqs2, env = if merge then trans neqs env p2 else [], lem env p2 in + let neqs1, env = if merge then trans neqs env p1 else [], lem env p1 in + + let neqs = match neqs1, neqs2 with + | [], [] -> [n_x_y; n_y_z] + | [], _ -> n_x_y :: neqs2 + | _, [] -> neqs1 @ [n_y_z] + | _, _ -> neqs1 @ neqs2 + in + + (* rm_duplicates Term.equal neqs *) + neqs, env + + | Some (n, [_; _; _; r]) when n == H.symm || n == H.negsymm -> + let neqs, env = trans neqs (rm_used env r) r in + List.rev neqs, env + + | Some (n, [_; r]) when n == H.refl -> neqs, rm_used env r + + | _ -> neqs, lem env p + + + + + (** Convert the local proof of a [satlem]. We use decductive style rules when + possible but revert to axiomatic ones when the context forces us to. *) + and lem ?(toplevel=false) env p = match app_name p with + | Some (n, [l1; l2; x; r]) + when (n == H.or_elim_1 || n == H.or_elim_2) && + (match app_name r with + | Some (n, _) -> n == H.iff_elim_1 || n == H.iff_elim_2 + | _ -> false) + -> + + let el, rem = if n == H.or_elim_1 then l1, l2 else l2, l1 in + + let env = lem env r in + let env = lem env x in + (match env.clauses with + | ci1 :: ci2 :: cls -> + { env with clauses = mk_clause_cl Reso [rem] [ci1; ci2] :: cls } + | _ -> env + ) + + | Some (n, [_; _; x; r]) + when (n == H.or_elim_1 || n == H.or_elim_2) && + (match app_name r with + | Some (n, _) -> n == H.impl_elim || + n == H.not_and_elim || + n == H.iff_elim_1 || + n == H.iff_elim_2 || + n == H.xor_elim_1 || + n == H.xor_elim_2 || + n == H.ite_elim_1 || + n == H.ite_elim_2 || + n == H.ite_elim_3 || + n == H.not_ite_elim_1 || + n == H.not_ite_elim_2 || + n == H.not_ite_elim_3 + | _ -> false) + -> + let env = rm_used env x in + let env = lem env r in + { env with ax = true } + + | Some (n, [a; b; x; r]) when n == H.or_elim_1 || n == H.or_elim_2 -> + let env = rm_used env x in + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> mk_clause_cl Or [a; b] env.clauses :: [] + | _ -> + let a_or_b = th_res r in + mk_clause_cl Orp [not_ a_or_b; a; b] [] :: env.clauses + in + { env with clauses; ax = true } + + | Some (n, [a; b; r]) when n == H.impl_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> mk_clause_cl Imp [not_ a; b] env.clauses :: [] + | _ -> + let a_impl_b = th_res r in + mk_clause_cl Impp [not_ a_impl_b; not_ a; b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; r]) when n == H.xor_elim_1 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Xor2 [not_ a; not_ b] env.clauses :: [] + | _ -> + let a_xor_b = xor_ a b in + mk_clause_cl Xorp2 [not_ a_xor_b; not_ a; not_ b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; r]) when n == H.xor_elim_2 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Xor1 [a; b] env.clauses :: [] + | _ -> + let a_xor_b = xor_ a b in + mk_clause_cl Xorp1 [not_ a_xor_b; a; b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; c; r]) when n == H.ite_elim_1 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Ite2 [not_ a; b] env.clauses :: [] + | _ -> + let ite_a_b_c = ifte_ a b c in + mk_clause_cl Itep2 [not_ ite_a_b_c; not_ a; b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; c; r]) when n == H.ite_elim_2 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Ite1 [a; c] env.clauses :: [] + | _ -> + let ite_a_b_c = ifte_ a b c in + mk_clause_cl Itep1 [not_ ite_a_b_c; a; c] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; c; r]) when n == H.not_ite_elim_1 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nite2 [not_ a; not_ b] env.clauses :: [] + | _ -> + let ite_a_b_c = ifte_ a b c in + mk_clause_cl Iten2 [ite_a_b_c; not_ a; not_ b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; c; r]) when n == H.not_ite_elim_2 -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nite1 [a; not_ c] env.clauses :: [] + | _ -> + let ite_a_b_c = ifte_ a b c in + mk_clause_cl Iten1 [ite_a_b_c; a; not_ c] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; c; r]) when n == H.ite_elim_3 -> + let env = lem env r in + let ite_a_b_c = ifte_ a b c in + { env with + clauses = + mk_clause_cl Itep1 [not_ ite_a_b_c; a; c] [] :: + mk_clause_cl Itep2 [not_ ite_a_b_c; not_ a; b] [] :: + env.clauses; + ax = true } + + | Some (n, [a; b; c; r]) when n == H.not_ite_elim_3 -> + let env = lem env r in + let ite_a_b_c = ifte_ a b c in + { env with + clauses = + mk_clause_cl Iten1 [ite_a_b_c; a; not_ c] [] :: + mk_clause_cl Iten2 [ite_a_b_c; not_ a; not_ b] [] :: + env.clauses; + ax = true } + + | Some (n, [a; b; r]) when n == H.iff_elim_1 -> + begin match app_name r with + | Some (n, [a; b; r]) when n == H.not_iff_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nequ2 [not_ a; not_ b] env.clauses :: [] + | _ -> + let a_iff_b = iff_ a b in + mk_clause_cl Equn1 [a_iff_b; not_ a; not_ b] [] :: env.clauses + in + { env with clauses } + | Some (n, [a; b; r]) when n == H.not_xor_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nxor2 [not_ a; b] env.clauses :: [] + | _ -> + let a_xor_b = xor_ a b in + mk_clause_cl Xorn2 [a_xor_b; not_ a; b] [] :: env.clauses + in + { env with clauses } + | _ -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Equ1 [not_ a; b] env.clauses :: [] + | _ -> + let a_iff_b = th_res r in + mk_clause_cl Equp2 [not_ a_iff_b; not_ a; b] [] :: env.clauses + in + { env with clauses } + end + + | Some (n, [a; b; r]) when n == H.iff_elim_2 -> + begin match app_name r with + | Some (n, [a; b; r]) when n == H.not_iff_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nequ1 [a; b] env.clauses :: [] + | _ -> + let a_iff_b = iff_ a b in + mk_clause_cl Equn2 [a_iff_b; a; b] [] :: env.clauses + in + { env with clauses } + | Some (n, [a; b; r]) when n == H.not_xor_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nxor1 [a; not_ b] env.clauses :: [] + | _ -> + let a_xor_b = xor_ a b in + mk_clause_cl Xorn1 [a_xor_b; a; not_ b] [] :: env.clauses + in + { env with clauses } + | _ -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Equ2 [a; not_ b] env.clauses :: [] + | _ -> + let a_iff_b = th_res r in + mk_clause_cl Equp1 [not_ a_iff_b; a; not_ b] [] :: env.clauses + in + { env with clauses } + end + + | Some (n, [a; b; r]) when n == H.not_and_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nand [not_ a; not_ b] env.clauses :: [] + | _ -> + let a_and_b = and_ a b in + mk_clause_cl Andn [a_and_b; not_ a; not_ b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; _; r]) when n == H.and_elim_1 -> + begin match app_name r with + | Some (n, [a; b; r]) when n == H.not_impl_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> mk_clause_cl Nimp1 [a] env.clauses :: [] + | _ -> + let a_impl_b = impl_ a b in + mk_clause_cl Impn1 [a_impl_b; a] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; r]) when n == H.not_or_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [id] when not env.ax -> mk_clause_cl Nor [not_ a] [id; 0] :: [] + | _ -> + let a_or_b = or_ a b in + mk_clause_cl Orn [a_or_b; not_ a] [0] :: env.clauses + in + { env with clauses } + + | _ -> + let env = lem env r in + let clauses = match env.clauses with + | [id] when not env.ax -> mk_clause_cl And [a] [id; 0] :: [] + | _ -> + let a_and_b = th_res r in + mk_clause_cl Andp [not_ a_and_b; a] [0] :: env.clauses + in + { env with clauses } + end + + | Some (n, [a; b; r]) when n == H.and_elim_2 -> + begin match app_name r with + | Some (n, [a; b; r]) when n == H.not_impl_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [_] when not env.ax -> + mk_clause_cl Nimp2 [not_ b] env.clauses :: [] + | _ -> + let a_impl_b = impl_ a b in + mk_clause_cl Impn2 [a_impl_b; not_ b] [] :: env.clauses + in + { env with clauses } + + | Some (n, [a; b; r]) when n == H.not_or_elim -> + let env = lem env r in + let clauses = match env.clauses with + | [id] when not env.ax -> mk_clause_cl Nor [not_ b] [id; 1] :: [] + | _ -> + let a_or_b = or_ a b in + mk_clause_cl Orn [a_or_b; not_ b] [1] :: env.clauses + in + { env with clauses } + + | _ -> + let env = lem env r in + let clauses = match env.clauses with + | [id] when not env.ax -> mk_clause_cl And [b] [id; 1] :: [] + | _ -> + let a_and_b = th_res r in + mk_clause_cl Andp [not_ a_and_b; b] [1] :: env.clauses + in + { env with clauses } + end + + (* Only handle symmetry rules when they are the only rule of the lemma *) + + | Some (n, [ty; a; b; r]) + when n == H.symm && toplevel && name r <> None -> + let env = lem env r in + let a_b = eq ty a b in + let b_a = eq ty b a in + + { env with + clauses = mk_clause_cl Eqtr [not_ a_b; b_a] [] :: env.clauses; + ax = true } + + | Some (n, [ty; a; b; r]) + when n == H.negsymm && toplevel && name r <> None -> + let env = lem env r in + let a_b = eq ty a b in + let b_a = eq ty b a in + + { env with + clauses = mk_clause_cl Eqtr [a_b; not_ b_a] [] :: env.clauses; + ax = true } + + (* Ignore other symmetry of equlity rules *) + | Some (n, [_; _; _; r]) when n == H.symm || n == H.negsymm -> + lem (rm_used env r) r + + (* Ignore double negation *) + | Some (n, [_; r]) when n == H.not_not_elim || n == H.not_not_intro -> + lem env r + + (* Should not be traversed anyway *) + | Some (n, [_; r]) when n == H.pred_eq_t || n == H.pred_eq_f -> + lem env r + + + | Some (n, [f]) when n == H.trust_f -> + begin match app_name f with + | Some (n, ty :: _) + when n == H.eq && + (match name ty with Some i -> i == H.tInt | None -> false) -> + (* trust are for lia lemma if equality between integers *) + { env with clauses = mk_clause_cl Lage [f] [] :: env.clauses } + | Some (n, [x]) when n == H.not_ -> + begin match app_name x with + | Some (n, ty :: _) + when n == H.eq && + (match name ty with Some i -> i == H.tInt | None -> false) -> + (* trust are for lia lemma if disequality between integers *) + { env with clauses = mk_clause_cl Lage [f] [] :: env.clauses } + | _ -> { env with clauses = mk_clause_cl Hole [f] [] :: env.clauses } + end + | _ -> { env with clauses = mk_clause_cl Hole [f] [] :: env.clauses } + end + + | Some (n, [_; _; _; _; r; w]) + when n == H.trans && + (match app_name w with + | Some (n, _) -> n == H.pred_eq_t || n == H.pred_eq_f + | _ -> false) + -> + (* Remember which direction of the implication we want for congruence over + predicates *) + let env = match app_name w with + | Some (n, [pt; x]) when n == H.pred_eq_t -> + let env = rm_used env x in + { env with mpred = MTerm.add pt false env.mpred } + | Some (n, [pt; x]) when n == H.pred_eq_f -> + let env = rm_used env x in + { env with mpred = MTerm.add pt true env.mpred } + | _ -> assert false + in + + lem env r + + + | Some (n, [ty; x; y; z; p1; p2]) + when n == H.negtrans || n == H.negtrans1 -> + + if term_equal x y || term_equal x z || term_equal y z then env + else + let env = lem env p2 in + let env = lem env p1 in + + let x_y = eq ty x y in + let y_z = eq ty y z in + let x_z = eq ty x z in + + { env with + clauses = mk_clause_cl Eqtr [x_y; not_ y_z; not_ x_z] [] :: env.clauses; + ax = true } + + | Some (n, [ty; x; y; z; p1; p2]) when n == H.negtrans2 -> + + if term_equal x y || term_equal x z || term_equal y z then env + else + let env = lem env p2 in + let env = lem env p1 in + + let x_y = eq ty x y in + let y_z = eq ty y z in + let x_z = eq ty x z in + + { env with + clauses = mk_clause_cl Eqtr [not_ x_y; y_z; not_ x_z] [] :: env.clauses; + ax = true } + + | Some (n, [ty; x; y; z; p1; p2]) when n == H.trans -> + (* | Some (("negtrans"|"negtrans1"), [ty; x; z; y; p1; p2]) *) + (* | Some ("negtrans2", [ty; y; x; z; p1; p2]) *) + + (* if Term.equal x y || Term.equal x z || Term.equal y z then env *) + (* else *) + + let neqs, env = trans [] env p in + let x_z = eq ty x z in + let cl = (neqs @ [x_z]) in + let id = mk_clause_cl Eqtr cl [] in + let id = mk_clause_cl ~reuse:false Weak cl [id] in + { env with + clauses = id :: env.clauses; + ax = true } + + (* | Some ("trans", [ty; x; y; z; p1; p2]) -> + + (* let clauses1 = lem mpred assum clauses p1 in *) + (* let clauses2 = lem mpred assum clauses p2 in *) + + (* TODO: intermediate resolution step *) + let clauses = lem mpred assum (lem mpred assum clauses p1) p2 in + + let x_y = th_res p1 in + let y_z = th_res p2 in + let x_z = eq ty x z in + let clauses = mk_clause_cl "eq_transitive" [not_ x_y; not_ y_z; x_z] [] :: clauses in + + + (* let cl1 = [th_res p1] in *) + (* let cl2 = [th_res p2] in *) + (* let clauses = [ *) + (* mk_inter_resolution cl1 clauses1; *) + (* mk_inter_resolution cl2 clauses2] *) + (* in *) + clauses + *) + + (* Congruence with predicates *) + | Some (n, [_; rty; pp; _; x; y; _; _]) + when n == H.cong && is_ty_Bool rty -> + + let neqs, env = cong [] env p in + let cptr, cpfa = match app_name (th_res p) with + | Some (n, [_; apx; apy]) when n == H.eq -> + (match MTerm.find apx env.mpred, MTerm.find apy env.mpred with + | true, false -> p_app apx, not_ (p_app apy) + | false, true -> p_app apy, not_ (p_app apx) + | true, true -> p_app apx, p_app apy + | false, false -> not_ (p_app apx), not_ (p_app apy) + ) + | _ -> assert false + in + let cl = neqs @ [cpfa; cptr] in + { env with + clauses = mk_clause_cl Eqcp cl [] :: env.clauses; + ax = true } + + (* Congruence *) + | Some (n, [_; _; _; _; _; _; _; _]) when n == H.cong -> + let neqs, env = cong [] env p in + let fx_fy = th_res p in + let cl = neqs @ [fx_fy] in + { env with + clauses = mk_clause_cl Eqco cl [] :: env.clauses; + ax = true } + + | Some (n, [_; _]) when n == H.refl -> + let x_x = th_res p in + { env with clauses = mk_clause_cl Eqre [x_x] [] :: env.clauses } + + | Some (n, [_; _; a; i; v]) when n == H.row1 -> + let raiwaiv = th_res p in + { env with clauses = mk_clause_cl Row1 [raiwaiv] [] :: env.clauses } + + | Some (n, [ti; _; i; j; a; v; r]) when n == H.row -> + let env = lem env r in + let i_eq_j = eq ti i j in + let pr1 = th_res p in + { env with + clauses = mk_clause_cl Row2 [i_eq_j; pr1] [] :: env.clauses; + ax = true} + + | Some (n, [ti; _; i; j; a; v; npr1]) when n == H.negativerow -> + let env = lem env npr1 in + let i_eq_j = eq ti i j in + let pr1 = match app_name (th_res p) with + | Some (n, [pr1]) when n == H.not_ -> pr1 + | _ -> assert false + in + { env with clauses = mk_clause_cl Row2 [i_eq_j; pr1] [] :: env.clauses } + + | Some (n, [_; x; y]) when n == H.bv_disequal_constants -> + { env with clauses = mk_clause_cl Bbdis [th_res p] [] :: env.clauses } + + | Some (rule, args) -> + eprintf "Warning: Introducing hole for unsupported rule %a@." + Hstring.print rule; + { env with clauses = mk_clause_cl Hole [th_res p] [] :: env.clauses } + + | None -> + + match name p with + + | Some n when n == H.truth -> + { env with clauses = mk_clause_cl True [ttrue] [] :: env.clauses } + + | Some h -> + (* should be an input clause *) + (try { env with clauses = get_input_id h :: env.clauses } + with Not_found -> + { env with + ax = true; + assum = List.filter (fun a -> a <> h) env.assum } + ) + + | None -> { env with ax = true } + + + + (** Returns the name given to this lemma, its type and the continuation. *) + let result_satlem p = match value p with + | Lambda ({sname=Name n} as s, r) -> + + begin match app_name s.stype with + | Some (n, [cl]) when n == H.holds -> n, cl, r + | _ -> assert false + end + + | _ -> assert false + + + (** Returns the clause used in a resolution step *) + let clause_qr p = + try match name p with + | Some n -> get_input_id n + | _ -> raise Not_found + with Not_found -> match app_name (deref p).ttype with + | Some (n, [cl]) when n == H.holds -> + (* eprintf "get_clause id : %a@." print_term cl; *) + get_clause_id (to_clause cl) + | _ -> raise Not_found + + + let rec reso_of_QR acc qr = match app_name qr with + | Some (n, [_; _; u1; u2; _]) when n == H.q || n == H.r -> + reso_of_QR (reso_of_QR acc u1) u2 + | _ -> clause_qr qr :: acc + + (** Returns clauses used in a linear resolution chain *) + let reso_of_QR qr = reso_of_QR [] qr |> List.rev + + + let rec reso_of_QR qr = match app_name qr with + | Some (n, [_; _; u1; u2; _]) when n == H.q || n == H.r -> + reso_of_QR u1 @ reso_of_QR u2 + | _ -> [clause_qr qr] + + let rec reso_of_QR depth acc qr = match app_name qr with + | Some (n, [_; _; u1; u2; _]) when n == H.q || n == H.r -> + let depth = depth + 1 in + reso_of_QR depth (reso_of_QR depth acc u1) u2 + | _ -> (depth, clause_qr qr) :: acc + + (** Returns clauses used in a linear resolution chain *) + let reso_of_QR qr = + reso_of_QR 0 [] qr + |> List.rev + |> List.stable_sort (fun (d1, _) (d2, _) -> d2 - d1) + |> List.map snd + + + (** convert resolution proofs of [satlem_simplify] *) + let satlem_simplify p = match app_name p with + | Some (n, [_; _; _; qr; p]) when n == H.satlem_simplify -> + let clauses = reso_of_QR qr in + let lem_name, res, p = result_satlem p in + let cl_res = to_clause res in + let id = mk_clause ~reuse:false Reso cl_res clauses in + register_clause_id cl_res id; + register_decl_id lem_name id; + Some id, p + | _ -> raise Exit + + + let rec many_satlem_simplify lastid p = + try + let lastid, p = satlem_simplify p in + many_satlem_simplify lastid p + with Exit -> lastid, p + + + (* can be empty, returns continuation *) + let satlem_simplifies_c p = + many_satlem_simplify None p |> snd + + + (* There must be at least one, returns id of last deduced clause *) + let reso_of_satlem_simplify p = + match many_satlem_simplify None p with + | Some id, _ -> id + | _ -> assert false + + + let rec bb_trim_intro_unit env p = match app_name p with + | Some (n, [_; _; _; ullit; _; l]) + when n == H.intro_assump_f || n == H.intro_assump_t -> + let env = rm_used env ullit in + (match value l with + | Lambda (_, p) -> bb_trim_intro_unit env p + | _ -> assert false) + | _ -> env, p + + + let is_last_bbres p = match app_name p with + | Some (n, [_; _; _; _; l]) when n == H.satlem_simplify -> + (match value l with + | Lambda ({sname=Name e}, pe) -> + (match name pe with Some ne -> ne = e | None -> false) + | _ -> false) + | _ -> false + + + let rec bb_lem_res lastid p = + try + if is_last_bbres p then raise Exit; + let lastid, p = satlem_simplify p in + bb_lem_res lastid p + with Exit -> match lastid with + | Some id -> id + | None -> assert false + + + let rec bb_lem env p = + let env, p = bb_trim_intro_unit env p in + let id = bb_lem_res None p in + { env with clauses = id :: env.clauses } + + + + exception ArithLemma + + (** Remove superfluous applications at the top of [satlem] and returns a list + of proofs whose resulting clauses need to be resolved. + + @raises {!ArithLemma} if the proof is a trust statement (we assume it is + the case for now). *) + let rec trim_junk_satlem p = match app_name p with + | Some (n, [p]) when n == H.clausify_false -> + (match name p with + | Some n when n == H.trust -> raise ArithLemma + | _ -> trim_junk_satlem p + ) + | Some (n, [_; p1; p2]) when n == H.contra -> + trim_junk_satlem p1 @ trim_junk_satlem p2 + | _ -> [p] + + + (** Returns the continuation of a [satlem]. *) + let continuation_satlem p = match value p with + | Lambda ({sname=Name n}, r) -> n, r + | _ -> assert false + + + let is_bbr_satlem_lam p = match value p with + | Lambda ({sname = Name h}, _) -> + (try String.sub (Hstring.view h) 0 5 = "bb.cl" + with Invalid_argument _ -> false) + | _ -> false + + let has_intro_bv p = match app_name p with + | Some (n, _) when n == H.intro_assump_f || n == H.intro_assump_t -> true + | _ -> false + + + let has_prefix p s = + try + for i = 0 to String.length p - 1 do + if p.[i] <> s.[i] then raise Exit + done; + true + with Exit | Invalid_argument _ -> false + + + (** Convert [satlem]. Clauses are chained together with an intermediate + resolution step when needed, and when CVC4 uses superfluous local + assumption, the clause is weakened. *) + let rec satlem ?(prefix_cont) p = + let old_p = p in + match app_name p with + + | Some (n, [c; _; l; p]) when n == H.satlem -> + (* eprintf "SATLEM ---@."; *) + let lem_name, lem_cont = continuation_satlem p in + begin match prefix_cont with + | Some pref when not (has_prefix pref (Hstring.view lem_name)) -> old_p + | _ -> + let cl = to_clause c in + (try + let assumptions, l = get_assumptions [] l in + let l = trim_junk_satlem l in + let env = { empty with assum = assumptions } in + let lem = + if is_bbr_satlem_lam p || List.exists has_intro_bv l then bb_lem + else lem ~toplevel:true in + let env = + List.fold_left (fun env p -> + let local_env = + { env with + clauses = []; + ax = false; + mpred = MTerm.empty; + } in + let local_env = lem local_env p in + { env with + clauses = List.rev_append local_env.clauses env.clauses; + assum = local_env.assum + } + ) env l + in + let clauses = List.rev env.clauses in + let id = mk_inter_resolution clauses in + (* eprintf "remaining assumptions:"; *) + (* List.iter (eprintf "%s, ") env.assu; *) + (* eprintf "@."; *) + (* if env.assum = [] then id else *) + let satlem_id = mk_clause Weak cl [id] in + register_clause_id cl satlem_id; + register_decl_id lem_name satlem_id; + (* eprintf "--- SATLEM@."; *) + + with ArithLemma -> + let satlem_id = mk_clause Lage cl [] in + register_clause_id cl satlem_id + + ); + + satlem ?prefix_cont lem_cont + end + + | Some (n, [_; _; _; _; l]) when n == H.satlem_simplify -> + (match value l with + | Lambda ({sname=Name _}, r) -> + (match name r with + | Some _ -> p + | None -> match app_name r with + | Some (n, _) when n == H.satlem_simplify -> p + | _ -> + (* Intermediate satlem_simplify *) + (* eprintf ">>>>>> intermediate satlemsimplify@."; *) + snd (satlem_simplify p) |> satlem ?prefix_cont + ) + | _ -> p) + + | _ -> p + + + let rec bbt p = match app_name p with + | Some (b, [n; v; bb]) when b == H.bv_bbl_var -> + let res = bblast_term n (a_var_bv n v) bb in + Some (mk_clause_cl Bbva [res] []) + | Some (b, [n; bb; bv]) when b == H.bv_bbl_const -> + let res = bblast_term n (a_bv n bv) bb in + Some (mk_clause_cl Bbconst [res] []) + | Some (rop, [n; x; y; _; _; rb; xbb; ybb]) + when rop == H.bv_bbl_bvand || + rop == H.bv_bbl_bvor || + rop == H.bv_bbl_bvxor || + rop == H.bv_bbl_bvadd || + rop == H.bv_bbl_bvmul || + rop == H.bv_bbl_bvult || + rop == H.bv_bbl_bvslt + -> + let bvop, rule = + if rop == H.bv_bbl_bvand then bvand, Bbop + else if rop == H.bv_bbl_bvor then bvor, Bbop + else if rop == H.bv_bbl_bvxor then bvxor, Bbop + else if rop == H.bv_bbl_bvadd then bvadd, Bbadd + else if rop == H.bv_bbl_bvmul then bvmul, Bbmul + else if rop == H.bv_bbl_bvult then bvult, Bbult + else if rop == H.bv_bbl_bvslt then bvslt, Bbslt + else assert false + in + let res = bblast_term n (bvop n x y) rb in + (match bbt xbb, bbt ybb with + | Some idx, Some idy -> + Some (mk_clause_cl rule [res] [idx; idy]) + | _ -> assert false + ) + + | Some (c, [n; x; _; rb; xbb]) when c == H.bv_bbl_bvnot -> + let res = bblast_term n (bvnot n x) rb in + (match bbt xbb with + | Some idx -> + Some (mk_clause_cl Bbnot [res] [idx]) + | _ -> assert false + ) + | Some (c, [n; x; _; rb; xbb]) when c == H.bv_bbl_bvneg -> + let res = bblast_term n (bvneg n x) rb in + (match bbt xbb with + | Some idx -> + Some (mk_clause_cl Bbneg [res] [idx]) + | _ -> assert false + ) + + | Some (c, [n; m; m'; x; y; _; _; rb; xbb; ybb]) + when c == H.bv_bbl_concat -> + let res = bblast_term n (concat n m m' x y) rb in + (match bbt xbb, bbt ybb with + | Some idx, Some idy -> + Some (mk_clause_cl Bbconc [res] [idx; idy]) + | _ -> assert false + ) + + | Some (c, [n; i; j; m; x; _; rb; xbb]) + when c == H.bv_bbl_extract -> + let res = bblast_term n (extract n i j m x) rb in + (match bbt xbb with + | Some idx -> + Some (mk_clause_cl Bbextr [res] [idx]) + | _ -> assert false + ) + + | Some (c, [n; k; m; x; _; rb; xbb]) + when c == H.bv_bbl_zero_extend -> + let res = bblast_term n (zero_extend n k m x) rb in + (match bbt xbb with + | Some idx -> + Some (mk_clause_cl Bbzext [res] [idx]) + | _ -> assert false + ) + + | Some (c, [n; k; m; x; _; rb; xbb]) + when c == H.bv_bbl_sign_extend -> + let res = bblast_term n (sign_extend n k m x) rb in + (match bbt xbb with + | Some idx -> + Some (mk_clause_cl Bbsext [res] [idx]) + | _ -> assert false + ) + + | None -> + begin match name p with + | Some h -> (* should be an declared clause *) + Some (try get_input_id h with Not_found -> assert false) + | None -> assert false + end + + | Some (rule, args) -> + eprintf "Warning: Introducing hole for unsupported rule %a@." + Hstring.print rule; + Some (mk_clause_cl Hole [ttype p] []) + + + + let rec bblast_decls p = match app_name p with + | Some (d, [n; b; t; bb; l]) when d == H.decl_bblast -> + (* let res = bblast_term n t b in *) + let id = match bbt bb with Some id -> id | None -> assert false in + begin match value l with + | Lambda ({sname = Name h}, p) -> + register_decl_id h id; + bblast_decls p + | _ -> assert false + end + + | Some (d, [n; b; t; a; bb; _; l]) when d == H.decl_bblast_with_alias -> + (* register_termalias a t; *) + (* begin match name a with *) + (* | Some n -> register_alias n t *) + (* | None -> () *) + (* end; *) + let id = match bbt bb with Some id -> id | None -> assert false in + begin match value l with + | Lambda ({sname = Name h}, p) -> + register_decl_id h id; + bblast_decls p + | _ -> assert false + end + + | _ -> p + + + let bv_pred n = + if n == H.bv_bbl_eq then Bbeq + else if n == H.bv_bbl_eq_swap then Bbeq + else if n == H.bv_bbl_bvult then Bbult + else if n == H.bv_bbl_bvslt then Bbslt + else assert false + + + let rec bblast_eqs p = match app_name p with + | Some (n, [f; pf; l]) when n == H.th_let_pf -> + begin match app_name pf with + | Some (rule_name, [_; _; _; _; _; _; a; b]) -> + begin match name a, name b with + | Some na, Some nb -> + let id1, id2 = + try get_input_id na, get_input_id nb + with Not_found -> assert false in + let clid = mk_clause_cl (bv_pred rule_name) [f] [id1; id2] in + begin match value l with + | Lambda ({sname = Name h}, p) -> + register_decl_id h clid; + bblast_eqs p + | _ -> assert false + end + | _ -> assert false + end + + | _ -> assert false + end + | _ -> p + + + (** Bit-blasting and bitvector proof conversion (returns rest of the sat + proof) *) + let bb_proof p = match app_name p with + | Some (n, _) when n == H.decl_bblast || n == H.decl_bblast_with_alias -> + p + |> bblast_decls + |> bblast_eqs + |> register_prop_vars + |> satlem ~prefix_cont:"bb." + |> satlem_simplifies_c + |> satlem + + | _ -> p + + + (** Convert an LFSC proof (this is the entry point) *) + let convert p = + p + + (* |> ignore_all_decls *) + (* |> produce_inputs_preproc *) + + |> ignore_decls + |> produce_inputs + + |> deferred + + |> admit_preproc + + |> register_prop_vars + |> satlem + + |> bb_proof + + |> reso_of_satlem_simplify + + + + let convert_pt p = + eprintf "Converting LFSC proof to SMTCoq...@?"; + let t0 = Sys.time () in + let r = convert p in + let t1 = Sys.time () in + eprintf " Done [%.3f s]@." (t1 -. t0); + r + + + + (** Clean global environments *) + let clear () = + Ast.clear_sc (); + T.clear () + + +end diff --git a/src/lfsc/hstring.ml b/src/lfsc/hstring.ml new file mode 100644 index 0000000..aa948e0 --- /dev/null +++ b/src/lfsc/hstring.ml @@ -0,0 +1,106 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Shashcons + +module S = + Shashcons.Make_consed(struct include String + let hash = Hashtbl.hash + let equal = (=) end) + +module HS = struct + + type t = string Shashcons.hash_consed + + let make s = S.hashcons s + + let view s = s.node + + let equal s1 s2 = s1.tag = s2.tag + + let compare s1 s2 = compare s1.tag s2.tag + + let hash s = s.tag + + let empty = make "" + + let rec list_assoc x = function + | [] -> raise Not_found + | (y, v) :: l -> if equal x y then v else list_assoc x l + + let rec list_assoc_inv x = function + | [] -> raise Not_found + | (y, v) :: l -> if equal x v then y else list_assoc_inv x l + + let rec list_mem_assoc x = function + | [] -> false + | (y, _) :: l -> compare x y = 0 || list_mem_assoc x l + + let rec list_mem x = function + | [] -> false + | y :: l -> compare x y = 0 || list_mem x l + + let compare_couple (x1,y1) (x2,y2) = + let c = compare x1 x2 in + if c <> 0 then c + else compare y1 y2 + + let rec compare_list l1 l2 = + match l1, l2 with + | [], [] -> 0 + | [], _ -> -1 + | _, [] -> 1 + | x::r1, y::r2 -> + let c = compare x y in + if c <> 0 then c + else compare_list r1 r2 + + let rec list_equal l1 l2 = + match l1, l2 with + | [], [] -> true + | [], _ -> false + | _, [] -> false + | x::r1, y::r2 -> equal x y && list_equal r1 r2 + + let rec list_mem_couple c = function + | [] -> false + | d :: l -> compare_couple c d = 0 || list_mem_couple c l + + let print fmt s = + Format.fprintf fmt "%s" (view s) + + let rec print_list sep fmt = function + | [] -> () + | [s] -> print fmt s + | s::r -> Format.fprintf fmt "%a%s%a" print s sep (print_list sep) r + +end + +include HS + +module H = Hashtbl.Make(HS) + +module HSet = Set.Make(HS) + +module HMap = Map.Make(HS) + +(* struct *) +(* include Hashtbl.Make(HS) *) + +(* let find x h = *) +(* TimeHS.start (); *) +(* try *) +(* let r = find x h in *) +(* TimeHS.pause (); *) +(* r *) +(* with Not_found -> TimeHS.pause (); raise Not_found *) +(* end *) diff --git a/src/lfsc/hstring.mli b/src/lfsc/hstring.mli new file mode 100644 index 0000000..7132c59 --- /dev/null +++ b/src/lfsc/hstring.mli @@ -0,0 +1,88 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(** Hash-consed strings + + Hash-consing is a technique to share values that are structurally + equal. More details on + {{:http://en.wikipedia.org/wiki/Hash_consing} Wikipedia} and + {{:http://www.lri.fr/~filliatr/ftp/publis/hash-consing2.pdf} here}. + + This module provides an easy way to use hash-consing for strings. +*) + +open Shashcons + +type t = string hash_consed +(** The type of Hash-consed string *) + +val make : string -> t +(** [make s] builds ans returns a hash-consed string from [s].*) + +val view : t -> string +(** [view hs] returns the string corresponding to [hs].*) + +val equal : t -> t -> bool +(** [equal x y] returns [true] if [x] and [y] are the same hash-consed string + (constant time).*) + +val compare : t -> t -> int +(** [compares x y] returns [0] if [x] and [y] are equal, and is unspecified + otherwise but provides a total ordering on hash-consed strings.*) + +val hash : t -> int +(** [hash x] returns the integer (hash) associated to [x].*) + +val empty : t +(** the empty ([""]) hash-consed string.*) + +val list_assoc : t -> (t * 'a) list -> 'a +(** [list_assoc x l] returns the element associated with [x] in the list of + pairs [l]. + @raise Not_found if there is no value associated with [x] in the list [l].*) + +val list_assoc_inv : t -> ('a * t) list -> 'a +(** [list_assoc_inv x l] returns the first element which is associated to [x] + in the list of pairs [l]. + @raise Not_found if there is no value associated to [x] in the list [l].*) + +val list_mem_assoc : t -> (t * 'a) list -> bool +(** Same as {! list_assoc}, but simply returns [true] if a binding exists, and + [false] if no bindings exist for the given key.*) + +val list_mem : t -> t list -> bool +(** [list_mem x l] is [true] if and only if [x] is equal to an element of [l].*) + +val list_mem_couple : t * t -> (t * t) list -> bool +(** [list_mem_couple (x,y) l] is [true] if and only if [(x,y)] is equal to an + element of [l].*) + +val compare_list : t list -> t list -> int +(** [compare_list l1 l2] returns [0] if and only if [l1] is equal to [l2].*) + +val list_equal : t list -> t list -> bool +(** [list_equal l1 l2] returns [true] if and only if [l1] is equal to [l2].*) + +val print : Format.formatter -> t -> unit +(** Prints a hash-consed strings on a formatter. *) + +val print_list : string -> Format.formatter -> t list -> unit +(** Prints a list of hash-consed strings on a formatter. *) + +module H : Hashtbl.S with type key = t +(** Hash-tables indexed by hash-consed strings *) + +module HSet : Set.S with type elt = t +(** Sets of hash-consed strings *) + +module HMap : Map.S with type key = t +(** Maps indexed by hash-consed strings *) diff --git a/src/lfsc/lfsc.ml b/src/lfsc/lfsc.ml new file mode 100644 index 0000000..0f9fd8d --- /dev/null +++ b/src/lfsc/lfsc.ml @@ -0,0 +1,506 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Format +open Entries +open Declare +open Decl_kinds + +open SmtMisc +open CoqTerms +open SmtForm +open SmtCertif +open SmtTrace +open SmtAtom + + +(******************************************************************************) +(* Given a lfsc trace build the corresponding certif and theorem *) +(******************************************************************************) + +(* Instantiate Converter with translator for SMTCoq *) +module C = Converter.Make (Tosmtcoq) + +exception No_proof + +(* Hard coded signatures *) +let signatures = + let sigdir = try Sys.getenv "LFSCSIGS" with Not_found -> Sys.getcwd () in + ["sat.plf"; + "smt.plf"; + "th_base.plf"; + "th_int.plf"; + "th_bv.plf"; + "th_bv_bitblast.plf"; + "th_bv_rewrites.plf"; + "th_arrays.plf" ] + |> List.map (Filename.concat sigdir) + + +let process_signatures_once = + let don = ref false in + fun () -> + if !don then () + else + try + (* don := true; *) + List.iter (fun f -> + let chan = open_in f in + let lexbuf = Lexing.from_channel chan in + LfscParser.ignore_commands LfscLexer.main lexbuf; + close_in chan + ) signatures + with + | Ast.TypingError (t1, t2) -> + Structures.error + (asprintf "@[<hov>LFSC typing error: expected %a, got %a@]@." + Ast.print_term t1 + Ast.print_term t2) + + +let lfsc_parse_last lb = + printf "Type-checking LFSC proof...@?"; + let t0 = Sys.time () in + let r = LfscParser.last_command LfscLexer.main lb in + let t1 = Sys.time () in + printf " Done [%.3f s]@." (t1 -. t0); + r + +let lfsc_parse_one lb = + printf "Type-checking LFSC proof...@?"; + let t0 = Sys.time () in + let r = LfscParser.one_command LfscLexer.main lb in + let t1 = Sys.time () in + printf " Done [%.3f s]@." (t1 -. t0); + r + + +let import_trace first parse lexbuf = + Printexc.record_backtrace true; + process_signatures_once (); + try + match parse lexbuf with + + | Some (Ast.Check p) -> + (* Ast.flatten_term p; *) + let confl_num = C.convert_pt p in + (* Afterwards, the SMTCoq libraries will produce the remaining, you do + not have to care *) + let first = + let aux = VeritSyntax.get_clause 1 in + match first, aux.value with + | Some (root,l), Some (fl::nil) -> + (* Format.eprintf "Root: %a ,,,,,,\n\ *) + (* input: %a@." *) + (* (Form.to_smt Atom.to_smt) l (Form.to_smt Atom.to_smt) fl; *) + if Form.equal l fl then + aux + else ( + (* eprintf "ADDING Flatten rule@."; *) + aux.kind <- Other (ImmFlatten(root,fl)); + SmtTrace.link root aux; + root + ) + | _,_ -> aux in + let confl = VeritSyntax.get_clause confl_num in + SmtTrace.select confl; + occur confl; + (alloc first, confl) + + | _ -> raise No_proof + + with + | Ast.TypingError (t1, t2) -> + Structures.error + (asprintf "@[<hov>LFSC typing error: expected %a, got %a@]@." + Ast.print_term t1 + Ast.print_term t2) + + + +let import_trace_from_file first filename = + let chan = open_in filename in + let lexbuf = Lexing.from_channel chan in + let p = import_trace first lfsc_parse_last lexbuf in + close_in chan; + p + + + +let clear_all () = + SmtTrace.clear (); + VeritSyntax.clear (); + C.clear () + + +let import_all fsmt fproof = + clear_all (); + let rt = SmtBtype.create () in + let ro = Op.create () in + let ra = VeritSyntax.ra in + let rf = VeritSyntax.rf in + let roots = Smtlib2_genConstr.import_smtlib2 rt ro ra rf fsmt in + let (max_id, confl) = import_trace_from_file None fproof in + (rt, ro, ra, rf, roots, max_id, confl) + + +let parse_certif t_i t_func t_atom t_form root used_root trace fsmt fproof = + SmtCommands.parse_certif t_i t_func t_atom t_form root used_root trace + (import_all fsmt fproof) + +let checker_debug fsmt fproof = + SmtCommands.checker_debug (import_all fsmt fproof) + +let theorem name fsmt fproof = + SmtCommands.theorem name (import_all fsmt fproof) + +let checker fsmt fproof = + SmtCommands.checker (import_all fsmt fproof) + +(* Same but print runtime *) +let checker fsmt fproof = + let c = import_all fsmt fproof in + printf "Coq checker...@."; + let t0 = Sys.time () in + let r = SmtCommands.checker c in + let t1 = Sys.time () in + printf "Done (Coq) [%.3f s]@." (t1 -. t0); + r + + + +(******************************************************************************) +(** Given a Coq formula build the proof *) +(******************************************************************************) + + +(* module Form2 = struct *) +(* (\* Just for printing *\) *) + +(* open Form *) + +(* let rec to_smt atom_to_smt fmt f = *) +(* if is_pos f then to_smt_pform atom_to_smt fmt (pform f) *) +(* else fprintf fmt "(not %a)" (to_smt_pform atom_to_smt) (pform f) *) + +(* and to_smt_pform atom_to_smt fmt = function *) +(* | Fatom a -> atom_to_smt fmt a *) +(* | Fapp (op,args) -> to_smt_op atom_to_smt op fmt (Array.to_list args) *) +(* | _ -> assert false *) + +(* and to_smt_op atom_to_smt op fmt args = *) +(* match op, args with *) +(* | Ftrue, [] -> fprintf fmt "true" *) +(* | Ffalse, [] -> fprintf fmt "false" *) +(* | Fand, [x; y] -> *) +(* fprintf fmt "(and %a %a)" (to_smt atom_to_smt) x (to_smt atom_to_smt) y *) +(* | For, [x; y] -> *) +(* fprintf fmt "(or %a %a)" (to_smt atom_to_smt) x (to_smt atom_to_smt) y *) +(* | Fand, x :: rargs -> *) +(* fprintf fmt "(and %a %a)" (to_smt atom_to_smt) x *) +(* (to_smt_op atom_to_smt Fand) rargs *) +(* | For, x :: rargs -> *) +(* fprintf fmt "(or %a %a)" (to_smt atom_to_smt) x *) +(* (to_smt_op atom_to_smt For) rargs *) +(* (\* andb and orb are left-associative in Coq *\) *) +(* (\* | Fand, _ -> left_assoc atom_to_smt Fand fmt (List.rev args) *\) *) +(* (\* | For, _ -> left_assoc atom_to_smt For fmt (List.rev args) *\) *) +(* | Fxor, _ -> *) +(* fprintf fmt "(xor%a)" *) +(* (fun fmt -> List.iter (fprintf fmt " %a" (to_smt atom_to_smt))) args *) +(* | Fimp, _ -> *) +(* fprintf fmt "(=>%a)" *) +(* (fun fmt -> List.iter (fprintf fmt " %a" (to_smt atom_to_smt))) args *) +(* | Fiff, _ -> *) +(* fprintf fmt "(=%a)" *) +(* (fun fmt -> List.iter (fprintf fmt " %a" (to_smt atom_to_smt))) args *) +(* | Fite, _ -> *) +(* fprintf fmt "(ite%a)" *) +(* (fun fmt -> List.iter (fprintf fmt " %a" (to_smt atom_to_smt))) args *) +(* | Fnot2 _, _ -> *) +(* fprintf fmt "(not (not %a))" *) +(* (fun fmt -> List.iter (fprintf fmt " %a" (to_smt atom_to_smt))) args *) +(* | _ -> assert false *) + +(* and left_assoc atom_to_smt op fmt args = *) +(* (\* args is reversed *\) *) +(* match op, args with *) +(* | Fand, [x; y] -> *) +(* fprintf fmt "(and %a %a)" (to_smt atom_to_smt) y (to_smt atom_to_smt) x *) +(* | For, [x; y] -> *) +(* fprintf fmt "(or %a %a)" (to_smt atom_to_smt) y (to_smt atom_to_smt) x *) +(* | Fand, last :: rargs -> *) +(* fprintf fmt "(and %a %a)" *) +(* (left_assoc atom_to_smt Fand) rargs (to_smt atom_to_smt) last *) +(* | For, last :: rargs -> *) +(* fprintf fmt "(or %a %a)" *) +(* (left_assoc atom_to_smt For) rargs (to_smt atom_to_smt) last *) +(* | _ -> assert false *) + +(* end *) + + +(* module Atom2 = struct *) +(* (\* Just for printing *\) *) + +(* open Atom *) + +(* let distrib x l = List.map (fun y -> (x,y)) l *) + +(* let rec cross acc l = match l with *) +(* | [] | [_] -> List.rev acc *) +(* | x :: r -> *) +(* cross (List.rev_append (distrib x r) acc) r *) + +(* let cross = cross [] *) + +(* let rec compute_int = function *) +(* | Acop c -> *) +(* (match c with *) +(* | CO_xH -> 1 *) +(* | CO_Z0 -> 0 *) +(* | CO_BV _ -> assert false) *) +(* | Auop (op,h) -> *) +(* (match op with *) +(* | UO_xO -> 2*(compute_hint h) *) +(* | UO_xI -> 2*(compute_hint h) + 1 *) +(* | UO_Zpos -> compute_hint h *) +(* | UO_Zneg -> - (compute_hint h) *) +(* | _ -> assert false) *) +(* | _ -> assert false *) + +(* and compute_hint h = compute_int (atom h) *) + +(* let to_smt_int fmt i = *) +(* let s1 = if i < 0 then "(- " else "" in *) +(* let s2 = if i < 0 then ")" else "" in *) +(* let j = if i < 0 then -i else i in *) +(* fprintf fmt "%s%i%s" s1 j s2 *) + +(* let rec to_smt fmt h = to_smt_atom fmt (atom h) *) + +(* and to_smt_atom fmt = function *) +(* | Acop _ as a -> to_smt_int fmt (compute_int a) *) +(* | Auop (UO_Zopp,h) -> *) +(* fprintf fmt "(- "; *) +(* to_smt fmt h; *) +(* fprintf fmt ")" *) +(* | Auop _ as a -> to_smt_int fmt (compute_int a) *) +(* | Abop (op,h1,h2) -> to_smt_bop fmt op h1 h2 *) +(* | Atop (op,h1,h2,h3) -> to_smt_bop fmt op h1 h2 h3 *) +(* | Anop (op,a) -> to_smt_nop fmt op a *) +(* | Aapp (op,a) -> *) +(* if Array.length a = 0 then ( *) +(* fprintf fmt "op_%i" (indexed_op_index op); *) +(* ) else ( *) +(* fprintf fmt "(op_%i" (indexed_op_index op); *) +(* Array.iter (fun h -> fprintf fmt " "; to_smt fmt h) a; *) +(* fprintf fmt ")" *) +(* ) *) + +(* and str_op = function *) +(* | BO_Zplus -> "+" *) +(* | BO_Zminus -> "-" *) +(* | BO_Zmult -> "*" *) +(* | BO_Zlt -> "<" *) +(* | BO_Zle -> "<=" *) +(* | BO_Zge -> ">=" *) +(* | BO_Zgt -> ">" *) +(* | BO_eq _ -> "=" *) + +(* and to_smt_bop fmt op h1 h2 = *) +(* match op with *) +(* | BO_Zlt -> fprintf fmt "(not (>= %a %a)" to_smt h1 to_smt h2 *) +(* | BO_Zle -> fprintf fmt "(not (>= %a (+ %a 1))" to_smt h1 to_smt h2 *) +(* | BO_Zgt -> fprintf fmt "(>= %a (+ %a 1)" to_smt h1 to_smt h2 *) +(* | _ -> fprintf fmt "(%s %a %a)" (str_op op) to_smt h1 to_smt h2 *) + +(* and to_smt_nop fmt op a = *) +(* let rec pp fmt = function *) +(* | [] -> assert false *) +(* | [x, y] -> fprintf fmt "(not (= %a %a))" to_smt x to_smt y *) +(* | (x, y) :: r -> *) +(* fprintf fmt "(and (not (= %a %a)) %a)" to_smt x to_smt y pp r *) +(* in *) +(* let pairs = cross (Array.to_list a) in *) +(* pp fmt pairs *) + +(* end *) + +let string_logic ro f = + let l = SL.union (Op.logic_ro ro) (Form.logic f) in + if SL.is_empty l then "QF_SAT" + else + sprintf "QF_%s%s%s%s" + (if SL.mem LArrays l then "A" else "") + (if SL.mem LUF l || SL.mem LLia l then "UF" else "") + (if SL.mem LBitvectors l then "BV" else "") + (if SL.mem LLia l then "LIA" else "") + + + +let call_cvc4 env rt ro ra rf root _ = + let open Smtlib2_solver in + let fl = snd root in + + let cvc4 = create [| + "cvc4"; + "--lang"; "smt2"; + "--proof"; + "--no-simplification"; "--fewer-preprocessing-holes"; + "--no-bv-eq"; "--no-bv-ineq"; "--no-bv-algebraic" |] in + + set_option cvc4 "print-success" true; + set_option cvc4 "produce-assignments" true; + set_option cvc4 "produce-proofs" true; + set_logic cvc4 (string_logic ro fl); + + List.iter (fun (i,t) -> + let s = "Tindex_"^(string_of_int i) in + VeritSyntax.add_btype s (SmtBtype.Tindex t); + declare_sort cvc4 s 0; + ) (SmtBtype.to_list rt); + + List.iter (fun (i,cod,dom,op) -> + let s = "op_"^(string_of_int i) in + VeritSyntax.add_fun s op; + let args = + Array.fold_right + (fun t acc -> asprintf "%a" SmtBtype.to_smt t :: acc) cod [] in + let ret = asprintf "%a" SmtBtype.to_smt dom in + declare_fun cvc4 s args ret + ) (Op.to_list ro); + + assume cvc4 (asprintf "%a" (Form.to_smt Atom.to_smt) fl); + + let proof = + match check_sat cvc4 with + | Unsat -> + begin + try get_proof cvc4 (import_trace (Some root) lfsc_parse_one) + with + | Ast.CVC4Sat -> Structures.error "CVC4 returned SAT" + | No_proof -> Structures.error "CVC4 did not generate a proof" + | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + end + | Sat -> + let smodel = get_model cvc4 in + Structures.error + ("CVC4 returned sat. Here is the model:\n\n" ^ + SmtCommands.model_string env rt ro ra rf smodel) + (* (asprintf "CVC4 returned sat. Here is the model:\n%a" SExpr.print smodel) *) + in + + quit cvc4; + proof + + + +let export out_channel rt ro l = + let fmt = formatter_of_out_channel out_channel in + fprintf fmt "(set-logic %s)@." (string_logic ro l); + + List.iter (fun (i,t) -> + let s = "Tindex_"^(string_of_int i) in + VeritSyntax.add_btype s (SmtBtype.Tindex t); + fprintf fmt "(declare-sort %s 0)@." s + ) (SmtBtype.to_list rt); + + List.iter (fun (i,cod,dom,op) -> + let s = "op_"^(string_of_int i) in + VeritSyntax.add_fun s op; + fprintf fmt "(declare-fun %s (" s; + let is_first = ref true in + Array.iter (fun t -> + if !is_first then is_first := false + else fprintf fmt " "; SmtBtype.to_smt fmt t + ) cod; + fprintf fmt ") %a)@." SmtBtype.to_smt dom; + ) (Op.to_list ro); + + fprintf fmt "(assert %a)@\n(check-sat)@\n(exit)@." + (Form.to_smt Atom.to_smt) l + + + +let get_model_from_file filename = + let chan = open_in filename in + let lexbuf = Lexing.from_channel chan in + match SExprParser.sexps SExprLexer.main lexbuf with + | [SExpr.Atom "sat"; m] -> m + | _ -> Structures.error "CVC4 returned SAT but no model" + + +let call_cvc4_file env rt ro ra rf root = + let fl = snd root in + let (filename, outchan) = Filename.open_temp_file "cvc4_coq" ".smt2" in + export outchan rt ro fl; + close_out outchan; + let bf = Filename.chop_extension filename in + let prooffilename = bf ^ ".lfsc" in + + (* let cvc4_cmd = *) + (* "cvc4 --proof --dump-proof -m --dump-model \ *) + (* --no-simplification --fewer-preprocessing-holes \ *) + (* --no-bv-eq --no-bv-ineq --no-bv-algebraic " *) + (* ^ filename ^ " > " ^ prooffilename in *) + (* CVC4 crashes when asking for both models and proofs *) + + let cvc4_cmd = + "cvc4 --proof --dump-proof \ + --no-simplification --fewer-preprocessing-holes \ + --no-bv-eq --no-bv-ineq --no-bv-algebraic " + ^ filename ^ " > " ^ prooffilename in + (* let clean_cmd = "sed -i -e '1d' " ^ prooffilename in *) + eprintf "%s@." cvc4_cmd; + let t0 = Sys.time () in + let exit_code = Sys.command cvc4_cmd in + + let t1 = Sys.time () in + eprintf "CVC4 = %.5f@." (t1-.t0); + + if exit_code <> 0 then + Structures.error ("CVC4 crashed: return code "^string_of_int exit_code); + + (* ignore (Sys.command clean_cmd); *) + + try import_trace_from_file (Some root) prooffilename + with + | No_proof -> Structures.error "CVC4 did not generate a proof" + | Failure s -> Structures.error ("Importing of proof failed: " ^ s) + | Ast.CVC4Sat -> + let smodel = get_model_from_file prooffilename in + Structures.error + ("CVC4 returned sat. Here is the model:\n\n" ^ + SmtCommands.model_string env rt ro ra rf smodel) + + +let cvc4_logic = + SL.of_list [LUF; LLia; LBitvectors; LArrays] + + +let tactic_gen vm_cast = + clear_all (); + let rt = SmtBtype.create () in + let ro = Op.create () in + let ra = VeritSyntax.ra in + let rf = VeritSyntax.rf in + let ra' = VeritSyntax.ra in + let rf' = VeritSyntax.rf in + SmtCommands.tactic call_cvc4 cvc4_logic rt ro ra rf ra' rf' vm_cast [] [] + (* let ra = VeritSyntax.ra in + * let rf = VeritSyntax.rf in + * (\* Currently, quantifiers are not handled by the cvc4 tactic: we pass + * the same ra and rf twice to have everything reifed *\) + * SmtCommands.tactic call_cvc4 cvc4_logic rt ro ra rf ra rf vm_cast [] [] *) +let tactic () = tactic_gen vm_cast_true +let tactic_no_check () = tactic_gen (fun _ -> vm_cast_true_no_check) diff --git a/src/lfsc/lfscLexer.mll b/src/lfsc/lfscLexer.mll new file mode 100644 index 0000000..3e8d5f9 --- /dev/null +++ b/src/lfsc/lfscLexer.mll @@ -0,0 +1,357 @@ +{ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(* This parser is adapted from Jane Street sexplib parser *) + + open Printf + open Lexing + open LfscParser + + let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + + let lf = '\010' + + let dec_code c1 c2 c3 = + 100 * (Char.code c1 - 48) + 10 * (Char.code c2 - 48) + (Char.code c3 - 48) + + let hex_code c1 c2 = + let d1 = Char.code c1 in + let val1 = + if d1 >= 97 then d1 - 87 + else if d1 >= 65 then d1 - 55 + else d1 - 48 in + let d2 = Char.code c2 in + let val2 = + if d2 >= 97 then d2 - 87 + else if d2 >= 65 then d2 - 55 + else d2 - 48 in + val1 * 16 + val2 + + let found_newline ({ lex_curr_p; _ } as lexbuf) diff = + lexbuf.lex_curr_p <- + { + lex_curr_p with + pos_lnum = lex_curr_p.pos_lnum + 1; + pos_bol = lex_curr_p.pos_cnum - diff; + } + + (* same length computation as in [Lexing.lexeme] *) + let lexeme_len { lex_start_pos; lex_curr_pos; _ } = lex_curr_pos - lex_start_pos + + let main_failure lexbuf msg = + let { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } = lexeme_start_p lexbuf in + let msg = + sprintf + "Sexplib.Lexer.main: %s at line %d char %d" + msg pos_lnum (pos_cnum - pos_bol) + in + failwith msg + + module type T = sig + module Quoted_string_buffer : sig + type t + val create : int -> t + val add_char : t -> char -> unit + val add_substring : t -> string -> int -> int -> unit + val add_lexeme : t -> lexbuf -> unit + val clear : t -> unit + val of_buffer : Buffer.t -> t + end + module Token : sig + type t + val lparen : t + val rparen : t + val lambda : t + val biglam : t + val pi : t + val colon : t + val hole : t + val sc : t + val at : t + val integer : string -> t + val ident : string -> t + val eof : t + val simple_string : string -> t + val hash_semi : t + val quoted_string : Lexing.position -> Quoted_string_buffer.t -> t + type s = Quoted_string_buffer.t -> Lexing.lexbuf -> t + val comment : string -> main:s -> s + val block_comment : Lexing.position -> main:s -> s + end + end + + + (* Create and populate a hashtable *) + let mk_hashtbl init = + let tbl = List.length init |> Hashtbl.create in + init |> List.iter (fun (k, v) -> Hashtbl.add tbl k v) ; + tbl + + let keywords = mk_hashtbl [ + ("check", CHECK); + ("define", DEFINE); + ("declare", DECLARE); + ("type", TYPE); + ("kind", KIND); + ("mpz", MPZ); + ("mpq", MPQ); + ("program", PROGRAM); + ("unsat", UNSAT); + ("sat", SAT); + ] + + module Make (X : T) : sig + val main : ?buf:Buffer.t -> Lexing.lexbuf -> X.Token.t + end = struct (* BEGIN FUNCTOR BODY CONTAINING GENERATED CODE *) + open X + +} + +let lf = '\010' +let lf_cr = ['\010' '\013'] +let dos_newline = "\013\010" +let blank = [' ' '\009' '\012'] +let unquoted = [^ ';' '(' ')' '"' '\\' ':' '@' '!' ] # blank # lf_cr +let digit = ['0'-'9'] +let hexdigit = digit | ['a'-'f' 'A'-'F'] + +let unquoted_start = + unquoted # ['#' '|'] | '#' unquoted # ['|'] | '|' unquoted # ['#'] + +let integer = digit+ +let ident = ('_')* ['a'-'z' 'A'-'Z' '\'' ]['a'-'z' 'A'-'Z' '0'-'9' '\\' '_']* + + +rule main buf = parse + | lf | dos_newline { found_newline lexbuf 0; + main buf lexbuf } + | blank+ { main buf lexbuf } + | (';' (_ # lf_cr)*) as text { Token.comment text ~main buf lexbuf } + | '(' { Token.lparen } + | ')' { Token.rparen } + | '\\' { Token.lambda } + | '!' { Token.pi } + | '%' { Token.biglam } + | '_' { Token.hole } + | ':' { Token.colon } + | '^' { Token.sc } + | '@' { Token.at } + | '(' '~' (integer as i) ')' {Token.integer ("-"^i) } + | integer as i { Token.integer i } + | '"' + { + let pos = Lexing.lexeme_start_p lexbuf in + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf pos lexbuf; + let tok = Token.quoted_string pos buf in + Quoted_string_buffer.clear buf; + tok + } + | "#;" { Token.hash_semi } + | "#|" + { + let pos = Lexing.lexeme_start_p lexbuf in + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_block_comment buf [pos] lexbuf; + let tok = Token.block_comment pos ~main buf lexbuf in + Quoted_string_buffer.clear buf; + tok + } + | "|#" { main_failure lexbuf "illegal end of comment" } + | "#" "#"+ "|" unquoted* (* unquoted_start can match ##, so ##| (which should be + refused) would not not be parsed by this case if the regexp + on the left was not there *) + | "|" "|"+ "#" unquoted* + | unquoted_start unquoted* ("#|" | "|#") unquoted* + { main_failure lexbuf "comment tokens in unquoted atom" } + | "#" | "|" | unquoted_start unquoted* as str { Token.simple_string str } + | eof { Token.eof } + +and scan_string buf start = parse + | '"' { Quoted_string_buffer.add_lexeme buf lexbuf; () } + | '\\' lf [' ' '\t']* + { + let len = lexeme_len lexbuf - 2 in + found_newline lexbuf len; + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | '\\' dos_newline [' ' '\t']* + { + let len = lexeme_len lexbuf - 3 in + found_newline lexbuf len; + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | '\\' (['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as c) + { + Quoted_string_buffer.add_char buf (char_for_backslash c); + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | '\\' (digit as c1) (digit as c2) (digit as c3) + { + let v = dec_code c1 c2 c3 in + if v > 255 then ( + let { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } = lexeme_end_p lexbuf in + let msg = + sprintf + "Sexplib.Lexer.scan_string: \ + illegal escape at line %d char %d: `\\%c%c%c'" + pos_lnum (pos_cnum - pos_bol - 3) + c1 c2 c3 in + failwith msg); + Quoted_string_buffer.add_char buf (Char.chr v); + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | '\\' 'x' (hexdigit as c1) (hexdigit as c2) + { + let v = hex_code c1 c2 in + Quoted_string_buffer.add_char buf (Char.chr v); + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | '\\' (_ as c) + { + Quoted_string_buffer.add_char buf '\\'; + Quoted_string_buffer.add_char buf c; + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | lf + { + found_newline lexbuf 0; + Quoted_string_buffer.add_char buf lf; + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | ([^ '\\' '"'] # lf)+ + { + let ofs = lexbuf.lex_start_pos in + let len = lexbuf.lex_curr_pos - ofs in + Quoted_string_buffer.add_substring buf lexbuf.lex_buffer ofs len; + Quoted_string_buffer.add_lexeme buf lexbuf; + scan_string buf start lexbuf + } + | eof + { + let msg = + sprintf + "Sexplib.Lexer.scan_string: unterminated string at line %d char %d" + start.pos_lnum (start.pos_cnum - start.pos_bol) + in + failwith msg + } + +and scan_block_comment buf locs = parse + | ('#'* | '|'*) lf + { Quoted_string_buffer.add_lexeme buf lexbuf; + found_newline lexbuf 0; scan_block_comment buf locs lexbuf } + | (('#'* | '|'*) [^ '"' '#' '|'] # lf)+ + { Quoted_string_buffer.add_lexeme buf lexbuf; + scan_block_comment buf locs lexbuf } + | ('#'* | '|'*) '"' + { + Quoted_string_buffer.add_lexeme buf lexbuf; + let cur = lexeme_end_p lexbuf in + let start = { cur with pos_cnum = cur.pos_cnum - 1 } in + scan_string buf start lexbuf; + scan_block_comment buf locs lexbuf + } + | '#'+ '|' + { + Quoted_string_buffer.add_lexeme buf lexbuf; + let cur = lexeme_end_p lexbuf in + let start = { cur with pos_cnum = cur.pos_cnum - 2 } in + scan_block_comment buf (start :: locs) lexbuf + } + | '|'+ '#' + { + Quoted_string_buffer.add_lexeme buf lexbuf; + match locs with + | [_] -> () (* the comment is finished *) + | _ :: (_ :: _ as t) -> scan_block_comment buf t lexbuf + | [] -> assert false (* impossible *) + } + | eof + { + match locs with + | [] -> assert false + | { pos_lnum; pos_bol; pos_cnum; pos_fname = _ } :: _ -> + let msg = + sprintf "Sexplib.Lexer.scan_block_comment: \ + unterminated block comment at line %d char %d" + pos_lnum (pos_cnum - pos_bol) + in + failwith msg + } + +{ (* RESUME FUNCTOR BODY CONTAINING GENERATED CODE *) + + let main ?buf = + let buf = + match buf with + | None -> Quoted_string_buffer.create 64 + | Some buf -> + Buffer.clear buf; + Quoted_string_buffer.of_buffer buf + in + main buf + + end (* END FUNCTOR BODY CONTAINING GENERATED CODE *) + + module Vanilla = + Make (struct + module Quoted_string_buffer = struct + include Buffer + let add_lexeme _ _ = () + let of_buffer b = b + end + module Token = struct + open LfscParser + type t = token + type s = Quoted_string_buffer.t -> Lexing.lexbuf -> t + let eof = EOF + let lparen = LPAREN + let rparen = RPAREN + let lambda = LAMBDA + let pi = PI + let biglam = BIGLAMBDA + let hole = HOLE + let colon = COLON + let sc = SC + let at = AT + let hash_semi = HASH_SEMI + let integer i = INT (Big_int.big_int_of_string i) + let ident i = + try Hashtbl.find keywords i with Not_found -> STRING i + let simple_string x = + try Hashtbl.find keywords x with Not_found -> STRING x + let quoted_string _ buf = STRING (Buffer.contents buf) + let block_comment _pos ~main buf lexbuf = + main buf lexbuf + let comment _text ~main buf lexbuf = + main buf lexbuf (* skip and continue lexing *) + end + end) + + + let main = Vanilla.main + +} diff --git a/src/lfsc/lfscParser.mly b/src/lfsc/lfscParser.mly new file mode 100644 index 0000000..26de090 --- /dev/null +++ b/src/lfsc/lfscParser.mly @@ -0,0 +1,347 @@ +%{ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(* This parser is adapted from Jane Street sexplib parser *) + +open Ast +open Lexing +open Format +open Builtin + +let parse_failure what = + let pos = Parsing.symbol_start_pos () in + let msg = + Printf.sprintf "Sexplib.Parser: failed to parse line %d char %d: %s" + pos.pos_lnum (pos.pos_cnum - pos.pos_bol) what in + failwith msg + +let scope = ref [] + +let renamings = Hashtbl.create 21 + +let register_rename = Hashtbl.add renamings + +let remove_rename = Hashtbl.remove renamings + + + +%} + +%token <string> STRING +%token <Big_int.big_int> INT +%token LPAREN RPAREN EOF HASH_SEMI +%token LAMBDA PI BIGLAMBDA COLON +%token CHECK DEFINE DECLARE +%token MPQ MPZ HOLE TYPE KIND +%token SC PROGRAM AT UNSAT SAT + +%start proof +%type <Ast.proof> proof + +%start last_command +%type <Ast.command option> last_command + +%start ignore_commands +%type <unit> ignore_commands + +%start proof_print +%type <unit> proof_print + +%start proof_ignore +%type <unit> proof_ignore + +%start one_command +%type <Ast.command option> one_command + +%start sexp +%type <Type.t> sexp + +%start sexp_opt +%type <Type.t option> sexp_opt + +%start sexps +%type <Type.t list> sexps + +%start rev_sexps +%type <Type.t list> rev_sexps + +%% +sexp: +| sexp_comments sexp_but_no_comment { $2 } +| sexp_but_no_comment { $1 } + +sexp_but_no_comment + : STRING { Type.Atom $1 } + | LPAREN RPAREN { Type.List [] } + | LPAREN rev_sexps_aux RPAREN { Type.List (List.rev $2) } + | error { parse_failure "sexp" } + +sexp_comment + : HASH_SEMI sexp_but_no_comment { () } + | HASH_SEMI sexp_comments sexp_but_no_comment { () } + +sexp_comments + : sexp_comment { () } + | sexp_comments sexp_comment { () } + +sexp_opt + : sexp_but_no_comment { Some $1 } + | sexp_comments sexp_but_no_comment { Some $2 } + | EOF { None } + | sexp_comments EOF { None } + +rev_sexps_aux + : sexp_but_no_comment { [$1] } + | sexp_comment { [] } + | rev_sexps_aux sexp_but_no_comment { $2 :: $1 } + | rev_sexps_aux sexp_comment { $1 } + +rev_sexps + : rev_sexps_aux EOF { $1 } + | EOF { [] } + +sexps + : rev_sexps_aux EOF { List.rev $1 } + | EOF { [] } +; + + +atom_ignore: + | STRING {} + | CHECK {} + | DEFINE {} + | DECLARE {} + | TYPE {} + | KIND {} + | MPZ {} + | MPQ {} + | PROGRAM {} + | INT {} + | LAMBDA {} + | PI {} + | HOLE {} + | SC {} + | AT {} + | COLON {} +; + +sexp_ignore : + | atom_ignore {} + | LPAREN ignore_sexp_list RPAREN {} +; + +ignore_sexp_list : + | { } + | sexp_ignore ignore_sexp_list { } +; + + +term_list: + | term { [$1]} + | term term_list { $1 :: $2 } +; + +binding: + | STRING term { + let n = String.concat "." (List.rev ($1 :: !scope)) in + let s = mk_symbol n $2 in + register_symbol s; + register_rename $1 n; + s, $1 + } +; + +untyped_sym: + | STRING { + let s = mk_symbol $1 (mk_hole_hole ()) in + register_symbol s; + s + } +; + +let_binding: + | STRING term { + let x = $1 in + let t = $2 in + let s = mk_symbol x t.ttype in + register_symbol s; + add_definition s.sname t; + s.sname + } +; + +/* +ignore_string_or_hole: + | STRING { } + | HOLE { } +; +*/ + +term: + | TYPE { lfsc_type } + | KIND { kind } + | MPQ { mpq } + | MPZ { mpz } + | INT { mk_mpz $1 } + | STRING + { + let n = try Hashtbl.find renamings $1 with Not_found -> $1 in + mk_const n + } + | HOLE { mk_hole_hole () } + | LPAREN AT let_binding term RPAREN { remove_definition $3; $4 } + | LPAREN term term_list RPAREN { mk_app $2 $3 } + | LPAREN LAMBDA untyped_sym term RPAREN + { let s = $3 in + let t = $4 in + let r = mk_lambda s t in + remove_symbol s; + r + } + | LPAREN LAMBDA HOLE term RPAREN + { let s = mk_symbol_hole (mk_hole_hole ()) in + let t = $4 in + mk_lambda s t } + | LPAREN BIGLAMBDA binding term RPAREN + { let s, old = $3 in + let t = $4 in + let r = mk_lambda s t in + remove_symbol s; + remove_rename old; + r + } + | LPAREN BIGLAMBDA HOLE term term RPAREN + { let t = $5 in + let s = mk_symbol_hole $4 in + mk_lambda s t } + | LPAREN PI binding term RPAREN + { let s, old = $3 in + let t = $4 in + let r = mk_pi s t in + remove_symbol s; + remove_rename old; + r + } + | LPAREN PI HOLE term term RPAREN + { let s = mk_symbol_hole $4 in + let t = $5 in + mk_pi s t } + | LPAREN PI STRING /* ignore_string_or_hole */ + LPAREN SC LPAREN STRING term_list RPAREN term RPAREN term RPAREN + { + add_sc $7 $8 $10 $12 + } + | LPAREN COLON term term RPAREN + { mk_ascr $3 $4 } +; + + + +declare: + | DECLARE STRING { scope := [$2]; $2 } +; + +define: + | DEFINE STRING { scope := [$2]; $2 } +; + +declare_command: + | LPAREN declare term RPAREN { + mk_declare $2 $3; + scope := []; + Declare (Hstring.make $2, $3) + } +; + + +define_command: + | LPAREN define term RPAREN { + mk_define $2 $3; + scope := []; + Define (Hstring.make $2, $3) } +; + +check_command: + | LPAREN CHECK term RPAREN { + mk_check $3; + Check $3 } +; + +command: + | check_command { $1 } + | define_command { $1 } + | declare_command { $1 } +; + +command_print: + | command { printf "@[<hov 1>%a@]@\n@." print_command $1 } + | LPAREN PROGRAM STRING ignore_sexp_list RPAREN + { printf "Ignored program %s\n@." $3 } +; + +command_ignore: + | command { () } + | LPAREN PROGRAM STRING ignore_sexp_list RPAREN { () } +; + +command_or_prog_or_unsat: + | command { Some $1 } + | SAT { raise CVC4Sat } + | UNSAT { None } + | LPAREN PROGRAM STRING ignore_sexp_list RPAREN + { None } +; + + +command_list: + | { [] } + | command_or_prog_or_unsat command_list + { match $1 with Some c -> c :: $2 | None -> $2 } +; + +command_print_list: + | { } + | command_print command_print_list { } +; + +command_ignore_list: + | { } + | command_ignore command_ignore_list { } +; + +proof: + | command_list EOF { $1 } +; + +proof_print: + | command_print_list EOF { } +; + +proof_ignore: + | command_ignore_list EOF { } +; + + +last_command: + | command_or_prog_or_unsat { $1 } + | command_or_prog_or_unsat last_command { $2 } +; + +one_command: + | command_or_prog_or_unsat { $1 } +; + +ignore_commands: + | command_or_prog_or_unsat { () } + | command_or_prog_or_unsat ignore_commands { () } +; diff --git a/src/lfsc/lfsctosmtcoq.ml b/src/lfsc/lfsctosmtcoq.ml new file mode 100644 index 0000000..0e9371d --- /dev/null +++ b/src/lfsc/lfsctosmtcoq.ml @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Ast +open Format +open Builtin +open VeritPrinter + +let _ = Printexc.record_backtrace true + + +(* Captures the output and exit status of a unix command : aux func *) +let syscall cmd = + let ic, oc = Unix.open_process cmd in + let buf = Buffer.create 16 in + (try + while true do + Buffer.add_channel buf ic 1 + done + with End_of_file -> ()); + ignore(Unix.close_process (ic, oc)); + Buffer.contents buf + +(* Set width of pretty printing boxes to number of columns *) +let vt_width = + try + let scol = syscall "tput cols" in + let w = int_of_string (String.trim scol) in + set_margin w; + w + with Not_found | Failure _ -> 80 + + +let _ = + pp_set_margin std_formatter vt_width; + pp_set_margin err_formatter vt_width; + set_max_indent (get_margin () / 3) + + + +module C = Converter.Make (VeritPrinter) + + +(* Hard coded signatures *) +let signatures = + let sigdir = try Sys.getenv "LFSCSIGS" with Not_found -> Sys.getcwd () in + ["sat.plf"; + "smt.plf"; + "th_base.plf"; + "th_int.plf"; + "th_bv.plf"; + "th_bv_bitblast.plf"; + "th_bv_rewrites.plf"; + "th_arrays.plf" ] + |> List.map (Filename.concat sigdir) + + +let process_signatures () = + try + List.iter (fun f -> + let chan = open_in f in + let lexbuf = Lexing.from_channel chan in + LfscParser.ignore_commands LfscLexer.main lexbuf; + close_in chan + ) signatures + with + | Ast.TypingError (t1, t2) -> + eprintf "@[<hov>LFSC typing error: expected %a, got %a@]@." + Ast.print_term t1 + Ast.print_term t2 + + +(** Translate to veriT proof format and print pretty LFSC proof with colors *) +let pretty_to_verit () = + process_signatures (); + let chan = + try + let filename = Sys.argv.(1) in + open_in filename + with Invalid_argument _ -> stdin + in + let buf = Lexing.from_channel chan in + + try + let proof = LfscParser.proof LfscLexer.main buf in + + printf "LFSC proof:\n\n%a\n\n@." print_proof proof; + + printf "Verit proof:\n@."; + + match List.rev proof with + | Check p :: _ -> + flatten_term p; + C.convert_pt p |> ignore + | _ -> eprintf "No proof@."; exit 1 + + + with Ast.TypingError (t1, t2) -> + eprintf "@[<hov>Typing error: expected %a, got %a@]@." + Ast.print_term t1 + Ast.print_term t2 + + +(** Translate to veriT proof format *) +let to_verit () = + process_signatures (); + let chan = + try + let filename = Sys.argv.(1) in + open_in filename + with Invalid_argument _ -> stdin + in + let buf = Lexing.from_channel chan in + + eprintf "Type-checking LFSC proof.@."; + try + + match LfscParser.last_command LfscLexer.main buf with + | Some (Check p) -> + (* eprintf "Flattening pointer structures...@."; *) + (* flatten_term p; *) + (* eprintf "Done (flatten)@."; *) + C.convert_pt p |> ignore + | _ -> eprintf "No proof@."; exit 1 + + with + | Ast.TypingError (t1, t2) as e -> + let backtrace = Printexc.get_backtrace () in + eprintf "Fatal error: %s@." (Printexc.to_string e); + eprintf "Backtrace:@\n%s@." backtrace; + + eprintf "@[<hov>Typing error: expected %a, got %a@]@." + Ast.print_term t1 + Ast.print_term t2 + | Ast.CVC4Sat -> + eprintf "CVC4 returned SAT@."; exit 1 + + + +let _ = to_verit () + + + + +(* + Local Variables: + compile-command: "make" + indent-tabs-mode: nil + End: +*) diff --git a/src/lfsc/shashcons.ml b/src/lfsc/shashcons.ml new file mode 100644 index 0000000..a3d0f0c --- /dev/null +++ b/src/lfsc/shashcons.ml @@ -0,0 +1,84 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(*s Hash tables for hash-consing. (Some code is borrowed from the ocaml + standard library, which is copyright 1996 INRIA.) *) + +module type HashedType = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + val tag : int -> t -> t + end + +module type S = + sig + type t + val hashcons : t -> t + val iter : (t -> unit) -> unit + val stats : unit -> int * int * int * int * int * int + end + +module Make(H : HashedType) : (S with type t = H.t) = +struct + type t = H.t + + module WH = Weak.Make (H) + + let next_tag = ref 0 + + let htable = WH.create 5003 + + let hashcons d = + let d = H.tag !next_tag d in + let o = WH.merge htable d in + if o == d then incr next_tag; + o + + let iter f = WH.iter f htable + + let stats () = WH.stats htable +end + + +type 'a hash_consed = { + tag : int; + node : 'a } + +module type HashedType_consed = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + end + +module type S_consed = + sig + type key + val hashcons : key -> key hash_consed + val iter : (key hash_consed -> unit) -> unit + val stats : unit -> int * int * int * int * int * int + end + +module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) = +struct + module M = Make(struct + type t = H.t hash_consed + let hash x = H.hash x.node + let equal x y = H.equal x.node y.node + let tag i x = {x with tag = i} + end) + include M + type key = H.t + let hashcons x = M.hashcons {tag = -1; node = x} +end diff --git a/src/lfsc/shashcons.mli b/src/lfsc/shashcons.mli new file mode 100644 index 0000000..049ec5f --- /dev/null +++ b/src/lfsc/shashcons.mli @@ -0,0 +1,93 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(** Hash tables for hash consing *) + +(*s Hash tables for hash consing. + + Hash consed values are of the + following type [hash_consed]. The field [tag] contains a unique + integer (for values hash consed with the same table). The field + [hkey] contains the hash key of the value (without modulo) for + possible use in other hash tables (and internally when hash + consing tables are resized). The field [node] contains the value + itself. + + Hash consing tables are using weak pointers, so that values that are no + more referenced from anywhere else can be erased by the GC. *) + +module type HashedType = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + val tag : int -> t -> t + end + +module type S = + sig + type t + + val hashcons : t -> t + (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns + any existing value in the table equal to [n], if any; + otherwise, creates a new value with function [f], stores it + in the table and returns it. Function [f] is passed + the node [n] as first argument and the unique id as second argument. + *) + + val iter : (t -> unit) -> unit + (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int + (** Return statistics on the table. The numbers are, in order: + table length, number of entries, sum of bucket lengths, + smallest bucket length, median bucket length, biggest + bucket length. *) + end + +module Make(H : HashedType) : (S with type t = H.t) + + +(* For simple use *) +type 'a hash_consed = private { + tag : int; + node : 'a } + +module type HashedType_consed = + sig + type t + val equal : t -> t -> bool + val hash : t -> int + end + +module type S_consed = + sig + type key + + val hashcons : key -> key hash_consed + (** [hashcons n f] hash-cons the value [n] using function [f] i.e. returns + any existing value in the table equal to [n], if any; + otherwise, creates a new value with function [f], stores it + in the table and returns it. Function [f] is passed + the node [n] as first argument and the unique id as second argument. + *) + + val iter : (key hash_consed -> unit) -> unit + (** [iter f] iterates [f] over all elements of the table . *) + val stats : unit -> int * int * int * int * int * int + (** Return statistics on the table. The numbers are, in order: + table length, number of entries, sum of bucket lengths, + smallest bucket length, median bucket length, biggest + bucket length. *) + end + +module Make_consed(H : HashedType_consed) : (S_consed with type key = H.t) diff --git a/src/lfsc/tests/_sat.plf b/src/lfsc/tests/_sat.plf new file mode 100755 index 0000000..80cfd44 --- /dev/null +++ b/src/lfsc/tests/_sat.plf @@ -0,0 +1,95 @@ +(declare bool type) +(declare tt bool) +(declare ff bool) + +(declare var type) + +(declare formula type) +(declare th_holds (! f formula type)) + +(declare sort type) +(declare Bool sort) + +(declare term (! t sort type)) + +(declare p_app (! x (term Bool) formula)) + +(declare lit type) +(declare pos (! x var lit)) +(declare neg (! x var lit)) + +(declare clause type) +(declare cln clause) +(declare clc (! x lit (! c clause clause))) + +; constructs for general clauses for R, Q, satlem + +(declare concat (! c1 clause (! c2 clause clause))) +(declare clr (! l lit (! c clause clause))) + +; code to check resolutions + + +;; resolution proofs + +(declare holds (! c clause type)) + +(declare atom (! v var (! f formula type))) + +(declare decl_atom + (! f formula + (! u (! v var + (! a (atom v f) + (holds cln))) + (holds cln)))) + +(declare R (! c1 clause (! c2 clause + (! u1 (holds c1) + (! u2 (holds c2) + (! n var + (holds (concat (clr (pos n) c1) + (clr (neg n) c2))))))))) + +(declare Q (! c1 clause (! c2 clause + (! u1 (holds c1) + (! u2 (holds c2) + (! n var + (holds (concat (clr (neg n) c1) + (clr (pos n) c2))))))))) + +(declare satlem_simplify + (! c1 clause + (! c2 clause + (! c3 clause + (! u1 (holds c1) + (! r (^ (simplify_clause c1) c2) + (! u2 (! x (holds c2) (holds c3)) + (holds c3)))))))) + + +(declare satlem + (! c clause + (! c2 clause + (! u (holds c) + (! u2 (! v (holds c) (holds c2)) + (holds c2)))))) + +; A little example to demonstrate simplify_clause. +; It can handle nested clr's of both polarities, +; and correctly cleans up marks when it leaves a +; clr or clc scope. Uncomment and run with +; --show-runs to see it in action. +; +; (check +; (% v1 var +; (% u1 (holds (concat (clr (neg v1) (clr (pos v1) (clc (pos v1) (clr (pos v1) (clc (pos v1) (clc (neg v1) cln)))))) +; (clc (pos v1) (clc (pos v1) cln)))) +; (satlem _ _ _ u1 (\ x x)))))) + + + +;(check +; (% v1 var +; (% u1 (holds (clr (neg v1) (concat (clc (neg v1) cln) +; (clr (neg v1) (clc (neg v1) cln))))) +; (satlem _ _ _ u1 (\ x x)))))) diff --git a/src/lfsc/tests/array.smt2 b/src/lfsc/tests/array.smt2 new file mode 100644 index 0000000..82fbd71 --- /dev/null +++ b/src/lfsc/tests/array.smt2 @@ -0,0 +1,17 @@ +(set-logic QF_ALIA) + +(declare-fun a () (Array Int Int)) +(declare-fun b () (Array Int Int)) +(declare-fun c () (Array Int Int)) +(declare-fun d () (Array Int Int)) + +(assert (= c (store b 0 4))) + +;; (assert (= d (store (store (store a 0 3) 1 (select c 0)) 2 2))) + +(assert (not (= (select (store (store (store a 0 3) 1 (select c 0)) 2 2) 1) 4))) + +;; (assert (= c d)) + +(check-sat) + diff --git a/src/lfsc/tests/array_bv3.smt2 b/src/lfsc/tests/array_bv3.smt2 new file mode 100644 index 0000000..b3f1be9 --- /dev/null +++ b/src/lfsc/tests/array_bv3.smt2 @@ -0,0 +1,34 @@ +;; (set-logic QF_ALIA) +(set-logic QF_AUFBVLIA) + +(declare-fun bv1 () (_ BitVec 10)) +(declare-fun bv2 () (_ BitVec 10)) + +(declare-fun bv3 () (_ BitVec 10)) +(declare-fun bv4 () (_ BitVec 10)) + +(declare-fun a () (Array (_ BitVec 10) (_ BitVec 10))) +(declare-fun b () (Array (_ BitVec 10) (_ BitVec 10))) +(declare-fun c () (Array (_ BitVec 10) (_ BitVec 10))) +(declare-fun d () (Array (_ BitVec 10) (_ BitVec 10))) + +(assert (= #b0000000000 bv1)) +(assert (= #b0000000001 bv2)) +(assert (= #b0000000100 bv3)) +(assert (= #b1111111111 bv4)) + +(assert + (= (bvmul bv4 bv3) bv3)) + + + +(assert (not +(=> (= c (store b bv1 bv3)) +(=> (= d (store (store b bv1 bv3) bv2 bv3)) + +(=> (= a (store d bv2 (select b bv2))) + + (= a c)))))) + + +(check-sat) diff --git a/src/lfsc/tests/array_ext.smt2 b/src/lfsc/tests/array_ext.smt2 new file mode 100644 index 0000000..4f7586a --- /dev/null +++ b/src/lfsc/tests/array_ext.smt2 @@ -0,0 +1,27 @@ +;; (set-logic QF_ALIA) +(set-logic QF_AUFBVLIA) + +(declare-fun a () (Array Int Int)) +(declare-fun b () (Array Int Int)) +(declare-fun c () (Array Int Int)) +(declare-fun d () (Array Int Int)) + +;; (assert (= c (store b 0 4))) +;; (assert (= d (store (store b 0 4) 1 4))) + +;; (assert (= a (store d 1 (select b 1)))) + +;; (assert (not (= a c))) + + +(assert (not +(=> (= c (store b 0 4)) +(=> (= d (store (store b 0 4) 1 4)) + +(=> (= a (store d 1 (select b 1))) + + (= a c)))))) + + +(check-sat) + diff --git a/src/lfsc/tests/array_ext2.smt2 b/src/lfsc/tests/array_ext2.smt2 new file mode 100644 index 0000000..67d2a09 --- /dev/null +++ b/src/lfsc/tests/array_ext2.smt2 @@ -0,0 +1,31 @@ +;; (set-logic QF_ALIA) +(set-logic QF_AUFBVLIA) + +(declare-fun bv1 () (_ BitVec 32)) +(declare-fun bv2 () (_ BitVec 32)) + +(declare-fun bv3 () (_ BitVec 32)) + + +(declare-fun a () (Array (_ BitVec 32) (_ BitVec 32))) +(declare-fun b () (Array (_ BitVec 32) (_ BitVec 32))) +(declare-fun c () (Array (_ BitVec 32) (_ BitVec 32))) +(declare-fun d () (Array (_ BitVec 32) (_ BitVec 32))) + +(assert (= #b00000000000000000000000000000000 bv1)) +(assert (= #b00000000000000000000000000000001 bv2)) +(assert (= #b00000000000000000000000000000100 bv3)) + + + +(assert (not +(=> (= c (store b bv1 bv3)) +(=> (= d (store (store b bv1 bv3) bv2 bv3)) + +(=> (= a (store d bv2 (select b bv2))) + + (= a c)))))) + + +(check-sat) + diff --git a/src/lfsc/tests/array_incompleteness1.smt2 b/src/lfsc/tests/array_incompleteness1.smt2 new file mode 100644 index 0000000..76a1089 --- /dev/null +++ b/src/lfsc/tests/array_incompleteness1.smt2 @@ -0,0 +1,19 @@ +(set-logic QF_AUFLIA) +(set-info :source | This is based on an example in Section 6.2 of "A Decision +Procedure for an Extensional Theory of Arrays" by Stump, Barrett, Dill, and +Levitt. |) +(set-info :smt-lib-version 2.0) +(set-info :category "check") +(set-info :status unsat) +(set-info :notes |This benchmark is designed to require an array DP to propagate a properly entailed disjunction of equalities between shared terms.|) +(declare-fun a () (Array Int Int)) +(declare-fun b () (Array Int Int)) +(declare-fun v () Int) +(declare-fun w () Int) +(declare-fun x () Int) +(declare-fun y () Int) +(declare-fun g ((Array Int Int)) Int) +(declare-fun f (Int) Int) +(assert (and (= (store a x v) b) (and (= (store a y w) b) (and (not (= (f x) (f y))) (not (= (g a) (g b)))) ))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv1.smt2 b/src/lfsc/tests/bv1.smt2 new file mode 100644 index 0000000..c23b151 --- /dev/null +++ b/src/lfsc/tests/bv1.smt2 @@ -0,0 +1,5 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 2)) +(assert (not (= a a))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv2.smt2 b/src/lfsc/tests/bv2.smt2 new file mode 100644 index 0000000..e1d582a --- /dev/null +++ b/src/lfsc/tests/bv2.smt2 @@ -0,0 +1,7 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 2)) +(declare-fun b () (_ BitVec 2)) +(declare-fun c () (_ BitVec 2)) +(assert (and (= c a) (and (= b a) (not (= c b))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv3.smt2 b/src/lfsc/tests/bv3.smt2 new file mode 100644 index 0000000..b16d58c --- /dev/null +++ b/src/lfsc/tests/bv3.smt2 @@ -0,0 +1,6 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 2)) +(declare-fun b () (_ BitVec 2)) +(assert (and (= a b) (not (= a b)))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv_add.smt2 b/src/lfsc/tests/bv_add.smt2 new file mode 100644 index 0000000..dd7586e --- /dev/null +++ b/src/lfsc/tests/bv_add.smt2 @@ -0,0 +1,16 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 4)) +(declare-fun b () (_ BitVec 4)) +(declare-fun c () (_ BitVec 4)) +(declare-fun d () (_ BitVec 4)) + +(assert (= #b0010 a)) +(assert (= #b0110 b)) +(assert (= #b1000 c)) +(assert (= #b1100 d)) + +(assert + (not (= (bvadd a b) c))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv_artih.smt2 b/src/lfsc/tests/bv_artih.smt2 new file mode 100644 index 0000000..a6db769 --- /dev/null +++ b/src/lfsc/tests/bv_artih.smt2 @@ -0,0 +1,28 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 4)) +(declare-fun b () (_ BitVec 4)) +(declare-fun c () (_ BitVec 4)) +(declare-fun d () (_ BitVec 4)) + +;; (assert (= a #b0010)) +;; (assert (= b #b0110)) +;; (assert (= c #b1000)) +;; (assert (= d #b0010)) + +(assert (= #b0010 a)) +(assert (= #b0110 b)) +(assert (= #b1000 c)) +(assert (= #b0010 d)) + +;; (assert (= #b1111 a)) +;; (assert (= #b1111 b)) +;; (assert (= #b1111 c)) +;; (assert (= #b1111 d)) + +(assert + (not (= (bvand (bvand a b) d) d))) + +;; (assert +;; (not (= (bvadd a b) (bvadd b (bvadd a #b1111))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv_mult.smt2 b/src/lfsc/tests/bv_mult.smt2 new file mode 100644 index 0000000..7270afa --- /dev/null +++ b/src/lfsc/tests/bv_mult.smt2 @@ -0,0 +1,16 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 4)) +(declare-fun b () (_ BitVec 4)) +(declare-fun c () (_ BitVec 4)) +(declare-fun d () (_ BitVec 4)) + +(assert (= #b0010 a)) +(assert (= #b0110 b)) +(assert (= #b1000 c)) +(assert (= #b1100 d)) + +(assert + (not (= (bvmul a b) d))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bv_mult10.smt2 b/src/lfsc/tests/bv_mult10.smt2 new file mode 100644 index 0000000..38b8dec --- /dev/null +++ b/src/lfsc/tests/bv_mult10.smt2 @@ -0,0 +1,16 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 10)) +(declare-fun b () (_ BitVec 10)) +(declare-fun c () (_ BitVec 10)) +(declare-fun d () (_ BitVec 10)) + +(assert (= #b0000000010 a)) +(assert (= #b0000000110 b)) +(assert (= #b0000001000 c)) +(assert (= #b0000001100 d)) + +(assert + (not (= (bvmul a b) d))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bvand1.smt2 b/src/lfsc/tests/bvand1.smt2 new file mode 100644 index 0000000..1d88efc --- /dev/null +++ b/src/lfsc/tests/bvand1.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 2)) +(declare-fun b () (_ BitVec 2)) +(declare-fun c () (_ BitVec 2)) +(assert (= a #b10)) + +(assert (= (bvand a b) c)) +(assert (not (= (bvand (bvand a b) c) c))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bvconcat.smt2 b/src/lfsc/tests/bvconcat.smt2 new file mode 100644 index 0000000..a1021bd --- /dev/null +++ b/src/lfsc/tests/bvconcat.smt2 @@ -0,0 +1,15 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 4)) +(declare-fun b () (_ BitVec 5)) +(declare-fun c () (_ BitVec 9)) + + +(assert (= #b0010 a)) +(assert (= #b01101 b)) +(assert (= #b001001101 c)) + +(assert + (not (= (concat a b) c))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bvneg0_32.smt2 b/src/lfsc/tests/bvneg0_32.smt2 new file mode 100644 index 0000000..2062cba --- /dev/null +++ b/src/lfsc/tests/bvneg0_32.smt2 @@ -0,0 +1,10 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 32)) +(declare-fun b () (_ BitVec 32)) +(declare-fun c () (_ BitVec 32)) + +(assert (= c (bvneg a))) +(assert (not (= a (bvneg c)))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bvnot32.smt2 b/src/lfsc/tests/bvnot32.smt2 new file mode 100644 index 0000000..2185266 --- /dev/null +++ b/src/lfsc/tests/bvnot32.smt2 @@ -0,0 +1,10 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 32)) +(declare-fun b () (_ BitVec 32)) +(declare-fun c () (_ BitVec 32)) + +(assert (= c (bvnot a))) +(assert (not (= (bvnot c) a))) + +(check-sat) +(exit) diff --git a/src/lfsc/tests/bvult.smt2 b/src/lfsc/tests/bvult.smt2 new file mode 100644 index 0000000..5fd8cce --- /dev/null +++ b/src/lfsc/tests/bvult.smt2 @@ -0,0 +1,23 @@ +(set-logic QF_BV) +(declare-fun a () (_ BitVec 32)) +(declare-fun b () (_ BitVec 32)) +(declare-fun c () (_ BitVec 32)) +(declare-fun d () (_ BitVec 32)) + +;; (assert (= #b01 a)) +;; (assert (= #b10 b)) +;; (assert (= #b00 c)) +;; (assert (= #b11 d)) + +(declare-fun one () (_ BitVec 32)) +(declare-fun max () (_ BitVec 32)) + +(assert (= one #b00000000000000000000000000000001)) +(assert (= max #b11111111111111111111111111111111)) + +(assert (not (= a max))) + +(assert + (not (bvult a (bvadd a one)))) + +(check-sat) diff --git a/src/lfsc/tests/cvc4_coq40d8ed.smt2 b/src/lfsc/tests/cvc4_coq40d8ed.smt2 new file mode 100644 index 0000000..29e28b0 --- /dev/null +++ b/src/lfsc/tests/cvc4_coq40d8ed.smt2 @@ -0,0 +1,9 @@ +(set-logic QF_UFLIA) +(declare-fun op_4 () Int) +(declare-fun op_1 (Int) Bool) +(declare-fun op_0 () Int) +(declare-fun op_2 () Int) +(declare-fun op_3 (Int) Int) +(assert (and (= op_2 op_4) (and (= op_0 op_4) (or (not (= (op_3 op_2) (op_3 op_0))) (and (op_1 op_2) (not (op_1 op_0))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/cvc4tocoq b/src/lfsc/tests/cvc4tocoq new file mode 100755 index 0000000..72251bd --- /dev/null +++ b/src/lfsc/tests/cvc4tocoq @@ -0,0 +1,40 @@ +#!/bin/bash +set -e + +name=${1%.*} +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" + +gnudate() { + if hash gdate 2>/dev/null; then + gdate "$@" + else + date "$@" + fi +} + +echo -n "Running CVC4... " +T0=$(gnudate +%s.%N) +cvc4 --proof --dump-proof --no-simplification --fewer-preprocessing-holes --no-bv-eq --no-bv-ineq --no-bv-algebraic --allow-empty-dependencies $1 > $name.lfsc +T1=$(gnudate +%s.%N) +CVC4TIME=$(echo "$T1 - $T0" | bc) +echo "Done [$CVC4TIME s]" + +# sed -i -e '1d' $name.lfsc + + cat > ${name}_lfsc.v <<EOF + Require Import SMTCoq Bool List. + Import ListNotations BVList.BITVECTOR_LIST FArray. + Local Open Scope list_scope. + Local Open Scope farray_scope. + Local Open Scope bv_scope. + + Section File. + Lfsc_Checker "$name.smt2" "$name.lfsc". + End File. +EOF + +echo "Checking LFSC proof with Coq directly." +coqc -q -R $DIR/../.. SMTCoq ${name}_lfsc.v + +exit 0 + diff --git a/src/lfsc/tests/cvc4tov b/src/lfsc/tests/cvc4tov new file mode 100755 index 0000000..183629e --- /dev/null +++ b/src/lfsc/tests/cvc4tov @@ -0,0 +1,66 @@ +#!/bin/bash +set -e + +name=${1%.*} +DIR="$( cd "$( dirname "${BASH_SOURCE[0]}" )" && pwd )" + +echo "Running CVC4..." +cvc4 --proof --dump-proof --no-simplification --fewer-preprocessing-holes --no-bv-eq --no-bv-ineq --no-bv-algebraic $1 > $name.lfsc + +# sed -i -e '1d' $name.lfsc + +# echo "Convert LFSC proof to SMTCoq..." +$DIR/../lfsctosmtcoq.native $name.lfsc | grep "^1:" -A 9999999 > $name.log + +echo "Creating Coq file..." +cat > $name.v <<EOF +Require Import SMTCoq Bool List. +Import ListNotations BVList.BITVECTOR_LIST FArray. +Local Open Scope list_scope. +Local Open Scope farray_scope. +Local Open Scope bv_scope. + +Section File. + Verit_Checker "$name.smt2" "$name.log". +End File. +EOF + +cat > ${name}_debug.v <<EOF +Require Import SMTCoq Bool List. +Import ListNotations BVList.BITVECTOR_LIST FArray. +Local Open Scope list_scope. +Local Open Scope farray_scope. +Local Open Scope bv_scope. + +Section File. + Verit_Checker_Debug "$name.smt2" "$name.log". +End File. + +(* +Section File2. + Parse_certif_verit t_i t_func t_atom t_form root used_roots trace "$name.smt2" "$name.log". + Compute ( + let (nclauses, t, confl) := trace in + let s := add_roots (S.make nclauses) root used_roots in + let s' := Structures.trace_fold + (fun s a => + (@Euf_Checker.step_checker t_i t_func t_atom t_form) s a + ) s t in + let s'' := PArray.mapi (fun i c => (to_Z i, List.map to_Z c)) s' in + (PArray.to_list s'', to_Z confl)). +End File2. +*) +EOF + +cat > ${name}_debug.sh <<EOF +#!/bin/sh +coqc -q -R $DIR/../.. SMTCoq ${name}_debug.v | grep --color -E "\[0(;\s+0)*\]| 0|" +EOF + +chmod +x ${name}_debug.sh + + +echo "Checking with Coq..." +coqc -q -R $DIR/../.. SMTCoq $name.v + +exit 0 diff --git a/src/lfsc/tests/dead_dnd001.smt2 b/src/lfsc/tests/dead_dnd001.smt2 new file mode 100644 index 0000000..63a2800 --- /dev/null +++ b/src/lfsc/tests/dead_dnd001.smt2 @@ -0,0 +1,168 @@ +(set-logic QF_UF) +(set-info :status unsat) + +(declare-sort I 0) +(declare-fun f (I I) I) +(declare-fun a () I) +(declare-fun b () I) +(declare-fun c () I) + + + +(assert + (or + (= (f a a) a) + (or (= (f a a) b) + (= (f a a) c)) + )) + +(assert + (or + (= (f a b) a) + (or (= (f a b) b) + (= (f a b) c)) + )) + +(assert + (or + (= (f a c) a) + (or (= (f a c) b) + (= (f a c) c)) + )) + +(assert + (or + (= (f b a) a) + (or (= (f b a) b) + (= (f b a) c)) + )) + +(assert + (or + (= (f b b) a) + (or (= (f b b) b) + (= (f b b) c)) + )) + +(assert + (or + (= (f b c) a) + (or (= (f b c) b) + (= (f b c) c)) + )) + + +(assert + (or + (= (f c a) a) + (or (= (f c a) b) + (= (f c a) c)) + )) + +(assert + (or + (= (f c b) a) + (or (= (f c b) b) + (= (f c b) c)) + )) + +(assert + (or + (= (f c c) a) + (or (= (f c c) b) + (= (f c c) c)) + )) + + + +(assert + (or + (= (f a a) a) + (or (= (f b b) a) + (= (f c c) a)) + )) + +(assert + (or + (= (f a a) b) + (or (= (f b b) b) + (= (f c c) b)) + )) + +(assert + (or + (= (f a a) c) + (or (= (f b b) c) + (= (f c c) c)) + )) + + + +(assert + (or + (= (f a a) a) + (or (= (f b a) b) + (= (f c a) c)) + )) + +(assert + (or + (= (f a b) a) + (or (= (f b b) b) + (= (f c b) c)) + )) + +(assert + (or + (= (f a c) a) + (or (= (f b c) b) + (= (f c c) c)) + )) + + + + +(assert (not (= (f a a) a))) +(assert (not (= (f b b) b))) +(assert (not (= (f c c) c))) + + +(assert + (or + (not (= (f a (f a a)) a)) + (or (not (= (f a (f a b)) b)) + (not (= (f a (f a c)) c))) + )) + +(assert + (or + (not (= (f b (f b a)) a)) + (or (not (= (f b (f b b)) b)) + (not (= (f b (f b c)) c))) + )) + +(assert + (or + (not (= (f c (f c a)) a)) + (or (not (= (f c (f c b)) b)) + (not (= (f c (f c c)) c))) + )) + + +(assert (not (= (f a a) (f b a)))) +(assert (not (= (f a a) (f c a)))) +(assert (not (= (f b a) (f c a)))) + +(assert (not (= (f a b) (f b b)))) +(assert (not (= (f a b) (f c b)))) +(assert (not (= (f b b) (f c b)))) + +(assert (not (= (f a c) (f b c)))) +(assert (not (= (f a c) (f c c)))) +(assert (not (= (f b c) (f c c)))) + + + +(check-sat) + +(exit) diff --git a/src/lfsc/tests/dead_dnd001_and.smt2 b/src/lfsc/tests/dead_dnd001_and.smt2 new file mode 100644 index 0000000..4d93b9e --- /dev/null +++ b/src/lfsc/tests/dead_dnd001_and.smt2 @@ -0,0 +1,168 @@ +(set-logic QF_UF) +(set-info :status unsat) + +(declare-sort I 0) +(declare-fun f (I I) I) +(declare-fun a () I) +(declare-fun b () I) +(declare-fun c () I) + + +(assert +(and + (or + (= (f a a) a) + (or (= (f a a) b) + (= (f a a) c)) + ) + +(and + (or + (= (f a b) a) + (or (= (f a b) b) + (= (f a b) c)) + ) + +(and + (or + (= (f a c) a) + (or (= (f a c) b) + (= (f a c) c)) + ) + +(and + (or + (= (f b a) a) + (or (= (f b a) b) + (= (f b a) c)) + ) + +(and + (or + (= (f b b) a) + (or (= (f b b) b) + (= (f b b) c)) + ) + +(and + (or + (= (f b c) a) + (or (= (f b c) b) + (= (f b c) c)) + ) + + +(and + (or + (= (f c a) a) + (or (= (f c a) b) + (= (f c a) c)) + ) + +(and + (or + (= (f c b) a) + (or (= (f c b) b) + (= (f c b) c)) + ) + +(and + (or + (= (f c c) a) + (or (= (f c c) b) + (= (f c c) c)) + ) + + + +(and + (or + (= (f a a) a) + (or (= (f b b) a) + (= (f c c) a)) + ) + +(and + (or + (= (f a a) b) + (or (= (f b b) b) + (= (f c c) b)) + ) + +(and + (or + (= (f a a) c) + (or (= (f b b) c) + (= (f c c) c)) + ) + + + +(and + (or + (= (f a a) a) + (or (= (f b a) b) + (= (f c a) c)) + ) + +(and + (or + (= (f a b) a) + (or (= (f b b) b) + (= (f c b) c)) + ) + +(and + (or + (= (f a c) a) + (or (= (f b c) b) + (= (f c c) c)) + ) + + + + +(and (not (= (f a a) a)) +(and (not (= (f b b) b)) +(and (not (= (f c c) c)) + + +(and + (or + (not (= (f a (f a a)) a)) + (or (not (= (f a (f a b)) b)) + (not (= (f a (f a c)) c))) + ) + +(and + (or + (not (= (f b (f b a)) a)) + (or (not (= (f b (f b b)) b)) + (not (= (f b (f b c)) c))) + ) + +(and + (or + (not (= (f c (f c a)) a)) + (or (not (= (f c (f c b)) b)) + (not (= (f c (f c c)) c))) + ) + + +(and (not (= (f a a) (f b a))) +(and (not (= (f a a) (f c a))) +(and (not (= (f b a) (f c a))) + +(and (not (= (f a b) (f b b))) +(and (not (= (f a b) (f c b))) +(and (not (= (f b b) (f c b))) + +(and (not (= (f a c) (f b c))) +(and (not (= (f a c) (f c c))) + (not (= (f b c) (f c c)))) + +))))))))))))))))))))))))))))) + +(check-sat) + +(exit) diff --git a/src/lfsc/tests/eq_diamond37.smt2 b/src/lfsc/tests/eq_diamond37.smt2 new file mode 100644 index 0000000..0df4535 --- /dev/null +++ b/src/lfsc/tests/eq_diamond37.smt2 @@ -0,0 +1,162 @@ +(set-logic QF_UF) +(set-info :source | +Generating minimum transitivity constraints in P-time for deciding Equality Logic, +Ofer Strichman and Mirron Rozanov, +SMT Workshop 2005. + +Translator: Leonardo de Moura. |) +(set-info :smt-lib-version 2.0) +(set-info :category "crafted") +(set-info :status unsat) +(declare-sort U 0) +(declare-fun x0 () U) +(declare-fun y0 () U) +(declare-fun z0 () U) +(declare-fun x1 () U) +(declare-fun y1 () U) +(declare-fun z1 () U) +(declare-fun x2 () U) +(declare-fun y2 () U) +(declare-fun z2 () U) +(declare-fun x3 () U) +(declare-fun y3 () U) +(declare-fun z3 () U) +(declare-fun x4 () U) +(declare-fun y4 () U) +(declare-fun z4 () U) +(declare-fun x5 () U) +(declare-fun y5 () U) +(declare-fun z5 () U) +(declare-fun x6 () U) +(declare-fun y6 () U) +(declare-fun z6 () U) +(declare-fun x7 () U) +(declare-fun y7 () U) +(declare-fun z7 () U) +(declare-fun x8 () U) +(declare-fun y8 () U) +(declare-fun z8 () U) +(declare-fun x9 () U) +(declare-fun y9 () U) +(declare-fun z9 () U) +(declare-fun x10 () U) +(declare-fun y10 () U) +(declare-fun z10 () U) +(declare-fun x11 () U) +(declare-fun y11 () U) +(declare-fun z11 () U) +(declare-fun x12 () U) +(declare-fun y12 () U) +(declare-fun z12 () U) +(declare-fun x13 () U) +(declare-fun y13 () U) +(declare-fun z13 () U) +(declare-fun x14 () U) +(declare-fun y14 () U) +(declare-fun z14 () U) +(declare-fun x15 () U) +(declare-fun y15 () U) +(declare-fun z15 () U) +(declare-fun x16 () U) +(declare-fun y16 () U) +(declare-fun z16 () U) +(declare-fun x17 () U) +(declare-fun y17 () U) +(declare-fun z17 () U) +(declare-fun x18 () U) +(declare-fun y18 () U) +(declare-fun z18 () U) +(declare-fun x19 () U) +(declare-fun y19 () U) +(declare-fun z19 () U) +(declare-fun x20 () U) +(declare-fun y20 () U) +(declare-fun z20 () U) +(declare-fun x21 () U) +(declare-fun y21 () U) +(declare-fun z21 () U) +(declare-fun x22 () U) +(declare-fun y22 () U) +(declare-fun z22 () U) +(declare-fun x23 () U) +(declare-fun y23 () U) +(declare-fun z23 () U) +(declare-fun x24 () U) +(declare-fun y24 () U) +(declare-fun z24 () U) +(declare-fun x25 () U) +(declare-fun y25 () U) +(declare-fun z25 () U) +(declare-fun x26 () U) +(declare-fun y26 () U) +(declare-fun z26 () U) +(declare-fun x27 () U) +(declare-fun y27 () U) +(declare-fun z27 () U) +(declare-fun x28 () U) +(declare-fun y28 () U) +(declare-fun z28 () U) +(declare-fun x29 () U) +(declare-fun y29 () U) +(declare-fun z29 () U) +(declare-fun x30 () U) +(declare-fun y30 () U) +(declare-fun z30 () U) +(declare-fun x31 () U) +(declare-fun y31 () U) +(declare-fun z31 () U) +(declare-fun x32 () U) +(declare-fun y32 () U) +(declare-fun z32 () U) +(declare-fun x33 () U) +(declare-fun y33 () U) +(declare-fun z33 () U) +(declare-fun x34 () U) +(declare-fun y34 () U) +(declare-fun z34 () U) +(declare-fun x35 () U) +(declare-fun y35 () U) +(declare-fun z35 () U) +(declare-fun x36 () U) +(declare-fun y36 () U) +(declare-fun z36 () U) +(assert + (and (or (and (= x0 y0) (= y0 x1)) (and (= x0 z0) (= z0 x1))) + (and (or (and (= x1 y1) (= y1 x2)) (and (= x1 z1) (= z1 x2))) + (and (or (and (= x2 y2) (= y2 x3)) (and (= x2 z2) (= z2 x3))) + (and (or (and (= x3 y3) (= y3 x4)) (and (= x3 z3) (= z3 x4))) + (and (or (and (= x4 y4) (= y4 x5)) (and (= x4 z4) (= z4 x5))) + (and (or (and (= x5 y5) (= y5 x6)) (and (= x5 z5) (= z5 x6))) + (and (or (and (= x6 y6) (= y6 x7)) (and (= x6 z6) (= z6 x7))) + (and (or (and (= x7 y7) (= y7 x8)) (and (= x7 z7) (= z7 x8))) + (and (or (and (= x8 y8) (= y8 x9)) (and (= x8 z8) (= z8 x9))) + (and (or (and (= x9 y9) (= y9 x10)) (and (= x9 z9) (= z9 x10))) + (and (or (and (= x10 y10) (= y10 x11)) (and (= x10 z10) (= z10 x11))) + (and (or (and (= x11 y11) (= y11 x12)) (and (= x11 z11) (= z11 x12))) + (and (or (and (= x12 y12) (= y12 x13)) (and (= x12 z12) (= z12 x13))) + (and (or (and (= x13 y13) (= y13 x14)) (and (= x13 z13) (= z13 x14))) + (and (or (and (= x14 y14) (= y14 x15)) (and (= x14 z14) (= z14 x15))) + (and (or (and (= x15 y15) (= y15 x16)) (and (= x15 z15) (= z15 x16))) + (and (or (and (= x16 y16) (= y16 x17)) (and (= x16 z16) (= z16 x17))) + (and (or (and (= x17 y17) (= y17 x18)) (and (= x17 z17) (= z17 x18))) + (and (or (and (= x18 y18) (= y18 x19)) (and (= x18 z18) (= z18 x19))) + (and (or (and (= x19 y19) (= y19 x20)) (and (= x19 z19) (= z19 x20))) + (and (or (and (= x20 y20) (= y20 x21)) (and (= x20 z20) (= z20 x21))) + (and (or (and (= x21 y21) (= y21 x22)) (and (= x21 z21) (= z21 x22))) + (and (or (and (= x22 y22) (= y22 x23)) (and (= x22 z22) (= z22 x23))) + (and (or (and (= x23 y23) (= y23 x24)) (and (= x23 z23) (= z23 x24))) + (and (or (and (= x24 y24) (= y24 x25)) (and (= x24 z24) (= z24 x25))) + (and (or (and (= x25 y25) (= y25 x26)) (and (= x25 z25) (= z25 x26))) + (and (or (and (= x26 y26) (= y26 x27)) (and (= x26 z26) (= z26 x27))) + (and (or (and (= x27 y27) (= y27 x28)) (and (= x27 z27) (= z27 x28))) + (and (or (and (= x28 y28) (= y28 x29)) (and (= x28 z28) (= z28 x29))) + (and (or (and (= x29 y29) (= y29 x30)) (and (= x29 z29) (= z29 x30))) + (and (or (and (= x30 y30) (= y30 x31)) (and (= x30 z30) (= z30 x31))) + (and (or (and (= x31 y31) (= y31 x32)) (and (= x31 z31) (= z31 x32))) + (and (or (and (= x32 y32) (= y32 x33)) (and (= x32 z32) (= z32 x33))) + (and (or (and (= x33 y33) (= y33 x34)) (and (= x33 z33) (= z33 x34))) + (and (or (and (= x34 y34) (= y34 x35)) (and (= x34 z34) (= z34 x35))) + (and (or (and (= x35 y35) (= y35 x36)) (and (= x35 z35) (= z35 x36))) + (not (= x0 x36))))))))))))))))))))))))))))))))))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/ex.smt2 b/src/lfsc/tests/ex.smt2 new file mode 100644 index 0000000..66cf015 --- /dev/null +++ b/src/lfsc/tests/ex.smt2 @@ -0,0 +1,9 @@ +;; (set-logic QF_SAT) + +(declare-fun a () Bool) +(declare-fun b () Bool) +(declare-fun c () Bool) + +(assert (not (=> (and (=> a b) (=> b c)) (=> a c)))) + +(check-sat) diff --git a/src/lfsc/tests/exx.smt2 b/src/lfsc/tests/exx.smt2 new file mode 100644 index 0000000..351bc0c --- /dev/null +++ b/src/lfsc/tests/exx.smt2 @@ -0,0 +1,13 @@ +;; (set-logic QF_SAT) + +(declare-fun a () Bool) +(declare-fun b () Bool) +(declare-fun c () Bool) +(declare-fun d () Bool) +(declare-fun e () Bool) +(declare-fun f () Bool) +;; (declare-fun f (Bool Bool) Bool) + +(assert (not (=> (and (=> a b) (=> b c)) (=> a c)))) + +(check-sat) diff --git a/src/lfsc/tests/hole.smt2 b/src/lfsc/tests/hole.smt2 new file mode 100644 index 0000000..3c07466 --- /dev/null +++ b/src/lfsc/tests/hole.smt2 @@ -0,0 +1,99 @@ +(set-logic QF_UF) +(declare-fun a1 () Bool) +(declare-fun a2 () Bool) +(declare-fun a3 () Bool) +(declare-fun a4 () Bool) +(declare-fun a5 () Bool) +(declare-fun a6 () Bool) +(declare-fun a7 () Bool) +(declare-fun a8 () Bool) +(declare-fun a9 () Bool) +(declare-fun a10 () Bool) +(declare-fun a11 () Bool) +(declare-fun a12 () Bool) +(declare-fun a13 () Bool) +(declare-fun a14 () Bool) +(declare-fun a15 () Bool) +(declare-fun a16 () Bool) +(declare-fun a17 () Bool) +(declare-fun a18 () Bool) +(declare-fun a19 () Bool) +(declare-fun a20 () Bool) +(assert +(and (or a1 (or a2 (or a3 a4))) +(and (or a5 (or a6 (or a7 a8))) +(and (or a9 (or a10 (or a11 a12))) +(and (or a13 (or a14 (or a15 a16))) +(and (or a17 (or a18 (or a19 a20))) +(and (or (not a1) (not a2)) +(and (or (not a1) (not a3)) +(and (or (not a1) (not a4)) +(and (or (not a2) (not a3)) +(and (or (not a2) (not a4)) +(and (or (not a3) (not a4)) +(and (or (not a5) (not a6)) +(and (or (not a5) (not a7)) +(and (or (not a5) (not a8)) +(and (or (not a6) (not a7)) +(and (or (not a6) (not a8)) +(and (or (not a7) (not a8)) +(and (or (not a9) (not a10)) +(and (or (not a9) (not a11)) +(and (or (not a9) (not a12)) +(and (or (not a10) (not a11)) +(and (or (not a10) (not a12)) +(and (or (not a11) (not a12)) +(and (or (not a13) (not a14)) +(and (or (not a13) (not a15)) +(and (or (not a13) (not a16)) +(and (or (not a14) (not a15)) +(and (or (not a14) (not a16)) +(and (or (not a15) (not a16)) +(and (or (not a17) (not a18)) +(and (or (not a17) (not a19)) +(and (or (not a17) (not a20)) +(and (or (not a18) (not a19)) +(and (or (not a18) (not a20)) +(and (or (not a19) (not a20)) +(and (or (not a1) (not a5)) +(and (or (not a1) (not a9)) +(and (or (not a1) (not a13)) +(and (or (not a1) (not a17)) +(and (or (not a5) (not a9)) +(and (or (not a5) (not a13)) +(and (or (not a5) (not a17)) +(and (or (not a9) (not a13)) +(and (or (not a9) (not a17)) +(and (or (not a13) (not a17)) +(and (or (not a2) (not a6)) +(and (or (not a2) (not a10)) +(and (or (not a2) (not a14)) +(and (or (not a2) (not a18)) +(and (or (not a6) (not a10)) +(and (or (not a6) (not a14)) +(and (or (not a6) (not a18)) +(and (or (not a10) (not a14)) +(and (or (not a10) (not a18)) +(and (or (not a14) (not a18)) +(and (or (not a3) (not a7)) +(and (or (not a3) (not a11)) +(and (or (not a3) (not a15)) +(and (or (not a3) (not a19)) +(and (or (not a7) (not a11)) +(and (or (not a7) (not a15)) +(and (or (not a7) (not a19)) +(and (or (not a11) (not a15)) +(and (or (not a11) (not a19)) +(and (or (not a15) (not a19)) +(and (or (not a4) (not a8)) +(and (or (not a4) (not a12)) +(and (or (not a4) (not a16)) +(and (or (not a4) (not a20)) +(and (or (not a8) (not a12)) +(and (or (not a8) (not a16)) +(and (or (not a8) (not a20)) +(and (or (not a12) (not a16)) +(and (or (not a12) (not a20)) +(or (not a16) (not a20))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/lia1.smt2 b/src/lfsc/tests/lia1.smt2 new file mode 100644 index 0000000..16477e7 --- /dev/null +++ b/src/lfsc/tests/lia1.smt2 @@ -0,0 +1,8 @@ +(set-logic QF_LIA) + +(declare-fun x () Int) +(declare-fun y () Int) +(declare-fun z () Int) +(assert (not (=> (and (<= x 3) (or (not (>= y 8)) (not (>= z 10)))) (or (not (>= (+ x y) 11)) (not (>= (+ x z) 13)))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/run.sh b/src/lfsc/tests/run.sh new file mode 100755 index 0000000..c785e2c --- /dev/null +++ b/src/lfsc/tests/run.sh @@ -0,0 +1,10 @@ +#!/bin/bash +set -e +find work -name "*.smt2" -exec sh -c "./wrapper_cvc4tocoq.sh {} " \; +mv work/*.result work/results/ +mv work/*.lfsc work/lfsc/ +mv work/*.smt2 work/smt2/ +rm work/*.vo +rm work/*.v +rm work/*.glob +#exit 0 diff --git a/src/lfsc/tests/sat13.smt2 b/src/lfsc/tests/sat13.smt2 new file mode 100644 index 0000000..4ca190f --- /dev/null +++ b/src/lfsc/tests/sat13.smt2 @@ -0,0 +1,7 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(assert (and (not (not (= a b))) (not (= a b)))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/sat6.smt2 b/src/lfsc/tests/sat6.smt2 new file mode 100644 index 0000000..afa2640 --- /dev/null +++ b/src/lfsc/tests/sat6.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_UF) +(declare-fun a () Bool) +(declare-fun b () Bool) +(declare-fun c () Bool) +(declare-fun d () Bool) +(assert (and a b)) +(assert (or c d)) +(assert (not (or c (and a (and b d))))) +(check-sat) +(exit) + diff --git a/src/lfsc/tests/sat7.smt2 b/src/lfsc/tests/sat7.smt2 new file mode 100644 index 0000000..387da5e --- /dev/null +++ b/src/lfsc/tests/sat7.smt2 @@ -0,0 +1,8 @@ +(set-logic QF_UF) +(declare-fun a () Bool) +(declare-fun b () Bool) +(declare-fun c () Bool) +(declare-fun d () Bool) +(assert (and a (and b (and c (and (or (not a) (or (not b) d)) (or (not d) (not c))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/signatures/sat.plf b/src/lfsc/tests/signatures/sat.plf new file mode 100755 index 0000000..b95caa8 --- /dev/null +++ b/src/lfsc/tests/signatures/sat.plf @@ -0,0 +1,127 @@ +(declare bool type) +(declare tt bool) +(declare ff bool) + +(declare var type) + +(declare lit type) +(declare pos (! x var lit)) +(declare neg (! x var lit)) + +(declare clause type) +(declare cln clause) +(declare clc (! x lit (! c clause clause))) + +; constructs for general clauses for R, Q, satlem + +(declare concat_cl (! c1 clause (! c2 clause clause))) +(declare clr (! l lit (! c clause clause))) + +; code to check resolutions + +(program append ((c1 clause) (c2 clause)) clause + (match c1 (cln c2) ((clc l c1') (clc l (append c1' c2))))) + +; we use marks as follows: +; -- mark 1 to record if we are supposed to remove a positive occurrence of the variable. +; -- mark 2 to record if we are supposed to remove a negative occurrence of the variable. +; -- mark 3 if we did indeed remove the variable positively +; -- mark 4 if we did indeed remove the variable negatively +(program simplify_clause ((c clause)) clause + (match c + (cln cln) + ((clc l c1) + (match l + ; Set mark 1 on v if it is not set, to indicate we should remove it. + ; After processing the rest of the clause, set mark 3 if we were already + ; supposed to remove v (so if mark 1 was set when we began). Clear mark3 + ; if we were not supposed to be removing v when we began this call. + ((pos v) + (let m (ifmarked v tt (do (markvar v) ff)) + (let c' (simplify_clause c1) + (match m + (tt (do (ifmarked3 v v (markvar3 v)) c')) + (ff (do (ifmarked3 v (markvar3 v) v) (markvar v) (clc l c'))))))) + ; the same as the code for tt, but using different marks. + ((neg v) + (let m (ifmarked2 v tt (do (markvar2 v) ff)) + (let c' (simplify_clause c1) + (match m + (tt (do (ifmarked4 v v (markvar4 v)) c')) + (ff (do (ifmarked4 v (markvar4 v) v) (markvar2 v) (clc l c'))))))))) + ((concat_cl c1 c2) (append (simplify_clause c1) (simplify_clause c2))) + ((clr l c1) + (match l + ; set mark 1 to indicate we should remove v, and fail if + ; mark 3 is not set after processing the rest of the clause + ; (we will set mark 3 if we remove a positive occurrence of v). + ((pos v) + (let m (ifmarked v tt (do (markvar v) ff)) + (let m3 (ifmarked3 v (do (markvar3 v) tt) ff) + (let c' (simplify_clause c1) + (ifmarked3 v (do (match m3 (tt v) (ff (markvar3 v))) + (match m (tt v) (ff (markvar v))) c') + (fail clause)))))) + ; same as the tt case, but with different marks. + ((neg v) + (let m2 (ifmarked2 v tt (do (markvar2 v) ff)) + (let m4 (ifmarked4 v (do (markvar4 v) tt) ff) + (let c' (simplify_clause c1) + (ifmarked4 v (do (match m4 (tt v) (ff (markvar4 v))) + (match m2 (tt v) (ff (markvar2 v))) c') + (fail clause)))))) + )))) + + +; resolution proofs + +(declare holds (! c clause type)) + +(declare R (! c1 clause (! c2 clause + (! u1 (holds c1) + (! u2 (holds c2) + (! n var + (holds (concat_cl (clr (pos n) c1) + (clr (neg n) c2))))))))) + +(declare Q (! c1 clause (! c2 clause + (! u1 (holds c1) + (! u2 (holds c2) + (! n var + (holds (concat_cl (clr (neg n) c1) + (clr (pos n) c2))))))))) + +(declare satlem_simplify + (! c1 clause + (! c2 clause + (! c3 clause + (! u1 (holds c1) + (! r (^ (simplify_clause c1) c2) + (! u2 (! x (holds c2) (holds c3)) + (holds c3)))))))) + +(declare satlem + (! c clause + (! c2 clause + (! u (holds c) + (! u2 (! v (holds c) (holds c2)) + (holds c2)))))) + +; A little example to demonstrate simplify_clause. +; It can handle nested clr's of both polarities, +; and correctly cleans up marks when it leaves a +; clr or clc scope. Uncomment and run with +; --show-runs to see it in action. +; +; (check +; (% v1 var +; (% u1 (holds (concat_cl (clr (neg v1) (clr (pos v1) (clc (pos v1) (clr (pos v1) (clc (pos v1) (clc (neg v1) cln)))))) +; (clc (pos v1) (clc (pos v1) cln)))) +; (satlem _ _ _ u1 (\ x x)))))) + + +;(check +; (% v1 var +; (% u1 (holds (clr (neg v1) (concat_cl (clc (neg v1) cln) +; (clr (neg v1) (clc (neg v1) cln))))) +; (satlem _ _ _ u1 (\ x x)))))) diff --git a/src/lfsc/tests/signatures/smt.plf b/src/lfsc/tests/signatures/smt.plf new file mode 100755 index 0000000..fa89a45 --- /dev/null +++ b/src/lfsc/tests/signatures/smt.plf @@ -0,0 +1,423 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; SMT syntax and semantics (not theory-specific) +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; depends on sat.plf + +(declare formula type) +(declare th_holds (! f formula type)) + +; standard logic definitions +(declare true formula) +(declare false formula) + +(define formula_op1 + (! f formula + formula)) + +(define formula_op2 + (! f1 formula + (! f2 formula + formula))) + +(define formula_op3 + (! f1 formula + (! f2 formula + (! f3 formula + formula)))) + +(declare not formula_op1) +(declare and formula_op2) +(declare or formula_op2) +(declare impl formula_op2) +(declare iff formula_op2) +(declare xor formula_op2) +(declare ifte formula_op3) + +; terms +(declare sort type) +(declare term (! t sort type)) ; declared terms in formula + +; standard definitions for =, ite, let and flet +(declare = (! s sort + (! x (term s) + (! y (term s) + formula)))) +(declare ite (! s sort + (! f formula + (! t1 (term s) + (! t2 (term s) + (term s)))))) +(declare let (! s sort + (! t (term s) + (! f (! v (term s) formula) + formula)))) +(declare flet (! f1 formula + (! f2 (! v formula formula) + formula))) + +; We view applications of predicates as terms of sort "Bool". +; Such terms can be injected as atomic formulas using "p_app". +(declare Bool sort) ; the special sort for predicates +(declare p_app (! x (term Bool) formula)) ; propositional application of term + +; boolean terms +(declare t_true (term Bool)) +(declare t_false (term Bool)) +(declare t_t_neq_f + (th_holds (not (= Bool t_true t_false)))) +(declare pred_eq_t + (! x (term Bool) + (! u (th_holds (p_app x)) + (th_holds (= Bool x t_true))))) +(declare pred_eq_f + (! x (term Bool) + (! u (th_holds (not (p_app x))) + (th_holds (= Bool x t_false))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; CNF Clausification +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; binding between an LF var and an (atomic) formula + +(declare atom (! v var (! p formula type))) + +; binding between two LF vars +(declare bvatom (! sat_v var (! bv_v var type))) + +(declare decl_atom + (! f formula + (! u (! v var + (! a (atom v f) + (holds cln))) + (holds cln)))) + +;; declare atom enhanced with mapping +;; between SAT prop variable and BVSAT prop variable +(declare decl_bvatom + (! f formula + (! u (! v var + (! bv_v var + (! a (atom v f) + (! bva (atom bv_v f) + (! vbv (bvatom v bv_v) + (holds cln)))))) + (holds cln)))) + + +; clausify a formula directly +(declare clausify_form + (! f formula + (! v var + (! a (atom v f) + (! u (th_holds f) + (holds (clc (pos v) cln))))))) + +(declare clausify_form_not + (! f formula + (! v var + (! a (atom v f) + (! u (th_holds (not f)) + (holds (clc (neg v) cln))))))) + +(declare clausify_false + (! u (th_holds false) + (holds cln))) + +(declare th_let_pf + (! f formula + (! u (th_holds f) + (! u2 (! v (th_holds f) (holds cln)) + (holds cln))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Natural deduction rules : used for CNF +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; for eager bit-blasting +(declare iff_symm + (! f formula + (th_holds (iff f f)))) + + +;; contradiction + +(declare contra + (! f formula + (! r1 (th_holds f) + (! r2 (th_holds (not f)) + (th_holds false))))) + +; truth +(declare truth (th_holds true)) + +;; not not + +(declare not_not_intro + (! f formula + (! u (th_holds f) + (th_holds (not (not f)))))) + +(declare not_not_elim + (! f formula + (! u (th_holds (not (not f))) + (th_holds f)))) + +;; or elimination + +(declare or_elim_1 + (! f1 formula + (! f2 formula + (! u1 (th_holds (not f1)) + (! u2 (th_holds (or f1 f2)) + (th_holds f2)))))) + +(declare or_elim_2 + (! f1 formula + (! f2 formula + (! u1 (th_holds (not f2)) + (! u2 (th_holds (or f1 f2)) + (th_holds f1)))))) + +(declare not_or_elim + (! f1 formula + (! f2 formula + (! u2 (th_holds (not (or f1 f2))) + (th_holds (and (not f1) (not f2))))))) + +;; and elimination + +(declare and_elim_1 + (! f1 formula + (! f2 formula + (! u (th_holds (and f1 f2)) + (th_holds f1))))) + +(declare and_elim_2 + (! f1 formula + (! f2 formula + (! u (th_holds (and f1 f2)) + (th_holds f2))))) + +(declare not_and_elim + (! f1 formula + (! f2 formula + (! u2 (th_holds (not (and f1 f2))) + (th_holds (or (not f1) (not f2))))))) + +;; impl elimination + +(declare impl_intro (! f1 formula + (! f2 formula + (! i1 (! u (th_holds f1) + (th_holds f2)) + (th_holds (impl f1 f2)))))) + +(declare impl_elim + (! f1 formula + (! f2 formula + (! u2 (th_holds (impl f1 f2)) + (th_holds (or (not f1) f2)))))) + +(declare not_impl_elim + (! f1 formula + (! f2 formula + (! u (th_holds (not (impl f1 f2))) + (th_holds (and f1 (not f2))))))) + +;; iff elimination + +(declare iff_elim_1 + (! f1 formula + (! f2 formula + (! u1 (th_holds (iff f1 f2)) + (th_holds (or (not f1) f2)))))) + +(declare iff_elim_2 + (! f1 formula + (! f2 formula + (! u1 (th_holds (iff f1 f2)) + (th_holds (or f1 (not f2))))))) + +(declare not_iff_elim + (! f1 formula + (! f2 formula + (! u2 (th_holds (not (iff f1 f2))) + (th_holds (iff f1 (not f2))))))) + +; xor elimination + +(declare xor_elim_1 + (! f1 formula + (! f2 formula + (! u1 (th_holds (xor f1 f2)) + (th_holds (or (not f1) (not f2))))))) + +(declare xor_elim_2 + (! f1 formula + (! f2 formula + (! u1 (th_holds (xor f1 f2)) + (th_holds (or f1 f2)))))) + +(declare not_xor_elim + (! f1 formula + (! f2 formula + (! u2 (th_holds (not (xor f1 f2))) + (th_holds (iff f1 f2)))))) + +;; ite elimination + +(declare ite_elim_1 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (ifte a b c)) + (th_holds (or (not a) b))))))) + +(declare ite_elim_2 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (ifte a b c)) + (th_holds (or a c))))))) + +(declare ite_elim_3 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (ifte a b c)) + (th_holds (or b c))))))) + +(declare not_ite_elim_1 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (not (ifte a b c))) + (th_holds (or (not a) (not b)))))))) + +(declare not_ite_elim_2 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (not (ifte a b c))) + (th_holds (or a (not c)))))))) + +(declare not_ite_elim_3 + (! a formula + (! b formula + (! c formula + (! u2 (th_holds (not (ifte a b c))) + (th_holds (or (not b) (not c)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; For theory lemmas +; - make a series of assumptions and then derive a contradiction (or false) +; - then the assumptions yield a formula like "v1 -> v2 -> ... -> vn -> false" +; - In CNF, it becomes a clause: "~v1, ~v2, ..., ~vn" +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(declare ast + (! v var + (! f formula + (! C clause + (! r (atom v f) ;this is specified + (! u (! o (th_holds f) + (holds C)) + (holds (clc (neg v) C)))))))) + +(declare asf + (! v var + (! f formula + (! C clause + (! r (atom v f) + (! u (! o (th_holds (not f)) + (holds C)) + (holds (clc (pos v) C)))))))) + +;; Bitvector lemma constructors to assume +;; the unit clause containing the assumptions +;; it also requires the mapping between bv_v and v +;; The resolution proof proving false will use bv_v as the definition clauses use bv_v +;; but the Problem clauses in the main SAT solver will use v so the learned clause is in terms of v +(declare bv_asf + (! v var + (! bv_v var + (! f formula + (! C clause + (! r (atom v f) ;; passed in + (! x (bvatom v bv_v) ; establishes the equivalence of v to bv_ + (! u (! o (holds (clc (neg bv_v) cln)) ;; l binding to be used in proof + (holds C)) + (holds (clc (pos v) C)))))))))) + +(declare bv_ast + (! v var + (! bv_v var + (! f formula + (! C clause + (! r (atom v f) ; this is specified + (! x (bvatom v bv_v) ; establishes the equivalence of v to bv_v + (! u (! o (holds (clc (pos bv_v) cln)) + (holds C)) + (holds (clc (neg v) C)))))))))) + + +;; Example: +;; +;; Given theory literals (F1....Fn), and an input formula A of the form (th_holds (or F1 (or F2 .... (or F{n-1} Fn))))). +;; +;; We introduce atoms (a1,...,an) to map boolean literals (v1,...,vn) top literals (F1,...,Fn). +;; Do this at the beginning of the proof: +;; +;; (decl_atom F1 (\ v1 (\ a1 +;; (decl_atom F2 (\ v2 (\ a2 +;; .... +;; (decl_atom Fn (\ vn (\ an +;; +;; A is then clausified by the following proof: +;; +;;(satlem _ _ +;;(asf _ _ _ a1 (\ l1 +;;(asf _ _ _ a2 (\ l2 +;;... +;;(asf _ _ _ an (\ ln +;;(clausify_false +;; +;; (contra _ +;; (or_elim_1 _ _ l{n-1} +;; ... +;; (or_elim_1 _ _ l2 +;; (or_elim_1 _ _ l1 A))))) ln) +;; +;;))))))) (\ C +;; +;; We now have the free variable C, which should be the clause (v1 V ... V vn). +;; +;; Polarity of literals should be considered, say we have A of the form (th_holds (or (not F1) (or F2 (not F3)))). +;; Where necessary, we use "ast" instead of "asf", introduce negations by "not_not_intro" for pattern matching, and flip +;; the arguments of contra: +;; +;;(satlem _ _ +;;(ast _ _ _ a1 (\ l1 +;;(asf _ _ _ a2 (\ l2 +;;(ast _ _ _ a3 (\ l3 +;;(clausify_false +;; +;; (contra _ l3 +;; (or_elim_1 _ _ l2 +;; (or_elim_1 _ _ (not_not_intro l1) A)))) +;; +;;))))))) (\ C +;; +;; C should be the clause (~v1 V v2 V ~v3 ) + + diff --git a/src/lfsc/tests/signatures/th_arrays.plf b/src/lfsc/tests/signatures/th_arrays.plf new file mode 100755 index 0000000..b54a4ed --- /dev/null +++ b/src/lfsc/tests/signatures/th_arrays.plf @@ -0,0 +1,63 @@ +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Theory of Arrays +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; depends on : th_base.plf + +; sorts + +(declare Array (! s1 sort (! s2 sort sort))) ; s1 is index, s2 is element + +; functions +(declare write (! s1 sort + (! s2 sort + (term (arrow (Array s1 s2) + (arrow s1 + (arrow s2 (Array s1 s2)))))))) + +(declare read (! s1 sort + (! s2 sort + (term (arrow (Array s1 s2) + (arrow s1 s2)))))) + +; inference rules + +; read( a[i] = b, i ) == b +(declare row1 (! s1 sort + (! s2 sort + (! t1 (term (Array s1 s2)) + (! t2 (term s1) + (! t3 (term s2) + (th_holds (= _ + (apply _ _ (apply _ _ (read s1 s2) (apply _ _ (apply _ _ (apply _ _ (write s1 s2) t1) t2) t3)) t2) t3)))))))) + +(declare row (! s1 sort + (! s2 sort + (! t2 (term s1) + (! t3 (term s1) + (! t1 (term (Array s1 s2)) + (! t4 (term s2) + (! u (th_holds (not (= _ t2 t3))) + (th_holds (= _ (apply _ _ (apply _ _ (read s1 s2) (apply _ _ (apply _ _ (apply _ _ (write s1 s2) t1) t2) t4)) t3) + (apply _ _ (apply _ _ (read s1 s2) t1) t3))))))))))) + +(declare negativerow (! s1 sort + (! s2 sort + (! t2 (term s1) + (! t3 (term s1) + (! t1 (term (Array s1 s2)) + (! t4 (term s2) + (! u (th_holds (not (= _ + (apply _ _ (apply _ _ (read s1 s2) (apply _ _ (apply _ _ (apply _ _ (write s1 s2) t1) t2) t4)) t3) + (apply _ _ (apply _ _ (read s1 s2) t1) t3)))) + (th_holds (= _ t2 t3)))))))))) + +(declare ext (! s1 sort + (! s2 sort + (! t1 (term (Array s1 s2)) + (! t2 (term (Array s1 s2)) + (! u1 (! k (term s1) + (! u2 (th_holds (or (= _ t1 t2) (not (= _ (apply _ _ (apply _ _ (read s1 s2) t1) k) (apply _ _ (apply _ _ (read s1 s2) t2) k))))) + (holds cln))) + (holds cln)))))))
\ No newline at end of file diff --git a/src/lfsc/tests/signatures/th_base.plf b/src/lfsc/tests/signatures/th_base.plf new file mode 100755 index 0000000..ffa8667 --- /dev/null +++ b/src/lfsc/tests/signatures/th_base.plf @@ -0,0 +1,99 @@ + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; +; Theory of Equality and Congruence Closure +; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; depends on : smt.plf + +; sorts : + +(declare arrow (! s1 sort (! s2 sort sort))) ; function constructor + +; functions : + +(declare apply (! s1 sort + (! s2 sort + (! t1 (term (arrow s1 s2)) + (! t2 (term s1) + (term s2)))))) + + +; inference rules : + +(declare trust (th_holds false)) ; temporary +(declare trust_f (! f formula (th_holds f))) ; temporary + +(declare refl + (! s sort + (! t (term s) + (th_holds (= s t t))))) + +(declare symm (! s sort + (! x (term s) + (! y (term s) + (! u (th_holds (= _ x y)) + (th_holds (= _ y x))))))) + +(declare trans (! s sort + (! x (term s) + (! y (term s) + (! z (term s) + (! u (th_holds (= _ x y)) + (! u (th_holds (= _ y z)) + (th_holds (= _ x z))))))))) + +(declare negsymm (! s sort + (! x (term s) + (! y (term s) + (! u (th_holds (not (= _ x y))) + (th_holds (not (= _ y x)))))))) + +(declare negtrans1 (! s sort + (! x (term s) + (! y (term s) + (! z (term s) + (! u (th_holds (not (= _ x y))) + (! u (th_holds (= _ y z)) + (th_holds (not (= _ x z)))))))))) + +(declare negtrans2 (! s sort + (! x (term s) + (! y (term s) + (! z (term s) + (! u (th_holds (= _ x y)) + (! u (th_holds (not (= _ y z))) + (th_holds (not (= _ x z)))))))))) + +(define negtrans negtrans1) + + +(declare cong (! s1 sort + (! s2 sort + (! a1 (term (arrow s1 s2)) + (! b1 (term (arrow s1 s2)) + (! a2 (term s1) + (! b2 (term s1) + (! u1 (th_holds (= _ a1 b1)) + (! u2 (th_holds (= _ a2 b2)) + (th_holds (= _ (apply _ _ a1 a2) (apply _ _ b1 b2)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +; Examples + +; an example of "(p1 or p2(0)) and t1=t2(1)" +;(! p1 (term Bool) +;(! p2 (term (arrow Int Bool)) +;(! t1 (term Int) +;(! t2 (term (arrow Int Int)) +;(! F (th_holds (and (or (p_app p1) (p_app (apply _ _ p2 0))) +; (= _ t1 (apply _ _ t2 1)))) +; ... + +; another example of "p3(a,b)" +;(! a (term Int) +;(! b (term Int) +;(! p3 (term (arrow Int (arrow Int Bool))) ; arrow is right assoc. +;(! F (th_holds (p_app (apply _ _ (apply _ _ p3 a) b))) ; apply is left assoc. +; ... diff --git a/src/lfsc/tests/signatures/th_bv.plf b/src/lfsc/tests/signatures/th_bv.plf new file mode 100644 index 0000000..0004b35 --- /dev/null +++ b/src/lfsc/tests/signatures/th_bv.plf @@ -0,0 +1,192 @@ +;;;; TEMPORARY: + +(declare trust-bad (th_holds false)) + +; helper stuff +(program mpz_sub ((x mpz) (y mpz)) mpz + (mp_add x (mp_mul (~1) y))) + +(program mp_ispos ((x mpz)) formula + (mp_ifneg x false true)) + +(program mpz_eq ((x mpz) (y mpz)) formula + (mp_ifzero (mpz_sub x y) true false)) + +(program mpz_lt ((x mpz) (y mpz)) formula + (mp_ifneg (mpz_sub x y) true false)) + +(program mpz_lte ((x mpz) (y mpz)) formula + (mp_ifneg (mpz_sub x y) true (mpz_eq x y))) + +(program mpz_ ((x mpz) (y mpz)) formula + (mp_ifzero (mpz_sub x y) true false)) + + +; "bitvec" is a term of type "sort" +; (declare BitVec sort) +(declare BitVec (! n mpz sort)) + +; bit type +(declare bit type) +(declare b0 bit) +(declare b1 bit) + +; bit vector type used for constants +(declare bv type) +(declare bvn bv) +(declare bvc (! b bit (! v bv bv))) + +; calculate the length of a bitvector +;; (program bv_len ((v bv)) mpz +;; (match v +;; (bvn 0) +;; ((bvc b v') (mp_add (bv_len v') 1)))) + + +; a bv constant term +(declare a_bv + (! n mpz + (! v bv + (term (BitVec n))))) + +(program bv_constants_are_disequal ((x bv) (y bv)) formula + (match x + (bvn (fail formula)) + ((bvc bx x') + (match y + (bvn (fail formula)) + ((bvc by y') (match bx + (b0 (match by (b0 (bv_constants_are_disequal x' y')) (b1 (true)))) + (b1 (match by (b0 (true)) (b1 (bv_constants_are_disequal x' y')))) + )) + )) +)) + +(declare bv_disequal_constants + (! n mpz + (! x bv + (! y bv + (! c (^ (bv_constants_are_disequal x y) true) + (th_holds (not (= (BitVec n) (a_bv n x) (a_bv n y))))))))) + +; a bv variable +(declare var_bv type) +; a bv variable term +(declare a_var_bv + (! n mpz + (! v var_bv + (term (BitVec n))))) + +; bit vector binary operators +(define bvop2 + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (term (BitVec n)))))) + +(declare bvand bvop2) +(declare bvor bvop2) +(declare bvor bvop2) +(declare bvxor bvop2) +(declare bvnand bvop2) +(declare bvnor bvop2) +(declare bvxnor bvop2) +(declare bvmul bvop2) +(declare bvadd bvop2) +(declare bvsub bvop2) +(declare bvudiv bvop2) +(declare bvurem bvop2) +(declare bvsdiv bvop2) +(declare bvsrem bvop2) +(declare bvsmod bvop2) +(declare bvshl bvop2) +(declare bvlshr bvop2) +(declare bvashr bvop2) +(declare concat bvop2) + +; bit vector unary operators +(define bvop1 + (! n mpz + (! x (term (BitVec n)) + (term (BitVec n))))) + + +(declare bvneg bvop1) +(declare bvnot bvop1) +(declare rotate_left bvop1) +(declare rotate_right bvop1) + +(declare bvcomp + (! n mpz + (! t1 (term (BitVec n)) + (! t2 (term (BitVec n)) + (term (BitVec 1)))))) + + +(declare concat + (! n mpz + (! m mpz + (! m' mpz + (! t1 (term (BitVec m)) + (! t2 (term (BitVec m')) + (term (BitVec n)))))))) + +;; side-condition fails in signature only?? +;; (! s (^ (mp_add m m') n) + +;; (declare repeat bvopp) + +(declare extract + (! n mpz + (! i mpz + (! j mpz + (! m mpz + (! t2 (term (BitVec m)) + (term (BitVec n)))))))) + +(declare zero_extend + (! n mpz + (! i mpz + (! m mpz + (! t2 (term (BitVec m)) + (term (BitVec n))))))) + +(declare sign_extend + (! n mpz + (! i mpz + (! m mpz + (! t2 (term (BitVec m)) + (term (BitVec n))))))) + +(declare repeat + (! n mpz + (! i mpz + (! m mpz + (! t2 (term (BitVec m)) + (term (BitVec n))))))) + + + +;; TODO: add checks for valid typing for these operators +;; (! c1 (^ (mpz_lte i j) +;; (! c2 (^ (mpz_lt i n) true) +;; (! c3 (^ (mp_ifneg i false true) true) +;; (! c4 (^ (mp_ifneg j false true) true) +;; (! s (^ (mp_add (mpz_sub i j) 1) m) + + +; bit vector predicates +(define bvpred + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + formula)))) + +(declare bvult bvpred) +(declare bvule bvpred) +(declare bvugt bvpred) +(declare bvuge bvpred) +(declare bvslt bvpred) +(declare bvsle bvpred) +(declare bvsgt bvpred) +(declare bvsge bvpred) diff --git a/src/lfsc/tests/signatures/th_bv_bitblast.plf b/src/lfsc/tests/signatures/th_bv_bitblast.plf new file mode 100644 index 0000000..ebb412f --- /dev/null +++ b/src/lfsc/tests/signatures/th_bv_bitblast.plf @@ -0,0 +1,671 @@ +; bit blasted terms as list of formulas +(declare bblt type) +(declare bbltn bblt) +(declare bbltc (! f formula (! v bblt bblt))) + +; calculate the length of a bit-blasted term +(program bblt_len ((v bblt)) mpz + (match v + (bbltn 0) + ((bbltc b v') (mp_add (bblt_len v') 1)))) + + +; (bblast_term x y) means term y corresponds to bit level interpretation x +(declare bblast_term + (! n mpz + (! x (term (BitVec n)) + (! y bblt + type)))) + +; FIXME: for unsupported bit-blast terms +(declare trust_bblast_term + (! n mpz + (! x (term (BitVec n)) + (! y bblt + (bblast_term n x y))))) + + +; Binds a symbol to the bblast_term to be used later on. +(declare decl_bblast + (! n mpz + (! b bblt + (! t (term (BitVec n)) + (! bb (bblast_term n t b) + (! s (^ (bblt_len b) n) + (! u (! v (bblast_term n t b) (holds cln)) + (holds cln)))))))) + +(declare decl_bblast_with_alias + (! n mpz + (! b bblt + (! t (term (BitVec n)) + (! a (term (BitVec n)) + (! bb (bblast_term n t b) + (! e (th_holds (= _ t a)) + (! s (^ (bblt_len b) n) + (! u (! v (bblast_term n a b) (holds cln)) + (holds cln)))))))))) + +; a predicate to represent the n^th bit of a bitvector term +(declare bitof + (! x var_bv + (! n mpz formula))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; BITBLASTING RULES +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST CONSTANT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_const ((v bv) (n mpz)) bblt + (mp_ifneg n (match v (bvn bbltn) + (default (fail bblt))) + (match v ((bvc b v') (bbltc (match b (b0 false) (b1 true)) (bblast_const v' (mp_add n (~ 1))))) + (default (fail bblt))))) + +(declare bv_bbl_const (! n mpz + (! f bblt + (! v bv + (! c (^ (bblast_const v (mp_add n (~ 1))) f) + (bblast_term n (a_bv n v) f)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST VARIABLE +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_var ((x var_bv) (n mpz)) bblt + (mp_ifneg n bbltn + (bbltc (bitof x n) (bblast_var x (mp_add n (~ 1)))))) + +(declare bv_bbl_var (! n mpz + (! x var_bv + (! f bblt + (! c (^ (bblast_var x (mp_add n (~ 1))) f) + (bblast_term n (a_var_bv n x) f)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST CONCAT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_concat ((x bblt) (y bblt)) bblt + (match x + (bbltn (match y ((bbltc by y') (bbltc by (bblast_concat x y'))) + (bbltn bbltn))) + ((bbltc bx x') (bbltc bx (bblast_concat x' y))))) + +(declare bv_bbl_concat (! n mpz + (! m mpz + (! m1 mpz + (! x (term (BitVec m)) + (! y (term (BitVec m1)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term m x xb) + (! ybb (bblast_term m1 y yb) + (! c (^ (bblast_concat xb yb ) rb) + (bblast_term n (concat n m m1 x y) rb))))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST EXTRACT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_extract_rec ((x bblt) (i mpz) (j mpz) (n mpz)) bblt + (match x + ((bbltc bx x') (mp_ifneg (mpz_sub (mpz_sub j n) 1) + (mp_ifneg (mpz_sub (mpz_sub n i) 1) + (bbltc bx (bblast_extract_rec x' i j (mpz_sub n 1))) + (bblast_extract_rec x' i j (mpz_sub n 1))) + + bbltn)) + (bbltn bbltn))) + +(program bblast_extract ((x bblt) (i mpz) (j mpz) (n mpz)) bblt + (bblast_extract_rec x i j (mpz_sub n 1))) + +(declare bv_bbl_extract (! n mpz + (! i mpz + (! j mpz + (! m mpz + (! x (term (BitVec m)) + (! xb bblt + (! rb bblt + (! xbb (bblast_term m x xb) + (! c ( ^ (bblast_extract xb i j m) rb) + (bblast_term n (extract n i j m x) rb))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST ZERO/SIGN EXTEND +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program extend_rec ((x bblt) (i mpz) (b formula)) bblt + (mp_ifneg i x + (bbltc b (extend_rec x (mpz_sub i 1) b)))) + +(program bblast_zextend ((x bblt) (i mpz)) bblt + (extend_rec x (mpz_sub i 1) false)) + +(declare bv_bbl_zero_extend (! n mpz + (! k mpz + (! m mpz + (! x (term (BitVec m)) + (! xb bblt + (! rb bblt + (! xbb (bblast_term m x xb) + (! c ( ^ (bblast_zextend xb k m) rb) + (bblast_term n (zero_extend n k m x) rb)))))))))) + +(program bblast_sextend ((x bblt) (i mpz)) bblt + (match x (bbltn (fail bblt)) + ((bbltc xb x') (extend_rec x (mpz_sub i 1) xb)))) + +(declare bv_bbl_sign_extend (! n mpz + (! k mpz + (! m mpz + (! x (term (BitVec m)) + (! xb bblt + (! rb bblt + (! xbb (bblast_term m x xb) + (! c ( ^ (bblast_sextend xb k m) rb) + (bblast_term n (sign_extend n k m x) rb)))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVAND +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvand ((x bblt) (y bblt)) bblt + (match x + (bbltn (match y (bbltn bbltn) (default (fail bblt)))) + ((bbltc bx x') (match y + (bbltn (fail bblt)) + ((bbltc by y') (bbltc (and bx by) (bblast_bvand x' y'))))))) + +(declare bv_bbl_bvand (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! ybb (bblast_term n y yb) + (! c (^ (bblast_bvand xb yb ) rb) + (bblast_term n (bvand n x y) rb))))))))))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVNOT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvnot ((x bblt)) bblt + (match x + (bbltn bbltn) + ((bbltc bx x') (bbltc (not bx) (bblast_bvnot x'))))) + +(declare bv_bbl_bvnot (! n mpz + (! x (term (BitVec n)) + (! xb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! c (^ (bblast_bvnot xb ) rb) + (bblast_term n (bvnot n x) rb)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVOR +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvor ((x bblt) (y bblt)) bblt + (match x + (bbltn (match y (bbltn bbltn) (default (fail bblt)))) + ((bbltc bx x') (match y + (bbltn (fail bblt)) + ((bbltc by y') (bbltc (or bx by) (bblast_bvor x' y'))))))) + +(declare bv_bbl_bvor (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! ybb (bblast_term n y yb) + (! c (^ (bblast_bvor xb yb ) rb) + (bblast_term n (bvor n x y) rb))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVXOR +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvxor ((x bblt) (y bblt)) bblt + (match x + (bbltn (match y (bbltn bbltn) (default (fail bblt)))) + ((bbltc bx x') (match y + (bbltn (fail bblt)) + ((bbltc by y') (bbltc (xor bx by) (bblast_bvxor x' y'))))))) + +(declare bv_bbl_bvxor (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! ybb (bblast_term n y yb) + (! c (^ (bblast_bvxor xb yb ) rb) + (bblast_term n (bvxor n x y) rb))))))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVADD +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; return the carry bit after adding x y +;; FIXME: not the most efficient thing in the world +(program bblast_bvadd_carry ((a bblt) (b bblt) (carry formula)) formula +(match a + ( bbltn (match b (bbltn carry) (default (fail formula)))) + ((bbltc ai a') (match b + (bbltn (fail formula)) + ((bbltc bi b') (or (and ai bi) (and (xor ai bi) (bblast_bvadd_carry a' b' carry)))))))) + +;; ripple carry adder where carry is the initial carry bit +(program bblast_bvadd ((a bblt) (b bblt) (carry formula)) bblt +(match a + ( bbltn (match b (bbltn bbltn) (default (fail bblt)))) + ((bbltc ai a') (match b + (bbltn (fail bblt)) + ((bbltc bi b') (bbltc (xor (xor ai bi) (bblast_bvadd_carry a' b' carry)) + (bblast_bvadd a' b' carry))))))) + + +(program reverse_help ((x bblt) (acc bblt)) bblt +(match x + (bbltn acc) + ((bbltc xi x') (reverse_help x' (bbltc xi acc))))) + + +(program reverseb ((x bblt)) bblt + (reverse_help x bbltn)) + + +; AJR: use this version? +;(program bblast_bvadd_2h ((a bblt) (b bblt) (carry formula)) bblt +;(match a +; ( bbltn (match b (bbltn bbltn) (default (fail bblt)))) +; ((bbltc ai a') (match b +; (bbltn (fail bblt)) +; ((bbltc bi b') +; (let carry' (or (and ai bi) (and (xor ai bi) carry)) +; (bbltc (xor (xor ai bi) carry) +; (bblast_bvadd_2h a' b' carry')))))))) + +;(program bblast_bvadd_2 ((a bblt) (b bblt) (carry formula)) bblt +;(let ar (reverseb a) ;; reverse a and b so that we can build the circuit +;(let br (reverseb b) ;; from the least significant bit up +;(let ret (bblast_bvadd_2h ar br carry) +; (reverseb ret))))) + +(declare bv_bbl_bvadd (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! ybb (bblast_term n y yb) + (! c (^ (bblast_bvadd xb yb false) rb) + (bblast_term n (bvadd n x y) rb))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVNEG +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_zero ((n mpz)) bblt +(mp_ifzero n bbltn + (bbltc false (bblast_zero (mp_add n (~1)))))) + +(program bblast_bvneg ((x bblt) (n mpz)) bblt + (bblast_bvadd (bblast_bvnot x) (bblast_zero n) true)) + + +(declare bv_bbl_bvneg (! n mpz + (! x (term (BitVec n)) + (! xb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! c (^ (bblast_bvneg xb n) rb) + (bblast_term n (bvneg n x) rb)))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVMUL +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; shift add multiplier + +;; (program concat ((a bblt) (b bblt)) bblt +;; (match a (bbltn b) +;; ((bbltc ai a') (bbltc ai (concat a' b))))) + + +(program top_k_bits ((a bblt) (k mpz)) bblt + (mp_ifzero k bbltn + (match a (bbltn (fail bblt)) + ((bbltc ai a') (bbltc ai (top_k_bits a' (mpz_sub k 1))))))) + +(program bottom_k_bits ((a bblt) (k mpz)) bblt + (reverseb (top_k_bits (reverseb a) k))) + +;; assumes the least signigicant bit is at the beginning of the list +(program k_bit ((a bblt) (k mpz)) formula +(mp_ifneg k (fail formula) +(match a (bbltn (fail formula)) + ((bbltc ai a') (mp_ifzero k ai (k_bit a' (mpz_sub k 1))))))) + +(program and_with_bit ((a bblt) (bt formula)) bblt +(match a (bbltn bbltn) + ((bbltc ai a') (bbltc (and bt ai) (and_with_bit a' bt))))) + +;; a is going to be the current result +;; carry is going to be false initially +;; b is the and of a and b[k] +;; res is going to be bbltn initially +(program mult_step_k_h ((a bblt) (b bblt) (res bblt) (carry formula) (k mpz)) bblt +(match a + (bbltn (match b (bbltn res) (default (fail bblt)))) + ((bbltc ai a') + (match b (bbltn (fail bblt)) + ((bbltc bi b') + (mp_ifneg (mpz_sub k 1) + (let carry_out (or (and ai bi) (and (xor ai bi) carry)) + (let curr (xor (xor ai bi) carry) + (mult_step_k_h a' b' (bbltc curr res) carry_out (mpz_sub k 1)))) + (mult_step_k_h a' b (bbltc ai res) carry (mpz_sub k 1)) +)))))) + +;; assumes that a, b and res have already been reversed +(program mult_step ((a bblt) (b bblt) (res bblt) (n mpz) (k mpz)) bblt +(let k' (mpz_sub n k ) +(let ak (top_k_bits a k') +(let b' (and_with_bit ak (k_bit b k)) + (mp_ifzero (mpz_sub k' 1) + (mult_step_k_h res b' bbltn false k) + (let res' (mult_step_k_h res b' bbltn false k) + (mult_step a b (reverseb res') n (mp_add k 1)))))))) + + +(program bblast_bvmul ((a bblt) (b bblt) (n mpz)) bblt +(let ar (reverseb a) ;; reverse a and b so that we can build the circuit +(let br (reverseb b) ;; from the least significant bit up +(let res (and_with_bit ar (k_bit br 0)) + (mp_ifzero (mpz_sub n 1) ;; if multiplying 1 bit numbers no need to call mult_step + res + (mult_step ar br res n 1)))))) + +(declare bv_bbl_bvmul (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! xb bblt + (! yb bblt + (! rb bblt + (! xbb (bblast_term n x xb) + (! ybb (bblast_term n y yb) + (! c (^ (bblast_bvmul xb yb n) rb) + (bblast_term n (bvmul n x y) rb))))))))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST EQUALS +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +; bit blast x = y +; for x,y of size n, it will return a conjuction (x.0 = y.0 ^ ( ... ^ (x.{n-1} = y.{n-1}))) +; f is the accumulator formula that builds the equality in the right order +(program bblast_eq_rec ((x bblt) (y bblt) (f formula)) formula + (match x + (bbltn (match y (bbltn f) (default (fail formula)))) + ((bbltc fx x') (match y + (bbltn (fail formula)) + ((bbltc fy y') (bblast_eq_rec x' y' (and (iff fx fy) f))))) + (default (fail formula)))) + +(program bblast_eq ((x bblt) (y bblt)) formula + (match x + ((bbltc bx x') (match y ((bbltc by y') (bblast_eq_rec x' y' (iff bx by))) + (default (fail formula)))) + (default (fail formula)))) + + +;; TODO: a temporary bypass for rewrites that we don't support yet. As soon +;; as we do, remove this rule. + +(declare bv_bbl_=_false + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! bx bblt + (! by bblt + (! f formula + (! bbx (bblast_term n x bx) + (! bby (bblast_term n y by) + (! c (^ (bblast_eq bx by) f) + (th_holds (iff (= (BitVec n) x y) false)))))))))))) + +(declare bv_bbl_= + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! bx bblt + (! by bblt + (! f formula + (! bbx (bblast_term n x bx) + (! bby (bblast_term n y by) + (! c (^ (bblast_eq bx by) f) + (th_holds (iff (= (BitVec n) x y) f)))))))))))) + +(declare bv_bbl_=_swap + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! bx bblt + (! by bblt + (! f formula + (! bbx (bblast_term n x bx) + (! bby (bblast_term n y by) + (! c (^ (bblast_eq by bx) f) + (th_holds (iff (= (BitVec n) x y) f)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVULT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvult ((x bblt) (y bblt) (n mpz)) formula +(match x + ( bbltn (fail formula)) + ((bbltc xi x') (match y + (bbltn (fail formula)) + ((bbltc yi y') (mp_ifzero n + (and (not xi) yi) + (or (and (iff xi yi) (bblast_bvult x' y' (mp_add n (~1)))) (and (not xi) yi)))))))) + +(declare bv_bbl_bvult + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! bx bblt + (! by bblt + (! f formula + (! bbx (bblast_term n x bx) + (! bby (bblast_term n y by) + (! c (^ (bblast_bvult bx by (mp_add n (~1))) f) + (th_holds (iff (bvult n x y) f)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; BITBLAST BVSLT +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(program bblast_bvslt ((x bblt) (y bblt) (n mpz)) formula +(match x + ( bbltn (fail formula)) + ((bbltc xi x') (match y + (bbltn (fail formula)) + ((bbltc yi y') (mp_ifzero (mpz_sub n 1) + (and xi (not yi)) + (or (and (iff xi yi) + (bblast_bvult x' y' (mpz_sub n 2))) + (and xi (not yi))))))))) + +(declare bv_bbl_bvslt + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (! bx bblt + (! by bblt + (! f formula + (! bbx (bblast_term n x bx) + (! bby (bblast_term n y by) + (! c (^ (bblast_bvslt bx by n) f) + (th_holds (iff (bvslt n x y) f)))))))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; BITBLASTING CONNECTORS +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +; bit-blasting connections + +(declare intro_assump_t + (! f formula + (! v var + (! C clause + (! h (th_holds f) + (! a (atom v f) + (! u (! unit (holds (clc (pos v) cln)) + (holds C)) + (holds C)))))))) + +(declare intro_assump_f + (! f formula + (! v var + (! C clause + (! h (th_holds (not f)) + (! a (atom v f) + (! u (! unit (holds (clc (neg v) cln)) + (holds C)) + (holds C)))))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; REWRITE RULES +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +; rewrite rule : +; x + y = y + x +(declare bvadd_symm + (! n mpz + (! x (term (BitVec n)) + (! y (term (BitVec n)) + (th_holds (= (BitVec n) (bvadd _ x y) (bvadd _ y x))))))) + +;; (declare bvcrazy_rewrite +;; (! n mpz +;; (! x (term (BitVec n)) +;; (! y (term (BitVec n)) +;; (! xn bv_poly +;; (! yn bv_poly +;; (! hxn (bv_normalizes x xn) +;; (! hyn (bv_normalizes y yn) +;; (! s (^ (rewrite_scc xn yn) true) +;; (! u (! x (term (BitVec n)) (holds cln)) +;; (holds cln))))))))))) + +;; (th_holds (= (BitVec n) (bvadd x y) (bvadd y x))))))) + + + +; necessary? +;; (program calc_bvand ((a bv) (b bv)) bv +;; (match a +;; (bvn (match b (bvn bvn) (default (fail bv)))) +;; ((bvc ba a') (match b +;; ((bvc bb b') (bvc (match ba (b0 b0) (b1 bb)) (calc_bvand a' b'))) +;; (default (fail bv)))))) + +;; ; rewrite rule (w constants) : +;; ; a & b = c +;; (declare bvand_const (! c bv +;; (! a bv +;; (! b bv +;; (! u (^ (calc_bvand a b) c) +;; (th_holds (= BitVec (bvand (a_bv a) (a_bv b)) (a_bv c)))))))) + + +;; making constant bit-vectors +(program mk_ones ((n mpz)) bv + (mp_ifzero n bvn (bvc b1 (mk_ones (mpz_sub n 1))))) + +(program mk_zero ((n mpz)) bv + (mp_ifzero n bvn (bvc b0 (mk_ones (mpz_sub n 1))))) + + + +;; (bvxnor a b) => (bvnot (bvxor a b)) +;; (declare bvxnor_elim +;; (! n mpz +;; (! a (term (BitVec n)) +;; (! b (term (BitVec n)) +;; (! a' (term (BitVec n)) +;; (! b' (term (BitVec n)) +;; (! rwa (rw_term _ a a') +;; (! rwb (rw_term _ b b') +;; (rw_term n (bvxnor _ a b) +;; (bvnot _ (bvxor _ a' b'))))))))))) + + + +;; ;; (bvxor a 0) => a +;; (declare bvxor_zero +;; (! n mpz +;; (! zero_bits bv +;; (! sc (^ (mk_zero n) zero_bits) +;; (! a (term (BitVec n)) +;; (! b (term (BitVec n)) +;; (! a' (term (BitVec n)) +;; (! rwa (rw_term _ a a') +;; (! rwb (rw_term _ b (a_bv _ zero_bits)) +;; (rw_term _ (bvxor _ a b) +;; a')))))))))) + +;; ;; (bvxor a 11) => (bvnot a) +;; (declare bvxor_one +;; (! n mpz +;; (! one_bits bv +;; (! sc (^ (mk_ones n) one_bits) +;; (! a (term (BitVec n)) +;; (! b (term (BitVec n)) +;; (! a' (term (BitVec n)) +;; (! rwa (rw_term _ a a') +;; (! rwb (rw_term _ b (a_bv _ one_bits)) +;; (rw_term _ (bvxor _ a b) +;; (bvnot _ a'))))))))))) + + +;; ;; (bvnot (bvnot a)) => a +;; (declare bvnot_idemp +;; (! n mpz +;; (! a (term (BitVec n)) +;; (! a' (term (BitVec n)) +;; (! rwa (rw_term _ a a') +;; (rw_term _ (bvnot _ (bvnot _ a)) +;; a')))))) diff --git a/src/lfsc/tests/signatures/th_bv_rewrites.plf b/src/lfsc/tests/signatures/th_bv_rewrites.plf new file mode 100644 index 0000000..4af9a09 --- /dev/null +++ b/src/lfsc/tests/signatures/th_bv_rewrites.plf @@ -0,0 +1,22 @@ +; +; Equality swap +; + +(declare rr_bv_eq + (! n mpz + (! t1 (term (BitVec n)) + (! t2 (term (BitVec n)) + (th_holds (iff (= (BitVec n) t2 t1) (= (BitVec n) t1 t2))))))) + +; +; Additional rules... +; + +; +; Default, if nothing else applied +; + +(declare rr_bv_default + (! t1 formula + (! t2 formula + (th_holds (iff t1 t2))))) diff --git a/src/lfsc/tests/signatures/th_int.plf b/src/lfsc/tests/signatures/th_int.plf new file mode 100644 index 0000000..9a0a2d6 --- /dev/null +++ b/src/lfsc/tests/signatures/th_int.plf @@ -0,0 +1,25 @@ +(declare Int sort) + +(define arithpred_Int (! x (term Int) + (! y (term Int) + formula))) + +(declare >_Int arithpred_Int) +(declare >=_Int arithpred_Int) +(declare <_Int arithpred_Int) +(declare <=_Int arithpred_Int) + +(define arithterm_Int (! x (term Int) + (! y (term Int) + (term Int)))) + +(declare +_Int arithterm_Int) +(declare -_Int arithterm_Int) +(declare *_Int arithterm_Int) ; is * ok to use? +(declare /_Int arithterm_Int) ; is / ok to use? + +; a constant term +(declare a_int (! x mpz (term Int))) + +; unary negation +(declare u-_Int (! t (term Int) (term Int))) diff --git a/src/lfsc/tests/simple.smt2 b/src/lfsc/tests/simple.smt2 new file mode 100644 index 0000000..13d15cb --- /dev/null +++ b/src/lfsc/tests/simple.smt2 @@ -0,0 +1,16 @@ +(set-option :produce-proofs true) +(set-logic QF_UF) +(declare-sort U 0) + +(declare-fun f (U U) U) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) + +(assert (not (= (f a b) (f b b)))) +(assert (not (= (f a b) (f c b)))) + +(assert (or (= a b) (= a c))) +(check-sat) +(get-proof) +(exit) diff --git a/src/lfsc/tests/swap1.smt2 b/src/lfsc/tests/swap1.smt2 new file mode 100644 index 0000000..7755705 --- /dev/null +++ b/src/lfsc/tests/swap1.smt2 @@ -0,0 +1,20 @@ +(set-logic QF_AUFLIA) +(set-info :source | +Benchmarks used in the followin paper: +Big proof engines as little proof engines: new results on rewrite-based satisfiability procedure +Alessandro Armando, Maria Paola Bonacina, Silvio Ranise, Stephan Schulz. +PDPAR'05 +http://www.ai.dist.unige.it/pdpar05/ + + +|) +(set-info :smt-lib-version 2.0) +(set-info :category "crafted") +(set-info :status unsat) +(declare-fun a1 () (Array Int Int)) +(declare-fun i0 () Int) +(declare-fun i1 () Int) +(declare-fun sk ((Array Int Int) (Array Int Int)) Int) +(assert (let ((?v_0 (select a1 i1))) (let ((?v_1 (store (store a1 i1 ?v_0) i1 ?v_0))) (let ((?v_3 (select ?v_1 i0)) (?v_4 (select ?v_1 i1))) (let ((?v_2 (store (store ?v_1 i0 ?v_4) i1 ?v_3)) (?v_5 (store (store ?v_1 i1 ?v_3) i0 ?v_4))) (let ((?v_6 (sk ?v_2 ?v_5))) (not (= (select ?v_2 ?v_6) (select ?v_5 ?v_6))))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/swap3.smt2 b/src/lfsc/tests/swap3.smt2 new file mode 100644 index 0000000..cade13f --- /dev/null +++ b/src/lfsc/tests/swap3.smt2 @@ -0,0 +1,82 @@ +(set-logic QF_AUFLIA) +(set-info :source | +Benchmarks used in the followin paper: +Big proof engines as little proof engines: new results on rewrite-based satisfiability procedure +Alessandro Armando, Maria Paola Bonacina, Silvio Ranise, Stephan Schulz. +PDPAR'05 +http://www.ai.dist.unige.it/pdpar05/ + + +|) +(set-info :smt-lib-version 2.0) +(set-info :category "crafted") +(set-info :status unsat) +(declare-fun a_705 () (Array Int Int)) +(declare-fun a_707 () (Array Int Int)) +(declare-fun a_709 () (Array Int Int)) +(declare-fun a_711 () (Array Int Int)) +(declare-fun a_713 () (Array Int Int)) +(declare-fun a_715 () (Array Int Int)) +(declare-fun a_717 () (Array Int Int)) +(declare-fun a_719 () (Array Int Int)) +(declare-fun a_721 () (Array Int Int)) +(declare-fun a_723 () (Array Int Int)) +(declare-fun a_725 () (Array Int Int)) +(declare-fun a_727 () (Array Int Int)) +(declare-fun a_728 () (Array Int Int)) +(declare-fun a_729 () (Array Int Int)) +(declare-fun e_704 () Int) +(declare-fun e_706 () Int) +(declare-fun e_708 () Int) +(declare-fun e_710 () Int) +(declare-fun e_712 () Int) +(declare-fun e_714 () Int) +(declare-fun e_716 () Int) +(declare-fun e_718 () Int) +(declare-fun e_720 () Int) +(declare-fun e_722 () Int) +(declare-fun e_724 () Int) +(declare-fun e_726 () Int) +(declare-fun e_731 () Int) +(declare-fun e_732 () Int) +(declare-fun i_730 () Int) +(declare-fun a1 () (Array Int Int)) +(declare-fun i0 () Int) +(declare-fun i1 () Int) +(declare-fun i2 () Int) +(declare-fun i3 () Int) +(declare-fun i4 () Int) +(declare-fun i5 () Int) +(declare-fun sk ((Array Int Int) (Array Int Int)) Int) +(assert (= a_705 (store a1 i4 e_704))) +(assert (= a_707 (store a_705 i2 e_706))) +(assert (= a_709 (store a_707 i1 e_708))) +(assert (= a_711 (store a_709 i4 e_710))) +(assert (= a_713 (store a_711 i5 e_712))) +(assert (= a_715 (store a_713 i3 e_714))) +(assert (= a_717 (store a_715 i4 e_716))) +(assert (= a_719 (store a_717 i2 e_718))) +(assert (= a_721 (store a_719 i1 e_720))) +(assert (= a_723 (store a_721 i0 e_722))) +(assert (= a_725 (store a_723 i5 e_724))) +(assert (= a_727 (store a_725 i2 e_726))) +(assert (= a_728 (store a_723 i2 e_726))) +(assert (= a_729 (store a_728 i5 e_724))) +(assert (= e_704 (select a1 i2))) +(assert (= e_706 (select a1 i4))) +(assert (= e_708 (select a_707 i4))) +(assert (= e_710 (select a_707 i1))) +(assert (= e_712 (select a_711 i3))) +(assert (= e_714 (select a_711 i5))) +(assert (= e_716 (select a_715 i2))) +(assert (= e_718 (select a_715 i4))) +(assert (= e_720 (select a_719 i0))) +(assert (= e_722 (select a_719 i1))) +(assert (= e_724 (select a_723 i2))) +(assert (= e_726 (select a_723 i5))) +(assert (= e_731 (select a_727 i_730))) +(assert (= e_732 (select a_729 i_730))) +(assert (= i_730 (sk a_727 a_729))) +(assert (not (= e_731 e_732))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/tcong.smt2 b/src/lfsc/tests/tcong.smt2 new file mode 100644 index 0000000..47a3bf8 --- /dev/null +++ b/src/lfsc/tests/tcong.smt2 @@ -0,0 +1,14 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) +(declare-fun f (U U) U) + +(assert (not + (=> (and (= a b) (= a c)) + (= (f a c) (f b a))))) + +(check-sat) +(exit) + diff --git a/src/lfsc/tests/trans.smt2 b/src/lfsc/tests/trans.smt2 new file mode 100644 index 0000000..b27b52a --- /dev/null +++ b/src/lfsc/tests/trans.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) +(declare-fun d () U) +(declare-fun e () U) +(declare-fun f () U) +(assert (and (= a b) (and (= b c) (and (= c d) (and (= c e) (and (= e f) (not (= a f)))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/typesafe2.smt2 b/src/lfsc/tests/typesafe2.smt2 new file mode 100644 index 0000000..8154a58 --- /dev/null +++ b/src/lfsc/tests/typesafe2.smt2 @@ -0,0 +1,29 @@ +(set-logic QF_UF) +(set-info :source |Benchmarks from the paper: "Extending Sledgehammer with SMT Solvers" by Jasmin Blanchette, Sascha Bohme, and Lawrence C. Paulson, CADE 2011. Translated to SMT2 by Andrew Reynolds and Morgan Deters.|) +(set-info :smt-lib-version 2.0) +(set-info :category "industrial") +(set-info :status unsat) +(declare-sort S1 0) +(declare-sort S2 0) +(declare-sort S3 0) +(declare-sort S4 0) +(declare-sort S5 0) +(declare-sort S6 0) +(declare-sort S7 0) +(declare-fun f1 () S1) +(declare-fun f2 () S1) +(declare-fun f3 (S2 S3 S4 S5 S6) S1) +(declare-fun f4 () S2) +(declare-fun f5 () S3) +(declare-fun f6 () S4) +(declare-fun f7 () S5) +(declare-fun f8 (S7) S6) +(declare-fun f9 () S7) +(declare-fun f10 () S6) +(assert (not (= f1 f2))) +(assert (not (= (f3 f4 f5 f6 f7 (f8 f9)) f1))) +(assert (= (f3 f4 f5 f6 f7 f10) f1)) +(assert (= f10 (f8 f9))) +(assert (= (f3 f4 f5 f6 f7 f10) f1)) +(check-sat) +(exit) diff --git a/src/lfsc/tests/typesafe3.smt2 b/src/lfsc/tests/typesafe3.smt2 new file mode 100644 index 0000000..35725de --- /dev/null +++ b/src/lfsc/tests/typesafe3.smt2 @@ -0,0 +1,28 @@ +(set-logic QF_UF) +(set-info :source |Benchmarks from the paper: "Extending Sledgehammer with SMT Solvers" by Jasmin Blanchette, Sascha Bohme, and Lawrence C. Paulson, CADE 2011. Translated to SMT2 by Andrew Reynolds and Morgan Deters.|) +(set-info :smt-lib-version 2.0) +(set-info :category "industrial") +(set-info :status unsat) +(declare-sort S1 0) +(declare-sort S2 0) +(declare-sort S3 0) +(declare-sort S4 0) +(declare-sort S5 0) +(declare-sort S6 0) +(declare-sort S7 0) +(declare-fun f1 () S1) +(declare-fun f2 () S1) +(declare-fun f3 (S2 S3 S4 S5 S6) S1) +(declare-fun f4 () S2) +(declare-fun f5 () S3) +(declare-fun f6 () S4) +(declare-fun f7 () S5) +(declare-fun f8 (S7) S6) +(declare-fun f9 () S7) +(declare-fun f10 () S6) +(assert (not (= f1 f2))) +(assert (not (= (f3 f4 f5 f6 f7 (f8 f9)) f1))) +(assert (= (f3 f4 f5 f6 f7 f10) f1)) +(assert (= f10 (f8 f9))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/uf1.smt2 b/src/lfsc/tests/uf1.smt2 new file mode 100644 index 0000000..b7c9df4 --- /dev/null +++ b/src/lfsc/tests/uf1.smt2 @@ -0,0 +1,10 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) +(declare-fun f (U) U) +(declare-fun p (U) Bool) +(assert (and (= a c) (and (= b c) (or (not (= (f a) (f b))) (and (p a) (not (p b))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/uf2.smt2 b/src/lfsc/tests/uf2.smt2 new file mode 100644 index 0000000..9b2e47b --- /dev/null +++ b/src/lfsc/tests/uf2.smt2 @@ -0,0 +1,9 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) +(declare-fun p (U) Bool) +(assert (and (or (and (p a) (p b)) (and (p b) (p c))) (not (p b)))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/uf4.smt2 b/src/lfsc/tests/uf4.smt2 new file mode 100644 index 0000000..1b9a7e1 --- /dev/null +++ b/src/lfsc/tests/uf4.smt2 @@ -0,0 +1,9 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun x () U) +(declare-fun y () U) +(declare-fun z () U) +(declare-fun f (U) U) +(assert (and (not (= (f x) (f y))) (and (= y z) (and (= (f x) (f (f z))) (= x y))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/uf5.smt2 b/src/lfsc/tests/uf5.smt2 new file mode 100644 index 0000000..b27b52a --- /dev/null +++ b/src/lfsc/tests/uf5.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun a () U) +(declare-fun b () U) +(declare-fun c () U) +(declare-fun d () U) +(declare-fun e () U) +(declare-fun f () U) +(assert (and (= a b) (and (= b c) (and (= c d) (and (= c e) (and (= e f) (not (= a f)))))))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/uf6.smt2 b/src/lfsc/tests/uf6.smt2 new file mode 100644 index 0000000..2fa1932 --- /dev/null +++ b/src/lfsc/tests/uf6.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun x () U) +(declare-fun y () U) +(declare-fun z () U) +(declare-fun f (U U) U) +(assert (= x y)) +(assert (not (= (f z x) (f z y)))) +(check-sat) +(exit) + diff --git a/src/lfsc/tests/uf7.smt2 b/src/lfsc/tests/uf7.smt2 new file mode 100644 index 0000000..30efa7c --- /dev/null +++ b/src/lfsc/tests/uf7.smt2 @@ -0,0 +1,11 @@ +(set-logic QF_UF) +(declare-sort U 0) +(declare-fun x () U) +(declare-fun y () U) +(declare-fun z () U) +(declare-fun P (U U) Bool) +(assert (= x y)) +(assert (P z x)) +(assert (not (P z y))) +(check-sat) +(exit) diff --git a/src/lfsc/tests/vmcai_bytes.smt2 b/src/lfsc/tests/vmcai_bytes.smt2 new file mode 100644 index 0000000..6628e37 --- /dev/null +++ b/src/lfsc/tests/vmcai_bytes.smt2 @@ -0,0 +1,39 @@ +(set-logic QF_ABV) +(declare-fun initialMemoryState_0x2ae2bf0 () (Array (_ BitVec 64) (_ BitVec 8))) +(assert +(let ((x1 (_ bv1 8))) +(let ((x2 (_ bv0 32))) +(let ((x3 (_ bv3221225470 64))) +(let ((x4 (_ bv3221225468 64))) +(let ((x5 initialMemoryState_0x2ae2bf0)) +(let ((x6 (_ bv3221225468 64))) +(let ((x7 ((_ extract 7 0) x2))) +(let ((x8 (store x5 x6 x7))) +(let ((x9 (_ bv3221225469 64))) +(let ((x10 ((_ extract 15 8) x2))) +(let ((x11 (store x8 x9 x10))) +(let ((x12 (_ bv3221225470 64))) +(let ((x13 ((_ extract 23 16) x2))) +(let ((x14 (store x11 x12 x13))) +(let ((x15 (_ bv3221225471 64))) +(let ((x16 ((_ extract 31 24) x2))) +(let ((x17 (store x14 x15 x16))) +(let ((x18 (store x17 x3 x1))) +(let ((x19 (_ bv3221225468 64))) +(let ((x20 (select x18 x19))) +(let ((x21 (_ bv3221225469 64))) +(let ((x22 (select x18 x21))) +(let ((x23 (_ bv3221225470 64))) +(let ((x24 (select x18 x23))) +(let ((x25 (_ bv3221225471 64))) +(let ((x26 (select x18 x25))) +(let ((x27 (concat x22 x20))) +(let ((x28 (concat x24 x27))) +(let ((x29 (concat x26 x28))) +(let ((dollar_x30 (not (= x29 x2)))) +(let ((dollar_x31 (not dollar_x30))) +dollar_x31 +))))))))))))))))))))))))))))))) +) +(check-sat) +(exit) diff --git a/src/lfsc/tests/wrapper_cvc4tocoq.sh b/src/lfsc/tests/wrapper_cvc4tocoq.sh new file mode 100755 index 0000000..dba9bdc --- /dev/null +++ b/src/lfsc/tests/wrapper_cvc4tocoq.sh @@ -0,0 +1,9 @@ +#!/bin/bash +set -e +OUTPUT_FOLDER=/home/burak/Desktop/smtcoq/src/lfsc/tests/results/ +CVC4TOCOQ_HOME=/home/burak/Desktop/smtcoq/src/lfsc/tests/ + +${CVC4TOCOQ_HOME}/cvc4tocoq $1 &> $1.result +#exit 0 +# exit'e gerek var mi emin degilim abi +#${CVC4TOCOQ_HOME}/cvc4tocoq $1 &> ${OUTPUT_FOLDER}$1.result diff --git a/src/lfsc/tosmtcoq.ml b/src/lfsc/tosmtcoq.ml new file mode 100644 index 0000000..0395244 --- /dev/null +++ b/src/lfsc/tosmtcoq.ml @@ -0,0 +1,595 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open SmtAtom +open SmtForm +open SmtCertif +open SmtTrace +open VeritSyntax +open Ast +open Builtin +open Format +open Translator_sig +open SmtBtype + +type lit = SmtAtom.Form.t + +type clause = lit list + +let lit_of_atom_form_lit rf af = lit_of_atom_form_lit rf (true, af) + +let show_veritproof = + try ignore (Sys.getenv "DONTSHOWVERIT"); false + with Not_found -> true + + +module HS = Hstring.H +(* module HT = Hashtbl.Make (Term) *) +module HCl = Hashtbl + +module HT = struct + module M = Map.Make (Term) + let create _ = ref M.empty + let add h k v = h := M.add k v !h + let find h k = M.find k !h + let clear h = h := M.empty + let iter f h = M.iter f !h +end + + + +let clauses_ids = HCl.create 201 +let ids_clauses = Hashtbl.create 201 +let propvars = HT.create 201 +let inputs : int HS.t = HS.create 13 +let alias_tbl = HS.create 17 +let memo_terms = HT.create 31 +(* let termalias_tbl = HT.create 17 *) + +let cl_cpt = ref 0 + + +let get_rule = function + | Reso -> VeritSyntax.Reso + | Weak -> VeritSyntax.Weak + | Or -> VeritSyntax.Or + | Orp -> VeritSyntax.Orp + | Imp -> VeritSyntax.Imp + | Impp -> VeritSyntax.Impp + | Nand -> VeritSyntax.Nand + | Andn -> VeritSyntax.Andn + | Nimp1 -> VeritSyntax.Nimp1 + | Nimp2 -> VeritSyntax.Nimp2 + | Impn1 -> VeritSyntax.Impn1 + | Impn2 -> VeritSyntax.Impn2 + | Nor -> VeritSyntax.Nor + | Orn -> VeritSyntax.Orn + | And -> VeritSyntax.And + | Andp -> VeritSyntax.Andp + | Equ1 -> VeritSyntax.Equ1 + | Equ2 -> VeritSyntax.Equ2 + | Nequ1 -> VeritSyntax.Nequ1 + | Nequ2 -> VeritSyntax.Nequ2 + | Equp1 -> VeritSyntax.Equp1 + | Equp2 -> VeritSyntax.Equp2 + | Equn1 -> VeritSyntax.Equn1 + | Equn2 -> VeritSyntax.Equn2 + | Xor1 -> VeritSyntax.Xor1 + | Xor2 -> VeritSyntax.Xor2 + | Xorp1 -> VeritSyntax.Xorp1 + | Xorp2 -> VeritSyntax.Xorp2 + | Xorn1 -> VeritSyntax.Xorn1 + | Xorn2 -> VeritSyntax.Xorn2 + | Nxor1 -> VeritSyntax.Nxor1 + | Nxor2 -> VeritSyntax.Nxor2 + | Itep1 -> VeritSyntax.Itep1 + | Itep2 -> VeritSyntax.Itep2 + | Iten1 -> VeritSyntax.Iten1 + | Iten2 -> VeritSyntax.Iten2 + | Ite1 -> VeritSyntax.Ite1 + | Ite2 -> VeritSyntax.Ite2 + | Nite1 -> VeritSyntax.Nite1 + | Nite2 -> VeritSyntax.Nite2 + | Eqtr -> VeritSyntax.Eqtr + | Eqcp -> VeritSyntax.Eqcp + | Eqco -> VeritSyntax.Eqco + | Eqre -> VeritSyntax.Eqre + | Lage -> VeritSyntax.Lage + | Flat -> VeritSyntax.Flat + | Hole -> VeritSyntax.Hole + | True -> VeritSyntax.True + | Fals -> VeritSyntax.Fals + | Bbva -> VeritSyntax.Bbva + | Bbconst -> VeritSyntax.Bbconst + | Bbeq -> VeritSyntax.Bbeq + | Bbdis -> VeritSyntax.Bbdis + | Bbop -> VeritSyntax.Bbop + | Bbadd -> VeritSyntax.Bbadd + | Bbmul -> VeritSyntax.Bbmul + | Bbult -> VeritSyntax.Bbult + | Bbslt -> VeritSyntax.Bbslt + | Bbshl -> VeritSyntax.Bbshl + | Bbshr -> VeritSyntax.Bbshr + | Bbnot -> VeritSyntax.Bbnot + | Bbneg -> VeritSyntax.Bbneg + | Bbconc -> VeritSyntax.Bbconc + | Bbextr -> VeritSyntax.Bbextr + | Bbzext -> VeritSyntax.Bbzext + | Bbsext -> VeritSyntax.Bbsext + | Row1 -> VeritSyntax.Row1 + | Row2 -> VeritSyntax.Row2 + | Exte -> VeritSyntax.Exte + +let string_of_rule = function + | Reso -> "resolution" + | Weak -> "weaken" + | Or -> "or" + | Orp -> "or_pos" + | Imp -> "implies" + | Impp -> "implies_pos" + | Nand -> "not_and" + | Andn -> "and_neg" + | Nimp1 -> "not_implies1" + | Nimp2 -> "not_implies2" + | Impn1 -> "implies_neg1" + | Impn2 -> "implies_neg2" + | Nor -> "not_or" + | Orn -> "or_neg" + | And -> "and" + | Andp -> "and_pos" + | Equ1 -> "equiv1" + | Equ2 -> "equiv2" + | Nequ1 -> "not_equiv1" + | Nequ2 -> "not_equiv2" + | Equp1 -> "equiv_pos1" + | Equp2 -> "equiv_pos2" + | Equn1 -> "equiv_neg1" + | Equn2 -> "equiv_neg2" + | Xor1 -> "xor1" + | Xor2 -> "xor2" + | Xorp1 -> "xor_pos1" + | Xorp2 -> "xor_pos2" + | Xorn1 -> "xor_neg1" + | Xorn2 -> "xor_neg2" + | Nxor1 -> "not_xor1" + | Nxor2 -> "not_xor2" + | Itep1 -> "ite_pos1" + | Itep2 -> "ite_pos2" + | Iten1 -> "ite_neg1" + | Iten2 -> "ite_neg2" + | Ite1 -> "ite1" + | Ite2 -> "ite2" + | Nite1 -> "not_ite1" + | Nite2 -> "not_ite2" + | Eqtr -> "eq_transitive" + | Eqcp -> "eq_congruent_pred" + | Eqco -> "eq_congruent" + | Eqre -> "eq_reflexive" + | Lage -> "la_generic" + | Flat -> "flatten" + | Hole -> "hole" + | True -> "true" + | Fals -> "false" + | Bbva -> "bbvar" + | Bbconst -> "bbconst" + | Bbeq -> "bbeq" + | Bbdis -> "bv_const_neq" + | Bbop -> "bbop" + | Bbadd -> "bbadd" + | Bbmul -> "bbmul" + | Bbult -> "bbult" + | Bbslt -> "bbslt" + | Bbshl -> "bbshl" + | Bbshr -> "bbshr" + | Bbnot -> "bbnot" + | Bbneg -> "bbneg" + | Bbconc -> "bbconcat" + | Bbextr -> "bbextract" + | Bbzext -> "bbzextend" + | Bbsext -> "bbsextend" + | Row1 -> "row1" + | Row2 -> "row2" + | Exte -> "ext" + + +let bit_to_bool t = match name t with + | Some n when n == H.b0 -> false + | Some n when n == H.b1 -> true + | _ -> assert false + +let rec const_bv_aux acc t = match name t with + | Some n when n == H.bvn -> acc + | _ -> + match app_name t with + | Some (n, [b; t]) when n == H.bvc -> const_bv_aux (bit_to_bool b :: acc) t + | _ -> assert false + +let const_bv t = + let bv_list = const_bv_aux [] t in + Atom (Atom.mk_bvconst ra bv_list) + + +let rec term_smtcoq_old t = + match value t with + | Const {sname=Name n} when n == H.ttrue -> Form Form.pform_true + | Const {sname=Name n} when n == H.tfalse -> Form Form.pform_false + | Const {sname=Name n} when n == H.bvn -> const_bv t + | Const {sname=Name n} -> + begin + try + term_smtcoq (HS.find alias_tbl n) + with Not_found -> + Atom (Atom.get ra (Aapp (get_fun (Hstring.view n),[||]))) + end + | Int bi -> Atom (Atom.hatom_Z_of_bigint ra bi) + | App _ -> + begin match app_name t with + | Some (n, [f]) when n == H.not_ -> + Lit (Form.neg (lit_of_atom_form_lit rf (term_smtcoq f))) + | Some (n, args) when n == H.and_ -> Form (Fapp (Fand, args_smtcoq args)) + | Some (n, args) when n == H.or_ -> Form (Fapp (For, args_smtcoq args)) + | Some (n, args) when n == H.impl_ -> Form (Fapp (Fimp, args_smtcoq args)) + | Some (n, args) when n == H.xor_ -> Form (Fapp (Fxor, args_smtcoq args)) + | Some (n, args) when n == H.ite || n == H.ifte_ -> + Form (Fapp (Fite, args_smtcoq args)) + | Some (n, args) when n == H.iff -> Form (Fapp (Fiff, args_smtcoq args)) + | Some (n, [_; a; b]) when n == H.eq -> + let h1, h2 = term_smtcoq_atom a, term_smtcoq_atom b in + Atom (Atom.mk_eq ra (Atom.type_of h1) h1 h2) + | Some (n, _) when n == H.apply -> uncurry [] t + | Some (n, [p]) when n == H.p_app -> term_smtcoq p + | Some (n, [{value = Int bi}]) when n == H.a_int -> + Atom (Atom.hatom_Z_of_bigint ra bi) + | Some (n, [ni]) when n == H.a_int -> + begin match app_name ni with + | Some (n, [{value = Int bi}]) when n == H.uminus -> + Atom (Atom.hatom_Z_of_bigint ra (Big_int.minus_big_int bi)) + | _ -> assert false + end + | Some (n, [_; v]) when n == H.a_var_bv -> term_smtcoq v + | Some (n, _) when n == H.bvc -> const_bv t + | Some (n, [_; v]) when n == H.a_bv -> term_smtcoq v + | Some (b, [a; {value = Int n}]) when b == H.bitof -> + (let ha = term_smtcoq_atom a in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bitof ra s (Big_int.int_of_big_int n) ha) + | _ -> assert false) + | Some (n, [_; a; bb]) when n == H.bblast_term -> + Form (FbbT ((term_smtcoq_atom a), bblt_lits [] bb)) + | Some (n, [_; a]) when n == H.bvnot -> + (let ha = term_smtcoq_atom a in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvnot ra s ha) + | _ -> assert false) + | Some (n, [_; a]) when n == H.bvneg -> + (let ha = term_smtcoq_atom a in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvneg ra s ha) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvand -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvand ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvor -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvor ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvxor -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvxor ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvadd -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvadd ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvmul -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvmult ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvult -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvult ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvslt -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvslt ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvule -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> + let a = Atom (Atom.mk_bvult ra s hb ha) in + Lit (Form.neg (lit_of_atom_form_lit rf a)) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvsle -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> + let a = Atom (Atom.mk_bvslt ra s hb ha) in + Lit (Form.neg (lit_of_atom_form_lit rf a)) + | _ -> assert false) + | Some (n, [_; _; _; a; b]) when n == H.concat -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha, Atom.type_of hb with + | TBV s1, TBV s2 -> Atom (Atom.mk_bvconcat ra s1 s2 ha hb) + | _ -> assert false) + | Some (n, [_; {value = Int bj}; {value = Int bi}; _; a]) + when n == H.extract -> + (let ha = term_smtcoq_atom a in + let i = Big_int.int_of_big_int bi in + let j = Big_int.int_of_big_int bj in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvextr ra ~s ~i ~n:(j-i+1) ha) + | _ -> assert false) + | Some (n, [_; {value = Int bi}; _; a]) + when n == H.zero_extend -> + (let ha = term_smtcoq_atom a in + let n = Big_int.int_of_big_int bi in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvzextn ra ~s ~n ha) + | _ -> assert false) + | Some (n, [_; {value = Int bi}; _; a]) + when n == H.sign_extend -> + (let ha = term_smtcoq_atom a in + let n = Big_int.int_of_big_int bi in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvsextn ra ~s ~n ha) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvshl -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvshl ra s ha hb) + | _ -> assert false) + | Some (n, [_; a; b]) when n == H.bvlshr -> + (let ha = term_smtcoq_atom a in + let hb = term_smtcoq_atom b in + match Atom.type_of ha with + | TBV s -> Atom (Atom.mk_bvshr ra s ha hb) + | _ -> assert false) + + | Some (n, [a; b]) when n == H.lt_Int -> + Atom (Atom.mk_lt ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.le_Int -> + Atom (Atom.mk_le ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.gt_Int -> + Atom (Atom.mk_gt ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.ge_Int -> + Atom (Atom.mk_ge ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.plus_Int -> + Atom (Atom.mk_plus ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.minus_Int -> + Atom (Atom.mk_minus ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a; b]) when n == H.times_Int -> + Atom (Atom.mk_mult ra (term_smtcoq_atom a) (term_smtcoq_atom b)) + | Some (n, [a]) when n == H.uminus_Int -> + Atom (Atom.mk_opp ra (term_smtcoq_atom a)) + | Some (n, _) -> + Format.eprintf "\nTerm: %a\n@." print_term t; + failwith ("LFSC function symbol "^Hstring.view n^" not supported.") + | _ -> assert false + end + + | Rat _ -> failwith ("LFSC rationals not supported") + | Type -> failwith ("LFSC Type not supported") + | Kind -> failwith ("LFSC Kind not supported") + | Mpz -> failwith ("LFSC mpz not supported") + | Mpq -> failwith ("LFSC mpq not supported") + | Pi _ -> failwith ("LFSC pi abstractions not supported") + | Lambda _ -> failwith ("LFSC lambda abstractions not supported") + | Hole _ -> failwith ("LFSC holes not supported") + | Ptr _ -> failwith ("LFSC Ptr not supported") + | SideCond _ -> failwith ("LFSC side conditions not supported") + | _ -> assert false + + +and term_smtcoq t = + try HT.find memo_terms t + with Not_found -> + let v = term_smtcoq_old t in + HT.add memo_terms t v; + v + + +and term_smtcoq_atom a = match term_smtcoq a with + | Atom h -> h + | _ -> assert false + +and args_smtcoq args = + List.map (fun t -> lit_of_atom_form_lit rf (term_smtcoq t)) args + |> Array.of_list + +and uncurry acc t = match app_name t, acc with + | Some (n, [_; _; f; a]), _ when n == H.apply -> + uncurry (term_smtcoq_atom a :: acc) f + | Some (n, [_; _]) , [h1; h2] when n == H.read -> + (match Atom.type_of h1 with + | TFArray (ti,te) -> Atom (Atom.mk_select ra ti te h1 h2) + | _ -> assert false) + | Some (n, [_; _]) , [h1; h2; h3] when n == H.write -> + (match Atom.type_of h1 with + | TFArray (ti,te) -> Atom (Atom.mk_store ra ti te h1 h2 h3) + | _ -> assert false) + | Some (n, [_; _]) , [h1; h2] when n == H.diff -> + (match Atom.type_of h1 with + | TFArray (ti,te) -> Atom (Atom.mk_diffarray ra ti te h1 h2) + | _ -> assert false) + | None, _ -> + (match name t with + | Some n -> + let args = Array.of_list acc in + Atom (Atom.get ra (Aapp (get_fun (Hstring.view n), args))) + | _ -> assert false) + | _ -> + eprintf "uncurry fail: %a@." Ast.print_term t; + assert false + +(* Endianness dependant: LFSC big endian -> SMTCoq little endian *) +and bblt_lits acc t = match name t with + | Some n when n == H.bbltn -> acc + | _ -> match app_name t with + | Some (n, [f; r]) when n == H.bbltc -> + bblt_lits (lit_of_atom_form_lit rf (term_smtcoq f) :: acc) r + | _ -> assert false + + +let term_smtcoq t = + (* eprintf "translate term %a@." Ast.print_term t; *) + lit_of_atom_form_lit rf (term_smtcoq t) + + +let rec clause_smtcoq acc t = match name t with + | Some n when n == H.cln || n == H.tfalse -> acc + | Some _ -> term_smtcoq t :: acc + | None -> + match app_name t with + | Some (n, [v]) when n == H.pos -> + let t = HT.find propvars (deref v) in + term_smtcoq t :: acc + | Some (n, [v]) when n == H.neg -> + let t = HT.find propvars (deref v) in + Form.neg (term_smtcoq t) :: acc + | Some (n, [a; cl]) when n == H.clc -> + clause_smtcoq (clause_smtcoq acc a) cl + | Some (n, [a; b]) when n == H.or_ -> clause_smtcoq (clause_smtcoq acc a) b + | _ -> term_smtcoq t :: acc + + +let to_clause = clause_smtcoq [] + + +let print_clause fmt cl = + fprintf fmt "("; + List.iter (fprintf fmt "%a " (Form.to_smt Atom.to_smt)) cl; + fprintf fmt ")" + + + +type clause_res_id = NewCl of int | OldCl of int + + +let register_clause_id cl id = + HCl.add clauses_ids cl id; + Hashtbl.add ids_clauses id cl + + +let register_termclause_id t id = + register_clause_id (to_clause t) id + + +let new_clause_id ?(reuse=true) cl = + try + if not reuse then raise Not_found; + OldCl (HCl.find clauses_ids cl) + with Not_found -> + incr cl_cpt; + let id = !cl_cpt in + register_clause_id cl id; + NewCl id + + +let mk_clause ?(reuse=true) rule cl args = + match new_clause_id ~reuse cl with + | NewCl id -> + if show_veritproof then + eprintf "%d:(%s %a %a)@." id (string_of_rule rule) + print_clause cl + (fun fmt -> List.iter (fprintf fmt " %d")) args; + VeritSyntax.mk_clause (id, (get_rule rule), cl, args) + | OldCl id -> + (* Format.eprintf "old_clause %d@." id; *) + id + + +let mk_clause_cl ?(reuse=true) rule cl args = + mk_clause ~reuse rule (List.map term_smtcoq cl) args + + +let mk_input name formula = + let cl = [term_smtcoq formula] in + match new_clause_id cl with + | NewCl id -> + register_clause_id cl id; + HS.add inputs name id; + if show_veritproof then eprintf "%d:input %a@." id print_clause cl; + VeritSyntax.mk_clause (id, VeritSyntax.Inpu, cl, []) |> ignore + | OldCl _ -> () + + +let mk_admit_preproc name formula = + let cl = [term_smtcoq formula] in + match new_clause_id cl with + | NewCl id -> + register_clause_id cl id; + HS.add inputs name id; + if show_veritproof then eprintf "%d:hole %a@." id print_clause cl; + VeritSyntax.mk_clause (id, VeritSyntax.Hole, cl, []) |> ignore + | OldCl _ -> () + + +let register_prop_abstr vt formula = HT.add propvars vt formula + + +let register_alias name_index t = HS.add alias_tbl name_index t + + +(* let register_termalias a t = HT.add termalias_tbl a t *) + + +let get_clause_id cl = + try HCl.find clauses_ids cl with Not_found -> assert false + + +let get_input_id h = HS.find inputs h + + +let register_decl name formula = + let cl = [term_smtcoq formula] in + match new_clause_id cl with + | NewCl id | OldCl id -> + (* eprintf "register decl %d@." id; *) + HS.add inputs name id + +let register_decl_id name id = + (* eprintf "register_decl %s : %d@." name id; *) + HS.add inputs name id + + + +let clear () = + HCl.clear clauses_ids; + Hashtbl.clear ids_clauses; + HT.clear propvars; + HS.clear inputs; + HS.clear alias_tbl; + HT.clear memo_terms; + (* HT.clear termalias_tbl; *) + cl_cpt := 0 + + diff --git a/src/lfsc/tosmtcoq.mli b/src/lfsc/tosmtcoq.mli new file mode 100644 index 0000000..b0d980b --- /dev/null +++ b/src/lfsc/tosmtcoq.mli @@ -0,0 +1,13 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +include Translator_sig.S diff --git a/src/lfsc/translator_sig.mli b/src/lfsc/translator_sig.mli new file mode 100644 index 0000000..66005f3 --- /dev/null +++ b/src/lfsc/translator_sig.mli @@ -0,0 +1,159 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(** + Signature to implement to build a converter of LFSC proofs. + See {!Converter.Make}, {!Tosmtcoq} and {!VeritPrinter}. +*) + +open Ast +open Format + + +(** The type of destination rules that are currently supported byt the + converter *) +type rule = + | Reso + | Weak + | Or + | Orp + | Imp + | Impp + | Nand + | Andn + | Nimp1 + | Nimp2 + | Impn1 + | Impn2 + | Nor + | Orn + | And + | Andp + | Equ1 + | Equ2 + | Nequ1 + | Nequ2 + | Equp1 + | Equp2 + | Equn1 + | Equn2 + | Xor1 + | Xor2 + | Xorp1 + | Xorp2 + | Xorn1 + | Xorn2 + | Nxor1 + | Nxor2 + | Itep1 + | Itep2 + | Iten1 + | Iten2 + | Ite1 + | Ite2 + | Nite1 + | Nite2 + | Eqtr + | Eqcp + | Eqco + | Eqre + | Lage + | Flat + | Hole + | True + | Fals + | Bbva + | Bbconst + | Bbeq + | Bbdis + | Bbop + | Bbadd + | Bbmul + | Bbult + | Bbslt + | Bbshl + | Bbshr + | Bbnot + | Bbneg + | Bbconc + | Bbextr + | Bbzext + | Bbsext + | Row1 + | Row2 + | Exte + +(** Signature for translators *) +module type S = sig + + (** The type of literal depends on the chosen tranlation, it is abstract *) + type lit + + (** Clauses are lists of the aforementioned literals *) + type clause = lit list + + (** Transform a term in LFSC to the chosen clause representation. (This + eliminates top-level dijunctions and implications.) *) + val to_clause : term -> clause + + (** Print a clause (for debugging purposes) *) + val print_clause : formatter -> clause -> unit + + (** Manually resgister a clause with an integer identifier *) + val register_clause_id : clause -> int -> unit + + (** Create a new clause as the result of a rule application with a list of + intgeger arguments. These can be either previously defined clause + identifiers or an arbitrary positive integer depending on the rule. It + returns the identifier of the newly created resulting clause. The + optional arguemnt [reuse] ([true] by default) says if we should reuse + clauses that were previously deduced, in this case the rule application + will not be created and it returns the identifier of this pre-existing + clause. *) + val mk_clause : ?reuse:bool -> rule -> clause -> int list -> int + + (** Same as {!mk_clause} but with an hybrid representation for clauses. This + is just used to avoid creating unecessary terms for these clauses when + they are built by hand. *) + val mk_clause_cl : ?reuse:bool -> rule -> term list -> int list -> int + + (** Create an input unit clause. It is given an identifier that is not + returned. *) + val mk_input : Hstring.t -> term -> unit + + val mk_admit_preproc : Hstring.t -> term -> unit + + (** [register_prop_abstr v p] register the term [v] as being a propositional + abstraction of the term [p]. *) + val register_prop_abstr : term -> term -> unit + + (** Returns the identifier of a previously deduced clause. *) + val get_clause_id : clause -> int + + (** Returns the identifier of a unit input clause given its name, as + intoduced by the proprocessor of CVC4 in the LFSC proof. *) + val get_input_id : Hstring.t -> int + + val register_decl : Hstring.t -> term -> unit + + val register_decl_id : Hstring.t -> int -> unit + + (** register an alias name for a term *) + val register_alias : Hstring.t -> term -> unit + + (* (\** register a term as an alias for another term *\) *) + (* val register_termalias : term -> term -> unit *) + + (** Clear and reset global tables and values. *) + val clear : unit -> unit + +end diff --git a/src/lfsc/type.ml b/src/lfsc/type.ml new file mode 100644 index 0000000..7c30a2a --- /dev/null +++ b/src/lfsc/type.ml @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +(** Type of S-expressions *) +type t = Atom of string | List of t list + + +let rec print fmt = function + | Atom s -> Format.pp_print_string fmt s + | List l -> + Format.fprintf fmt "("; + List.iter (Format.fprintf fmt "%a " print) l; + Format.fprintf fmt ")" + +let rec print_list fmt = function + | [] -> () + | s :: r -> + Format.fprintf fmt "%a@." print s; + print_list fmt r + +let rec size = function + | Atom _ -> 1 + | List l -> List.fold_left (fun acc s -> size s + acc) 0 l + +let rec size_list = function + | [] -> 0 + | s :: r -> size s + size_list r diff --git a/src/lfsc/veritPrinter.ml b/src/lfsc/veritPrinter.ml new file mode 100644 index 0000000..4601587 --- /dev/null +++ b/src/lfsc/veritPrinter.ml @@ -0,0 +1,493 @@ +(**************************************************************************) +(* *) +(* SMTCoq *) +(* Copyright (C) 2011 - 2019 *) +(* *) +(* See file "AUTHORS" for the list of authors *) +(* *) +(* This file is distributed under the terms of the CeCILL-C licence *) +(* *) +(**************************************************************************) + + +open Format +open Ast +open Builtin +open Translator_sig + + +type lit = term + +type clause = term list + +(* module HT = Hashtbl.Make (Term) *) + +(* module HCl = Hashtbl.Make (struct *) +(* type t = clause *) +(* let equal c1 c2 = compare_term_list c1 c2 = 0 *) +(* let hash = Hashtbl.hash (\* List.fold_left (fun acc t -> Term.hash t + 17*acc) 0 *\) *) +(* end) *) + + +module HS = Hstring.H + +module HT = struct + module M = Map.Make (Term) + let create _ = ref M.empty + let add h k v = h := M.add k v !h + let find h k = M.find k !h + let clear h = h := M.empty + let iter f h = M.iter f !h +end + +module HCl = struct + module M = Map.Make (struct + type t = clause + let compare c1 c2 = compare_term_list c1 c2 + end) + let create _ = ref M.empty + let add h k v = h := M.add k v !h + let find h k = M.find k !h + let clear h = h := M.empty + let iter f h = M.iter f !h +end + + +let fmt = std_formatter + +let clauses_ids = HCl.create 201 +let ids_clauses = Hashtbl.create 201 +let propvars = HT.create 201 +let sharp_tbl = HT.create 13 +let inputs : int HS.t = HS.create 13 +let alias_tbl = HS.create 17 +(* let termalias_tbl = HT.create 17 *) + +let cpt = ref 0 +let cl_cpt = ref 0 + + + + +let get_rule = function + | Reso -> "resolution" + | Weak -> "weaken" + | Or -> "or" + | Orp -> "or_pos" + | Imp -> "implies" + | Impp -> "implies_pos" + | Nand -> "not_and" + | Andn -> "and_neg" + | Nimp1 -> "not_implies1" + | Nimp2 -> "not_implies2" + | Impn1 -> "implies_neg1" + | Impn2 -> "implies_neg2" + | Nor -> "not_or" + | Orn -> "or_neg" + | And -> "and" + | Andp -> "and_pos" + | Equ1 -> "equiv1" + | Equ2 -> "equiv2" + | Nequ1 -> "not_equiv1" + | Nequ2 -> "not_equiv2" + | Equp1 -> "equiv_pos1" + | Equp2 -> "equiv_pos2" + | Equn1 -> "equiv_neg1" + | Equn2 -> "equiv_neg2" + | Xor1 -> "xor1" + | Xor2 -> "xor2" + | Xorp1 -> "xor_pos1" + | Xorp2 -> "xor_pos2" + | Xorn1 -> "xor_neg1" + | Xorn2 -> "xor_neg2" + | Nxor1 -> "not_xor1" + | Nxor2 -> "not_xor2" + | Itep1 -> "ite_pos1" + | Itep2 -> "ite_pos2" + | Iten1 -> "ite_neg1" + | Iten2 -> "ite_neg2" + | Ite1 -> "ite1" + | Ite2 -> "ite2" + | Nite1 -> "not_ite1" + | Nite2 -> "not_ite2" + | Eqtr -> "eq_transitive" + | Eqcp -> "eq_congruent_pred" + | Eqco -> "eq_congruent" + | Eqre -> "eq_reflexive" + | Lage -> "la_generic" + | Flat -> "flatten" + | Hole -> "hole" + | True -> "true" + | Fals -> "false" + | Bbva -> "bbvar" + | Bbconst -> "bbconst" + | Bbeq -> "bbeq" + | Bbdis -> "bv_const_neq" + | Bbop -> "bbop" + | Bbadd -> "bbadd" + | Bbmul -> "bbmul" + | Bbult -> "bbult" + | Bbslt -> "bbslt" + | Bbshl -> "bbshl" + | Bbshr -> "bbshr" + | Bbnot -> "bbnot" + | Bbneg -> "bbneg" + | Bbconc -> "bbconcat" + | Bbextr -> "bbextract" + | Bbzext -> "bbzextend" + | Bbsext -> "bbsextend" + | Row1 -> "row1" + | Row2 -> "row2" + | Exte -> "ext" + + + +let print_sharps () = + HT.iter (fun t id -> + printf "#%d --> %a@." id Ast.print_term_type t) sharp_tbl + + +let smt2_of_lfsc t = + if t == H.iff then "=" + else if t == H.ifte_ then "ite" + else if t == H.flet then "let" + else if t == H.impl then "=>" + else if t == H.gt_Int then ">" + else if t == H.ge_Int then ">=" + else if t == H.lt_Int then "<" + else if t == H.le_Int then "<=" + else if t == H.plus_Int then "+" + else if t == H.minus_Int then "-" + else if t == H.times_Int then "*" + else if t == H.div_Int then "/" (* Maybe div? *) + else if t == H.uminus_Int then "-" + else Hstring.view t + + +let new_sharp t = + incr cpt; + HT.add sharp_tbl t !cpt; + !cpt + + +let print_bit fmt b = match name b with + | Some b when b == H.b0 -> fprintf fmt "0" + | Some b when b == H.b1 -> fprintf fmt "1" + | _ -> assert false + +let rec print_bv_const fmt t = match name t with + | Some b when b == H.bvn -> () + | _ -> match app_name t with + | Some (n, [b; t]) when n == H.bvc -> + fprintf fmt "%a%a" print_bit b print_bv_const t + | _ -> assert false + +let rec print_apply fmt t = match app_name t with + | Some (n, [_; _; f; a]) when n == H.apply -> + fprintf fmt "%a %a" print_apply f print_term a + | _ -> print_term fmt t + + +(* Endianness dependant: LFSC big endian -> SMTCoq little endian *) +and print_bblt fmt t = match name t with + | Some n when n == H.bbltn -> () + | _ -> match app_name t with + | Some (n, [f; r]) when n == H.bbltc -> + fprintf fmt "%a %a" print_bblt r print_term f + | _ -> assert false + + +and print_term fmt t = + try HT.find sharp_tbl t |> fprintf fmt "#%d" with Not_found -> + match value t with + | Int n -> fprintf fmt "%s" (Big_int.string_of_big_int n) + | _ -> + match name t with + | Some n -> + begin + try + print_term fmt (HS.find alias_tbl n) + with Not_found -> pp_print_string fmt (smt2_of_lfsc n) + end + | None -> match app_name t with + + | Some (n, [ty; a; b]) when n == H.eq -> + let eqt = match value t with App (eqt, _ ) -> eqt | _ -> assert false in + incr cpt; + let eq_b_a = mk_app eqt [ty; b; a] in + HT.add sharp_tbl t !cpt; + HT.add sharp_tbl eq_b_a !cpt; + (* let a, b = if compare_term a b <= 0 then a, b else b, a in *) + fprintf fmt "#%d:(= %a %a)" !cpt print_term a print_term b + + | Some (n, [a]) when n == H.not_ -> fprintf fmt "(not %a)" print_term a + + | Some (n, _) when n == H.apply -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a)" nb print_apply t + + | Some (n, [a]) when n == H.p_app -> print_term fmt a + + | Some (a, [{value = Int n}]) when a == H.a_int -> + fprintf fmt "%s" (Big_int.string_of_big_int n) + + | Some (n, [_; a]) when n == H.a_var_bv -> print_term fmt a + + | Some (n, [_; a]) when n == H.a_bv -> print_term fmt a + + | Some (n, _) when n == H.bvc -> fprintf fmt "#b%a" print_bv_const t + + | Some (op,[_; a; b]) + when op == H.bvand || + op == H.bvor || + op == H.bvxor || + op == H.bvadd || + op == H.bvmul || + op == H.bvult || + op == H.bvslt || + op == H.bvule || + op == H.bvsle || + op == H.bvshl || + op == H.bvlshr -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a %a %a)" nb + Hstring.print op print_term a print_term b + + | Some (op, [_; a]) when op == H.bvnot || op == H.bvneg -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a %a)" nb Hstring.print op print_term a + + | Some (op, [_; _; _; a; b]) when op == H.concat -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a %a %a)" nb + Hstring.print op print_term a print_term b + + | Some (op, [_; i; j; _; a]) when op == H.extract -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a %a %a %a)" nb + Hstring.print op print_term i print_term j print_term a + + | Some (op, [_; i; _; a]) + when op == H.zero_extend || op == H.sign_extend -> + let nb = new_sharp t in + fprintf fmt "#%d:(%a %a %a)" nb + Hstring.print op print_term i print_term a + + | Some (op, [a; {value = Int n}]) when op == H.bitof -> + let nb = new_sharp t in + fprintf fmt "#%d:(bitof %s %a)" nb + (Big_int.string_of_big_int n) print_term a + + | Some (n, _) when n == H.bbltc -> fprintf fmt "[%a]" print_bblt t + + | Some (n, [_; a; bb]) when n == H.bblast_term -> + let nb = new_sharp t in + fprintf fmt "#%d:(bbT %a [%a])" nb print_term a print_bblt bb + + | Some (n, [_; _]) when n == H.read -> fprintf fmt "select" + | Some (n, [_; _]) when n == H.write -> fprintf fmt "store" + | Some (n, [_; _]) when n == H.diff -> fprintf fmt "diff" + + | Some (n, [_; c; a; b]) when n == H.ite -> + let nb = new_sharp t in + fprintf fmt "#%d:(ite %a %a %a)" nb + print_term c print_term a print_term b + + | Some (n, l) -> + let n = smt2_of_lfsc n in + let nb = new_sharp t in + fprintf fmt "#%d:(%s%a)" nb n + (fun fmt -> List.iter (fprintf fmt " %a" print_term)) l + + | None -> + eprintf "Could not translate term %a@." Ast.print_term t; + assert false + + +let print_term fmt t = print_term fmt t (* (get_real t) *) + + +let rec print_clause elim_or fmt t = match name t with + | Some n when n == H.cln || n == H.tfalse -> () + | Some n -> pp_print_string fmt (smt2_of_lfsc n) + | None -> + match app_name t with + | Some (n, [v]) when n == H.pos -> + let t = try HT.find propvars (deref v) with Not_found -> assert false in + fprintf fmt "%a" print_term t + | Some (n, [v]) when n == H.neg -> + let t = try HT.find propvars (deref v) with Not_found -> assert false in + fprintf fmt "(not %a)" print_term t + | Some (n, [a; cl]) when n == H.clc -> + fprintf fmt "%a %a" (print_clause elim_or) a (print_clause elim_or) cl + | Some (n, [a; b]) when n == H.or_ && elim_or -> + fprintf fmt "%a %a" (print_clause elim_or) a (print_clause elim_or) b + | _ -> fprintf fmt "%a" print_term t + + +let print_clause_elim_or fmt t = fprintf fmt "(%a)" (print_clause true) t + +let print_clause fmt t = fprintf fmt "(%a)" (print_clause false) t + + +let rec to_clause acc t = match name t with + | Some n when n == H.cln || n == H.tfalse -> acc + | Some n -> t :: acc + | None -> + match app_name t with + | Some (n, [v]) when n == H.pos -> + let t = try HT.find propvars (deref v) with Not_found -> assert false in + t :: acc + | Some (n, [v]) when n == H.neg -> + let t = + try HT.find propvars (deref v) |> not_ + with Not_found -> assert false in + t :: acc + | Some (n, [a; cl]) when n == H.clc -> + to_clause (to_clause acc a) cl + | Some (n, [a; b]) when n == H.or_ -> + to_clause (to_clause acc a) b + | _ -> t :: acc + + +let to_clause = to_clause [] + + +let rec print_clause fmt = function + | [] -> () + | [t] -> print_term fmt t + | t :: cl -> fprintf fmt "%a %a" print_term t print_clause cl + +let print_clause fmt = fprintf fmt "(%a)" print_clause + + +let th_res p = match app_name (deref p).ttype with + | Some (n, [r]) when n == H.th_holds -> r + | _ -> assert false + + +type clause_res_id = NewCl of int | OldCl of int + + +let clause_mod_eqsymm cl = + List.fold_left (fun acc t -> match app_name t with + | Some (n, [ty; a; b]) when n == H.eq -> + let eqt = match value t with App (eqt, _ ) -> eqt | _ -> assert false in + let eq_b_a = mk_app eqt [ty; b; a] in + let acc2 = List.map (fun cl -> eq_b_a :: cl) acc in + let acc1 = List.map (fun cl -> t :: cl) acc in + List.rev_append acc2 acc1 + | _ -> List.map (fun cl -> t :: cl) acc + ) [[]] cl + + + +let rec normalize_eq_symm p = match app_name p with + | Some (n, [ty; a; b]) when n == H.eq && compare_term a b > 0 -> + let eqt = match value p with App (eqt, _ ) -> eqt | _ -> assert false in + mk_app eqt [ty; b; a] + | _ -> match p.value with + | App (f, args) -> + let nargs = List.map normalize_eq_symm args in + if List.for_all2 (==) args nargs then p + else mk_app f nargs + | Pi (s, x) -> + let x' = normalize_eq_symm x in + if x == x' then p else mk_pi s x' + | Lambda (s, x) -> + let x' = normalize_eq_symm x in + if x == x' then p else mk_lambda s x' + | _ -> p + + +let normalize_clause = List.map normalize_eq_symm + +let register_clause_id cl id = + HCl.add clauses_ids cl id; + Hashtbl.add ids_clauses id cl + +(* let register_clause_id cl id = *) +(* List.iter (fun cl -> register_clause_id cl id) *) +(* (clause_mod_eqsymm cl) *) + + +let new_clause_id ?(reuse=true) cl = + let cl = normalize_clause cl in + try + if not reuse then raise Not_found; + OldCl (HCl.find clauses_ids cl) + with Not_found -> + (* eprintf "new clause : [%a]@." (fun fmt -> List.iter (fprintf fmt "%a, " Ast.print_term)) cl; *) + incr cl_cpt; + let id = !cl_cpt in + register_clause_id cl id; + NewCl id + + +let mk_clause ?(reuse=true) rule cl args = + match new_clause_id ~reuse cl with + | NewCl id -> + fprintf fmt "%d:(%s %a%a)@." id (get_rule rule) print_clause cl + (fun fmt -> List.iter (fprintf fmt " %d")) args; + id + | OldCl id -> id + + +let mk_clause_cl = mk_clause + + +let mk_input name formula = + let cl = [formula] in + match new_clause_id cl with + | NewCl id -> + register_clause_id cl id; + HS.add inputs name id; + fprintf fmt "%d:(input (%a))@." id print_term formula + | OldCl _ -> () + + +let mk_admit_preproc name formula = + let cl = [formula] in + match new_clause_id cl with + | NewCl id -> + register_clause_id cl id; + HS.add inputs name id; + fprintf fmt "%d:(hole (%a))@." id print_term formula + | OldCl _ -> () + + +let register_prop_abstr vt formula = HT.add propvars vt formula + + +let get_clause_id cl = HCl.find clauses_ids cl + + +let get_input_id h = HS.find inputs h + + +let register_decl name formula = + let cl = [formula] in + match new_clause_id cl with + | NewCl id | OldCl id -> HS.add inputs name id + + +let register_decl_id name id = HS.add inputs name id + + +let register_alias name_index t = HS.add alias_tbl name_index t + + +(* let register_termalias a t = HT.add termalias_tbl a t *) + + +let clear () = + HCl.clear clauses_ids; + Hashtbl.clear ids_clauses; + HT.clear propvars; + HT.clear sharp_tbl; + HS.clear inputs; + HS.clear alias_tbl; + (* HT.clear termalias_tbl; *) + cl_cpt := 0; + cpt := 0 + |