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

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

fix record-variant print issue by hardcoding export identifier (boo)

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