mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-13 12:52:08 -08:00
Code Issues Projects Releases Packages Wiki Activity

tests: merge multiprocessing tests

Browse source 
Signed-off-by: Daniel Kochmański <daniel@turtleware.eu>
This commit is contained in:
Daniel Kochmański 2015-09-01 16:54:46 +02:00
parent 0188e5559c
commit 5da6743f3f
2 changed files with 41 additions and 40 deletions
Download patch file Download diff file Expand all files Collapse all files

39
src/tests/bugs/mp-tools.lsp
View file

@ -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)))

42
src/tests/bugs/mp-001.lsp → src/tests/bugs/multiprocessing.lsp
View file

@ -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)