diff --git a/domains/interval.ml b/domains/interval.ml index d7ad380..50debd1 100644 --- a/domains/interval.ml +++ b/domains/interval.ml @@ -8,6 +8,8 @@ module Interval : NAKED_VALUE_DOMAIN = struct let rand a b = { lower = Z.min a b; upper = Z.max a b } let infty = Z.of_int64_unsigned Int64.max_int let min_infty = Z.neg infty + let pos = rand Z.one infty + let neg = rand min_infty Z.minus_one let rand3 a b c = let mi = List.fold_left Z.min a [ a; b; c ] in @@ -20,19 +22,20 @@ module Interval : NAKED_VALUE_DOMAIN = struct rand mi ma let minus z = rand (Z.neg z.upper) (Z.neg z.lower) - let join z1 z2 = rand4 z1.lower z2.lower z1.upper z2.upper + let meet z1 z2 = if Z.lt z1.upper z2.lower || Z.lt z2.upper z1.lower then raise Absurd else rand (Z.max z1.lower z2.lower) (Z.min z1.upper z2.upper) + let widen z1 z2 = rand (if Z.lt z1.lower z2.lower then z1.lower else min_infty) (if Z.gt z1.upper z2.upper then z1.upper else infty) + let narrow = meet let subset z1 z2 = Z.geq z1.lower z2.lower && Z.leq z1.upper z2.upper - let binary z1 z2 = function | AST_PLUS -> rand (Z.add z1.lower z2.lower) (Z.add z1.upper z2.upper) | AST_MINUS -> rand (Z.sub z1.lower z2.upper) (Z.sub z1.upper z2.lower) @@ -46,7 +49,8 @@ module Interval : NAKED_VALUE_DOMAIN = struct rand4 (Z.div z1.lower z2.lower) (Z.div z1.upper z2.lower) (Z.div z1.lower z2.upper) (Z.div z1.upper z2.upper) | AST_MODULO -> - if Z.sign z2.lower <> Z.sign z2.upper || Z.sign z2.lower = 0 then raise Absurd + if Z.sign z2.lower <> Z.sign z2.upper || Z.sign z2.lower = 0 then + raise Absurd else rand4 (Z.rem z1.lower z2.lower) (Z.rem z1.upper z2.lower) (Z.rem z1.lower z2.upper) (Z.rem z1.upper z2.upper) @@ -97,8 +101,29 @@ module Interval : NAKED_VALUE_DOMAIN = struct let r1 = rand z1.lower (Z.min z1.upper z2.upper) in let r2 = rand (Z.max z1.lower z2.lower) z2.upper in (r1, r2) - | AST_GREATER -> let r1, r2 = compare z2 z1 AST_LESS in r2, r1 - | AST_GREATER_EQUAL -> let r1, r2 = compare z2 z1 AST_LESS_EQUAL in r2, r1 + | AST_GREATER -> + let r1, r2 = compare z2 z1 AST_LESS in + (r2, r1) + | AST_GREATER_EQUAL -> + let r1, r2 = compare z2 z1 AST_LESS_EQUAL in + (r2, r1) + + let has_zero z = Z.leq z.lower Z.zero && Z.geq z.upper Z.zero + let has_one z = Z.leq z.lower Z.one && Z.geq z.upper Z.one + let has_minus_one z = Z.leq z.lower Z.minus_one && Z.geq z.upper Z.minus_one + + let three_part z1 z2 op = + if has_one z2 then + if has_minus_one z2 then + let a = meet pos z2 in + let b = meet neg z2 in + join (binary z1 a op) (binary z1 b op) + else + let a = meet pos z2 in + binary z1 a op + else + let a = meet neg z2 in + binary z1 a op let bwd_binary z1 z2 op r = match op with @@ -107,12 +132,21 @@ module Interval : NAKED_VALUE_DOMAIN = struct | AST_MINUS -> (meet z1 (binary r z2 AST_PLUS), meet z2 (binary z1 r AST_MINUS)) | AST_MULTIPLY -> - (meet z1 (binary r z2 AST_DIVIDE), meet z2 (binary r z1 AST_DIVIDE)) + if is_only_zero z1 || is_only_zero z2 then + if has_zero r then + z1, z2 + else raise Absurd + else + let z2' = meet z2 (three_part r z1 AST_DIVIDE) in + let z1' = meet z1 (three_part r z2 AST_DIVIDE) in + if has_zero r then + ( (if has_zero z1' then join z1' (const Z.zero) else z1'), + if has_zero z2' then join z2' (const Z.zero) else z2' ) + else (z1', z2') | AST_DIVIDE -> (meet z1 (binary r z2 AST_MULTIPLY), meet z2 (binary z1 r AST_DIVIDE)) | AST_MODULO -> (z1, z2) - let print fmt z = Format.pp_print_string fmt "["; Z.pp_print fmt z.lower;