/usr/share/guile/3.0/ice-9
Edit: /usr/share/guile/3.0/ice-9/occam-channel.scm (7436B)
;;;; Occam-like channels
;;; Copyright (C) 2003, 2006 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 (ice-9 occam-channel)
#:use-module (oop goops)
#:use-module (ice-9 threads)
#: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
)
)
(define no-data '(no-data))
(define receiver-waiting '(receiver-waiting))
(define-class
())
(define-class ()
(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 ) initargs)
(next-method)
(set! (handshake-channel ch) ch))
(define-method (make-channel)
(make ))
(define-method (sender-waiting? (ch ))
(not (eq? (data ch) no-data)))
(define-method (receiver-waiting? (ch ))
(eq? (data ch) receiver-waiting))
(define-method (immediate-receive (ch ))
(signal-condition-variable (cv ch))
(let ((res (data ch)))
(set! (data ch) no-data)
res))
(define-method (late-receive (ch ))
(let ((res (data ch)))
(set! (data ch) no-data)
res))
(define-method (? (ch ))
(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))
(define-method (! (ch ))
(! ch *unspecified*))
(define-method (! (ch ) (x ))
(lock-mutex (mutex (handshake-channel ch)))
(cond ((receiver-waiting? ch)
(set! (data ch) x)
(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))
(else
(set! (data ch) x)
(wait-condition-variable (cv ch) (mutex ch))))
(unlock-mutex (mutex (handshake-channel ch))))
;;; Add protocols?
(define-class ()
(port #:accessor port #:init-keyword #:port))
(define-method (make-channel (port ))
(make #:port port))
(define-method (? (ch ))
(read (port ch)))
(define-method (! (ch ))
(write (port ch)))
(define-class ())
(define the-timer (make ))
(define timer-cv (make-condition-variable))
(define timer-mutex (make-mutex))
(define (make-timer)
the-timer)
(define (timeofday->us t)
(+ (* 1000000 (car t)) (cdr t)))
(define (us->timeofday n)
(cons (quotient n 1000000)
(remainder n 1000000)))
(define-method (? (ch ))
(timeofday->us (gettimeofday)))
(define-method (? (ch ) (t ))
(lock-mutex timer-mutex)
(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 :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)))))))