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

Last change on this file since 39716 was 39716, checked in by Kon Lovett, 6 months ago

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