Reimplement in terms of Parallel Concurrent ML

* fibers/operations.scm: New file.
* fibers/channels.scm: Reimplement in terms of operations (CML events).
* tests/basic.scm: Remove channels tests.
* tests/channels.scm: Add channels tests.
* Makefile.am: Update for new files.

2 files changed, 81 insertions, 22 deletions

diff --git a/tests/basic.scm b/tests/basic.scm
index 1e1ab24..b3d92fa 100644
--- a/tests/basic.scm
+++ b/tests/basic.scm
@@ -18,8 +18,7 @@
 ;;;;
 
 (define-module (tests basic)
-  #:use-module (fibers)
-  #:use-module (fibers channels))
+  #:use-module (fibers))
 
 (define failed? #f)
 
@@ -127,20 +126,6 @@
 
 (assert-run-fibers-returns (1) 1)
 
-(define-syntax-rule (rpc exp)
-  (let ((ch (make-channel)))
-    (spawn-fiber (lambda () (put-message ch exp)))
-    (get-message ch)))
-
-(assert-run-fibers-returns (1) (rpc 1))
-
-(define (rpc-fib n)
-  (rpc (if (< n 2)
-           1
-           (+ (rpc-fib (- n 1)) (rpc-fib (- n 2))))))
-
-(assert-run-fibers-returns (75025) (rpc-fib 24))
-
 (define (check-sleep timeout)
   (spawn-fiber (lambda ()
                  (let ((start (get-internal-real-time)))
@@ -155,14 +140,8 @@
 (assert-run-fibers-terminates
  (do-times 20 (check-sleep (random 1.0))))
 
-;; timed channel wait
-
-;; multi-channel wait
-
 ;; exceptions
 
-;; cross-thread calls
-
 ;; closing port causes pollerr
 
 ;; live threads list
diff --git a/tests/channels.scm b/tests/channels.scm
new file mode 100644
index 0000000..5a9b58b
--- /dev/null
+++ b/tests/channels.scm
@@ -0,0 +1,80 @@
+;; Fibers: cooperative, event-driven user-space threads.
+
+;;;; Copyright (C) 2016 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+;;;;
+
+(define-module (tests cml)
+  #:use-module (fibers)
+  #:use-module (fibers channels))
+
+(define failed? #f)
+
+(define-syntax-rule (assert-equal expected actual)
+  (let ((x expected))
+    (format #t "assert ~s equal to ~s: " 'actual x)
+    (force-output)
+    (let ((y actual))
+      (cond
+       ((equal? x y) (format #t "ok\n"))
+       (else
+        (format #t "no (got ~s)\n" y)
+        (set! failed? #t))))))
+
+(define-syntax-rule (assert-run-fibers-terminates exp)
+  (begin
+    (format #t "assert run-fibers on ~s terminates: " 'exp)
+    (force-output)
+    (let ((start (get-internal-real-time)))
+      (call-with-values (lambda () (run-fibers (lambda () exp)))
+        (lambda vals
+          (format #t "ok (~a s)\n" (/ (- (get-internal-real-time) start)
+                                      1.0 internal-time-units-per-second))
+          (apply values vals))))))
+
+(define-syntax-rule (assert-run-fibers-returns (expected ...) exp)
+  (begin
+    (call-with-values (lambda () (assert-run-fibers-terminates exp))
+      (lambda run-fiber-return-vals
+        (assert-equal '(expected ...) run-fiber-return-vals)))))
+
+(define-syntax-rule (do-times n exp)
+  (let lp ((count n))
+    (let ((count (1- count)))
+      exp
+      (unless (zero? count) (lp count)))))
+
+(define-syntax-rule (rpc exp)
+  (let ((ch (make-channel)))
+    (spawn-fiber (lambda () (put-message ch exp)))
+    (get-message ch)))
+
+(assert-run-fibers-returns (1) (rpc 1))
+
+(define (rpc-fib n)
+  (rpc (if (< n 2)
+           1
+           (+ (rpc-fib (- n 1)) (rpc-fib (- n 2))))))
+
+(assert-run-fibers-returns (75025) (rpc-fib 24))
+
+;; timed channel wait
+
+;; multi-channel wait
+
+;; cross-thread calls
+
+(exit (if failed? 1 0))