/[guile]/guile/guile-core/ice-9/occam-channel.scm
ViewVC logotype

Diff of /guile/guile-core/ice-9/occam-channel.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by mdj, Fri Jan 10 18:52:16 2003 UTC revision 1.3 by mdj, Fri Jan 10 22:18:14 2003 UTC
# Line 45  Line 45 
45    #:use-module (oop goops)    #:use-module (oop goops)
46    #:use-module (ice-9 threads)    #:use-module (ice-9 threads)
47    ;;#:export-syntax (alt)    ;;#:export-syntax (alt)
48    #:export (make-channel ? !))    #:export (make-channel
49                ?
50                !
51                make-timer
52                )
53      )
54    
55  (define no-data '(no-data))  (define no-data '(no-data))
56  (define receiver-waiting '(receiver-waiting))  (define receiver-waiting '(receiver-waiting))
57    
58  (define-class <channel> ()  (define-class <channel> ())
59    
60    (define-class <data-channel> (<channel>)
61    (data #:accessor data #:init-value no-data)    (data #:accessor data #:init-value no-data)
62    (cv #:accessor cv #:init-form (make-condition-variable))    (cv #:accessor cv #:init-form (make-condition-variable))
63    (mutex #:accessor mutex #:init-form (make-mutex)))    (mutex #:accessor mutex #:init-form (make-mutex)))
64    
65  (define-method (make-channel)  (define-method (make-channel)
66    (make <channel>))    (make <data-channel>))
67    
68  (define-method (? (ch <channel>))  (define-method (? (ch <data-channel>))
69    (lock-mutex (mutex ch))    (lock-mutex (mutex ch))
70    (cond ((eq? (data ch) no-data)    (cond ((eq? (data ch) no-data)
71           (set! (data ch) receiver-waiting)           (set! (data ch) receiver-waiting)
# Line 75  Line 82 
82      (unlock-mutex (mutex ch))      (unlock-mutex (mutex ch))
83      res))      res))
84    
85  (define-method (! (ch <channel>) (x <top>))  (define-method (! (ch <data-channel>))
86      (! ch *unspecified*))
87    
88    (define-method (! (ch <data-channel>) (x <top>))
89    (lock-mutex (mutex ch))    (lock-mutex (mutex ch))
90    (cond ((eq? (data ch) no-data)    (cond ((eq? (data ch) no-data)
91           (set! (data ch) x)           (set! (data ch) x)
# Line 88  Line 98 
98           (scm-error 'misc-error '! "another process is already sending on ~A"           (scm-error 'misc-error '! "another process is already sending on ~A"
99                      (list ch) #f)))                      (list ch) #f)))
100    (unlock-mutex (mutex ch)))    (unlock-mutex (mutex ch)))
101    
102    ;;; Add protocols?
103    
104    (define-class <port-channel> (<channel>)
105      (port #:accessor port #:init-keyword #:port))
106    
107    (define-method (make-channel (port <port>))
108      (make <port-channel> #:port port))
109    
110    (define-method (? (ch <port-channel>))
111      (read (port ch)))
112    
113    (define-method (! (ch <port-channel>))
114      (write (port ch)))
115    
116    (define-class <timer-channel> (<channel>))
117    
118    (define the-timer (make <timer-channel>))
119    
120    (define timer-cv (make-condition-variable))
121    (define timer-mutex (make-mutex))
122    
123    (define (make-timer)
124      the-timer)
125    
126    (define (timeofday->us t)
127      (+ (* 1000000 (car t)) (cdr t)))
128    
129    (define (us->timeofday n)
130      (cons (quotient n 1000000)
131            (remainder n 1000000)))
132    
133    (define-method (? (ch <timer-channel>))
134      (timeofday->us (gettimeofday)))
135    
136    (define-method (? (ch <timer-channel>) (t <integer>))
137      (lock-mutex timer-mutex)
138      (wait-condition-variable timer-cv timer-mutex (us->timeofday t))
139      (unlock-mutex timer-mutex))
140    

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26