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

Last change on this file since 36192 was 36192, checked in by Kon Lovett, 14 months ago

C5 port

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