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

Last change on this file since 37684 was 37684, checked in by kon, 6 weeks ago

fix tag identifier

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