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

Last change on this file since 36563 was 36563, checked in by kon, 3 months ago

remove article stuff

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