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

Last change on this file since 36579 was 36579, checked in by Kon Lovett, 2 years ago

remove record-variants dependency

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