* occam-channel.scm (alt): New syntax.

2 files changed, 172 insertions, 23 deletions

diff --git a/ice-9/ChangeLog b/ice-9/ChangeLog
index 5ab444557..c220254b7 100644
--- a/ice-9/ChangeLog
+++ b/ice-9/ChangeLog
@@ -1,5 +1,7 @@
 2003-01-20  Mikael Djurfeldt  <djurfeldt@nada.kth.se>
 
+	* occam-channel.scm (alt): New syntax.
+
 	* psyntax.ss (self-evaluating?): Removed.  Guile now provides this
 	operator as a primitive procedure.
 	(build-data): Quote vectors (psyntax.ss requires this).
diff --git a/ice-9/occam-channel.scm b/ice-9/occam-channel.scm
index 4c7c90383..791244190 100644
--- a/ice-9/occam-channel.scm
+++ b/ice-9/occam-channel.scm
@@ -42,13 +42,22 @@
 ;;; If you do not wish that, delete this exception notice.
 
 (define-module (ice-9 occam-channel)
+  #:use-syntax (ice-9 syncase)
   #:use-module (oop goops)
   #:use-module (ice-9 threads)
-  ;;#:export-syntax (alt)
+  #:export-syntax (alt
+		   ;; macro use:
+		   oc:lock oc:unlock oc:consequence
+		   oc:immediate-dispatch oc:late-dispatch oc:first-channel
+		   oc:set-handshake-channel oc:unset-handshake-channel)
   #:export (make-channel
 	    ?
 	    !
 	    make-timer
+	    ;; macro use:
+	    handshake-channel mutex
+	    sender-waiting?
+	    immediate-receive late-receive
 	    )
   )
 
