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

Last change on this file since 36707 was 36707, checked in by Kon Lovett, 11 months ago

more sugar, very little is pure, stronger type where possible, commentary

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