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) |
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) |
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 |
|
|