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

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

use format

File size: 20.9 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 format) format)
67  (only (chicken string) ->string)
68  (only (srfi 1) append! delete! list-copy last-pair)
69  (only (srfi 18)
70    time?
71    current-thread
72    thread-signal! thread-sleep!
73    thread-suspend! thread-resume!))
74
75;;; Support
76
77;;record-variants
78
79(define-syntax define-record-type-variant
80  (er-macro-transformer
81   (lambda (form r c)
82     (define (any p L)
83       (and (pair? L)
84            (or (p (car L))
85                (any p (cdr L)))))
86     (##sys#check-syntax 'define-record-type-variant form
87                         '(_ _ #(variable 0)
88                             #(variable 1) _ . _))
89     (let* ((name-spec (cadr form))
90            (name (if (pair? name-spec) (car name-spec) name-spec))
91            (t (if (pair? name-spec) (cadr name-spec) name-spec))
92            (variant? (lambda (type) (any (lambda (x) (c x (r type)))
93                                          (caddr form))))
94            (unsafe? (variant? 'unsafe))
95            (unchecked? (variant? 'unchecked))
96            (inline? (variant? 'inline))
97            (constructor? (eq? name t))
98
99            (conser (cadddr form))
100            (predspec (car (cddddr form)))
101            (pred (if (pair? predspec) (car predspec) predspec))
102            (checker (if (and (pair? predspec)
103                              (pair? (cdr predspec)))
104                         (cadr predspec) #f))
105            (slots (cdr (cddddr form)))
106            (%begin (r 'begin))
107            (%lambda (r 'lambda))
108            (%define (if inline? (r 'define-inline) (r 'define)))
109            (vars (cdr conser))
110            (x (r 'x))
111            (y (r 'y))
112            (%getter-with-setter (r 'getter-with-setter))
113            (slotnames (map car slots)))
114       `(,%begin
115         ,(if constructor?
116              `(,%define ,conser
117                         (##sys#make-structure
118                          ,t
119                          ,@(map (lambda (sname)
120                                   (if (memq sname vars)
121                                       sname
122                                       '(##core#undefined)))
123                                 slotnames)))
124              `(,%begin))
125         (,%define (,pred ,x) (##sys#structure? ,x ,t))
126         ,(if checker
127              `(,%define (,checker ,x)
128                         (##core#check (##sys#check-structure ,x ,t)))
129              `(,%begin))
130         ,@(let loop ([slots slots] [i 1])
131             (if (null? slots)
132                 '()
133                 (let* ([slot (car slots)]
134                        (setters (memq #:record-setters ##sys#features))
135                        (setr? (pair? (cddr slot)))
136                        (getr `(,%lambda (,x)
137                                         ,(if unchecked?
138                                              `(,%begin)
139                                              `(##core#check
140                                                (##sys#check-structure ,x ,t)))
141                                         ,(if unsafe?
142                                              `(##sys#slot ,x ,i)
143                                              `(##sys#block-ref ,x ,i)))))
144                   `(,@(if setr?
145                           `((,%define (,(caddr slot) ,x ,y)
146                                       ,(if unchecked?
147                                            `(,%begin)
148                                            `(##core#check
149                                              (##sys#check-structure ,x ,t)))
150                                       ,(if unsafe?
151                                            `(##sys#setslot ,x ,i ,y)
152                                            `(##sys#block-set! ,x ,i ,y))))
153                           '())
154                     (,%define ,(cadr slot)
155                               ,(if (and setr? setters)
156                                    `(,%getter-with-setter ,getr ,(caddr slot))
157                                    getr) )
158                     ,@(loop (cdr slots) (add1 i)))))))))))
159
160;;miscmacros
161
162;; evaluates body with an explicit exit continuation
163;;
164  (define-syntax let/cc
165    (syntax-rules ()
166      ((let/cc k e0 e1 ...)
167       (call-with-current-continuation
168        (lambda (k) e0 e1 ...)))))
169
170;;(only type-errors define-error-type)
171
172(define (make-bad-argument-message #!optional argnam)
173  (if (not argnam)
174    "bad argument"
175    (string-append "bad `" (->string argnam) "' argument") ) )
176
177(define (make-type-name-message typnam)
178  (string-append "a " (->string typnam)) )
179
180(define (make-error-type-message typnam #!optional argnam)
181  (string-append
182    (make-bad-argument-message argnam)
183    " type - not "
184    (make-type-name-message typnam)) )
185
186(define (error-list loc obj #!optional argnam)
187  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
188
189(include-relative "inline-type-checks")
190
191;;
192
193(define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
194(define-inline (%thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
195
196(define-inline (%->boolean obj) (and obj #t))
197
198(define-inline (%make-unique-object #!optional (id 'unique)) (vector id))
199
200;; Time Support
201
202(define-inline (%time-number? obj)
203  (or (fixnum? obj) (flonum? obj)) )
204
205(define-inline (%timeout? obj)
206  (or (%time-number? obj) (time? obj)) )
207
208(define (error-timeout loc obj #!optional argnam)
209  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
210
211(define (timeout? obj) (%timeout? obj))
212
213(define-inline-check-type timeout)
214
215;; Queue Support
216
217(include-relative "inline-queue")
218
219;;; Typoes
220
221(define-type srfi-18-time   (struct time))
222(define-type mailbox        (struct mailbox))
223(define-type mailbox-cursor (struct mailbox-cursor))
224(define-type time-number    (or fixnum float))
225(define-type timeout        (or time-number srfi-18-time))
226(define-type unique-object  (vector-of symbol))
227
228(: mailbox-timeout-condition?         (* -> boolean : condition))
229(: make-mailbox                       (#!optional * -> mailbox))
230(: mailbox?                           (* -> boolean : mailbox))
231(: mailbox-name                       (mailbox --> *))
232(: mailbox-empty?                     (mailbox -> boolean))
233(: mailbox-count                      (mailbox -> fixnum))
234(: mailbox-waiting?                   (mailbox -> boolean))
235(: mailbox-waiters                    (mailbox -> list))
236(: mailbox-send!                      (mailbox * -> void))
237(: mailbox-wait!                      (mailbox #!optional timeout -> void))
238(: mailbox-receive!                   (mailbox #!optional timeout * -> *))
239(: mailbox-push-back!                 (mailbox * -> void))
240(: mailbox-push-back-list!            (mailbox list -> void))
241(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
242(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
243(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
244(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
245(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
246(: mailbox-cursor-rewind              (mailbox-cursor -> void))
247(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
248(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
249
250;;; Mailbox
251
252;the identifier needs to be defined by somebody
253(define mailbox 'mailbox)
254(define-record-type-variant mailbox (unsafe unchecked inline)
255  (%raw-make-mailbox nm qu wt)
256  (%mailbox?)
257  (nm %mailbox-name)
258  (qu %mailbox-queue)
259  (wt %mailbox-waiters %mailbox-waiters-set!) )
260
261(define-inline (%make-mailbox nm)
262  (%raw-make-mailbox nm (%make-empty-queue) '()) )
263
264(define (error-mailbox loc obj #!optional argnam)
265  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox argnam) obj) )
266
267(define-inline-check-type mailbox)
268
269;; Message queue
270
271(define-inline (%mailbox-queue-first-pair mb)
272  (%queue-first-pair (%mailbox-queue mb)) )
273
274(define-inline (%mailbox-queue-last-pair mb)
275  (%queue-last-pair (%mailbox-queue mb)) )
276
277(define-inline (%mailbox-queue-empty? mb)
278  (%queue-empty? (%mailbox-queue mb)) )
279
280(define-inline (%mailbox-queue-count mb)
281  (%queue-count (%mailbox-queue mb)) )
282
283(define-inline (%mailbox-queue-add! mb x)
284  (%queue-add! (%mailbox-queue mb) x) )
285
286(define-inline (%mailbox-queue-remove! mb)
287  (%queue-remove! (%mailbox-queue mb)) )
288
289(define-inline (%mailbox-queue-push-back! mb x)
290  (%queue-push-back! (%mailbox-queue mb) x) )
291
292(define-inline (%mailbox-queue-push-back-list! mb ls)
293  (%queue-push-back-list! (%mailbox-queue mb) ls) )
294
295;; Waiting threads
296
297(define-inline (%mailbox-waiters-empty? mb)
298  (null? (%mailbox-waiters mb)) )
299
300(define-inline (%mailbox-waiters-count mb)
301  (length (%mailbox-waiters mb)) )
302
303(define-inline (%mailbox-waiters-add! mb th)
304  (%mailbox-waiters-set! mb (append! (%mailbox-waiters mb) (cons th '()))) )
305
306(define-inline (%mailbox-waiters-delete! mb th)
307  (%mailbox-waiters-set! mb (delete! th (%mailbox-waiters mb))) )
308
309(define-inline (%mailbox-waiters-pop! mb)
310  (let ((ts (%mailbox-waiters mb)))
311    (%mailbox-waiters-set! mb (cdr ts))
312    (car ts) ) )
313
314;;; Mailbox Cursor Support
315
316;the identifier needs to be defined by somebody
317(define mailbox-cursor 'mailbox-cursor)
318(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
319  (%raw-make-mailbox-cursor np pp mb)
320  (%mailbox-cursor?)
321  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
322  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
323  (mb %mailbox-cursor-mailbox) )
324
325(define-inline (%make-mailbox-cursor mb)
326  (%raw-make-mailbox-cursor '() #f mb) )
327
328(define (error-mailbox-cursor loc obj #!optional argnam)
329  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
330
331(define-inline-check-type mailbox-cursor)
332
333(define-inline (%mailbox-cursor-winding? mbc)
334  (%->boolean (%mailbox-cursor-prev-pair mbc)) )
335
336(define-inline (%mailbox-cursor-next-pair-empty! mbc)
337  (%mailbox-cursor-next-pair-set! mbc '()) )
338
339(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
340  (%mailbox-cursor-prev-pair-set! mbc #f) )
341
342(define-inline (%mailbox-cursor-rewind! mbc)
343  (%mailbox-cursor-next-pair-empty! mbc)
344  (%mailbox-cursor-prev-pair-clear! mbc) )
345
346(define-inline (%mailbox-cursor-extract! mbc)
347  ;unless 'mailbox-cursor-next' has been called don't remove
348  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
349    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
350
351;;;
352
353;Unique objects used as tags
354(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
355(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
356(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
357#; ;XXX
358(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
359
360;;; Mailbox Exceptions
361
362(define-inline (optional-timeout-value x #!optional (def (void)))
363  (if (eq? x NO-TOVAL-TAG) def x) )
364
365(define (make-mailbox-timeout-condition loc mb timout timout-value)
366  (let ((tv (optional-timeout-value timout-value)))
367    (make-composite-condition
368      (make-property-condition 'exn
369        'location loc
370        'message "mailbox wait timeout occurred"
371        'arguments (list timout tv))
372      (make-property-condition 'mailbox 'box mb)
373      (make-property-condition 'timeout 'time timout 'value tv)) ) )
374
375;;; Mailbox Threading
376
377;; Select next waiting thread for the mailbox
378
379(define-inline (%mailbox-waiters-pop!? mb)
380  (and (not (%mailbox-waiters-empty? mb)) (%mailbox-waiters-pop! mb)) )
381
382(define (ready-mailbox-thread! mb)
383  ;ready oldest waiting thread
384  (and-let* ((th (%mailbox-waiters-pop!? mb)))
385    ;ready the thread based on wait mode
386    (if (not (%thread-blocked? th))
387      ;then restart
388      (thread-resume! th)
389      ;else wake early if sleeping
390      ;all others dropped on the floor
391      (when (%thread-blocked-for-timeout? th)
392        ;ready the thread
393        (##sys#thread-unblock! th)
394        ;tell 'wait-mailbox-thread!' we unblocked early
395        (thread-signal! th UNBLOCKED-TAG) ) ) )
396    (void) )
397
398;; Sleep current thread until timeout, known condition,
399;; or some other condition
400
401(define (thread-sleep/maybe-unblock! tim unblocked-tag)
402;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
403  ;sleep current thread for desired seconds, unless unblocked "early".
404  (let/cc 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(define (mailbox-timeout-condition? obj)
500  (and
501    ((condition-predicate 'exn) obj)
502    ((condition-predicate 'mailbox) obj)
503    ((condition-predicate 'timeout) obj) ) )
504
505;; Mailbox Constructor
506
507(define (make-mailbox #!optional (nm (gensym 'mailbox)))
508  (%make-mailbox nm) )
509
510(define (mailbox? obj)
511  (%mailbox? obj) )
512
513;; Mailbox Properties
514
515(define (mailbox-name mb)
516  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
517
518(define (mailbox-empty? mb)
519  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
520
521(define (mailbox-count mb)
522  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
523
524(define (mailbox-waiting? mb)
525  (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
526
527(define (mailbox-waiters mb)
528  (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
529
530;; Mailbox Operations
531
532(define (mailbox-send! mb x)
533  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
534  (ready-mailbox-thread! mb) )
535
536(define (mailbox-wait! mb #!optional timout)
537  (when timout (%check-timeout 'mailbox-wait! timout))
538  (on-mailbox-available 'mailbox-wait!
539    (%check-mailbox 'mailbox-wait! mb)
540    timout NO-TOVAL-TAG
541    (void) ) )
542
543(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
544  (when timout (%check-timeout 'mailbox-receive! timout))
545  (on-mailbox-available 'mailbox-receive!
546    (%check-mailbox 'mailbox-receive! mb)
547    timout timout-value
548    (%mailbox-queue-remove! mb) ) )
549
550(define (mailbox-push-back! mb x)
551  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
552  (ready-mailbox-thread! mb) )
553
554(define (mailbox-push-back-list! mb ls)
555  (%mailbox-queue-push-back-list!
556    (%check-mailbox 'mailbox-send! mb)
557    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
558  (ready-mailbox-thread! mb) )
559
560;; Read/Print Syntax
561
562(define (mailbox-print mb out)
563  (format out "#<mailbox ~A queued: ~A waiters: ~A>"
564    (%mailbox-name mb)
565    (%mailbox-queue-count mb)
566    (%mailbox-waiters-count mb)) )
567
568;;; Mailbox Cursor
569
570;; Mailbox Cursor Constructor
571
572(define (make-mailbox-cursor mb)
573  (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
574
575;; Mailbox Cursor Properties
576
577(define (mailbox-cursor? obj)
578  (%mailbox-cursor? obj) )
579
580(define (mailbox-cursor-mailbox mbc)
581  (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
582
583(define (mailbox-cursor-rewound? mbc)
584  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
585
586(define (mailbox-cursor-unwound? mbc)
587  (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
588
589;; Mailbox Cursor Operations
590
591(define (mailbox-cursor-rewind mbc)
592  (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
593
594(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
595  (when timout (%check-timeout 'mailbox-cursor-next timout))
596  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
597    ;seed rewound cursor
598    (unless (%mailbox-cursor-winding? mbc)
599      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
600    ;pull next item from queue at cursor
601    (let scanning ()
602      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
603        ;anything next?
604        (if (not (null? curr-pair))
605          ;then peek into the queue for the next item
606          (let ((item (car curr-pair)))
607            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
608            (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
609            item )
610          ;else wait for something in the mailbox
611          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
612            (cond
613              ;continue scanning?
614              ((eq? UNBLOCKED-TAG res)
615                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
616                (scanning) )
617              ;some problem (timeout maybe)
618              (else
619                res ) ) ) ) ) ) ) )
620
621(define (mailbox-cursor-extract-and-rewind! mbc)
622  (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
623  (%mailbox-cursor-rewind! mbc) )
624
625;; Read/Print Syntax
626
627(define (mailbox-cursor-print mbc out)
628  (format out "#<mailbox-cursor mailbox: ~A status: ~A>"
629    (%mailbox-name (%mailbox-cursor-mailbox mbc))
630    (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) )
631
632;;;
633
634(set! (record-printer mailbox) mailbox-print)
635(set! (record-printer mailbox-cursor) mailbox-cursor-print)
636
637) ;module mailbox
Note: See TracBrowser for help on using the repository browser.