source: project/release/5/mailbox/tags/3.3.6/mailbox.scm @ 39006

Last change on this file since 39006 was 39006, checked in by Kon Lovett, 8 weeks ago

type is interface

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