41 lines
1.6 KiB
OCaml
41 lines
1.6 KiB
OCaml
|
open Naked
|
||
|
|
open Abstract_syntax_tree
|
||
|
|
|
||
|
|
module Constants : NAKED_VALUE_DOMAIN = struct
|
||
|
|
type t = Z.t
|
||
|
|
let const z = z
|
||
|
|
let rand z w = raise NeedTop (* We know rand is never called on singletons *)
|
||
|
|
let minus z = Z.neg z
|
||
|
|
let binary a b op = match op with
|
||
|
|
| AST_PLUS -> Z.add a b
|
||
|
|
| AST_MINUS -> Z.sub a b
|
||
|
|
| AST_MULTIPLY -> Z.mul a b
|
||
|
|
| AST_DIVIDE -> (try(Z.div a b)with Division_by_zero -> raise Absurd)
|
||
|
|
| AST_MODULO -> Z.rem a b
|
||
|
|
|
||
|
|
let is_only_zero z = Z.equal (Z.zero) z
|
||
|
|
let multiples_of z = if Z.equal Z.zero z then Z.zero else raise NeedTop
|
||
|
|
let divisors_of z = if Z.equal Z.zero z then Z.zero else raise NeedTop
|
||
|
|
let remainders z = if Z.equal Z.zero z then Z.zero else raise NeedTop
|
||
|
|
let convex_sym z = if Z.equal Z.zero z then Z.zero else raise NeedTop
|
||
|
|
|
||
|
|
let compatible z op = match op with
|
||
|
|
| AST_EQUAL -> z
|
||
|
|
| _ -> raise NeedTop
|
||
|
|
let compare z w op = match op with
|
||
|
|
| AST_EQUAL -> if Z.equal z w then z,w else raise Absurd
|
||
|
|
| AST_NOT_EQUAL -> if Z.equal z w then raise Absurd else z,w
|
||
|
|
| AST_LESS -> if Z.lt z w then z,w else raise Absurd
|
||
|
|
| AST_LESS_EQUAL -> if Z.leq z w then z,w else raise Absurd
|
||
|
|
| AST_GREATER -> if Z.gt z w then z,w else raise Absurd
|
||
|
|
| AST_GREATER_EQUAL -> if Z.geq z w then z,w else raise Absurd
|
||
|
|
let bwd_binary x y op r = if Z.equal (binary x y op) r then x,y else raise Absurd
|
||
|
|
let join x y = if Z.equal x y then x else raise NeedTop
|
||
|
|
let meet x y = if Z.equal x y then x else raise Absurd
|
||
|
|
let widen x y = if Z.equal x y then x else raise NeedTop
|
||
|
|
let narrow x y = if Z.equal x y then x else raise Absurd
|
||
|
|
let subset x y = Z.equal x y
|
||
|
|
let print out x = Z.pp_print out x
|
||
|
|
end
|
||
|
|
|