|
1 (* Title: HOL/Word/Tools/smt2_word.ML |
|
2 Author: Sascha Boehme, TU Muenchen |
|
3 |
|
4 SMT setup for words. |
|
5 *) |
|
6 |
|
7 structure SMT2_Word: sig end = |
|
8 struct |
|
9 |
|
10 open Word_Lib |
|
11 |
|
12 (* SMT-LIB logic *) |
|
13 |
|
14 fun smtlib_logic ts = |
|
15 if exists (Term.exists_type (Term.exists_subtype is_wordT)) ts |
|
16 then SOME "QF_AUFBV" |
|
17 else NONE |
|
18 |
|
19 |
|
20 (* SMT-LIB builtins *) |
|
21 |
|
22 local |
|
23 val smtlib2C = SMTLIB2_Interface.smtlib2C |
|
24 |
|
25 val wordT = @{typ "'a::len word"} |
|
26 |
|
27 fun index1 s i = "(_ " ^ s ^ " " ^ string_of_int i ^ ")" |
|
28 fun index2 s i j = "(_ " ^ s ^ " " ^ string_of_int i ^ " " ^ string_of_int j ^ ")" |
|
29 |
|
30 fun word_typ (Type (@{type_name word}, [T])) = Option.map (index1 "BitVec") (try dest_binT T) |
|
31 | word_typ _ = NONE |
|
32 |
|
33 fun word_num (Type (@{type_name word}, [T])) k = |
|
34 Option.map (index1 ("bv" ^ string_of_int k)) (try dest_binT T) |
|
35 | word_num _ _ = NONE |
|
36 |
|
37 fun if_fixed pred m n T ts = |
|
38 let val (Us, U) = Term.strip_type T |
|
39 in |
|
40 if pred (U, Us) then |
|
41 SOME (n, length Us, ts, Term.list_comb o pair (Const (m, T))) |
|
42 else NONE |
|
43 end |
|
44 |
|
45 fun if_fixed_all m = if_fixed (forall (can dest_wordT) o (op ::)) m |
|
46 fun if_fixed_args m = if_fixed (forall (can dest_wordT) o snd) m |
|
47 |
|
48 fun add_word_fun f (t, n) = |
|
49 let val (m, _) = Term.dest_Const t |
|
50 in SMT2_Builtin.add_builtin_fun smtlib2C (Term.dest_Const t, K (f m n)) end |
|
51 |
|
52 fun hd2 xs = hd (tl xs) |
|
53 |
|
54 fun mk_nat i = @{const nat} $ HOLogic.mk_number @{typ nat} i |
|
55 |
|
56 fun dest_nat (@{const nat} $ n) = snd (HOLogic.dest_number n) |
|
57 | dest_nat t = raise TERM ("not a natural number", [t]) |
|
58 |
|
59 fun mk_shift c [t, u] = Const c $ t $ mk_nat (snd (HOLogic.dest_number u)) |
|
60 | mk_shift c ts = raise TERM ("bad arguments", Const c :: ts) |
|
61 |
|
62 fun shift m n T ts = |
|
63 let val U = Term.domain_type T |
|
64 in |
|
65 (case (can dest_wordT U, try (dest_nat o hd2) ts) of |
|
66 (true, SOME i) => |
|
67 SOME (n, 2, [hd ts, HOLogic.mk_number U i], mk_shift (m, T)) |
|
68 | _ => NONE) (* FIXME: also support non-numerical shifts *) |
|
69 end |
|
70 |
|
71 fun mk_extract c i ts = Term.list_comb (Const c, mk_nat i :: ts) |
|
72 |
|
73 fun extract m n T ts = |
|
74 let val U = Term.range_type (Term.range_type T) |
|
75 in |
|
76 (case (try (dest_nat o hd) ts, try dest_wordT U) of |
|
77 (SOME lb, SOME i) => |
|
78 SOME (index2 n (i + lb - 1) lb, 1, tl ts, mk_extract (m, T) lb) |
|
79 | _ => NONE) |
|
80 end |
|
81 |
|
82 fun mk_extend c ts = Term.list_comb (Const c, ts) |
|
83 |
|
84 fun extend m n T ts = |
|
85 let val (U1, U2) = Term.dest_funT T |
|
86 in |
|
87 (case (try dest_wordT U1, try dest_wordT U2) of |
|
88 (SOME i, SOME j) => |
|
89 if j-i >= 0 then SOME (index1 n (j-i), 1, ts, mk_extend (m, T)) |
|
90 else NONE |
|
91 | _ => NONE) |
|
92 end |
|
93 |
|
94 fun mk_rotate c i ts = Term.list_comb (Const c, mk_nat i :: ts) |
|
95 |
|
96 fun rotate m n T ts = |
|
97 let val U = Term.domain_type (Term.range_type T) |
|
98 in |
|
99 (case (can dest_wordT U, try (dest_nat o hd) ts) of |
|
100 (true, SOME i) => SOME (index1 n i, 1, tl ts, mk_rotate (m, T) i) |
|
101 | _ => NONE) |
|
102 end |
|
103 in |
|
104 |
|
105 val setup_builtins = |
|
106 SMT2_Builtin.add_builtin_typ smtlib2C (wordT, word_typ, word_num) #> |
|
107 fold (add_word_fun if_fixed_all) [ |
|
108 (@{term "uminus :: 'a::len word => _"}, "bvneg"), |
|
109 (@{term "plus :: 'a::len word => _"}, "bvadd"), |
|
110 (@{term "minus :: 'a::len word => _"}, "bvsub"), |
|
111 (@{term "times :: 'a::len word => _"}, "bvmul"), |
|
112 (@{term "bitNOT :: 'a::len word => _"}, "bvnot"), |
|
113 (@{term "bitAND :: 'a::len word => _"}, "bvand"), |
|
114 (@{term "bitOR :: 'a::len word => _"}, "bvor"), |
|
115 (@{term "bitXOR :: 'a::len word => _"}, "bvxor"), |
|
116 (@{term "word_cat :: 'a::len word => _"}, "concat") ] #> |
|
117 fold (add_word_fun shift) [ |
|
118 (@{term "shiftl :: 'a::len word => _ "}, "bvshl"), |
|
119 (@{term "shiftr :: 'a::len word => _"}, "bvlshr"), |
|
120 (@{term "sshiftr :: 'a::len word => _"}, "bvashr") ] #> |
|
121 add_word_fun extract |
|
122 (@{term "slice :: _ => 'a::len word => _"}, "extract") #> |
|
123 fold (add_word_fun extend) [ |
|
124 (@{term "ucast :: 'a::len word => _"}, "zero_extend"), |
|
125 (@{term "scast :: 'a::len word => _"}, "sign_extend") ] #> |
|
126 fold (add_word_fun rotate) [ |
|
127 (@{term word_rotl}, "rotate_left"), |
|
128 (@{term word_rotr}, "rotate_right") ] #> |
|
129 fold (add_word_fun if_fixed_args) [ |
|
130 (@{term "less :: 'a::len word => _"}, "bvult"), |
|
131 (@{term "less_eq :: 'a::len word => _"}, "bvule"), |
|
132 (@{term word_sless}, "bvslt"), |
|
133 (@{term word_sle}, "bvsle") ] |
|
134 |
|
135 end |
|
136 |
|
137 |
|
138 (* setup *) |
|
139 |
|
140 val _ = Theory.setup (Context.theory_map ( |
|
141 SMTLIB2_Interface.add_logic (20, smtlib_logic) #> |
|
142 setup_builtins)) |
|
143 |
|
144 end |