unikernel/duniverse/optint/fuzz/dune

@@ -0,0 +1,19 @@
+(executable
+ (name fuzz)
+ (modules fuzz)
+ (libraries fmt crowbar optint))
+
+(alias
+ (name runtest)
+ (deps (:fuzz fuzz.exe))
+ (action (run %{fuzz})))
+
+(executable
+ (name fuzz_int63)
+ (modules fuzz_int63)
+ (libraries monolith optint))
+
+(alias
+ (name monolith)
+ (deps (:fuzz fuzz_int63.exe))
+ (action (run %{fuzz})))

unikernel/duniverse/optint/fuzz/fuzz.ml

@@ -0,0 +1,135 @@
+let max_intl = 0x3fffffff
+
+let () =
+  Crowbar.add_test ~name:"identity with int32" Crowbar.[ int32 ] @@ fun i32 ->
+  let v = Optint.of_int32 i32 in
+  let u = Optint.to_int32 v in
+  Crowbar.check_eq ~pp:Fmt.int32 ~eq:Int32.equal ~cmp:Int32.compare i32 u
+
+let () =
+  Crowbar.add_test ~name:"identity with int" Crowbar.[ bool; range max_intl ] @@ fun s i ->
+  let i = if s then - i else i in
+  let v = Optint.of_int i in
+  let u = Optint.to_int v in
+  Crowbar.check_eq ~pp:Fmt.int ~eq:(=) ~cmp:compare i u
+
+let binary_operator =
+  Crowbar.(choose [ const `Add
+                  ; const `Sub
+                  ; const `Mul
+                  ; const `Div
+                  ; const `Rem
+                  ; const `Lor
+                  ; const `Land
+                  ; const `Lxor ])
+let unary_operator =
+  Crowbar.(choose [ const `Neg
+                  ; const `Succ
+                  ; const `Pred
+                  ; const `Lnot ])
+
+type binary = [ `Add | `Sub | `Mul | `Div | `Rem | `Lor | `Land | `Lxor ]
+type unary = [ `Neg | `Succ | `Pred | `Lnot ]
+
+let generate ~of_int =
+  let edge = Crowbar.map Crowbar.[ bool; range max_intl ] @@ fun sign v -> match sign with
+    | false -> `V (of_int v)
+    | true  -> `V (of_int (- v)) in
+
+  let edge_binary = Crowbar.map [ edge; edge; binary_operator ] @@ fun a b o -> [ a; b; o ] in
+  let node_binary = Crowbar.map [ edge; binary_operator ] @@ fun x o -> [ x; o ] in
+
+  let edge_unary = Crowbar.map [ edge; unary_operator ] @@ fun x o -> [ x; o ] in
+  let node_unary = Crowbar.map [ unary_operator ] @@ fun o -> [ o ] in
+
+  let edge = Crowbar.map [ edge ] @@ fun x -> [ x ] in
+  let edge = Crowbar.choose [ edge; edge_binary; edge_unary ] in
+  let node = Crowbar.choose [ node_binary; node_unary ] in
+
+  Crowbar.(map [ edge; list node ] @@ fun x r -> List.concat (x :: r))
+
+module type ARITHMETIC = sig
+  type t
+
+  val add : t -> t -> t
+  val sub : t -> t -> t
+  val mul : t -> t -> t
+  val div : t -> t -> t
+  val rem : t -> t -> t
+  val logor : t -> t -> t
+  val logand : t -> t -> t
+  val logxor : t -> t -> t
+
+  val abs : t -> t
+  val neg : t -> t
+  val succ : t -> t
+  val pred : t -> t
+  val lognot : t -> t
+end
+
+type 'v p = [ binary | unary | `V of 'v ]
+
+let pp_p ~pp_v ppf = function
+  | `Add -> Fmt.string ppf "+" | `Sub -> Fmt.string ppf "-" | `Mul -> Fmt.string ppf "*" | `Div -> Fmt.string ppf "/" | `Rem -> Fmt.string ppf "%"
+  | `Lor -> Fmt.string ppf "|" | `Land -> Fmt.string ppf "&" | `Lxor -> Fmt.string ppf "^"
+  | `Neg -> Fmt.string ppf "neg" | `Succ -> Fmt.string ppf "succ" | `Pred -> Fmt.string ppf "pred"
+  | `Lnot -> Fmt.string ppf "~"
+  | `V v -> pp_v ppf v
+
+let rec binary
+  : type v. (module ARITHMETIC with type t = v) -> v -> v -> binary -> v p list -> v
+  = fun (module Arith) a b o r ->
+    let open Arith in
+
+    match o with
+    | `Add -> eval (module Arith) (`V (add a b) :: r)
+    | `Sub -> eval (module Arith) (`V (sub a b) :: r)
+    | `Mul -> eval (module Arith) (`V (mul a b) :: r)
+    | `Div -> eval (module Arith) (`V (div a b) :: r)
+    | `Rem -> eval (module Arith) (`V (rem a b) :: r)
+    | `Lor -> eval (module Arith) (`V (logor a b) :: r)
+    | `Land -> eval (module Arith) (`V (logand a b) :: r)
+    | `Lxor -> eval (module Arith) (`V (logxor a b) :: r)
+
+and unary
+  : type v. (module ARITHMETIC with type t = v) -> v -> unary -> v p list -> v
+  = fun (module Arith) x o r ->
+    let open Arith in
+
+    match o with
+    | `Neg -> eval (module Arith) (`V (neg x) :: r)
+    | `Succ -> eval (module Arith) (`V (succ x) :: r)
+    | `Pred -> eval (module Arith) (`V (pred x) :: r)
+    | `Lnot -> eval (module Arith) (`V (lognot x) :: r)
+
+and eval
+  : type v. (module ARITHMETIC with type t = v) -> v p list -> v
+  = fun arith -> function
+    | (`V a) :: (`V b) :: (#binary as o) :: r -> binary arith a b o r
+    | (`V x) :: (#unary as o) :: r -> unary arith x o r
+    | [ `V v ] -> v
+    | _ -> Crowbar.bad_test ()
+
+let () =
+  Crowbar.add_test ~name:"computation" Crowbar.[ generate ~of_int:(fun x -> x) ] @@ fun l ->
+  (* XXX(dinosaure): FIXME even if it's not used. *)
+  if Sys.word_size = 32
+  then
+  let la = List.map
+      (function `V x -> `V (Optint.of_int x)
+        | (#binary | #unary) as x -> (x :> Optint.t p)) l in
+  let lb = List.map
+      (function `V x -> `V (Int32.of_int x)
+        | (#binary | #unary) as x -> (x :> int32 p)) l in
+
+  let a = try Some (eval (module Optint) la) with Division_by_zero -> None in
+  let b = try Some (eval (module Int32) lb) with Division_by_zero -> None in
+  match a, b with
+  | None, None -> ()
+  | Some _, None | None, Some _ -> Crowbar.bad_test ()
+  | Some a, Some b ->
+    if (b > 0x3fffffffl || b < -0x3fffffffl) then Crowbar.bad_test () ;
+    let a = Optint.to_int a in
+    let b = Int32.to_int b in
+
+    Crowbar.check_eq ~pp:(Fmt.fmt "%x") ~eq:(=) ~cmp:compare a b

unikernel/duniverse/optint/fuzz/fuzz_int63.ml

@@ -0,0 +1,105 @@
+open Monolith
+
+let int = le Int.max_int
+
+let int32 =
+  let gen_random =
+    let open Int32 in
+    let bits () = of_int (Gen.bits ()) in
+    fun () -> logxor (bits ()) (shift_left (bits ()) 30)
+  in
+  let pos = easily_constructible gen_random PPrint.OCaml.int32 in
+  let neg = deconstructible PPrint.OCaml.int32 in
+  ifpol pos neg
+
+let float = deconstructible PPrint.OCaml.float
+let string = deconstructible PPrint.string
+
+module type INTEGER = module type of Optint.Int63.Boxed
+
+module Fuzz_integer_equivalence (Reference : INTEGER) (Candidate : INTEGER) =
+struct
+  module R = Reference
+  module C = Candidate
+
+  let encoded_string : (string, string) spec =
+    let check_valid r c =
+      let exception Incorrect_length of string in
+      let exception Different of string * string in
+      if not (String.length c = R.encoded_size) then raise (Incorrect_length c);
+      if not (String.equal r c) then raise (Different (r, c))
+    in
+    declare_abstract_type
+      ~check:(fun r -> (check_valid r, document (PPrint.string r)))
+      ()
+
+  module Wrap = struct
+    let pp f x =
+      f Format.str_formatter x;
+      Format.flush_str_formatter ()
+
+    let encode f x =
+      let buf = Bytes.create R.encoded_size in
+      f buf ~off:0 x;
+      Bytes.unsafe_to_string buf
+
+    let decode f s = f s ~off:0
+  end
+
+  let run t fuel =
+    let endo = t ^> t in
+    let binop = t ^> t ^> t in
+    let binop_exn = t ^> t ^!> t in
+
+    declare "zero" t R.zero C.zero;
+    declare "one" t R.one C.one;
+    declare "minus_one" t R.minus_one C.minus_one;
+    declare "max_int" t R.max_int C.max_int;
+    declare "min_int" t R.min_int C.min_int;
+
+    declare "succ" endo R.succ C.succ;
+    declare "pred" endo R.pred C.pred;
+    declare "abs" endo R.abs C.abs;
+    declare "neg" endo R.neg C.neg;
+    declare "add" binop R.add C.add;
+    declare "sub" binop R.sub C.sub;
+    declare "mul" binop R.mul C.mul;
+    declare "div" binop_exn R.div C.div;
+    declare "rem" binop_exn R.rem C.rem;
+    declare "logand" binop R.logand C.logand;
+    declare "logor" binop R.logor C.logor;
+    declare "logxor" binop R.logxor C.logxor;
+    declare "lognot" endo R.lognot C.lognot;
+    declare "shift_left" (t ^> int ^> t) R.shift_left C.shift_left;
+    declare "shift_right" (t ^> int ^> t) R.shift_right C.shift_right;
+    declare "shift_right_logical"
+      (t ^> int ^> t)
+      R.shift_right_logical C.shift_right_logical;
+
+    declare "compare" (t ^> t ^> int) R.compare C.compare;
+    declare "equal" (t ^> t ^> bool) R.equal C.equal;
+
+    declare "of_int" (int ^> t) R.of_int C.of_int;
+    declare "to_int" (t ^> int) R.to_int C.to_int;
+    declare "of_int32" (int32 ^> t) R.of_int32 C.of_int32;
+    declare "to_int32" (t ^> int32) R.to_int32 C.to_int32;
+    declare "to_float" (t ^> float) R.to_float C.to_float;
+    declare "to_string" (t ^> string) R.to_string C.to_string;
+
+    declare "pp" (t ^> string) (Wrap.pp R.pp) (Wrap.pp C.pp);
+    declare "encoded_size" int R.encoded_size C.encoded_size;
+    declare "encode" (t ^> encoded_string) (Wrap.encode R.encode)
+      (Wrap.encode C.encode);
+    declare "decode" (encoded_string ^> t) (Wrap.decode R.decode)
+      (Wrap.decode C.decode);
+
+    main fuel
+end
+
+module Reference = Optint.Int63
+module Candidate = Optint.Int63.Boxed
+module Int63_equiv = Fuzz_integer_equivalence (Reference) (Candidate)
+
+let () =
+  let t : (Reference.t, Candidate.t) spec = declare_abstract_type () in
+  Int63_equiv.run t 5

unikernel/duniverse/optint/fuzz/fuzz_int63.mli

@@ -0,0 +1 @@
+(* Intentionally empty *)