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

Last change on this file since 37656 was 37656, checked in by Kon Lovett, 4 months ago

#1581, add arg chks

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