@@ -58,27 +67,48 @@
 (define-class <channel> ())
 
 (define-class <data-channel> (<channel>)
+  (handshake-channel #:accessor handshake-channel)
   (data #:accessor data #:init-value no-data)
   (cv #:accessor cv #:init-form (make-condition-variable))
   (mutex #:accessor mutex #:init-form (make-mutex)))
 
+(define-method (initialize (ch <data-channel>) initargs)
+  (next-method)
+  (set! (handshake-channel ch) ch))
+
 (define-method (make-channel)
   (make <data-channel>))
 
-(define-method (? (ch <data-channel>))
-  (lock-mutex (mutex ch))
-  (cond ((eq? (data ch) no-data)
-	 (set! (data ch) receiver-waiting)
-	 (wait-condition-variable (cv ch) (mutex ch)))
-	((eq? (data ch) receiver-waiting)
-	 (unlock-mutex (mutex ch))
-	 (scm-error 'misc-error '? "another process is already receiving on ~A"
-		    (list ch) #f))
-	(else
-	 ;; sender is waiting
-	 (signal-condition-variable (cv ch))))
+(define-method (sender-waiting? (ch <data-channel>))
+  (not (eq? (data ch) no-data)))
+
+(define-method (receiver-waiting? (ch <data-channel>))
+  (eq? (data ch) receiver-waiting))
+
+(define-method (immediate-receive (ch <data-channel>))
+  (signal-condition-variable (cv ch))
   (let ((res (data ch)))
     (set! (data ch) no-data)
+    res))
+
+(define-method (late-receive (ch <data-channel>))
+  (let ((res (data ch)))
+    (set! (data ch) no-data)
+    res))
+
+(define-method (? (ch <data-channel>))
+  (lock-mutex (mutex ch))
+  (let ((res (cond ((receiver-waiting? ch)
+		    (unlock-mutex (mutex ch))
+		    (scm-error 'misc-error '?
+			       "another process is already receiving on ~A"
+			       (list ch) #f))
+		   ((sender-waiting? ch)
+		    (immediate-receive ch))
+		   (else
+		    (set! (data ch) receiver-waiting)
+		    (wait-condition-variable (cv ch) (mutex ch))
+		    (late-receive ch)))))
     (unlock-mutex (mutex ch))
     res))
 
@@ -86,18 +116,18 @@
   (! ch *unspecified*))
 
 (define-method (! (ch <data-channel>) (x <top>))
-  (lock-mutex (mutex ch))
-  (cond ((eq? (data ch) no-data)
-	 (set! (data ch) x)
-	 (wait-condition-variable (cv ch) (mutex ch)))
-	((eq? (data ch) receiver-waiting)
+  (lock-mutex (mutex (handshake-channel ch)))
+  (cond ((receiver-waiting? ch)
 	 (set! (data ch) x)
-	 (signal-condition-variable (cv ch)))
-	(else
-	 (unlock-mutex (mutex ch))
+	 (signal-condition-variable (cv (handshake-channel ch))))
+	((sender-waiting? ch)
+	 (unlock-mutex (mutex (handshake-channel ch)))
 	 (scm-error 'misc-error '! "another process is already sending on ~A"
-		    (list ch) #f)))
-  (unlock-mutex (mutex ch)))
+		    (list ch) #f))
+	(else
+	 (set! (data ch) x)
+	 (wait-condition-variable (cv ch) (mutex ch))))
+  (unlock-mutex (mutex (handshake-channel ch))))
 
 ;;; Add protocols?
 
@@ -138,3 +168,120 @@
   (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
   (unlock-mutex timer-mutex))
 
+;;; (alt CLAUSE ...)
+;;;
+;;; CLAUSE ::= ((? CH) FORM ...)
+;;;            | (EXP (? CH) FORM ...)
+;;;            | (EXP FORM ...)
+;;;
+;;; where FORM ... can be => (lambda (x) ...)
+;;;
+;;; *fixme* Currently only handles <data-channel>:s
+;;;
+
+(define-syntax oc:lock
+  (syntax-rules (?)
+    ((_ ((? ch) form ...)) (lock-mutex (mutex ch)))
+    ((_ (exp (? ch) form ...)) (lock-mutex (mutex ch)))
+    ((_ (exp form ...)) #f)))
+
+(define-syntax oc:unlock
+  (syntax-rules (?)
+    ((_ ((? ch) form ...)) (unlock-mutex (mutex ch)))
+    ((_ (exp (? ch) form ...)) (unlock-mutex (mutex ch)))
+    ((_ (exp form ...)) #f)))
+
+(define-syntax oc:consequence
+  (syntax-rules (=>)
+    ((_ data) data)
+    ((_ data => (lambda (x) e1 e2 ...))
+     (let ((x data)) e1 e2 ...))
+    ((_ data e1 e2 ...)
+     (begin data e1 e2 ...))))
+
+(define-syntax oc:immediate-dispatch
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     ((sender-waiting? ch)
+      (oc:consequence (immediate-receive ch) e1 ...)))
+    ((_ (exp (? ch) e1 ...))
+     ((and exp (sender-waiting? ch))
+      (oc:consequence (immediate-receive ch) e1 ...)))
+    ((_ (exp e1 ...))
+     (exp e1 ...))))
+
+(define-syntax oc:late-dispatch
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     ((sender-waiting? ch)
+      (oc:consequence (late-receive ch) e1 ...)))
+    ((_ (exp (? ch) e1 ...))
+     ((and exp (sender-waiting? ch))
+      (oc:consequence (late-receive ch) e1 ...)))
+    ((_ (exp e1 ...))
+     (#f))))
+
+(define-syntax oc:first-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...) c2 ...)
+     ch)
+    ((_ (exp (? ch) e1 ...) c2 ...)
+     ch)
+    ((_ c1 c2 ...)
+     (first-channel c2 ...))))
+
+(define-syntax oc:set-handshake-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...) handshake)
+     (set! (handshake-channel ch) handshake))
+    ((_ (exp (? ch) e1 ...) handshake)
+     (and exp (set! (handshake-channel ch) handshake)))
+    ((_ (exp e1 ...) handshake)
+     #f)))
+
+(define-syntax oc:unset-handshake-channel
+  (syntax-rules (?)
+    ((_ ((? ch) e1 ...))
+     (set! (handshake-channel ch) ch))
+    ((_ (exp (? ch) e1 ...))
+     (and exp (set! (handshake-channel ch) ch)))
+    ((_ (exp e1 ...))
+     #f)))
+
+(define-syntax alt
+  (lambda (x)
+    (define (else-clause? x)
+      (syntax-case x (else)
+	((_) #f)
+	((_ (else e1 e2 ...)) #t)
+	((_ c1 c2 ...) (else-clause? (syntax (_ c2 ...))))))
+    
+    (syntax-case x (else)
+      ((_ c1 c2 ...)
+       (else-clause? x)
+       (syntax (begin
+		 (oc:lock c1)
+		 (oc:lock c2) ...
+		 (let ((res (cond (oc:immediate-dispatch c1)
+				  (oc:immediate-dispatch c2) ...)))
+		   (oc:unlock c1)
+		   (oc:unlock c2) ...
+		   res))))
+      ((_ c1 c2 ...)
+       (syntax (begin
+		 (oc:lock c1)
+		 (oc:lock c2) ...
+		 (let ((res (cond (oc:immediate-dispatch c1)
+				  (oc:immediate-dispatch c2) ...
+				  (else (let ((ch (oc:first-channel c1 c2 ...)))
+					  (oc:set-handshake-channel c1 ch)
+					  (oc:set-handshake-channel c2 ch) ...
+					  (wait-condition-variable (cv ch)
+								   (mutex ch))
+					  (oc:unset-handshake-channel c1)
+					  (oc:unset-handshake-channel c2) ...
+					  (cond (oc:late-dispatch c1)
+						(oc:late-dispatch c2) ...))))))
+		   (oc:unlock c1)
+		   (oc:unlock c2) ...
+		   res)))))))