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

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

queue depth limit by record (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  (unless (%valid-queue-limit? lm)
267    (error '%make-mailbox "invalid limit" lm nm) )
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 #t) (nm (gensym 'mailbox)))
517  (%make-mailbox nm lm) )
518
519(define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
520  (make-limited-mailbox lm nm) )
521
522(define (mailbox? obj)
523  (%mailbox? obj) )
524
525;; Mailbox Properties
526
527(define (mailbox-name mb)
528  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
529
530(define (mailbox-empty? mb)
531  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
532
533(define (mailbox-count mb)
534  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
535
536(define (mailbox-limit mb)
537  (%mailbox-queue-limit (%check-mailbox 'mailbox-count mb)) )
538
539(define (mailbox-waiting? mb)
540  (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
541
542(define (mailbox-waiters mb)
543  (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
544
545;; Mailbox Operations
546
547(define (mailbox-send! mb x)
548  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
549  (ready-mailbox-thread! mb) )
550
551(define (mailbox-wait! mb #!optional timout)
552  (when timout (%check-timeout 'mailbox-wait! timout))
553  (on-mailbox-available 'mailbox-wait!
554    (%check-mailbox 'mailbox-wait! mb)
555    timout NO-TOVAL-TAG
556    (void) ) )
557
558(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
559  (when timout (%check-timeout 'mailbox-receive! timout))
560  (on-mailbox-available 'mailbox-receive!
561    (%check-mailbox 'mailbox-receive! mb)
562    timout timout-value
563    (%mailbox-queue-remove! mb) ) )
564
565(define (mailbox-push-back! mb x)
566  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
567  (ready-mailbox-thread! mb) )
568
569(define (mailbox-push-back-list! mb ls)
570  (%mailbox-queue-push-back-list!
571    (%check-mailbox 'mailbox-send! mb)
572    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
573  (ready-mailbox-thread! mb) )
574
575;; Read/Print Syntax
576
577(define (mailbox-print mb out)
578  (with-output-to-port out
579    (lambda ()
580      (printf "#<mailbox ~A queued: ~A waiters: ~A limit: ~A>"
581        (%mailbox-name mb)
582        (%mailbox-queue-count mb)
583        (%mailbox-waiters-count mb)
584        (%mailbox-queue-limit mb)) ) ) )
585
586;;; Mailbox Cursor
587
588;; Mailbox Cursor Constructor
589
590(define (make-mailbox-cursor mb)
591  (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
592
593;; Mailbox Cursor Properties
594
595(define (mailbox-cursor? obj)
596  (%mailbox-cursor? obj) )
597
598(define (mailbox-cursor-mailbox mbc)
599  (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-mailbox mbc)) )
600
601(define (mailbox-cursor-rewound? mbc)
602  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
603
604(define (mailbox-cursor-unwound? mbc)
605  (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
606
607;; Mailbox Cursor Operations
608
609(define (mailbox-cursor-rewind mbc)
610  (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
611
612(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
613  (when timout (%check-timeout 'mailbox-cursor-next timout))
614  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
615    ;seed rewound cursor
616    (unless (%mailbox-cursor-winding? mbc)
617      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
618    ;pull next item from queue at cursor
619    (let scanning ()
620      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
621        ;anything next?
622        (if (not (null? curr-pair))
623          ;then peek into the queue for the next item
624          (let ((item (car curr-pair)))
625            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
626            (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
627            item )
628          ;else wait for something in the mailbox
629          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
630            (cond
631              ;continue scanning?
632              ((eq? UNBLOCKED-TAG res)
633                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
634                (scanning) )
635              ;some problem (timeout maybe)
636              (else
637                res ) ) ) ) ) ) ) )
638
639(define (mailbox-cursor-extract-and-rewind! mbc)
640  (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
641  (%mailbox-cursor-rewind! mbc) )
642
643;; Read/Print Syntax
644
645(define (mailbox-cursor-print mbc out)
646  (with-output-to-port out
647    (lambda ()
648      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
649      (%mailbox-name (%mailbox-cursor-mailbox mbc))
650      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
651
652;;;
653
654(set! (record-printer mailbox) mailbox-print)
655(set! (record-printer mailbox-cursor) mailbox-cursor-print)
656
657) ;module mailbox
Note: See TracBrowser for help on using the repository browser.