From: Daniel Kochmański <daniel@turtleware.eu>
Date: Tue, 1 Sep 2015 14:54:46 +0000 (+0200)
Subject: tests: merge multiprocessing tests
X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=5da6743f3f06df85bfaaa30d8b1630b7da3c6f2e;p=ecl.git

tests: merge multiprocessing tests

Signed-off-by: Daniel Kochmański <daniel@turtleware.eu>
---

diff --git a/src/tests/bugs/mp-tools.lsp b/src/tests/bugs/mp-tools.lsp
deleted file mode 100644
index 8fb39c1..0000000
--- a/src/tests/bugs/mp-tools.lsp
+++ /dev/null
@@ -1,39 +0,0 @@
-;-*- Mode:     Lisp -*-
-;;;; Author:   Juan Jose Garcia-Ripoll
-;;;; Created:  Fri Apr 14 CEST 2012
-;;;; Contains: Supporting routines for multithreaded tests
-
-(in-package :cl-test)
-
-(defun kill-and-wait (process-list &optional original wait)
-  "Kills a list of processes, which may be the difference between two lists,
-waiting for all processes to finish. Currently it has no timeout, meaning
-it may block hard the lisp image."
-  (let ((process-list (set-difference process-list original)))
-    (when (member mp:*current-process* process-list)
-      (error "Found myself in the kill list"))
-    (mapc #'mp:process-kill process-list)
-    (when wait
-      (loop for i in process-list
-         do (mp:process-join i)))
-    process-list))
-
-(defun mp-test-run (closure)
-  (let* ((all-processes (mp:all-processes))
-         (output (multiple-value-list (funcall closure))))
-    (sleep 0.2) ; time to exit some processes
-    (let ((leftovers (kill-and-wait (mp:all-processes) all-processes)))
-      (cond (leftovers
-             (format t "~%;;; Stray processes: ~A" leftovers))
-            (t
-             (values-list output))))))
-
-(defmacro def-mp-test (name body expected-value)
-  "Runs some test code and only returns the output when the code exited without
-creating stray processes."
-  (let ((all-processes (gensym))
-        (output (gensym))
-        (leftover (gensym)))
-    `(deftest ,name
-         (mp-test-run #'(lambda () ,body))
-       ,expected-value)))
diff --git a/src/tests/bugs/mp-001.lsp b/src/tests/bugs/multiprocessing.lsp
similarity index 53%
rename from src/tests/bugs/mp-001.lsp
rename to src/tests/bugs/multiprocessing.lsp
index 26e347b..77051d4 100644
--- a/src/tests/bugs/mp-001.lsp
+++ b/src/tests/bugs/multiprocessing.lsp
@@ -5,6 +5,45 @@
 
 (in-package :cl-test)
 
+
+;; Auxiliary routines for multithreaded tests
+
+(defun kill-and-wait (process-list &optional original wait)
+  "Kills a list of processes, which may be the difference between two lists,
+waiting for all processes to finish. Currently it has no timeout, meaning
+it may block hard the lisp image."
+  (let ((process-list (set-difference process-list original)))
+    (when (member mp:*current-process* process-list)
+      (error "Found myself in the kill list"))
+    (mapc #'mp:process-kill process-list)
+    (when wait
+      (loop for i in process-list
+         do (mp:process-join i)))
+    process-list))
+
+(defun mp-test-run (closure)
+  (let* ((all-processes (mp:all-processes))
+         (output (multiple-value-list (funcall closure))))
+    (sleep 0.2) ; time to exit some processes
+    (let ((leftovers (kill-and-wait (mp:all-processes) all-processes)))
+      (cond (leftovers
+             (format t "~%;;; Stray processes: ~A" leftovers))
+            (t
+             (values-list output))))))
+
+(defmacro def-mp-test (name body expected-value)
+  "Runs some test code and only returns the output when the code exited without
+creating stray processes."
+  (let ((all-processes (gensym))
+        (output (gensym))
+        (leftover (gensym)))
+    `(deftest ,name
+         (mp-test-run #'(lambda () ,body))
+       ,expected-value)))
+
+
+;; Tests
+
 ;;; Date: 04/09/2009
 ;;; From: Matthew Mondor
 ;;; Fixed: 05/09/2009 (Juanjo)
@@ -13,7 +52,6 @@
 ;;;     When a WITH-LOCK is interrupted, it is not able to release
 ;;;     the resulting lock and an error is signaled.
 ;;;
-
 (def-mp-test mp-0001-with-lock
     (let ((flag t)
           (lock (mp:make-lock :name "mp-0001-with-lock" :recursive nil)))
@@ -42,3 +80,5 @@
                (eq flag 1)
                t))))
   t)
+
+