Commit 091f023c authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft
Browse files

Reification and side condition generation improvements

parent b5d67fb3
......@@ -53,7 +53,6 @@ end
module LinearEquationsDecision
use import int.Int
type coeff
clone LinearEquationsCoeffs as C with type t = coeff
......@@ -296,6 +295,8 @@ let rec norm_eq_aux (ex acc_e:expr) (acc_c:coeff) : (expr, coeff)
norm_eq_aux e2 ae ac
end
use import debug.Debug
let norm_eq (e:equality) : (expr, coeff)
returns { (ex, c) -> forall y z.
interp_eq e y z <-> interp_eq (ex, Cst c) y z }
......@@ -474,8 +475,6 @@ let sub_expr (e1 e2:expr)
= C.(+) (C.(+) v1 (C.(-_) v2)) v2 = v1 };
r
use import debug.Debug
let rec same_eq (eq1 eq2: equality) : bool
ensures { result -> forall y z. interp_eq eq1 y z -> interp_eq eq2 y z }
raises { C.Unknown -> true }
......@@ -660,15 +659,17 @@ let linear_decision (l: context) (g: equality) : bool
variant { length l - i }
requires { length l - i = length ctx }
requires { 0 <= i <= length l }
raises { C.Unknown -> true }
raises { Absurd -> true }
= match ctx with
| Nil -> ()
| Cons e t ->
assert { i < length l };
let ex, c = norm_eq e in
if (not (C.eq c C.czero)) then b[i] <- C.add b[i] c;
fill_expr ex i;
try
let ex, c = norm_eq e in
if (not (C.eq c C.czero)) then b[i] <- C.add b[i] c;
fill_expr ex i;
with C.Unknown -> () (* some equalities are in the context but cannot be normalized, typically they are useless, ignore them *)
end;
fill_ctx t (i+1)
end in
let rec fill_goal (ex:expr) : unit
......@@ -808,7 +809,7 @@ use import int.Abs
type t = (int, int)
type rvars = int -> real
exception Unknown
exception QError
let constant rzero = (0,1)
let constant rone = (1,1)
......@@ -889,10 +890,10 @@ let simp (t:t) : t
let radd (a b:t)
ensures { forall y. rinterp result y = rinterp a y +. rinterp b y }
raises { Unknown -> true }
raises { QError -> true }
= match (a,b) with
| (n1,d1), (n2,d2) ->
if d1 = 0 || d2 = 0 then raise Unknown
if d1 = 0 || d2 = 0 then raise QError
else begin
let r = (n1*d2 + n2*d1, d1*d2) in
let ghost d = from_int d1 *. from_int d2 in
......@@ -908,10 +909,10 @@ let radd (a b:t)
let rmul (a b:t)
ensures { forall y. rinterp result y = rinterp a y *. rinterp b y }
raises { Unknown -> true }
raises { QError -> true }
= match (a,b) with
| (n1,d1), (n2, d2) ->
if d1 = 0 || d2 = 0 then raise Unknown
if d1 = 0 || d2 = 0 then raise QError
else begin
let r = (n1*n2, d1*d2) in
assert { forall y. rinterp r y = rinterp a y *. rinterp b y
......@@ -939,9 +940,9 @@ let rinv (a:t)
requires { not req a rzero }
ensures { not req result rzero }
ensures { forall y. rinterp result y *. rinterp a y = 1.0 }
raises { Unknown -> true }
raises { QError -> true }
= match a with
| (n,d) -> if n = 0 || d = 0 then raise Unknown else (d,n)
| (n,d) -> if n = 0 || d = 0 then raise QError else (d,n)
end
end
......@@ -952,7 +953,7 @@ use import RationalCoeffs
use import real.RealInfix
use import real.FromInt
clone export LinearEquationsDecision with type C.a = real, function C.(+) = (+.), function C.( * ) = ( *. ), function C.(-_) = (-._), function C.(-) = (-.), type coeff = t, type C.cvars=int -> real, function C.interp=rinterp, exception C.Unknown = Unknown, constant C.azero = Real.zero, constant C.aone = Real.one, predicate C.ale = (<=.), val C.czero=rzero, val C.cone=rone, lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add=radd, val C.mul=rmul, val C.opp=ropp, val C.eq=req, val C.inv=rinv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
clone export LinearEquationsDecision with type C.a = real, function C.(+) = (+.), function C.( * ) = ( *. ), function C.(-_) = (-._), function C.(-) = (-.), type coeff = t, type C.cvars=int -> real, function C.interp=rinterp, exception C.Unknown = QError, constant C.azero = Real.zero, constant C.aone = Real.one, predicate C.ale = (<=.), val C.czero=rzero, val C.cone=rone, lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add=radd, val C.mul=rmul, val C.opp=ropp, val C.eq=req, val C.inv=rinv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
end
......@@ -963,21 +964,21 @@ use import int.Int
function id (t:int) (v:int -> int) : int = t
let predicate eq (a b:int) = a=b
exception Unknown
exception NError
let inv (t:int) : int
(*ensures { forall v: int -> int. id result v * id t v = one }*)
ensures { not (eq result zero) }
raises { Unknown -> true }
= raise Unknown
raises { NError -> true }
= raise NError
clone export LinearEquationsDecision with type C.a = int, function C.(+)=(+), function C.(*) = (*), function C.(-_) = (-_), function C.(-) = (-), type coeff = int, type C.cvars = int->int,function C.interp = id, constant C.azero = zero, constant C.aone = one, predicate C.ale= (<=), val C.czero = zero, val C.cone = one, lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add = (+), val C.mul = (*), val C.opp = (-_), val C.eq = eq, val C.inv = inv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
use import real.FromInt
use import RationalCoeffs
use LinearDecisionRational as R
use import list.List
let function m (x:int) : (int, int)
ensures { forall z. rinterp result z = from_int x }
= (x,1)
......@@ -1029,7 +1030,7 @@ let int_decision (l: context') (g: equality') : bool
requires { valid_ctx' l }
requires { valid_eq' g }
ensures { forall y z. result -> interp_ctx' l g y z }
raises { R.Absurd -> true | (* R.NonLinear -> true | *) Unknown -> true }
raises { R.Absurd -> true | QError -> true }
= R.decision (m_ctx l) (m_eq g)
end
......@@ -1043,6 +1044,7 @@ use import int.Int
use import real.RealInfix
use import real.FromInt
meta "compute_max_steps" 0x10000
meta coercion function from_int
goal g: forall x y: real.
......@@ -1056,6 +1058,8 @@ module TestInt
use import LinearDecisionInt
use import int.Int
meta "compute_max_steps" 0x10000
goal g: forall x y:int.
3 * x + 2 * y = 21 ->
7 * x + 4 * y = 47 ->
......@@ -1111,7 +1115,7 @@ function minterp (t:t) (y:evars) : real
qinterp q *. pow rradix (from_int (interp_exp e y))
end
exception Unknown
exception MPError
let rec opp_exp (e:exp)
ensures { forall y. interp_exp result y = - interp_exp e y }
......@@ -1129,19 +1133,19 @@ let rec add_sub_exp (e1 e2:exp) (s:bool) : exp
if s
then interp_exp result y = interp_exp e1 y + interp_exp e2 y
else interp_exp result y = interp_exp e1 y - interp_exp e2 y }
raises { Unknown -> true }
raises { MPError -> true }
variant { e2, e1 }
=
let rec add_atom (e a:exp) (s:bool) : (exp, bool)
returns { r, _ -> forall y.
if s then interp_exp r y = interp_exp e y + interp_exp a y
else interp_exp r y = interp_exp e y - interp_exp a y }
raises { Unknown -> true }
raises { MPError -> true }
variant { e }
= match (e,a) with
| Lit n1, Lit n2 -> (if s then Lit (n1+n2) else Lit (n1-n2)), true
| Lit n1, Lit n2 -> (if s then Lit (n1+n2) else Lit (n1-n2)), True
| Lit n, Var i
-> if n = 0 then (if s then Var i else Minus (Var i)), true
-> if n = 0 then (if s then Var i else Minus (Var i)), True
else (if s then Plus e a else Sub e a), False
| Var i, Lit n
-> if n = 0 then Var i, true
......@@ -1159,6 +1163,9 @@ let rec add_sub_exp (e1 e2:exp) (s:bool) : exp
else
if i = j then Lit 0, True
else Sub e a, False
| Minus (Var i), Minus (Var j) ->
if (not s) && (i=j) then Lit 0, true
else (if s then Plus e a else Sub e a), False
| Minus _, Minus _ -> (if s then Plus e a else Sub e a), False
| Plus e1 e2, _ ->
let r, b = add_atom e1 a s in
......@@ -1179,7 +1186,7 @@ let rec add_sub_exp (e1 e2:exp) (s:bool) : exp
if b then Sub e1 r, True
else if s then Sub (Plus e1 a) e2, False
else Sub e1 (Plus e2 a), False
| _ -> raise Unknown
| _ -> raise MPError
end
in
match e2 with
......@@ -1204,14 +1211,14 @@ let rec add_sub_exp (e1 e2:exp) (s:bool) : exp
let add_exp (e1 e2:exp) : exp
ensures { forall y. interp_exp result y = interp_exp e1 y + interp_exp e2 y }
raises { Unknown -> True }
raises { MPError -> True }
= add_sub_exp e1 e2 True
let rec zero_exp (e:exp) : bool
ensures { result -> forall y. interp_exp e y = 0 }
variant { e }
raises { Unknown -> true }
raises { MPError -> true }
=
let rec all_zero (e:exp) : bool
ensures { result -> forall y. interp_exp e y = 0 }
......@@ -1230,7 +1237,7 @@ let rec zero_exp (e:exp) : bool
let rec same_exp (e1 e2: exp)
ensures { result -> forall y. interp_exp e1 y = interp_exp e2 y }
variant { e1, e2 }
raises { Unknown -> true }
raises { MPError -> true }
= match e1, e2 with
| Lit n1, Lit n2 -> n1 = n2
| Var v1, Var v2 -> v1 = v2
......@@ -1240,8 +1247,8 @@ let rec same_exp (e1 e2: exp)
let madd (a b:t)
ensures { forall y. minterp result y = minterp a y +. minterp b y }
raises { Unknown -> true }
raises { Q.Unknown -> true }
raises { MPError -> true }
raises { Q.QError -> true }
= match a, b with
| (q1, e1), (q2, e2) ->
if Q.req q1 Q.rzero then b
......@@ -1256,13 +1263,13 @@ let madd (a b:t)
= qinterp q1 *. p +. qinterp q2 *. p
= minterp a y +. minterp b y };
(q,e1) end
else (print a; print b; raise Unknown)
else raise MPError
end
let mmul (a b:t)
ensures { forall y. minterp result y = minterp a y *. minterp b y }
raises { Q.Unknown -> true }
raises { Unknown -> true }
raises { Q.QError -> true }
raises { MPError -> true }
= match a, b with
| (q1,e1), (q2,e2) ->
let q = Q.rmul q1 q2 in
......@@ -1310,7 +1317,7 @@ let minv (a:t)
requires { not meq a mzero }
ensures { not meq result mzero }
(* ensures { forall y. minterp result y *. minterp a y = 1.0 } no need to prove this*)
raises { Q.Unknown -> true }
raises { Q.QError -> true }
= match a with
| (q,e) -> (Q.rinv q, opp_exp e)
end
......@@ -1324,7 +1331,7 @@ use import real.RealInfix
type coeff = t
clone export LinearEquationsDecision with type C.a = real, function C.(+) = (+.), function C.( *) = ( *.), function C.(-_) = (-._), function C.(-) = (-.), type coeff = t, type C.cvars=evars, function C.interp=minterp, exception C.Unknown = Q.Unknown, constant C.azero = Real.zero, constant C.aone = Real.one, predicate C.ale = (<=.), val C.czero=mzero, val C.cone=mone, lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add=madd, val C.mul=mmul, val C.opp=mopp, val C.eq=meq, val C.inv=minv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
clone export LinearEquationsDecision with type C.a = real, function C.(+) = (+.), function C.( *) = ( *.), function C.(-_) = (-._), function C.(-) = (-.), type coeff = t, type C.cvars=evars, function C.interp=minterp, exception C.Unknown = MPError, constant C.azero = Real.zero, constant C.aone = Real.one, predicate C.ale = (<=.), val C.czero=mzero, val C.cone=mone, lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add=madd, val C.mul=mmul, val C.opp=mopp, val C.eq=meq, val C.inv=minv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
end
module LinearDecisionIntMP
......@@ -1349,18 +1356,18 @@ function mpinterp (t:t) (y:evars) : int
let mpadd (a b:t) : t
ensures { forall y. mpinterp result y = mpinterp a y + mpinterp b y }
raises { Unknown -> true }
= raise Unknown
raises { MPError -> true }
= raise MPError
let mpmul (a b:t) : t
ensures { forall y. mpinterp result y = mpinterp a y * mpinterp b y }
raises { Unknown -> true }
= raise Unknown
raises { MPError -> true }
= raise MPError
let mpopp (a:t) : t
ensures { forall y. mpinterp result y = - mpinterp a y }
raises { Unknown -> true }
= raise Unknown
raises { MPError -> true }
= raise MPError
let predicate mpeq (a b:t)
ensures { result -> forall y. mpinterp a y = mpinterp b y }
......@@ -1370,8 +1377,8 @@ let predicate mpeq (a b:t)
let mpinv (a:t) : t
ensures { not mpeq result mpzero }
raises { Unknown -> true }
= raise Unknown
raises { MPError -> true }
= raise MPError
clone export LinearEquationsDecision with type C.a = int, function C.(+) = (+), function C.(*) = (*), function C.(-_) = (-_), function C.(-) = (-), type coeff = t, type C.cvars = int->int, function C.interp = mpinterp, constant C.azero = zero, constant C.aone = one, val C.czero = mpzero, val C.cone = mpone, predicate C.ale = (<=), lemma C.sub_def, lemma C.zero_def, lemma C.one_def, val C.add = mpadd, val C.mul = mpmul, val C.opp = mpopp, val C.eq = mpeq, val C.inv = mpinv, goal C.A.ZeroLessOne, goal C.A.CompatOrderAdd, goal C.A.CompatOrderMult, goal C.A.Unitary, goal C.A.NonTrivialRing, goal C.A.Mul_distr_l, goal C.A.Mul_distr_r, goal C.A.Inv_def_l, goal C.A.Inv_def_r, goal C.A.MulAssoc.Assoc, goal C.A.Assoc, goal C.A.MulComm.Comm, goal C.A.Comm, goal C.A.Unit_def_l, goal C.A.Unit_def_r
......@@ -1469,7 +1476,7 @@ let mp_decision (l: context') (g: equality') : bool
requires { valid_eq' g }
ensures { forall y z. result -> pos_ctx' l z -> pos_eq' g z
-> interp_ctx' l g y z }
raises { R.Absurd -> true | Unknown -> true | Q.Unknown -> true }
raises { R.Absurd -> true | MPError -> true | Q.QError -> true }
=
R.decision (m_ctx l) (m_eq g)
......@@ -1868,8 +1875,6 @@ let prop_ctx (l:context') (g:equality') : (context', equality')
Cons h' t'
end
in
(*propagate (propagate (propagate l)),
propagate_eq (propagate_eq (propagate_eq g))*)
propagate l, propagate_eq g
use LinearDecisionRationalMP as R
......@@ -1879,8 +1884,8 @@ let prop_ctx (l:context') (g:equality') : (context', equality')
requires { valid_eq' g }
ensures { forall y z. result -> pos_ctx' l z -> pos_eq' g z
-> y = z -> interp_ctx' l g y z }
raises { | OutOfBounds -> true | E.Unknown -> true
| E.Q.Unknown -> true | R.Absurd -> true}
raises { | OutOfBounds -> true | E.MPError -> true
| E.Q.QError -> true | R.Absurd -> true}
= let l', g' = prop_ctx l g in
mp_decision l' g'
......@@ -1893,6 +1898,8 @@ use import mach.int.UInt64
use import int.Int
use import int.Power
meta "compute_max_steps" 0x10000
goal g: forall i x c r: int.
0 <= i ->
x + (2 * (power radix i) * c) = r ->
......@@ -1922,6 +1929,8 @@ module Test2
use import int.Int
use import LinearDecisionInt
meta "compute_max_steps" 0x10000
goal g: forall x y z: int.
x + y = 0 ->
y - z = 0 ->
......@@ -1966,6 +1975,8 @@ module TestFmla
use import Fmla
meta "compute_max_steps" 0x10000
goal g:
forall a: value.
((forall x. forall y. foo (add x (add (add a dummy) y))) = True)
......
......@@ -808,6 +808,66 @@ module N
end
end
(** [incr x y sz] adds to [x] the value of the limb [y] in place.
[x] has size [sz]. The addition must not overflow. This corresponds
to [mpn_incr] *)
let incr (x:t) (y:limb) (sz:int32) : unit
requires { valid x sz }
requires { sz > 0 }
requires { value x sz + y < power radix sz }
ensures { value x sz = value (old x) sz + y }
ensures { forall j. j < x.offset \/ x.offset + sz <= j ->
(pelts x)[j] = (pelts (old x))[j] }
writes { x.data.elts }
=
let ghost ox = { x } in
let c = ref y in
let lx : ref limb = ref 0 in
let i : ref int32 = ref 0 in
while not (Limb.(=) !c 0) do
invariant { 0 <= !i <= sz }
invariant { !i = sz -> !c = 0 }
invariant { !i > 0 -> 0 <= !c <= 1 }
invariant { value x !i + (power radix !i) * !c
= value ox !i + y }
invariant { forall j. !i <= j < sz ->
(pelts x)[x.offset + j] = (pelts ox)[x.offset + j] }
invariant { forall j. j < x.offset \/ x.offset + sz <= j ->
(pelts x)[j] = (pelts ox)[j] }
variant { sz - !i }
label StartLoop in
lx := get_ofs x !i;
assert { !lx = (pelts ox)[ox.offset + !i] };
let (res, carry) = add_with_carry !lx !c 0 in (*TODO*)
assert { res + radix * carry = !lx + !c }; (* TODO remove this *)
value_sub_update_no_change (pelts x) (x.offset + p2i !i)
(x.offset + p2i !i + 1)
(x.offset + p2i sz) res;
set_ofs x !i res;
assert { forall j. !i < j < sz ->
(pelts x)[x.offset + j]
= (pelts ox)[x.offset + j] };
assert { value x !i + (power radix !i) * !c = value ox !i + y };
c := carry;
value_tail x !i;
value_tail ox !i;
assert { value x (!i+1) + power radix (!i+1) * !c =
value ox (!i+1) + y };
i := Int32.(+) !i 1;
assert { !i = sz -> !c = 0
by value x sz + power radix sz * !c = value ox sz + y
so value ox sz + y < power radix sz
so 0 <= !c <= 1};
done;
value_concat x !i sz;
value_concat ox !i sz;
assert { forall j. x.offset + !i <= j < x.offset + sz ->
(pelts x)[j] = (pelts ox)[j]
by let k = j - x.offset in
!i <= k < sz
so (pelts x)[x.offset + k] = (pelts ox)[x.offset + k]};
value_sub_frame (pelts x) (pelts ox) (x.offset + p2i !i) (x.offset + p2i sz)
(** [sub_limb r x y sz] substracts [y] from [(x, sz)] and writes
the result to [(r, sz)]. Returns borrow, either 0 or
......@@ -1745,14 +1805,14 @@ module N
(** [mul r x y sx sy] multiplies [(x, sx)] and [(y,sy)] and writes
the result in [(r, sx+sy)]. [sx] must be greater than or equal to
[sy]. Corresponds to [mpn_mul]. *)
let mul (r x y:t) (sx sy:int32) : limb
let mul (r x y:t) (sx sy:int32) : unit
requires { 0 < sy <= sx }
requires { valid x sx }
requires { valid y sy }
requires { valid r (sy + sx) }
writes { r.data.elts }
ensures { value r (sy + sx) = value x sx * value y sy }
ensures { result = (pelts r)[r.offset + sx + sy - 1] }
(*ensures { result = (pelts r)[r.offset + sx + sy - 1] }*)
=
let ly = ref (C.get y) in
let c = mul_limb r x !ly sx in
......@@ -1854,7 +1914,7 @@ module N
i := Int32.(+) !i one;
rp.contents <- C.incr !rp one;
done;
get_ofs !rp (Int32.(-) sx one);
(*get_ofs !rp (Int32.(-) sx one);*)
(** {3 Logical operations} *)
......@@ -6617,11 +6677,11 @@ let divmod_1 (q x:t) (y:limb) (sz:int32) : limb
let snx = Int32.(+) sx one in
let tp = C.malloc (UInt32.of_int32 st) in
mul tp q ny !qn ign;
let b = sub_in_place nx tp snx st in (* TODO in place *)
let b = sub_in_place nx tp snx st in
(if Limb.(>) b limb_zero
then (* quotient too large *)
let _s = sub_limb_in_place q (Limb.of_int 1) (!qn) in (*TODO in place *)
let _a = add_in_place nx ny snx sy in (* TODO in place *)
let _s = sub_limb_in_place q (Limb.of_int 1) (!qn) in
let _a = add_in_place nx ny snx sy in
()
else ());
if Int32.(=) clz zero
......
......@@ -17,3 +17,6 @@ val meta_rewrite_def : Theory.meta
val normalize_goal_transf_all : Env.env -> Task.task Trans.tlist
val normalize_goal_transf_few : Env.env -> Task.task Trans.tlist
val normalize_hyp : int option -> Decl.prsymbol option -> Env.env
-> Task.task Trans.tlist
......@@ -4,6 +4,7 @@ open Decl
open Ident
open Task
open Args_wrapper
open Generic_arg_trans_utils
exception NoReification
exception Exit of string
......@@ -299,7 +300,7 @@ let rec reify_term renv t rt =
end
and invert_interp renv ls (t:term) =
let ld = try Opt.get (find_logic_definition renv.kn ls)
with _ ->
with Invalid_argument _ ->
if debug
then Format.printf "did not find def of %a@."
Pretty.print_ls ls;
......@@ -336,7 +337,7 @@ let rec reify_term renv t rt =
raise NoReification
and invert_ctx_interp renv ls t l g =
let ld = try Opt.get (find_logic_definition renv.kn ls)
with _ ->
with Invalid_argument _ ->
if debug
then Format.printf "did not find def of %a@." Pretty.print_ls ls;
raise NoReification
......@@ -400,6 +401,9 @@ let rec reify_term renv t rt =
match td.td_node with
| Decl {d_node = Dprop (Paxiom, _, e)}
-> add_to_ctx (renv, ctx) e
| Decl {d_node = Dlogic [ls, ld]} when ls.ls_args = []
->
add_to_ctx (renv, ctx) (ls_defn_axiom ld)
| _-> renv,ctx)
(renv, (t_app nil [] (Some ty_list_g))) renv.task in
{ renv with subst = Mvs.add l ctx renv.subst }
......@@ -552,6 +556,7 @@ let build_goals do_trans prev prs subst env lp g rt =
let task_r = Task.add_decl (Task.add_decl prev d_r) d in
if debug then Format.printf "building cut indication rt %a g %a@."
Pretty.print_term rt Pretty.print_term g;
let compute_hyp pr = Compute.normalize_hyp None (Some pr) env in
let compute_in_goal = Compute.normalize_goal_transf_all env in
let ltask_r =
try let ci =
......@@ -566,31 +571,28 @@ let build_goals do_trans prev prs subst env lp g rt =
| _ -> raise Not_found in
if debug then Format.printf "cut ok@.";
Trans.apply (Cut.cut ci (Some "interp")) task_r
with _ ->
with Arg_trans _ | TypeMismatch _ | Not_found ->
if debug then Format.printf "no cut found@.";
let t = Trans.apply (Ind_itp.revert_tr_symbol [Tsprsymbol hr]) task_r in
if do_trans
then
let t = Trans.apply compute_in_goal t in
let t = Trans.apply (compute_hyp hr) task_r in
match t with
| [t] ->
let rewrite pr = Apply.rewrite None false pr None in
let lt, prs =
List.fold_left
(fun (acc, f) pr ->
try (Lists.apply (Trans.apply (rewrite pr)) acc,f)
with _ -> acc, pr::f)
([t],[]) prs in
(* for the prs that failed once, trying again seems to work ? *)
List.fold_left
(fun acc pr ->
try Lists.apply (Trans.apply (rewrite pr)) acc
with _ -> acc)
lt (List.rev prs)
let rewrite pr = Apply.rewrite None false pr (Some hr) in
let rewrites lt =
List.fold_left
(fun (acc, b) pr ->
try (Lists.apply (Trans.apply (rewrite pr)) acc,true)
with Arg_trans _ -> acc, b)
(lt,false) prs in
let rec rewrite_loop lt =
let (lt, b) = rewrites lt in
if b then rewrite_loop lt
else lt in
rewrite_loop [t]
| [] -> []
| _ -> assert false
else [t] in
else [task_r] in
let lt = List.map (fun ng -> Task.add_decl prev
(create_prop_decl Pgoal (create_prsymbol (id_fresh "G")) ng))
inst_lp in
......@@ -1172,18 +1174,20 @@ let rec interp_expr info (e:Mltree.expr) : value =
let rec aux = function
| [] -> if debug then Format.printf "Etry: uncaught exception@.";
raise e
| (xs', pvl, e) :: bl when xs_equal xs xs' ->
begin match pvl, ov with
| [], None -> interp_expr info e
| l, Some (Vtuple l') when (List.length l = List.length l') ->
let info = List.fold_left2 (fun info pv v -> add_pv pv v info)
info l l' in
interp_expr info e
| [pv], Some v ->
interp_expr (add_pv pv v info) e
| _ -> if debug then Format.printf "Etry: bad arity@.";
aux bl end
| _::bl -> aux bl
| (xs', pvl, e) :: bl ->
if xs_equal xs xs'
then begin
match pvl, ov with
| [], None -> interp_expr info e
| l, Some (Vtuple l') when (List.length l = List.length l') ->
let info = List.fold_left2 (fun info pv v -> add_pv pv v info)
info l l' in
interp_expr info e
| [pv], Some v ->
interp_expr (add_pv pv v info) e
| _ -> if debug then Format.printf "Etry: bad arity@.";
aux bl end
else aux bl
in
aux bl)
......@@ -1192,21 +1196,28 @@ let eval_fun decl info = match decl with
interp_expr info expr
| _ -> raise CannotReduce
let rec value_of_term t =
let rec value_of_term kn t =
match t.t_node with
| Ttrue -> Vbool true
| Tfalse -> Vbool false
| Term.Tapp (ls, lp) when ls.ls_constr > 0 ->
let rs = restore_rs ls in
if is_rs_tuple rs
then Vtuple (List.map value_of_term lp)
then Vtuple (List.map (value_of_term kn) lp)
else Vconstr ((restore_rs ls),
(List.map (fun t -> Fimmutable (value_of_term t)) lp))
| Tnot t -> begin match value_of_term t with
(List.map (fun t -> Fimmutable (value_of_term kn t)) lp))
| Tnot t -> begin match value_of_term kn t with
| Vbool b -> Vbool (not b)
| _ -> raise CannotReduce end
(* TODO Tbinop maybe *)
| Tconst (Number.ConstInt ic) -> Vint (Number.compute_int_constant ic)
| Term.Tapp (ls,[]) ->
begin match find_logic_definition kn ls with