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

Last change on this file since 36562 was 36562, checked in by Kon Lovett, 13 months ago

remove condition-utils & check-errors dependencies

File size: 19.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) conc ->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  (only record-variants define-record-type-variant))
76
77;;;
78
79;;
80
81(define-inline (->boolean x)
82  (and x #t) )
83
84;;;(only type-errors define-error-type)
85
86;;
87
88(define-inline (localized-type-name-message typnam)
89  ;FIXME en only
90  (conc (appropriate-indefinite-article typnam) " " typnam) )
91
92;;
93
94(define +english-vowels+ '(#\a #\e #\i #\o #\u))
95(define +english-indefinite-articles+ '(an a))
96
97(define-inline (vowel? ch)
98  (->boolean (memq ch +english-vowels+)) )
99
100(define-inline (appropriate-indefinite-article wrd)
101  (let ((s (->string wrd)))
102    (if (vowel? (string-ref s 0))
103      (car +english-indefinite-articles+)
104      (cadr +english-indefinite-articles+) ) ) )
105
106;;
107
108(define-inline (make-bad-argument-message #!optional argnam)
109  (if (not argnam)
110    "bad argument"
111    (conc "bad " #\` argnam #\' " argument") ) )
112
113(define-inline (make-type-name-message typnam)
114  (or
115    (localized-type-name-message typnam)
116    (->string typnam)) )
117
118(define-inline (make-error-type-message typnam #!optional argnam)
119  (string-append
120    (make-bad-argument-message argnam)
121    " type - not "
122    (make-type-name-message typnam)) )
123
124;;
125
126(define-inline (error-list loc obj #!optional argnam)
127  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
128
129;;; Primitives
130
131(include "chicken-primitive-object-inlines")
132(include "chicken-thread-object-inlines")
133(include "inline-type-checks")
134(include "inline-queue")
135
136(cond-expand
137  (unsafe-operations
138    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (%eq? ?arg0 ...))))
139    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (%null? ?arg0 ...))))
140    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (%list? ?arg0 ...))))
141    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (%length ?arg0 ...))))
142    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (%append! ?arg0 ...))))
143    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (%delq! ?arg0 ...))))
144    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (%cons ?arg0 ...))))
145    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (%car ?arg0 ...))))
146    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (%cdr ?arg0 ...))))
147    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (%set-car! ?arg0 ...))))
148    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (%set-cdr! ?arg0 ...))))
149    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (%list-copy ?arg0 ...))))
150    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (%last-pair ?arg0 ...))))
151    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (%current-thread ?arg0 ...))))
152    (define-syntax $thread-blocked? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked? ?arg0 ...))))
153    (define-syntax $thread-blocked-for-timeout? (syntax-rules () ((_ ?arg0 ...) (%thread-blocked-for-timeout? ?arg0 ...)))) )
154  (else
155    (define-syntax $eq? (syntax-rules () ((_ ?arg0 ...) (eq? ?arg0 ...))))
156    (define-syntax $null? (syntax-rules () ((_ ?arg0 ...) (null? ?arg0 ...))))
157    (define-syntax $list? (syntax-rules () ((_ ?arg0 ...) (list? ?arg0 ...))))
158    (define-syntax $length (syntax-rules () ((_ ?arg0 ...) (length ?arg0 ...))))
159    (define-syntax $append! (syntax-rules () ((_ ?arg0 ...) (append! ?arg0 ...))))
160    (define-syntax $delq! (syntax-rules () ((_ ?arg0 ...) (delete! ?arg0 ...))))
161    (define-syntax $cons (syntax-rules () ((_ ?arg0 ...) (cons ?arg0 ...))))
162    (define-syntax $car (syntax-rules () ((_ ?arg0 ...) (car ?arg0 ...))))
163    (define-syntax $cdr (syntax-rules () ((_ ?arg0 ...) (cdr ?arg0 ...))))
164    (define-syntax $set-car! (syntax-rules () ((_ ?arg0 ...) (set-car! ?arg0 ...))))
165    (define-syntax $set-cdr! (syntax-rules () ((_ ?arg0 ...) (set-cdr! ?arg0 ...))))
166    (define-syntax $list-copy (syntax-rules () ((_ ?arg0 ...) (list-copy ?arg0 ...))))
167    (define-syntax $last-pair (syntax-rules () ((_ ?arg0 ...) (last-pair ?arg0 ...))))
168    (define-syntax $current-thread (syntax-rules () ((_ ?arg0 ...) (current-thread ?arg0 ...))))
169    (define ($thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
170    (define ($thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11)))) ) )
171
172;;; Support
173
174(define-type srfi-18-time (struct time))
175
176(define-inline (->boolean obj)
177  (and obj #t) )
178
179;;; Mailbox Support
180
181;; Mailbox
182
183(define-type mailbox (struct mailbox))
184
185(define-record-type-variant mailbox (unsafe unchecked inline)
186  (%raw-make-mailbox nm qu wt)
187  %mailbox?
188  (nm %mailbox-name)
189  (qu %mailbox-queue)
190  (wt %mailbox-waiters %mailbox-waiters-set!) )
191
192(define-inline (%make-mailbox nm)
193  (%raw-make-mailbox nm (%make-queue) '()) )
194
195(define (error-mailbox loc obj #!optional argnam)
196  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox argnam) obj) )
197
198(define-inline-check-type mailbox)
199
200;; Message queue
201
202(define-inline (%mailbox-queue-first-pair mb)
203        (%queue-first-pair (%mailbox-queue mb)) )
204
205(define-inline (%mailbox-queue-last-pair mb)
206        (%queue-last-pair (%mailbox-queue mb)) )
207
208(define-inline (%mailbox-queue-empty? mb)
209        (%queue-empty? (%mailbox-queue mb)) )
210
211(define-inline (%mailbox-queue-count mb)
212        (%queue-count (%mailbox-queue mb)) )
213
214(define-inline (%mailbox-queue-add! mb x)
215        (%queue-add! (%mailbox-queue mb) x) )
216
217(define-inline (%mailbox-queue-remove! mb)
218        (%queue-remove! (%mailbox-queue mb)) )
219
220(define-inline (%mailbox-queue-push-back! mb x)
221        (%queue-push-back! (%mailbox-queue mb) x) )
222
223(define-inline (%mailbox-queue-push-back-list! mb ls)
224        (%queue-push-back-list! (%mailbox-queue mb) ls) )
225
226;; Waiting threads
227
228(define-inline (%mailbox-waiters-empty? mb)
229  ($null? (%mailbox-waiters mb)) )
230
231(define-inline (%mailbox-waiters-count mb)
232  ($length (%mailbox-waiters mb)) )
233
234(define-inline (%mailbox-waiters-add! mb th)
235  (%mailbox-waiters-set! mb ($append! (%mailbox-waiters mb) ($cons th '()))) )
236
237(define-inline (%mailbox-waiters-delete! mb th)
238  (%mailbox-waiters-set! mb ($delq! th (%mailbox-waiters mb))) )
239
240(define-inline (%mailbox-waiters-pop! mb)
241  (let ((ts (%mailbox-waiters mb)))
242    (%mailbox-waiters-set! mb ($cdr ts))
243    ($car ts) ) )
244
245;;; Mailbox Cursor Support
246
247(define-type mailbox-cursor (struct mailbox-cursor))
248
249(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
250  (%raw-make-mailbox-cursor np pp mb)
251  %mailbox-cursor?
252  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
253  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
254  (mb %mailbox-cursor-mailbox) )
255
256(define-inline (%make-mailbox-cursor mb)
257  (%raw-make-mailbox-cursor '() #f mb) )
258
259(define (error-mailbox-cursor loc obj #!optional argnam)
260  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
261
262(define-inline-check-type mailbox-cursor)
263
264(define-inline (%mailbox-cursor-winding? mbc)
265  (->boolean (%mailbox-cursor-prev-pair mbc)) )
266
267(define-inline (%mailbox-cursor-next-pair-empty! mbc)
268  (%mailbox-cursor-next-pair-set! mbc '()) )
269
270(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
271  (%mailbox-cursor-prev-pair-set! mbc #f) )
272
273(define-inline (%mailbox-cursor-rewind! mbc)
274  (%mailbox-cursor-next-pair-empty! mbc)
275  (%mailbox-cursor-prev-pair-clear! mbc) )
276
277(define-inline (%mailbox-cursor-extract! mbc)
278  ;unless 'mailbox-cursor-next' has been called don't remove
279  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
280    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
281
282;; Time Support
283
284(define-type time-number (or fixnum float))
285
286(define-inline (%time-number? obj)
287  (or (fixnum? obj) (flonum? obj)) )
288
289(define-type timeout (or time-number srfi-18-time))
290
291(define-inline (%timeout? obj)
292  (or (%time-number? obj) (time? obj)) )
293
294(define (error-timeout loc obj #!optional argnam)
295  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
296
297(define-inline-check-type timeout)
298
299;;;
300
301(define-type unique-object vector)
302
303;Unique objects used as tags
304(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
305(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
306(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
307#; ;XXX
308(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
309
310;;; Mailbox Exceptions
311
312(define (make-mailbox-timeout-condition loc mb timout timout-value)
313  (let ((tv (if ($eq? timout-value NO-TOVAL-TAG) (void) timout-value)))
314    (make-composite-condition
315      (make-property-condition 'exn
316        'location loc
317        'message "mailbox wait timeout occurred"
318        'arguments (list timout tv))
319      (make-property-condition 'mailbox 'box mb)
320      (make-property-condition 'timeout 'time timout 'value tv)) ) )
321
322;;; Mailbox Threading
323
324;; Select next waiting thread for the mailbox
325
326(define (ready-mailbox-thread! mb)
327  ;ready oldest waiting thread
328  (unless (%mailbox-waiters-empty? mb)
329    (let ((thread (%mailbox-waiters-pop! mb)))
330      ;ready the thread based on wait mode
331      (if (not ($thread-blocked? thread))
332        (thread-resume! thread)
333        ;else wake early if sleeping
334        (when ($thread-blocked-for-timeout? thread)
335          ;ready the thread
336          (##sys#thread-unblock! thread)
337          ;tell 'wait-mailbox-thread!' we unblocked early
338          (thread-signal! thread UNBLOCKED-TAG) ) ) )
339    (void) ) )
340
341;; Sleep current thread until timeout, known condition,
342;; or some other condition
343
344(define (thread-sleep/maybe-unblock! tim unblocked-tag)
345;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
346  ;sleep current thread for desired seconds, unless unblocked "early".
347  (call/cc
348    (lambda (return)
349      (with-exception-handler
350        (lambda (exp)
351          (if ($eq? unblocked-tag exp)
352            (return #f)
353            ;propagate any "real" exception.
354            (signal exp) ) )
355        (lambda ()
356          (thread-sleep! tim) #t) ) ) ) )
357
358;; Wait current thread on the mailbox until timeout, available message
359;; or some other condition
360
361(define (wait-mailbox-thread! loc mb timout timout-value)
362  ;
363  ;no available message due to timeout
364  (define (timeout-exit!)
365    (if (not ($eq? timout-value NO-TOVAL-TAG))
366      timout-value
367      (begin
368        (thread-signal!
369          ($current-thread)
370          (make-mailbox-timeout-condition loc mb timout timout-value))
371        SEQ-FAIL-TAG ) ) )
372  ;
373  ;push current thread on mailbox waiting queue
374  (%mailbox-waiters-add! mb ($current-thread))
375  ;waiting action
376  (cond
377    ;timeout wanted so sleep until something happens
378    (timout
379      (cond-expand
380        (sleep-primordial-thread
381          ;
382          (cond
383            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
384              ;timed-out, so no message
385              ;remove from wait queue
386              (%mailbox-waiters-delete! mb ($current-thread))
387              ;indicate no available message
388              (timeout-exit!) )
389            (else
390              ;unblocked early
391              UNBLOCKED-TAG ) ) )
392        (else
393          ;
394          (if (eq? ($current-thread) ##sys#primordial-thread)
395            (begin
396              (%mailbox-waiters-delete! mb ($current-thread))
397              (warning "mailbox attempt to sleep primordial-thread" mb)
398              (timeout-exit!) )
399            (cond
400              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
401                ;timed-out, so no message
402                ;remove from wait queue
403                (%mailbox-waiters-delete! mb ($current-thread))
404                ;indicate no available message
405                (timeout-exit!) )
406              (else
407                ;unblocked early
408                UNBLOCKED-TAG ) ) ) ) ) )
409    ;no timeout so suspend until something delivered
410    (else
411      (thread-suspend! ($current-thread))
412      ;we're resumed
413      UNBLOCKED-TAG ) ) )
414
415;; Wait current thread on the mailbox unless a message available
416
417;Note that the arguments, except the ?expr0 ..., must be base values.
418(define-syntax on-mailbox-available
419  (syntax-rules ()
420    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
421      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
422        (let waiting ()
423          (cond
424            ((%mailbox-queue-empty? _mb)
425              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
426                ;when a thread ready then check mailbox again, could be empty.
427                (if ($eq? UNBLOCKED-TAG res)
428                  (waiting)
429                  ;else some sort of problem
430                  res ) ) )
431            (else
432              ?expr0 ... ) ) ) ) ) ) )
433
434#; ;XXX
435(define (wait-mailbox-if-empty! loc mb timout timout-value)
436  (on-mailbox-available loc mb timout timout-value
437    MESSAGE-WAITING-TAG ) )
438
439;;; Mailbox
440
441;; Mailbox Exceptions
442
443(: mailbox-timeout-condition? (* -> boolean : condition))
444;
445(define (mailbox-timeout-condition? obj)
446  (and
447    ((condition-predicate 'exn) obj)
448    ((condition-predicate 'mailbox) obj)
449    ((condition-predicate 'timeout) obj) ) )
450
451;; Mailbox Constructor
452
453(: make-mailbox (#!optional * --> mailbox))
454;
455(define (make-mailbox #!optional (nm (gensym 'mailbox)))
456  (%make-mailbox nm) )
457
458(: mailbox? (* -> boolean : mailbox))
459;
460(define (mailbox? obj)
461  (%mailbox? obj) )
462
463;; Mailbox Properties
464
465(: mailbox-name (mailbox --> *))
466;
467(define (mailbox-name mb)
468  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
469
470(: mailbox-empty? (mailbox --> boolean))
471;
472(define (mailbox-empty? mb)
473  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
474
475(: mailbox-count (mailbox --> fixnum))
476;
477(define (mailbox-count mb)
478  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
479
480(: mailbox-waiting? (mailbox --> boolean))
481;
482(define (mailbox-waiting? mb)
483  (not
484    ($null?
485      (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
486
487(: mailbox-waiters (mailbox --> list))
488;
489(define (mailbox-waiters mb)
490  ($list-copy
491    (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
492
493;; Mailbox Operations
494
495(: mailbox-send! (mailbox * -> void))
496;
497(define (mailbox-send! mb x)
498  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
499  (ready-mailbox-thread! mb) )
500
501(: mailbox-wait! (mailbox #!optional timeout -> void))
502;
503(define (mailbox-wait! mb #!optional timout)
504  (when timout (%check-timeout 'mailbox-wait! timout))
505  (on-mailbox-available 'mailbox-wait!
506    (%check-mailbox 'mailbox-wait! mb)
507    timout NO-TOVAL-TAG
508    (void) ) )
509
510(: mailbox-receive! (mailbox #!optional timeout * -> *))
511;
512(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
513  (when timout (%check-timeout 'mailbox-receive! timout))
514  (on-mailbox-available 'mailbox-receive!
515    (%check-mailbox 'mailbox-receive! mb)
516    timout timout-value
517    (%mailbox-queue-remove! mb) ) )
518
519(: mailbox-push-back! (mailbox * -> void))
520;
521(define (mailbox-push-back! mb x)
522  (%mailbox-queue-push-back!
523    (%check-mailbox 'mailbox-send! mb) x)
524  (ready-mailbox-thread! mb) )
525
526(: mailbox-push-back-list! (mailbox list -> void))
527;
528(define (mailbox-push-back-list! mb ls)
529  (%mailbox-queue-push-back-list!
530    (%check-mailbox 'mailbox-send! mb)
531    (%check-list ls 'mailbox-send!))
532  (ready-mailbox-thread! mb) )
533
534;;; Mailbox Cursor
535
536;; Mailbox Cursor Constructor
537
538(: make-mailbox-cursor (mailbox --> mailbox-cursor))
539;
540(define (make-mailbox-cursor mb)
541  (%make-mailbox-cursor
542    (%check-mailbox 'make-mailbox-cursor mb)) )
543
544;; Mailbox Cursor Properties
545
546(: mailbox-cursor? (* -> boolean : mailbox-cursor))
547;
548(define (mailbox-cursor? obj)
549  (%mailbox-cursor? obj) )
550
551(: mailbox-cursor-mailbox (mailbox-cursor --> mailbox))
552;
553(define (mailbox-cursor-mailbox mbc)
554  (%mailbox-cursor-mailbox
555    (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
556
557(: mailbox-cursor-rewound? (mailbox-cursor --> boolean))
558;
559(define (mailbox-cursor-rewound? mbc)
560  (not
561    (%mailbox-cursor-winding?
562      (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
563
564(: mailbox-cursor-unwound? (mailbox-cursor --> boolean))
565;
566(define (mailbox-cursor-unwound? mbc)
567  ($null?
568    (%mailbox-cursor-next-pair
569      (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
570
571;; Mailbox Cursor Operations
572
573(: mailbox-cursor-rewind (mailbox-cursor -> void))
574;
575(define (mailbox-cursor-rewind mbc)
576  (%mailbox-cursor-rewind!
577    (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
578
579(: mailbox-cursor-next (mailbox-cursor #!optional timeout * -> *))
580;
581(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
582  (when timout (%check-timeout 'mailbox-cursor-next timout))
583  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
584    ;seed rewound cursor
585    (unless (%mailbox-cursor-winding? mbc)
586      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
587    ;pull next item from queue at cursor
588    (let scanning ()
589      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
590        ;anything next?
591        (if (not ($null? curr-pair))
592          ;then peek into the queue for the next item
593          (let ((item ($car curr-pair)))
594            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
595            (%mailbox-cursor-next-pair-set! mbc ($cdr curr-pair))
596            item )
597          ;else wait for something in the mailbox
598          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
599            (cond
600              ;continue scanning?
601              (($eq? UNBLOCKED-TAG res)
602                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
603                (scanning) )
604              ;some problem (timeout maybe)
605              (else
606                res ) ) ) ) ) ) ) )
607
608(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
609;
610(define (mailbox-cursor-extract-and-rewind! mbc)
611  (%mailbox-cursor-extract!
612    (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
613  (%mailbox-cursor-rewind! mbc) )
614
615;;; Read/Print Syntax
616
617(define-record-printer (mailbox mb out)
618  (with-output-to-port out
619    (lambda ()
620      (printf "#<mailbox ~A queued: ~A waiters: ~A>"
621        (%mailbox-name mb)
622        (%mailbox-queue-count mb)
623        (%mailbox-waiters-count mb)) ) ) )
624
625(define-record-printer (mailbox-cursor mbc out)
626  (with-output-to-port out
627    (lambda ()
628      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
629      (%mailbox-name (%mailbox-cursor-mailbox mbc))
630      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
631
632) ;module mailbox
Note: See TracBrowser for help on using the repository browser.