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

Last change on this file since 39702 was 39702, checked in by Kon Lovett, 3 months ago

doesn't require record-variants (regression)

File size: 21.1 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;; - Has explicit "unspecified" returns in some cases to avoid leaks of internal
10;; objects.
11;;
12;; - 'wait-mailbox' may not return should a timeout exception occur.
13;;
14;; - Uses ##sys#thread-unblock!
15;;
16;; - Has knowledge of Unit srfi-18 time object internals.
17;;
18;; - Uses the Chicken extensions 'thread-suspend' & 'thread-resume'.
19;;
20;; - The thread waiting on a mailbox cursor may miss items since only
21;; the end of the queue is available safely.
22;;
23;; - Probably should be rewritten to use a mutex & condition-variable rather than
24;; disabling interrupts and having own thread waiting queue.
25;;
26;; -
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
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;;miscmacros
162
163;; evaluates body with an explicit exit continuation
164;;
165  (define-syntax let/cc
166    (syntax-rules ()
167      ((let/cc k e0 e1 ...)
168       (call-with-current-continuation
169        (lambda (k) e0 e1 ...)))))
170
171;;(only type-errors define-error-type)
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(define (error-list loc obj #!optional argnam)
188  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
189
190(include-relative "inline-type-checks")
191
192;;
193
194(define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
195(define-inline (%thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
196
197(define-inline (%->boolean obj) (and obj #t))
198
199(define-inline (%make-unique-object #!optional (id 'unique)) (vector id))
200
201;; Time Support
202
203(define-inline (%time-number? obj)
204  (or (fixnum? obj) (flonum? obj)) )
205
206(define-inline (%timeout? obj)
207  (or (%time-number? obj) (time? obj)) )
208
209(define (error-timeout loc obj #!optional argnam)
210  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
211
212(define (timeout? obj) (%timeout? obj))
213
214(define-inline-check-type timeout)
215
216;; Queue Support
217
218(include-relative "inline-queue")
219
220;;; Typoes
221
222(define-type srfi-18-time   (struct time))
223(define-type mailbox        (struct mailbox))
224(define-type mailbox-cursor (struct mailbox-cursor))
225(define-type time-number    (or fixnum float))
226(define-type timeout        (or time-number srfi-18-time))
227(define-type unique-object  (vector-of symbol))
228
229(: mailbox-timeout-condition?         (* -> boolean : condition))
230(: make-mailbox                       (#!optional * -> mailbox))
231(: mailbox?                           (* -> boolean : mailbox))
232(: mailbox-name                       (mailbox --> *))
233(: mailbox-empty?                     (mailbox -> boolean))
234(: mailbox-count                      (mailbox -> fixnum))
235(: mailbox-waiting?                   (mailbox -> boolean))
236(: mailbox-waiters                    (mailbox -> list))
237(: mailbox-send!                      (mailbox * -> void))
238(: mailbox-wait!                      (mailbox #!optional timeout -> void))
239(: mailbox-receive!                   (mailbox #!optional timeout * -> *))
240(: mailbox-push-back!                 (mailbox * -> void))
241(: mailbox-push-back-list!            (mailbox list -> void))
242(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
243(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
244(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
245(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
246(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
247(: mailbox-cursor-rewind              (mailbox-cursor -> void))
248(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
249(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
250
251;;; Mailbox
252
253;the identifier needs to be defined by somebody
254(define mailbox 'mailbox)
255(define-record-type-variant mailbox (unsafe unchecked inline)
256  (%raw-make-mailbox nm qu wt)
257  (%mailbox?)
258  (nm %mailbox-name)
259  (qu %mailbox-queue)
260  (wt %mailbox-waiters %mailbox-waiters-set!) )
261
262(define-inline (%make-mailbox nm)
263  (%raw-make-mailbox nm (%make-empty-queue) '()) )
264
265(define (error-mailbox loc obj #!optional argnam)
266  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox argnam) obj) )
267
268(define-inline-check-type mailbox)
269
270;; Message queue
271
272(define-inline (%mailbox-queue-first-pair mb)
273  (%queue-first-pair (%mailbox-queue mb)) )
274
275(define-inline (%mailbox-queue-last-pair mb)
276  (%queue-last-pair (%mailbox-queue mb)) )
277
278(define-inline (%mailbox-queue-empty? mb)
279  (%queue-empty? (%mailbox-queue mb)) )
280
281(define-inline (%mailbox-queue-count mb)
282  (%queue-count (%mailbox-queue mb)) )
283
284(define-inline (%mailbox-queue-add! mb x)
285  (%queue-add! (%mailbox-queue mb) x) )
286
287(define-inline (%mailbox-queue-remove! mb)
288  (%queue-remove! (%mailbox-queue mb)) )
289
290(define-inline (%mailbox-queue-push-back! mb x)
291  (%queue-push-back! (%mailbox-queue mb) x) )
292
293(define-inline (%mailbox-queue-push-back-list! mb ls)
294  (%queue-push-back-list! (%mailbox-queue mb) ls) )
295
296;; Waiting threads
297
298(define-inline (%mailbox-waiters-empty? mb)
299  (null? (%mailbox-waiters mb)) )
300
301(define-inline (%mailbox-waiters-count mb)
302  (length (%mailbox-waiters mb)) )
303
304(define-inline (%mailbox-waiters-add! mb th)
305  (%mailbox-waiters-set! mb (append! (%mailbox-waiters mb) (cons th '()))) )
306
307(define-inline (%mailbox-waiters-delete! mb th)
308  (%mailbox-waiters-set! mb (delete! th (%mailbox-waiters mb))) )
309
310(define-inline (%mailbox-waiters-pop! mb)
311  (let ((ts (%mailbox-waiters mb)))
312    (%mailbox-waiters-set! mb (cdr ts))
313    (car ts) ) )
314
315;;; Mailbox Cursor Support
316
317;the identifier needs to be defined by somebody
318(define mailbox-cursor 'mailbox-cursor)
319(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
320  (%raw-make-mailbox-cursor np pp mb)
321  (%mailbox-cursor?)
322  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
323  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
324  (mb %mailbox-cursor-mailbox) )
325
326(define-inline (%make-mailbox-cursor mb)
327  (%raw-make-mailbox-cursor '() #f mb) )
328
329(define (error-mailbox-cursor loc obj #!optional argnam)
330  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
331
332(define-inline-check-type mailbox-cursor)
333
334(define-inline (%mailbox-cursor-winding? mbc)
335  (%->boolean (%mailbox-cursor-prev-pair mbc)) )
336
337(define-inline (%mailbox-cursor-next-pair-empty! mbc)
338  (%mailbox-cursor-next-pair-set! mbc '()) )
339
340(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
341  (%mailbox-cursor-prev-pair-set! mbc #f) )
342
343(define-inline (%mailbox-cursor-rewind! mbc)
344  (%mailbox-cursor-next-pair-empty! mbc)
345  (%mailbox-cursor-prev-pair-clear! mbc) )
346
347(define-inline (%mailbox-cursor-extract! mbc)
348  ;unless 'mailbox-cursor-next' has been called don't remove
349  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
350    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
351
352;;;
353
354;Unique objects used as tags
355(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
356(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
357(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
358#; ;XXX
359(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
360
361;;; Mailbox Exceptions
362
363(define-inline (optional-timeout-value x #!optional (def (void)))
364  (if (eq? x NO-TOVAL-TAG) def x) )
365
366(define (make-mailbox-timeout-condition loc mb timout timout-value)
367  (let ((tv (optional-timeout-value timout-value)))
368    (make-composite-condition
369      (make-property-condition 'exn
370        'location loc
371        'message "mailbox wait timeout occurred"
372        'arguments (list timout tv))
373      (make-property-condition 'mailbox 'box mb)
374      (make-property-condition 'timeout 'time timout 'value tv)) ) )
375
376;;; Mailbox Threading
377
378;; Select next waiting thread for the mailbox
379
380(define-inline (%mailbox-waiters-pop!? mb)
381  (and (not (%mailbox-waiters-empty? mb)) (%mailbox-waiters-pop! mb)) )
382
383(define (ready-mailbox-thread! mb)
384  ;ready oldest waiting thread
385  (and-let* ((th (%mailbox-waiters-pop!? mb)))
386    ;ready the thread based on wait mode
387    (if (not (%thread-blocked? th))
388      ;then restart
389      (thread-resume! th)
390      ;else wake early if sleeping
391      ;all others dropped on the floor
392      (when (%thread-blocked-for-timeout? th)
393        ;ready the thread
394        (##sys#thread-unblock! th)
395        ;tell 'wait-mailbox-thread!' we unblocked early
396        (thread-signal! th UNBLOCKED-TAG) ) ) )
397    (void) )
398
399;; Sleep current thread until timeout, known condition,
400;; or some other condition
401
402(define (thread-sleep/maybe-unblock! tim unblocked-tag)
403;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
404  ;sleep current thread for desired seconds, unless unblocked "early".
405  (let/cc return
406    (with-exception-handler
407      (lambda (exp)
408        (if (eq? unblocked-tag exp)
409          (return #f)
410          ;propagate any "real" exception.
411          (signal exp) ) )
412      (lambda ()
413        (thread-sleep! tim) #t) ) ) )
414
415;; Wait current thread on the mailbox until timeout, available message
416;; or some other condition
417
418(define (wait-mailbox-thread! loc mb timout timout-value)
419  ;
420  ;no available message due to timeout
421  (define (timeout-exit!)
422    (if (not (eq? timout-value NO-TOVAL-TAG))
423      timout-value
424      (begin
425        (thread-signal!
426          (current-thread)
427          (make-mailbox-timeout-condition loc mb timout timout-value))
428        SEQ-FAIL-TAG ) ) )
429  ;
430  ;push current thread on mailbox waiting queue
431  (%mailbox-waiters-add! mb (current-thread))
432  ;waiting action
433  (cond
434    ;timeout wanted so sleep until something happens
435    (timout
436      (cond-expand
437        (sleep-primordial-thread
438          ;
439          (cond
440            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
441              ;timed-out, so no message
442              ;remove from wait queue
443              (%mailbox-waiters-delete! mb (current-thread))
444              ;indicate no available message
445              (timeout-exit!) )
446            (else
447              ;unblocked early
448              UNBLOCKED-TAG ) ) )
449        (else
450          ;
451          (if (eq? (current-thread) ##sys#primordial-thread)
452            (begin
453              (%mailbox-waiters-delete! mb (current-thread))
454              (warning "mailbox attempt to sleep primordial-thread" mb)
455              (timeout-exit!) )
456            (cond
457              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
458                ;timed-out, so no message
459                ;remove from wait queue
460                (%mailbox-waiters-delete! mb (current-thread))
461                ;indicate no available message
462                (timeout-exit!) )
463              (else
464                ;unblocked early
465                UNBLOCKED-TAG ) ) ) ) ) )
466    ;no timeout so suspend until something delivered
467    (else
468      (thread-suspend! (current-thread))
469      ;we're resumed
470      UNBLOCKED-TAG ) ) )
471
472;; Wait current thread on the mailbox unless a message available
473
474;Note that the arguments, except the ?expr0 ..., must be base values.
475(define-syntax on-mailbox-available
476  (syntax-rules ()
477    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
478      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
479        (let waiting ()
480          (cond
481            ((%mailbox-queue-empty? _mb)
482              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
483                ;when a thread ready then check mailbox again, could be empty.
484                (if (eq? UNBLOCKED-TAG res)
485                  (waiting)
486                  ;else some sort of problem
487                  res ) ) )
488            (else
489              ?expr0 ... ) ) ) ) ) ) )
490
491#; ;XXX
492(define (wait-mailbox-if-empty! loc mb timout timout-value)
493  (on-mailbox-available loc mb timout timout-value
494    MESSAGE-WAITING-TAG ) )
495
496;;; Mailbox
497
498;; Mailbox Exceptions
499
500(define (mailbox-timeout-condition? obj)
501  (and
502    ((condition-predicate 'exn) obj)
503    ((condition-predicate 'mailbox) obj)
504    ((condition-predicate 'timeout) obj) ) )
505
506;; Mailbox Constructor
507
508(define (make-mailbox #!optional (nm (gensym 'mailbox)))
509  (%make-mailbox nm) )
510
511(define (mailbox? obj)
512  (%mailbox? obj) )
513
514;; Mailbox Properties
515
516(define (mailbox-name mb)
517  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
518
519(define (mailbox-empty? mb)
520  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
521
522(define (mailbox-count mb)
523  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
524
525(define (mailbox-waiting? mb)
526  (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
527
528(define (mailbox-waiters mb)
529  (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
530
531;; Mailbox Operations
532
533(define (mailbox-send! mb x)
534  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
535  (ready-mailbox-thread! mb) )
536
537(define (mailbox-wait! mb #!optional timout)
538  (when timout (%check-timeout 'mailbox-wait! timout))
539  (on-mailbox-available 'mailbox-wait!
540    (%check-mailbox 'mailbox-wait! mb)
541    timout NO-TOVAL-TAG
542    (void) ) )
543
544(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
545  (when timout (%check-timeout 'mailbox-receive! timout))
546  (on-mailbox-available 'mailbox-receive!
547    (%check-mailbox 'mailbox-receive! mb)
548    timout timout-value
549    (%mailbox-queue-remove! mb) ) )
550
551(define (mailbox-push-back! mb x)
552  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
553  (ready-mailbox-thread! mb) )
554
555(define (mailbox-push-back-list! mb ls)
556  (%mailbox-queue-push-back-list!
557    (%check-mailbox 'mailbox-send! mb)
558    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
559  (ready-mailbox-thread! mb) )
560
561;; Read/Print Syntax
562
563(define (mailbox-print mb out)
564  (with-output-to-port out
565    (lambda ()
566      (printf "#<mailbox ~A queued: ~A waiters: ~A>"
567        (%mailbox-name mb)
568        (%mailbox-queue-count mb)
569        (%mailbox-waiters-count mb)) ) ) )
570
571;;; Mailbox Cursor
572
573;; Mailbox Cursor Constructor
574
575(define (make-mailbox-cursor mb)
576  (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
577
578;; Mailbox Cursor Properties
579
580(define (mailbox-cursor? obj)
581  (%mailbox-cursor? obj) )
582
583(define (mailbox-cursor-mailbox mbc)
584  (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
585
586(define (mailbox-cursor-rewound? mbc)
587  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
588
589(define (mailbox-cursor-unwound? mbc)
590  (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
591
592;; Mailbox Cursor Operations
593
594(define (mailbox-cursor-rewind mbc)
595  (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
596
597(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
598  (when timout (%check-timeout 'mailbox-cursor-next timout))
599  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
600    ;seed rewound cursor
601    (unless (%mailbox-cursor-winding? mbc)
602      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
603    ;pull next item from queue at cursor
604    (let scanning ()
605      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
606        ;anything next?
607        (if (not (null? curr-pair))
608          ;then peek into the queue for the next item
609          (let ((item (car curr-pair)))
610            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
611            (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
612            item )
613          ;else wait for something in the mailbox
614          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
615            (cond
616              ;continue scanning?
617              ((eq? UNBLOCKED-TAG res)
618                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
619                (scanning) )
620              ;some problem (timeout maybe)
621              (else
622                res ) ) ) ) ) ) ) )
623
624(define (mailbox-cursor-extract-and-rewind! mbc)
625  (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
626  (%mailbox-cursor-rewind! mbc) )
627
628;; Read/Print Syntax
629
630(define (mailbox-cursor-print mbc out)
631  (with-output-to-port out
632    (lambda ()
633      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
634      (%mailbox-name (%mailbox-cursor-mailbox mbc))
635      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
636
637;;;
638
639(set! (record-printer mailbox) mailbox-print)
640(set! (record-printer mailbox-cursor) mailbox-cursor-print)
641
642) ;module mailbox
Note: See TracBrowser for help on using the repository browser.