source: project/release/5/mailbox/trunk/mailbox.scm @ 36583

Last change on this file since 36583 was 36583, checked in by kon, 11 months ago

restore lib-like error message

File size: 22.7 KB
Line 
1;;;; mailbox.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3;;;; Kon Lovett, Aug '17
4;;;; Kon Lovett, Mar '09
5;;;; From Chicken 3 "mailbox" by Felix & Kon
6
7;; Issues
8;;
9;; - When compile-time feature `unsafe-operations' inlined & primitive routines used.
10;;
11;; - Has explicit "unspecified" returns in some cases to avoid leaks of internal
12;; objects.
13;;
14;; - 'wait-mailbox' may not return should a timeout exception occur.
15;;
16;; - Uses ##sys#thread-unblock!
17;;
18;; - Has knowledge of Unit srfi-18 time object internals.
19;;
20;; - Uses the Chicken extensions 'thread-suspend' & 'thread-resume'.
21;;
22;; - The thread waiting on a mailbox cursor may miss items since only
23;; the end of the queue is available safely.
24;;
25;; - Probably should be rewritten to use a mutex & condition-variable rather than
26;; disabling interrupts and having own thread waiting queue.
27
28(declare
29  (disable-interrupts) ;REQUIRED - see Issues above
30  (always-bound ##sys#primordial-thread)
31  (bound-to-procedure ##sys#signal-hook ##sys#thread-unblock!))
32
33(module mailbox
34
35(;export
36  ;Mailbox Exception API
37  mailbox-timeout-condition?
38  ;Mailbox API
39  make-mailbox
40  mailbox?
41  mailbox-name
42  mailbox-empty?
43  mailbox-count
44  mailbox-waiting?
45  mailbox-waiters
46  mailbox-send!
47  mailbox-wait!
48  mailbox-receive!
49  mailbox-push-back!
50  mailbox-push-back-list!
51  ;Mailbox Cursor API
52  make-mailbox-cursor
53  mailbox-cursor?
54  mailbox-cursor-mailbox
55  mailbox-cursor-next
56  mailbox-cursor-rewind
57  mailbox-cursor-rewound?
58  mailbox-cursor-unwound?
59  mailbox-cursor-extract-and-rewind!)
60
61(import scheme
62  (chicken base)
63  (chicken syntax)
64  (chicken condition)
65  (chicken type)
66  (only (chicken port) with-output-to-port)
67  (only (chicken format) printf)
68  (only (chicken string) ->string)
69  (only (srfi 1) append! delete! list-copy last-pair)
70  (only (srfi 18)
71    time?
72    current-thread
73    thread-signal! thread-sleep!
74    thread-suspend! thread-resume!))
75
76;;; Support
77
78;;record-variants, Jim Ursett
79
80(define-syntax define-record-type-variant
81  (er-macro-transformer
82   (lambda (form r c)
83     (define (any p L)
84       (and (pair? L)
85            (or (p (car L))
86                (any p (cdr L)))))
87     (##sys#check-syntax 'define-record-type-variant form
88                         '(_ _ #(variable 0)
89                             #(variable 1) _ . _))
90     (let* ((name-spec (cadr form))
91            (name (if (pair? name-spec) (car name-spec) name-spec))
92            (t (if (pair? name-spec) (cadr name-spec) name-spec))
93            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
94                                          (caddr form))))
95            (unsafe? (variant? 'unsafe))
96            (unchecked? (variant? 'unchecked))
97            (inline? (variant? 'inline))
98            (constructor? (eq? name t))
99
100            (conser (cadddr form))
101            (predspec (car (cddddr form)))
102            (pred (if (pair? predspec) (car predspec) predspec))
103            (checker (if (and (pair? predspec)
104                              (pair? (cdr predspec)))
105                         (cadr predspec) #f))
106            (slots (cdr (cddddr form)))
107            (%begin (r 'begin))
108            (%lambda (r 'lambda))
109            (%define (if inline? (r 'define-inline) (r 'define)))
110            (vars (cdr conser))
111            (x (r 'x))
112            (y (r 'y))
113            (%getter-with-setter (r 'getter-with-setter))
114            (slotnames (map car slots)))
115       `(,%begin
116         ,(if constructor?
117              `(,%define ,conser
118                         (##sys#make-structure
119                          ',t
120                          ,@(map (lambda (sname)
121                                   (if (memq sname vars)
122                                       sname
123                                       '(##core#undefined)))
124                                 slotnames)))
125              `(,%begin))
126         (,%define (,pred ,x) (##sys#structure? ,x ',t))
127         ,(if checker
128              `(,%define (,checker ,x)
129                         (##core#check (##sys#check-structure ,x ',t)))
130              `(,%begin))
131         ,@(let loop ([slots slots] [i 1])
132             (if (null? slots)
133                 '()
134                 (let* ([slot (car slots)]
135                        (setters (memq #:record-setters ##sys#features))
136                        (setr? (pair? (cddr slot)))
137                        (getr `(,%lambda (,x)
138                                         ,(if unchecked?
139                                              `(,%begin)
140                                              `(##core#check
141                                                (##sys#check-structure ,x ',t)))
142                                         ,(if unsafe?
143                                              `(##sys#slot ,x ,i)
144                                              `(##sys#block-ref ,x ,i)))))
145                   `(,@(if setr?
146                           `((,%define (,(caddr slot) ,x ,y)
147                                       ,(if unchecked?
148                                            `(,%begin)
149                                            `(##core#check
150                                              (##sys#check-structure ,x ',t)))
151                                       ,(if unsafe?
152                                            `(##sys#setslot ,x ,i ,y)
153                                            `(##sys#block-set! ,x ,i ,y))))
154                           '())
155                     (,%define ,(cadr slot)
156                               ,(if (and setr? setters)
157                                    `(,%getter-with-setter ,getr ,(caddr slot))
158                                    getr) )
159                     ,@(loop (cdr slots) (add1 i)))))))))))
160
161;;
162
163(define-type srfi-18-time (struct time))
164
165;;
166
167(define-inline (->boolean obj) (and obj #t))
168
169;;;(only type-errors define-error-type)
170
171;;
172
173(define (make-bad-argument-message #!optional argnam)
174  (if (not argnam)
175    "bad argument"
176    (string-append "bad `" (->string argnam) "' argument") ) )
177
178(define (make-type-name-message typnam)
179  (string-append "a " (->string typnam)) )
180
181(define (make-error-type-message typnam #!optional argnam)
182  (string-append
183    (make-bad-argument-message argnam)
184    " type - not "
185    (make-type-name-message typnam)) )
186
187;;
188
189(define (error-list loc obj #!optional argnam)
190  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
191
192;;; Primitives
193
194(include "chicken-primitive-object-inlines")
195(include "chicken-thread-object-inlines")
196(include "inline-type-checks")
197(include "inline-queue")
198
199(cond-expand
200  (unsafe-operations
201    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (%eq? ?arg0 ...))))
202    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (%null? ?arg0 ...))))
203    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (%list? ?arg0 ...))))
204    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (%length ?arg0 ...))))
205    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (%append! ?arg0 ...))))
206    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (%delq! ?arg0 ...))))
207    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (%cons ?arg0 ...))))
208    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (%car ?arg0 ...))))
209    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (%cdr ?arg0 ...))))
210    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (%set-car! ?arg0 ...))))
211    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (%set-cdr! ?arg0 ...))))
212    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (%list-copy ?arg0 ...))))
213    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (%last-pair ?arg0 ...))))
214    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
215    (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
216    (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...)))) )
217  (else
218    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
219    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (null? ?arg0 ...))))
220    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (list? ?arg0 ...))))
221    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (length ?arg0 ...))))
222    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (append! ?arg0 ...))))
223    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (delete! ?arg0 ...))))
224    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (cons ?arg0 ...))))
225    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (car ?arg0 ...))))
226    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (cdr ?arg0 ...))))
227    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (set-car! ?arg0 ...))))
228    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (set-cdr! ?arg0 ...))))
229    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (list-copy ?arg0 ...))))
230    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (last-pair ?arg0 ...))))
231    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
232    (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
233    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
234
235;;; Mailbox Support
236
237;; Mailbox
238
239(define-type mailbox (struct mailbox))
240
241(define-record-type-variant mailbox (unsafe unchecked inline)
242  (%raw-make-mailbox nm qu wt)
243  %mailbox?
244  (nm %mailbox-name)
245  (qu %mailbox-queue)
246  (wt %mailbox-waiters %mailbox-waiters-set!) )
247
248(define-inline (%make-mailbox nm)
249  (%raw-make-mailbox nm (%make-queue) '()) )
250
251(define (error-mailbox loc obj #!optional argnam)
252  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox argnam) obj) )
253
254(define-inline-check-type mailbox)
255
256;; Message queue
257
258(define-inline (%mailbox-queue-first-pair mb)
259  (%queue-first-pair (%mailbox-queue mb)) )
260
261(define-inline (%mailbox-queue-last-pair mb)
262  (%queue-last-pair (%mailbox-queue mb)) )
263
264(define-inline (%mailbox-queue-empty? mb)
265  (%queue-empty? (%mailbox-queue mb)) )
266
267(define-inline (%mailbox-queue-count mb)
268  (%queue-count (%mailbox-queue mb)) )
269
270(define-inline (%mailbox-queue-add! mb x)
271  (%queue-add! (%mailbox-queue mb) x) )
272
273(define-inline (%mailbox-queue-remove! mb)
274  (%queue-remove! (%mailbox-queue mb)) )
275
276(define-inline (%mailbox-queue-push-back! mb x)
277  (%queue-push-back! (%mailbox-queue mb) x) )
278
279(define-inline (%mailbox-queue-push-back-list! mb ls)
280  (%queue-push-back-list! (%mailbox-queue mb) ls) )
281
282;; Waiting threads
283
284(define-inline (%mailbox-waiters-empty? mb)
285  ($null? (%mailbox-waiters mb)) )
286
287(define-inline (%mailbox-waiters-count mb)
288  ($length (%mailbox-waiters mb)) )
289
290(define-inline (%mailbox-waiters-add! mb th)
291  (%mailbox-waiters-set! mb ($append! (%mailbox-waiters mb) ($cons th '()))) )
292
293(define-inline (%mailbox-waiters-delete! mb th)
294  (%mailbox-waiters-set! mb ($delq! th (%mailbox-waiters mb))) )
295
296(define-inline (%mailbox-waiters-pop! mb)
297  (let ((ts (%mailbox-waiters mb)))
298    (%mailbox-waiters-set! mb ($cdr ts))
299    ($car ts) ) )
300
301;;; Mailbox Cursor Support
302
303(define-type mailbox-cursor (struct mailbox-cursor))
304
305(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
306  (%raw-make-mailbox-cursor np pp mb)
307  %mailbox-cursor?
308  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
309  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
310  (mb %mailbox-cursor-mailbox) )
311
312(define-inline (%make-mailbox-cursor mb)
313  (%raw-make-mailbox-cursor '() #f mb) )
314
315(define (error-mailbox-cursor loc obj #!optional argnam)
316  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
317
318(define-inline-check-type mailbox-cursor)
319
320(define-inline (%mailbox-cursor-winding? mbc)
321  (->boolean (%mailbox-cursor-prev-pair mbc)) )
322
323(define-inline (%mailbox-cursor-next-pair-empty! mbc)
324  (%mailbox-cursor-next-pair-set! mbc '()) )
325
326(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
327  (%mailbox-cursor-prev-pair-set! mbc #f) )
328
329(define-inline (%mailbox-cursor-rewind! mbc)
330  (%mailbox-cursor-next-pair-empty! mbc)
331  (%mailbox-cursor-prev-pair-clear! mbc) )
332
333(define-inline (%mailbox-cursor-extract! mbc)
334  ;unless 'mailbox-cursor-next' has been called don't remove
335  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
336    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
337
338;; Time Support
339
340(define-type time-number (or fixnum float))
341
342(define-inline (%time-number? obj)
343  (or (fixnum? obj) (flonum? obj)) )
344
345(define-type timeout (or time-number srfi-18-time))
346
347(define-inline (%timeout? obj)
348  (or (%time-number? obj) (time? obj)) )
349
350(define (error-timeout loc obj #!optional argnam)
351  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
352
353(define-inline-check-type timeout)
354
355;;;
356
357(define-type unique-object vector)
358
359;Unique objects used as tags
360(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
361(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
362(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
363#; ;XXX
364(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
365
366;;; Mailbox Exceptions
367
368(define (make-mailbox-timeout-condition loc mb timout timout-value)
369  (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
370    (make-composite-condition
371      (make-property-condition 'exn
372        'location loc
373        'message "mailbox wait timeout occurred"
374        'arguments (list timout tv))
375      (make-property-condition 'mailbox 'box mb)
376      (make-property-condition 'timeout 'time timout 'value tv)) ) )
377
378;;; Mailbox Threading
379
380;; Select next waiting thread for the mailbox
381
382(define (ready-mailbox-thread! mb)
383  ;ready oldest waiting thread
384  (unless (%mailbox-waiters-empty? mb)
385    (let ((thread (%mailbox-waiters-pop! mb)))
386      ;ready the thread based on wait mode
387      (if (not ($thread-blocked? thread))
388        (thread-resume! thread)
389        ;else wake early if sleeping
390        (when ($thread-blocked-for-timeout? thread)
391          ;ready the thread
392          (##sys#thread-unblock! thread)
393          ;tell 'wait-mailbox-thread!' we unblocked early
394          (thread-signal! thread UNBLOCKED-TAG) ) ) )
395    (void) ) )
396
397;; Sleep current thread until timeout, known condition,
398;; or some other condition
399
400(define (thread-sleep/maybe-unblock! tim unblocked-tag)
401;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
402  ;sleep current thread for desired seconds, unless unblocked "early".
403  (call/cc
404    (lambda (return)
405      (with-exception-handler
406        (lambda (exp)
407          (if ($eq? unblocked-tag exp)
408            (return #f)
409            ;propagate any "real" exception.
410            (signal exp) ) )
411        (lambda ()
412          (thread-sleep! tim) #t) ) ) ) )
413
414;; Wait current thread on the mailbox until timeout, available message
415;; or some other condition
416
417(define (wait-mailbox-thread! loc mb timout timout-value)
418  ;
419  ;no available message due to timeout
420  (define (timeout-exit!)
421    (if (not ($eq? timout-value NO-TOVAL-TAG))
422      timout-value
423      (begin
424        (thread-signal!
425          ($current-thread)
426          (make-mailbox-timeout-condition loc mb timout timout-value))
427        SEQ-FAIL-TAG ) ) )
428  ;
429  ;push current thread on mailbox waiting queue
430  (%mailbox-waiters-add! mb ($current-thread))
431  ;waiting action
432  (cond
433    ;timeout wanted so sleep until something happens
434    (timout
435      (cond-expand
436        (sleep-primordial-thread
437          ;
438          (cond
439            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
440              ;timed-out, so no message
441              ;remove from wait queue
442              (%mailbox-waiters-delete! mb ($current-thread))
443              ;indicate no available message
444              (timeout-exit!) )
445            (else
446              ;unblocked early
447              UNBLOCKED-TAG ) ) )
448        (else
449          ;
450          (if (eq? ($current-thread) ##sys#primordial-thread)
451            (begin
452              (%mailbox-waiters-delete! mb ($current-thread))
453              (warning "mailbox attempt to sleep primordial-thread" mb)
454              (timeout-exit!) )
455            (cond
456              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
457                ;timed-out, so no message
458                ;remove from wait queue
459                (%mailbox-waiters-delete! mb ($current-thread))
460                ;indicate no available message
461                (timeout-exit!) )
462              (else
463                ;unblocked early
464                UNBLOCKED-TAG ) ) ) ) ) )
465    ;no timeout so suspend until something delivered
466    (else
467      (thread-suspend! ($current-thread))
468      ;we're resumed
469      UNBLOCKED-TAG ) ) )
470
471;; Wait current thread on the mailbox unless a message available
472
473;Note that the arguments, except the ?expr0 ..., must be base values.
474(define-syntax on-mailbox-available
475  (syntax-rules ()
476    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
477      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
478        (let waiting ()
479          (cond
480            ((%mailbox-queue-empty? _mb)
481              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
482                ;when a thread ready then check mailbox again, could be empty.
483                (if ($eq? UNBLOCKED-TAG res)
484                  (waiting)
485                  ;else some sort of problem
486                  res ) ) )
487            (else
488              ?expr0 ... ) ) ) ) ) ) )
489
490#; ;XXX
491(define (wait-mailbox-if-empty! loc mb timout timout-value)
492  (on-mailbox-available loc mb timout timout-value
493    MESSAGE-WAITING-TAG ) )
494
495;;; Mailbox
496
497;; Mailbox Exceptions
498
499(: mailbox-timeout-condition? (* -> boolean : condition))
500;
501(define (mailbox-timeout-condition? obj)
502  (and
503    ((condition-predicate 'exn) obj)
504    ((condition-predicate 'mailbox) obj)
505    ((condition-predicate 'timeout) obj) ) )
506
507;; Mailbox Constructor
508
509(: make-mailbox (#!optional * --> mailbox))
510;
511(define (make-mailbox #!optional (nm (gensym 'mailbox)))
512  (%make-mailbox nm) )
513
514(: mailbox? (* -> boolean : mailbox))
515;
516(define (mailbox? obj)
517  (%mailbox? obj) )
518
519;; Mailbox Properties
520
521(: mailbox-name (mailbox --> *))
522;
523(define (mailbox-name mb)
524  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
525
526(: mailbox-empty? (mailbox --> boolean))
527;
528(define (mailbox-empty? mb)
529  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
530
531(: mailbox-count (mailbox --> fixnum))
532;
533(define (mailbox-count mb)
534  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
535
536(: mailbox-waiting? (mailbox --> boolean))
537;
538(define (mailbox-waiting? mb)
539  (not ($null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
540
541(: mailbox-waiters (mailbox --> list))
542;
543(define (mailbox-waiters mb)
544  ($list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
545
546;; Mailbox Operations
547
548(: mailbox-send! (mailbox * -> void))
549;
550(define (mailbox-send! mb x)
551  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
552  (ready-mailbox-thread! mb) )
553
554(: mailbox-wait! (mailbox #!optional timeout -> void))
555;
556(define (mailbox-wait! mb #!optional timout)
557  (when timout (%check-timeout 'mailbox-wait! timout))
558  (on-mailbox-available 'mailbox-wait!
559    (%check-mailbox 'mailbox-wait! mb)
560    timout NO-TOVAL-TAG
561    (void) ) )
562
563(: mailbox-receive! (mailbox #!optional timeout * -> *))
564;
565(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
566  (when timout (%check-timeout 'mailbox-receive! timout))
567  (on-mailbox-available 'mailbox-receive!
568    (%check-mailbox 'mailbox-receive! mb)
569    timout timout-value
570    (%mailbox-queue-remove! mb) ) )
571
572(: mailbox-push-back! (mailbox * -> void))
573;
574(define (mailbox-push-back! mb x)
575  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
576  (ready-mailbox-thread! mb) )
577
578(: mailbox-push-back-list! (mailbox list -> void))
579;
580(define (mailbox-push-back-list! mb ls)
581  (%mailbox-queue-push-back-list!
582    (%check-mailbox 'mailbox-send! mb)
583    (%check-list ls 'mailbox-send!))
584  (ready-mailbox-thread! mb) )
585
586;;; Mailbox Cursor
587
588;; Mailbox Cursor Constructor
589
590(: make-mailbox-cursor (mailbox --> mailbox-cursor))
591;
592(define (make-mailbox-cursor mb)
593  (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
594
595;; Mailbox Cursor Properties
596
597(: mailbox-cursor? (* -> boolean : mailbox-cursor))
598;
599(define (mailbox-cursor? obj)
600  (%mailbox-cursor? obj) )
601
602(: mailbox-cursor-mailbox (mailbox-cursor --> mailbox))
603;
604(define (mailbox-cursor-mailbox mbc)
605  (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
606
607(: mailbox-cursor-rewound? (mailbox-cursor --> boolean))
608;
609(define (mailbox-cursor-rewound? mbc)
610  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
611
612(: mailbox-cursor-unwound? (mailbox-cursor --> boolean))
613;
614(define (mailbox-cursor-unwound? mbc)
615  ($null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
616
617;; Mailbox Cursor Operations
618
619(: mailbox-cursor-rewind (mailbox-cursor -> void))
620;
621(define (mailbox-cursor-rewind mbc)
622  (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
623
624(: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
625;
626(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
627  (when timout (%check-timeout 'mailbox-cursor-next timout))
628  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
629    ;seed rewound cursor
630    (unless (%mailbox-cursor-winding? mbc)
631      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
632    ;pull next item from queue at cursor
633    (let scanning ()
634      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
635        ;anything next?
636        (if (not ($null? curr-pair))
637          ;then peek into the queue for the next item
638          (let ((item ($car curr-pair)))
639            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
640            (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
641            item )
642          ;else wait for something in the mailbox
643          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
644            (cond
645              ;continue scanning?
646              (($eq? UNBLOCKED-TAG res)
647                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
648                (scanning) )
649              ;some problem (timeout maybe)
650              (else
651                res ) ) ) ) ) ) ) )
652
653(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
654;
655(define (mailbox-cursor-extract-and-rewind! mbc)
656  (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
657  (%mailbox-cursor-rewind! mbc) )
658
659;;; Read/Print Syntax
660
661(define-record-printer (mailbox mb out)
662  (with-output-to-port out
663    (lambda ()
664      (printf "#<mailbox ~A queued: ~A waiters: ~A>"
665        (%mailbox-name mb)
666        (%mailbox-queue-count mb)
667        (%mailbox-waiters-count mb)) ) ) )
668
669(define-record-printer (mailbox-cursor mbc out)
670  (with-output-to-port out
671    (lambda ()
672      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
673      (%mailbox-name (%mailbox-cursor-mailbox mbc))
674      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
675
676) ;module mailbox
Note: See TracBrowser for help on using the repository browser.