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

Last change on this file since 39717 was 39717, checked in by Kon Lovett, 5 months ago

queue depth limit by type (wip)

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