89 lines
2.9 KiB
OCaml
89 lines
2.9 KiB
OCaml
open! Import
|
|
open! Blit
|
|
|
|
(* This unit test checks that when [blit] calls [unsafe_blit], the slices are valid.
|
|
It also checks that [blit] doesn't call [unsafe_blit] when there is a range error. *)
|
|
let%test_module _ =
|
|
(module struct
|
|
let blit_was_called = ref false
|
|
let slices_are_valid = ref (Ok ())
|
|
|
|
module B = Make (struct
|
|
type t = bool array
|
|
|
|
let create ~len = Array.create false ~len
|
|
let length = Array.length
|
|
|
|
let unsafe_blit ~src ~src_pos ~dst ~dst_pos ~len =
|
|
blit_was_called := true;
|
|
slices_are_valid
|
|
:= Or_error.try_with (fun () ->
|
|
assert (len >= 0);
|
|
assert (src_pos >= 0);
|
|
assert (src_pos + len <= Array.length src);
|
|
assert (dst_pos >= 0);
|
|
assert (dst_pos + len <= Array.length dst));
|
|
Array.blit ~src ~src_pos ~dst ~dst_pos ~len
|
|
;;
|
|
end)
|
|
|
|
let%test_module "Bool" =
|
|
(module Test_blit.Test
|
|
(struct
|
|
type t = bool
|
|
|
|
let equal = Bool.equal
|
|
let of_bool = Fn.id
|
|
end)
|
|
(struct
|
|
type t = bool array [@@deriving sexp_of]
|
|
|
|
let create ~len = Array.create false ~len
|
|
let length = Array.length
|
|
let get = Array.get
|
|
let set = Array.set
|
|
end)
|
|
(B))
|
|
;;
|
|
|
|
let%test_unit _ =
|
|
let opts = [ None; Some (-1); Some 0; Some 1; Some 2 ] in
|
|
List.iter [ 0; 1; 2 ] ~f:(fun src ->
|
|
List.iter [ 0; 1; 2 ] ~f:(fun dst ->
|
|
List.iter opts ~f:(fun src_pos ->
|
|
List.iter opts ~f:(fun src_len ->
|
|
List.iter opts ~f:(fun dst_pos ->
|
|
try
|
|
let check f =
|
|
blit_was_called := false;
|
|
slices_are_valid := Ok ();
|
|
match Or_error.try_with f with
|
|
| Error _ -> assert (not !blit_was_called)
|
|
| Ok () -> ok_exn !slices_are_valid
|
|
in
|
|
check (fun () ->
|
|
B.blito
|
|
~src:(Array.create ~len:src false)
|
|
?src_pos
|
|
?src_len
|
|
~dst:(Array.create ~len:dst false)
|
|
?dst_pos
|
|
());
|
|
check (fun () ->
|
|
ignore
|
|
(B.subo (Array.create ~len:src false) ?pos:src_pos ?len:src_len
|
|
: bool array))
|
|
with
|
|
| exn ->
|
|
raise_s
|
|
[%message
|
|
"failure"
|
|
(exn : exn)
|
|
(src : int)
|
|
(src_pos : int option)
|
|
(src_len : int option)
|
|
(dst : int)
|
|
(dst_pos : int option)])))))
|
|
;;
|
|
end)
|
|
;;
|