rebase on new packaging

Author: n-osborne

lib/stm/STM.ml renamed to lib/STM.ml

@@ -1,5 +1,5 @@
 open QCheck
-include Common
+include Util
 
 (** A revised state machine framework with parallel testing.
     This version does not come with built-in GC commands. *)

lib/dune

@@ -1,21 +1,17 @@
-(library
- (name common)
- (modules common))
-  
-(library
- (name util)
- (modules util)
- (libraries qcheck unix)
- (preprocess (pps ppx_deriving.show)))
-
 (library
  (name STM)
- (public_name stm)
+ (public_name multicorecheck.stm)
  (modules STM)
- (libraries qcheck domainslib common))
+ (libraries qcheck domainslib util))
 
 (library
  (name lin)
- (public_name lin)
+ (public_name multicorecheck.lin)
  (modules lin)
- (libraries threads qcheck common))
+ (libraries threads qcheck util))
+
+(library
+ (name util)
+ (package multicorecheck)
+ (modules util)
+ (libraries qcheck unix))

lib/lin/lin.ml renamed to lib/lin.ml

@@ -1,5 +1,5 @@
 open QCheck
-include Common
+include Util
 
 module type CmdSpec = sig
   type t

lib/lin/dune

@@ -1,9 +1,46 @@
+(* Repeat a non-determistic property                          *)
+(* This is handy if the outcome depends on, e.g., scheduling. *)
 let rec repeat n prop = fun input ->
   if n<0 then failwith "repeat: negative repetition count";
   if n=0
   then true
   else prop input && repeat (n-1) prop input
 
+let set_ci_printing () =
+  if (Array.mem "--no-colors" Sys.argv)
+  && (Array.mem "--verbose" Sys.argv || Array.mem "-v" Sys.argv)
+  then
+    QCheck_base_runner.set_time_between_msg 2.5
+
+exception Timeout
+
+(* Test a property with a timeout.                       *)
+(* This is handy if the tested code can loop infinitely. *)
+let prop_timeout sec p x =
+  Sys.(signal sigalrm (Signal_handle (fun _ -> raise Timeout))) |> ignore;
+  ignore (Unix.alarm sec);
+  let res = p x in
+  ignore (Unix.alarm 0); (*cancel alarm*)
+  res
+
+
+(* Test a property in a separate process - with a timeout.           *)
+(* This is handy if the tested code can segfault or loop infinitely. *)
+let fork_prop_with_timeout sec p x =
+  let a = Unix.fork () in
+  match a with
+  | 0  ->
+    let _ = Unix.alarm sec in
+    if p x
+    then (ignore (Unix.alarm 0); exit 0) (*cancel alarm*)
+    else (ignore (Unix.alarm 0); exit 2) (*cancel alarm*)
+  | _  ->
+    let _childid, retcode = Unix.wait () in
+    (match retcode with
+     | WEXITED code -> (0=code)
+     | WSIGNALED _
+     | WSTOPPED _  -> false)
+
 let print_triple_vertical ?(fig_indent=10) ?(res_width=20) show (seq,cmds1,cmds2) =
   let seq,cmds1,cmds2 = List.(map show seq, map show cmds1, map show cmds2) in
   let max_width ss = List.fold_left max 0 (List.map String.length ss) in
@@ -34,3 +71,9 @@ let print_triple_vertical ?(fig_indent=10) ?(res_width=20) show (seq,cmds1,cmds2
   print_par_cols (bar_cmd::cmds1) (bar_cmd::cmds2);
   Buffer.contents buf
 
+let protect (f : 'a -> 'b) (a : 'a) : ('b, exn) result =
+  try Result.Ok (f a)
+  with e -> Result.Error e
+
+let pp_exn fmt e = Format.fprintf fmt "%s" (Printexc.to_string e)
+let show_exn e = Format.asprintf "%a" e pp_exn

lib/stm/dune

@@ -9,7 +9,7 @@
 (executable
  (name ws_deque_test)
  (modules ws_deque_test)
- (libraries util qcheck STM domainslib)
+ (libraries qcheck STM domainslib)
  (preprocess (pps ppx_deriving.show)))
 
 (env

lib/common.ml renamed to lib/util.ml

@@ -1,6 +1,7 @@
 (** Sequential tests of ws_deque *)
 
 open QCheck
+open STM
 
 module Ws_deque = Domainslib__Ws_deque
 
@@ -65,8 +66,8 @@ struct
     | RIs_empty of bool
     | RSize of int
     | RPush
-    | RPop of int Util.protected
-    | RSteal of int Util.protected [@@deriving show { with_path = false }]
+    | RPop of (int, exn) result
+    | RSteal of (int, exn) result [@@deriving show { with_path = false }]
 
   let run c d = match c with
     | Is_empty -> RIs_empty (Ws_deque.M.is_empty d)