summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2017-02-20 20:20:42 +0100
committerAndy Wingo <wingo@pobox.com>2017-02-20 20:20:42 +0100
commitfa66c4d4d94b092ae41eedf0f208038d8d045233 (patch)
tree37f541b8c0b9b858e7ec9ea6eeebb3ee3928ff4b
parentFix deprecation warning in (fibers operations) (diff)
downloadguile-fibers-fa66c4d4d94b092ae41eedf0f208038d8d045233.tar.gz
Add new channels test.
* tests/channels.scm (pingpong): New test.
-rw-r--r--tests/channels.scm22
1 files changed, 22 insertions, 0 deletions
diff --git a/tests/channels.scm b/tests/channels.scm
index 5a9b58b..67fa9aa 100644
--- a/tests/channels.scm
+++ b/tests/channels.scm
@@ -71,6 +71,28 @@
(assert-run-fibers-returns (75025) (rpc-fib 24))
+(define (pingpong M N)
+ (let ((request (make-channel)))
+ (for-each (lambda (m)
+ (spawn-fiber (lambda ()
+ (let lp ((n 0))
+ (when (< n N)
+ (let ((reply (make-channel)))
+ (put-message request reply)
+ (get-message reply)
+ (lp (1+ n))))))
+ #:parallel? #t))
+ (iota M))
+ (let lp ((m 0))
+ (when (< m M)
+ (let lp ((n 0))
+ (when (< n N)
+ (put-message (get-message request) 'foo)
+ (lp (1+ n))))
+ (lp (1+ m))))))
+
+(assert-run-fibers-terminates (pingpong (current-processor-count) 1000))
+
;; timed channel wait
;; multi-channel wait