Changeset 39773 in project


Ignore:
Timestamp:
04/01/21 21:21:36 (3 weeks ago)
Author:
Kon Lovett
Message:

ulim only

Location:
release/5/mailbox/trunk
Files:
7 edited

Legend:

Unmodified
Added
Removed

  • release/5/mailbox/trunk/inline-queue.scm

    r39746 r39773  
    11;;;; inline-queue.scm  -*- Scheme -*-
    2 ;;;; Kon Lovett, Mar '21
    32;;;; Kon Lovett, Jun '10
    43
    54;; Issues
    65;;
    7 ;; - Uses (chicken fixnum), (srfi 1), & record-variants
     6;; - Requires (only record-variants define-record-type-variant)
     7;; & (include "chicken-primitive-object-inlines")
    88
    9 ;; Queue Unlimited
     9;; Support
     10
     11;;
    1012
    1113;the identifier needs to be defined by somebody
    12 (define queue-unlimited 'queue-unlimited)
    13 (define-record-type-variant queue-unlimited (unsafe unchecked inline)
    14   (make-queue-unlimited ln hd tl)
    15   (queue-unlimited?)
    16   (ln queue-unlimited-count queue-unlimited-count-set!)
    17   (hd queue-unlimited-first-pair queue-unlimited-first-pair-set!)
    18   (tl queue-unlimited-last-pair queue-unlimited-last-pair-set!) )
     14(define queue 'queue)
     15(define-record-type-variant queue (unsafe unchecked inline)
     16  (%make-queue hd tl)
     17  (%queue?)
     18  (hd %queue-first-pair %queue-first-pair-set!)
     19  (tl %queue-last-pair %queue-last-pair-set!) )
    1920
    20 (define (make-empty-queue-unlimited)
    21   (make-queue-unlimited 0 '() '()) )
     21(define-inline (%make-empty-queue) (%make-queue '() '()))
    2222
    23 (define (queue-unlimited-limit q) most-positive-fixnum)
     23(define-inline (%queue-empty? q) (null? (%queue-first-pair q)))
     24(define-inline (%queue-count q) (length (%queue-first-pair q)))
    2425
    25 (define (queue-unlimited-room q) (queue-unlimited-limit q))
     26;; Operations
    2627
    27 (define (queue-unlimited-count-add! q n)
    28   (queue-unlimited-count-set! q (fx+ (queue-unlimited-count q) n)) )
     28(define-inline (%queue-last-pair-empty! q) (%queue-last-pair-set! q '()))
    2929
    30 (define (queue-unlimited-count-sub! q n)
    31   (queue-unlimited-count-set! q (fx- (queue-unlimited-count q) n)) )
     30(define-inline (%queue-add! q datum)
     31  (let ((new-pair (cons datum '())))
     32    (if (null? (%queue-first-pair q))
     33      (%queue-first-pair-set! q new-pair)
     34      (set-cdr! (%queue-last-pair q) new-pair) )
     35    (%queue-last-pair-set! q new-pair) ) )
    3236
    33 (define (queue-unlimited-empty? q #!optional (n 0))
    34   (fx<= (fx- (queue-unlimited-count q) n) 0) )
     37(define-inline (%queue-remove! q)
     38  (let* ((first-pair (%queue-first-pair q))
     39         (next-pair (cdr first-pair)))
     40    (%queue-first-pair-set! q next-pair)
     41    (when (null? next-pair) (%queue-last-pair-empty! q) )
     42    (car first-pair) ) )
    3543
    36 (define (queue-unlimited-full? q #!optional (n 0))
    37   #f )
     44(define-inline (%queue-push-back! q item)
     45  (let ((newlist (cons item (%queue-first-pair q))))
     46    (%queue-first-pair-set! q newlist)
     47    (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) ) ) )
    3848
    39 (define (queue-unlimited-extract-pair! q targ-pair)
     49(define-inline (%queue-push-back-list! q itemlist)
     50  (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
     51    (%queue-first-pair-set! q newlist)
     52    (if (null? newlist)
     53      (%queue-last-pair-empty! q)
     54      (%queue-last-pair-set! q (last-pair newlist) ) ) ) )
     55
     56(define-inline (%queue-extract-pair! q targ-pair)
    4057  ;scan queue list until we find the item to remove
    41   (let scanning ((this-pair (queue-unlimited-first-pair q)) (prev-pair '()))
     58  (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
    4259    ;keep scanning until found
    4360    (cond
    … …  
    4562      ((null? this-pair)
    4663        ;note that the pair to extract is in fact gone so ...
    47         (error "cannot find queue pair to extract; simultaneous operations?"))
     64        (warning "cannot find queue pair to extract; simultaneous operations?"))
    4865      ;found?
    4966      ((eq? this-pair targ-pair)
    … …  
    5269          ;at the head of the list, or in the body?
    5370          (if (null? prev-pair)
    54             (queue-unlimited-first-pair-set! q next-pair)
     71            (%queue-first-pair-set! q next-pair)
    5572            (set-cdr! prev-pair next-pair) )
    5673          ;when the cut pair is the last item update the last pair ref.
    57           (when (eq? this-pair (queue-unlimited-last-pair q))
    58             (queue-unlimited-last-pair-set! q prev-pair) )
    59           (queue-unlimited-count-sub! q 1) ) )
     74          (when (eq? this-pair (%queue-last-pair q))
     75            (%queue-last-pair-set! q prev-pair)) ) )
    6076      ;not found
    6177      (else
    6278        (scanning (cdr this-pair) this-pair) ) ) ) )
    63 
    64 (define (queue-unlimited-add! q v)
    65   (let ((new-pair (cons v '())))
    66     (if (null? (queue-unlimited-first-pair q))
    67       (queue-unlimited-first-pair-set! q new-pair)
    68       (set-cdr! (queue-unlimited-last-pair q) new-pair) )
    69     (queue-unlimited-last-pair-set! q new-pair)
    70     (queue-unlimited-count-add! q 1)) )
    71 
    72 (define (queue-unlimited-remove! q)
    73   (let* ((first-pair (queue-unlimited-first-pair q))
    74          (next-pair (cdr first-pair)))
    75     (queue-unlimited-first-pair-set! q next-pair)
    76     (when (null? next-pair) (queue-unlimited-last-pair-set! q '()))
    77     (queue-unlimited-count-sub! q 1)
    78     (car first-pair) ) )
    79 
    80 (define (queue-unlimited-push-back! q v)
    81   (let ((newlist (cons v (queue-unlimited-first-pair q))))
    82     (queue-unlimited-first-pair-set! q newlist)
    83     (when (null? (queue-unlimited-last-pair q))
    84       (queue-unlimited-last-pair-set! q newlist) )
    85     (queue-unlimited-count-add! q 1) ) )
    86 
    87 (define (queue-unlimited-push-back-list! q ls)
    88   (let ((newlist (append! (list-copy ls) (queue-unlimited-first-pair q))))
    89     (queue-unlimited-first-pair-set! q newlist)
    90     (if (null? newlist)
    91       (queue-unlimited-last-pair-set! q '())
    92       (queue-unlimited-last-pair-set! q (last-pair newlist) ) )
    93     (queue-unlimited-count-add! q (length ls)) ) )
    94 
    95 (define (make-queue-unlimited-cursor) (cons '() #f))
    96 (define (queue-unlimited-cursor? c) (pair? c))
    97 (define (queue-unlimited-cursor-next-pair c) (car c))
    98 (define (queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
    99 (define (queue-unlimited-cursor-prev-pair c) (cdr c))
    100 (define (queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
    101 
    102 (define (queue-unlimited-cursor-winding? q c)
    103   (->boolean (queue-unlimited-cursor-prev-pair c)) )
    104 
    105 (define (queue-unlimited-cursor-unwound? q c)
    106   (null? (queue-unlimited-cursor-next-pair c)) )
    107 
    108 (define (queue-unlimited-cursor-start! q c)
    109   ;(queue-unlimited-cursor-prev-pair-set! c #f)
    110   (queue-unlimited-cursor-next-pair-set! c (queue-unlimited-first-pair q)) )
    111 
    112 (define (queue-unlimited-cursor-next! q c)
    113   (let ((curr-pair (queue-unlimited-cursor-next-pair c)))
    114     ;anything next?
    115     (if (null? curr-pair)
    116       #!eof
    117       ;then peek into the queue for the next item
    118       (let ((item (car curr-pair)))
    119         (queue-unlimited-cursor-prev-pair-set! c curr-pair)
    120         (queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
    121         item ) ) ) )
    122 
    123 (define (queue-unlimited-cursor-continue! q c)
    124   ;NOTE assumes 1 next item, so prev-pair is still correct
    125   (queue-unlimited-cursor-next-pair-set! c (queue-unlimited-last-pair q)) )
    126 
    127 (define (queue-unlimited-cursor-rewind! q c)
    128   (queue-unlimited-cursor-prev-pair-set! c #f)
    129   (queue-unlimited-cursor-next-pair-set! c '()) )
    130 
    131 (define (queue-unlimited-cursor-extract! q c)
    132   ;unless 'mailbox-cursor-next' has been called don't remove
    133   (and-let* ((prev-pair (queue-unlimited-cursor-prev-pair c)))
    134     (queue-unlimited-extract-pair! q prev-pair) ) )
    135 
    136 (define (queue-unlimited-delete! q x)
    137   (let ((c (make-queue-unlimited-cursor)))
    138     (queue-unlimited-cursor-start! q c)
    139     (let loop ()
    140       (let ((y (queue-unlimited-cursor-next! q c)))
    141         (cond
    142           ((eof-object? y)
    143             #f )
    144           ((eq? x y)
    145             (queue-unlimited-cursor-extract! q c)
    146             #t )
    147           (else
    148             (loop) ) ) ) ) ) )
    149 
    150 (define (queue-unlimited->list q)
    151   (let ((c (make-queue-unlimited-cursor)))
    152     (queue-unlimited-cursor-start! q c)
    153     (let loop ((ls '()))
    154       (let ((y (queue-unlimited-cursor-next! q c)))
    155         (cond
    156           ((eof-object? y)
    157             ls )
    158           (else
    159             (loop (cons y ls)) ) ) ) ) ) )
    160 
    161 ;; Queue Limited
    162 
    163 ;circular buffer: s <= e: s = e -> empty, |e - s| = n -> full, s < e -> some
    164 ;
    165 ; inc i: (i + 1)      mod n
    166 ; dec i: (i + (n-1))  mod n
    167 
    168 ;the identifier needs to be defined by somebody
    169 (define queue-limited 'queue-limited)
    170 (define-record-type-variant queue-limited (unsafe unchecked inline)
    171   (make-queue-limited vc st ed)
    172   (queue-limited?)
    173   (vc queue-limited-vector)
    174   (st queue-limited-start queue-limited-start-set!)
    175   (ed queue-limited-end queue-limited-end-set!) )
    176 
    177 (define (make-empty-queue-limited lm)
    178   ;limit of 2 is lower-bound otherwise always s = e!
    179   ;limit + 1 so
    180   (make-queue-limited (make-vector (fx+ (fxmax 2 lm) 1) (void)) 0 0) )
    181 
    182 (define (queue-limited-peek q i)    (vector-ref (queue-limited-vector q) i))
    183 (define (queue-limited-poke! q i v) (vector-set! (queue-limited-vector q) i v))
    184 
    185 (define (queue-limited-limit q)
    186   (fx- (vector-length (queue-limited-vector q)) 1) )
    187 
    188 (define (queue-limited-index-inc q i)
    189   (fxmod (fx+ i 1) (queue-limited-limit q)) )
    190 
    191 (define (queue-limited-index-dec q i)
    192   (fxmod (fx+ i (fx- (queue-limited-limit q) 1)) (queue-limited-limit q)) )
    193 
    194 (define (queue-limited-start-inc! q)
    195   (queue-limited-start-set! q (queue-limited-index-inc q (queue-limited-start q))) )
    196 
    197 (define (queue-limited-start-dec! q)
    198   (queue-limited-start-set! q (queue-limited-index-dec q (queue-limited-start q))) )
    199 
    200 (define (queue-limited-end-inc! q)
    201   (queue-limited-end-set! q (queue-limited-index-inc q (queue-limited-end q))) )
    202 
    203 (define (queue-limited-end-dec! q)
    204   (queue-limited-end-set! q (queue-limited-index-dec q (queue-limited-end q))) )
    205 
    206 (define (queue-limited-count q)
    207   (fxabs (fx- (queue-limited-end q) (queue-limited-start q))) )
    208 
    209 (define (queue-limited-empty? q #!optional (n 0))
    210   (fx<= (fx- (queue-limited-count q) n) 0) )
    211 
    212 (define (queue-limited-full? q #!optional (n 0))
    213   (fx>= (fx+ (queue-limited-count q) n) (queue-limited-limit q)) )
    214 
    215 (define (queue-limited-room q)
    216   (fx- (queue-limited-limit q) (queue-limited-count q)) )
    217 
    218 (define (queue-limited-empty? q #!optional (n 0))
    219   (fx<= (fx- (queue-limited-count q) n) 0) )
    220 
    221 (define (queue-limited-full? q #!optional (n 0))
    222   (fx>= (fx+ (queue-limited-count q) n) (queue-limited-limit q)) )
    223 
    224 (define (queue-limited-add! q v)
    225   (queue-limited-poke! q (queue-limited-end q) v)
    226   (queue-limited-end-inc! q) )
    227 
    228 (define (queue-limited-remove! q)
    229   (let ((v (queue-limited-peek q (queue-limited-start q))))
    230     (queue-limited-start-inc! q)
    231     v ) )
    232 
    233 (define (queue-limited-push-back! q v)
    234   (queue-limited-start-dec! q)
    235   (queue-limited-poke! q (queue-limited-start q) v) )
    236 
    237 (define (queue-limited-push-back-list! q ls)
    238   ;assert enough room at the inn!
    239   ;move "down" from start to start-1; kinda like extract below
    240   (let loop ((i (queue-limited-start q)) (ls (reverse ls)))
    241     (if (null? ls)
    242       (queue-limited-start-set! q i)
    243       (let ((i-1 (queue-limited-index-dec q i)))
    244         (queue-limited-poke! q i-1 (car ls))
    245         (loop i-1 (cdr ls)) ) ) ) )
    246 
    247 (define (make-queue-limited-cursor) (cons -1 (void)))
    248 (define (queue-limited-cursor? c) (pair? c))
    249 (define (queue-limited-cursor-index c) (car c))
    250 (define (queue-limited-cursor-index-set! c v) (set-car! c v))
    251 
    252 (define (queue-limited-cursor-index-inc! q c)
    253   (queue-limited-cursor-index-set! c
    254     (queue-limited-index-inc q (queue-limited-cursor-index c))) )
    255 
    256 (define (queue-limited-cursor-index-dec! q c)
    257   (queue-limited-cursor-index-set! c
    258     (queue-limited-index-dec q (queue-limited-cursor-index c))) )
    259 
    260 (define (queue-limited-cursor-winding? q c)
    261   (fx<= 0 (queue-limited-cursor-index c)) )
    262 
    263 (define (queue-limited-cursor-unwound? q c)
    264   (fx= (queue-limited-end q) (queue-limited-cursor-index c)) )
    265 
    266 (define (queue-limited-cursor-start! q c)
    267   (queue-limited-cursor-index-set! c (queue-limited-start q)) )
    268 
    269 (define (queue-limited-cursor-next! q c)
    270   (cond
    271     ((queue-limited-cursor-unwound? q c) #!eof)
    272     (else
    273       (let ((v (queue-limited-peek q (queue-limited-cursor-index c))))
    274         (queue-limited-cursor-index-inc! q c)
    275         v ) ) ) )
    276 
    277 (define (queue-limited-cursor-continue! q c)
    278   (queue-limited-cursor-index-dec! q c) )
    279 
    280 (define (queue-limited-cursor-rewind! q c)
    281   (queue-limited-cursor-index-set! c -1) )
    282 
    283 (define (queue-limited-cursor-extract! q c)
    284   ;unless 'mailbox-cursor-next' has been called don't remove
    285   (when (queue-limited-cursor-winding? q c)
    286     ;move "up" from i-1 to i until i = start
    287     (let loop ((i (queue-limited-index-dec q (queue-limited-cursor-index c))))
    288       (let ((i-1 (queue-limited-index-dec q i)))
    289         (queue-limited-poke! q i (queue-limited-peek q i-1))
    290         (if (fx= (queue-limited-start q) i-1)
    291           (queue-limited-start-set! q i)
    292           (loop i-1) ) ) ) ) )
    293 
    294 (define (queue-limited-delete! q x)
    295   (let ((c (make-queue-limited-cursor)))
    296     (queue-limited-cursor-start! q c)
    297     (let loop ()
    298       (let ((y (queue-limited-cursor-next! q c)))
    299         (cond
    300           ((eof-object? y)
    301             #f )
    302           ((eq? x y)
    303             (queue-limited-cursor-extract! q c)
    304             #t )
    305           (else
    306             (loop) ) ) ) ) ) )
    307 
    308 (define (queue-limited->list q)
    309   (let ((vc (queue-limited-vector q)) (st (queue-limited-start q)))
    310     (let loop ((ed (queue-limited-count q)) (ls '()))
    311       (if (fx= st ed)
    312         ls
    313         (let ((ed (queue-limited-index-dec q ed)))
    314           (loop ed (cons (vector-ref vc ed) ls)) ) ) ) ) )
    315 
    316 ;; Queue Unbuffered
    317 
    318 ;the identifier needs to be defined by somebody
    319 (define queue-unbuffered 'queue-unbuffered)
    320 (define-record-type-variant queue-unbuffered (unsafe unchecked inline)
    321   (make-queue-unbuffered vd vl)
    322   (queue-unbuffered?)
    323   (vd queue-unbuffered-maybe? queue-unbuffered-maybe-set!)
    324   (vl queue-unbuffered-value queue-unbuffered-value-set!) )
    325 
    326 (define (make-empty-queue-unbuffered)
    327   (make-queue-unbuffered #f (void)) )
    328 
    329 (define (queue-unbuffered-limit q) 1)
    330 
    331 (define (queue-unbuffered-count q)
    332   (if (queue-unbuffered-maybe? q) 1 0) )
    333 
    334 (define (queue-unbuffered-empty? q #!optional (n 0))
    335   (or (fx< 0 n)
    336       (not (queue-unbuffered-maybe? q))) )
    337 
    338 (define (queue-unbuffered-full? q #!optional (n 0))
    339   (or (fx< 0 n)
    340       (queue-unbuffered-maybe? q)) )
    341 
    342 (define (queue-unbuffered-room q)
    343   (if (queue-unbuffered-maybe? q) 0 1) )
    344 
    345 (define (queue-unbuffered-add! q v)
    346   (queue-unbuffered-maybe-set! q #t)
    347   (queue-unbuffered-value-set! q v) )
    348 
    349 (define (queue-unbuffered-remove! q)
    350   (let ((v (queue-unbuffered-value q)))
    351     (queue-unbuffered-maybe-set! q #f)
    352     (queue-unbuffered-value-set! q (void))
    353     v ) )
    354 
    355 (define (queue-unbuffered-push-back! q v)
    356   (queue-unbuffered-add! q v) )
    357 
    358 (define (queue-unbuffered-push-back-list! q ls)
    359   ;assert length ls = 1
    360   (queue-unbuffered-add! q (car ls)) )
    361 
    362 (define (make-queue-unbuffered-cursor) (cons -1 (void)))
    363 (define (queue-unbuffered-cursor? c) (pair? c))
    364 (define (queue-unbuffered-cursor-index c) (car c))
    365 (define (queue-unbuffered-cursor-index-set! c v) (set-car! c v))
    366 
    367 (define (queue-unbuffered-cursor-winding? q c)
    368   (fx<= 0 (queue-unbuffered-cursor-index c)) )
    369 
    370 (define (queue-unbuffered-cursor-unwound? q c)
    371   (fx= 1 (queue-unbuffered-cursor-index c)) )
    372 
    373 (define (queue-unbuffered-cursor-start! q c)
    374   (queue-unbuffered-cursor-index-set! c 0) )
    375 
    376 (define (queue-unbuffered-cursor-next! q c)
    377   (cond
    378     ((queue-unbuffered-cursor-unwound? q c) #!eof)
    379     ((not (queue-unbuffered-maybe? q))      #!eof)
    380     (else
    381       (queue-unbuffered-cursor-index-set! c 1)
    382       (queue-unbuffered-value q) ) ) )
    383 
    384 (define (queue-unbuffered-cursor-continue! q c)
    385   (queue-unbuffered-cursor-index-set! c 0) )
    386 
    387 (define (queue-unbuffered-cursor-rewind! q c)
    388   (queue-unbuffered-cursor-index-set! c -1) )
    389 
    390 (define (queue-unbuffered-cursor-extract! q c)
    391   ;unless 'mailbox-cursor-next' has been called don't remove
    392   (when (queue-unbuffered-cursor-winding? q c)
    393     (queue-unbuffered-maybe-set! q #f) ) )
    394 
    395 (define (queue-unbuffered-delete! q x)
    396   (when (and (queue-unbuffered-maybe? q) (eq? (queue-unbuffered-value q) x))
    397     (queue-unbuffered-maybe-set! q #f) ) )
    398 
    399 (define (queue-unbuffered->list q)
    400   (if (queue-unbuffered-maybe? q)
    401     (list (queue-unbuffered-value q ))
    402     '() ) )
    403 
    404 ;; Queue Generic
    405 
    406 (define (valid-queue-limit? lm)
    407   (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
    408 
    409 (define (make-empty-queue lm)
    410   ;(assert (valid-queue-limit? lm))
    411   (cond
    412     ((not lm)       (make-empty-queue-unlimited))
    413     ((fixnum? lm)   (make-empty-queue-limited lm))
    414     (else           (make-empty-queue-unbuffered)) ) )
    415 
    416 (define (queue? x)
    417   (or
    418     (queue-unlimited? x)
    419     (queue-limited? x)
    420     (queue-unbuffered? x) ) )
    421 
    422 (define (queue-limit q)
    423   (cond
    424     ((queue-unlimited? q)  (queue-unlimited-limit q))
    425     ((queue-limited? q)    (queue-limited-limit q))
    426     (else                  (queue-unbuffered-limit q)) ) )
    427 
    428 (define (queue-count q)
    429   (cond
    430     ((queue-unlimited? q)  (queue-unlimited-count q))
    431     ((queue-limited? q)    (queue-limited-count q))
    432     (else                  (queue-unbuffered-count q)) ) )
    433 
    434 (define (queue-room q)
    435   (cond
    436     ((queue-unlimited? q)  (queue-unlimited-room q))
    437     ((queue-limited? q)    (queue-limited-room q))
    438     (else                  (queue-unbuffered-room q)) ) )
    439 
    440 (define (queue-empty? q #!optional (n 0))
    441   (cond
    442     ((queue-unlimited? q)  (queue-unlimited-empty? q))
    443     ((queue-limited? q)    (queue-limited-empty? q))
    444     (else                  (queue-unbuffered-empty? q)) ) )
    445 
    446 (define (queue-full? q #!optional (n 0))
    447   (cond
    448     ((queue-unlimited? q)  (queue-unlimited-full? q))
    449     ((queue-limited? q)    (queue-limited-full? q))
    450     (else                  (queue-unbuffered-full? q)) ) )
    451 
    452 (define (queue-empty-error loc q) (error loc "queue empty" q))
    453 (define (queue-full-error loc q v) (error loc "queue full" q v))
    454 
    455 (define (queue-add! q v)
    456   (cond
    457     ((queue-unlimited? q)  (queue-unlimited-add! q v))
    458     ((queue-limited? q)    (queue-limited-add! q v))
    459     (else                  (queue-unbuffered-add! q v))) )
    460 
    461 (define (queue-remove! q)
    462   (cond
    463     ((queue-unlimited? q)  (queue-unlimited-remove! q))
    464     ((queue-limited? q)    (queue-limited-remove! q))
    465     (else                  (queue-unbuffered-remove! q))) )
    466 
    467 (define (queue-push-back! q v)
    468   (cond
    469     ((queue-unlimited? q)  (queue-unlimited-push-back! q v))
    470     ((queue-limited? q)    (queue-limited-push-back! q v))
    471     (else                  (queue-unbuffered-push-back! q v))) )
    472 
    473 (define (queue-push-back-list! q ls)
    474   (cond
    475     ((queue-unlimited? q)  (queue-unlimited-push-back-list! q ls))
    476     ((queue-limited? q)    (queue-limited-push-back-list! q ls))
    477     (else                  (queue-unbuffered-push-back-list! q ls))) )
    478 
    479 (define (make-queue-cursor q)
    480   (cond
    481     ((queue-unlimited? q)  (make-queue-unlimited-cursor))
    482     ((queue-limited? q)    (make-queue-limited-cursor))
    483     (else                  (make-queue-unbuffered-cursor)) ) )
    484 
    485 (define (queue-cursor-winding? q c)
    486   (cond
    487     ((queue-unlimited? q)  (queue-unlimited-cursor-winding? q c))
    488     ((queue-limited? q)    (queue-limited-cursor-winding? q c))
    489     (else                  (queue-unbuffered-cursor-winding? q c)) ) )
    490 
    491 (define (queue-cursor-unwound? q c)
    492   (cond
    493     ((queue-unlimited? q)  (queue-unlimited-cursor-unwound? q c))
    494     ((queue-limited? q)    (queue-limited-cursor-unwound? q c))
    495     (else                  (queue-unbuffered-cursor-unwound? q c)) ) )
    496 
    497 (define (queue-cursor-rewind! q c)
    498   (cond
    499     ((queue-unlimited? q)  (queue-unlimited-cursor-rewind! q c))
    500     ((queue-limited? q)    (queue-limited-cursor-rewind! q c))
    501     (else                  (queue-unbuffered-cursor-rewind! q c)) ) )
    502 
    503 (define (queue-cursor-start! q c)
    504   (cond
    505     ((queue-unlimited? q)  (queue-unlimited-cursor-start! q c))
    506     ((queue-limited? q)    (queue-limited-cursor-start! q c))
    507     (else                  (queue-unbuffered-cursor-start! q c)) ))
    508 
    509 (define (queue-cursor-next! q c)
    510  (cond
    511     ((queue-unlimited? q)  (queue-unlimited-cursor-next! q c))
    512     ((queue-limited? q)    (queue-limited-cursor-next! q c))
    513     (else                  (queue-unbuffered-cursor-next! q c)) ))
    514 
    515 (define (queue-cursor-continue! q c)
    516  (cond
    517     ((queue-unlimited? q)  (queue-unlimited-cursor-continue! q c))
    518     ((queue-limited? q)    (queue-limited-cursor-continue! q c))
    519     (else                  (queue-unbuffered-cursor-continue! q c)) ))
    520 
    521 (define (queue-cursor-extract! q c)
    522   (cond
    523     ((queue-unlimited? q)  (queue-unlimited-cursor-extract! q c))
    524     ((queue-limited? q)    (queue-limited-cursor-extract! q c))
    525     (else                  (queue-unbuffered-cursor-extract! q c)) ) )
    526 
    527 (define (queue-delete! q x)
    528   (cond
    529     ((queue-unlimited? q)  (queue-unlimited-delete! q x))
    530     ((queue-limited? q)    (queue-limited-delete! q x))
    531     (else                  (queue-unbuffered-delete! q x)) ) )
    532 
    533 (define (queue->list q)
    534   (cond
    535     ((queue-unlimited? q)  (queue-unlimited->list q))
    536     ((queue-limited? q)    (queue-limited->list q))
    537     (else                  (queue-unbuffered->list q)) ) )

  • release/5/mailbox/trunk/inline-type-checks.scm

    r39743 r39773  
    1313
    1414;just in case older inlines
    15 (define-inline (natural? n) (<= 0 n))
    16 (define-inline (fxnatural? fx) (fx<= 0 fx))
     15(define-inline (%natural? n) (%<= 0 n))
     16(define-inline (%fxnatural? fx) (%fx<= 0 fx))
    1717
    1818(cond-expand
    … …  
    4242
    4343    (define-inline (%alist? obj)
    44       (or (null? obj)
    45           (and (pair? obj) (%list-every/1 (lambda (x) (pair? x)) obj))) )
     44      (or (%null? obj)
     45          (and (%pair? obj) (%list-every/1 (lambda (x) (%pair? x)) obj))) )
    4646
    4747    ;;
    … …  
    5656                   (typstr (symbol->string typ))
    5757                   (pred (if (not (null? (cddr frm))) (caddr frm)
    58                            (string->symbol (string-append "%" typstr "?"))))
     58                           (string->symbol (string-append #;"%" typstr "?"))))
    5959                   (nam (string->symbol (string-append "%check-" typstr)))
    6060                   (errnam (string->symbol (string-append "error-" typstr))) )
    … …  
    6767
    6868    (define-inline (%check-positive-fixnum loc obj . args)
    69       (unless (and (fixnum? obj) (fxpositive? obj))
     69      (unless (and (%fixnum? obj) (%fxpositive? obj))
    7070        (error-positive-fixnum loc obj (optional args)))
    7171      obj )
    7272
    7373    (define-inline (%check-natural-fixnum loc obj . args)
    74       (unless (and (fixnum? obj) (fxnatural? obj))
     74      (unless (and (%fixnum? obj) (%fxnatural? obj))
    7575        (error-natural-fixnum loc obj (optional args)))
    7676      obj )
    … …  
    7979
    8080    (define-inline (%check-positive-integer loc obj . args)
    81       (unless (and (integer? obj) (positive? obj))
     81      (unless (and (%integer? obj) (%positive? obj))
    8282        (error-positive-integer loc obj (optional args)))
    8383      obj )
    8484
    8585    (define-inline (%check-natural-integer loc obj . args)
    86       (unless (and (integer? obj) (natural? obj))
     86      (unless (and (%integer? obj) (%natural? obj))
    8787        (error-natural-integer loc obj (optional args)))
    8888      obj )
    … …  
    9191
    9292    (define-inline (%check-positive-number loc obj . args)
    93       (unless (and (number? obj) (positive? obj))
     93      (unless (and (%number? obj) (%positive? obj))
    9494        (error-positive-number loc obj (optional args)))
    9595      obj )
    9696
    9797    (define-inline (%check-natural-number loc obj . args)
    98       (unless (and (number? obj) (natural? obj))
     98      (unless (and (%number? obj) (%natural? obj))
    9999        (error-natural-number loc obj (optional args)))
    100100      obj )
    … …  
    110110
    111111    (define-inline (%check-minimum-argument-count loc argc minargc)
    112       (unless (fx<= minargc argc)
     112      (unless (%fx<= minargc argc)
    113113        (error-minimum-argument-count loc argc minargc))
    114114      argc )
    115115
    116116    (define-inline (%check-argument-count loc argc maxargc)
    117       (unless (fx<= argc maxargc)
     117      (unless (%fx<= argc maxargc)
    118118        (error-argument-count loc argc maxargc))
    119119      argc ) ) )

  • release/5/mailbox/trunk/mailbox.egg

    r39710 r39773  
    55((synopsis "Thread-safe queues with timeout")
    66 (category hell)
    7  (version "3.3.9")
     7 (version "3.3.8")
    88 (author "[[felix winkelman]] and [[kon lovett]]")
    99 (license "BSD")

  • release/5/mailbox/trunk/mailbox.scm

    r39747 r39773  
    3737  mailbox-timeout-condition?
    3838  ;Mailbox API
    39   make-unlimited-mailbox
    40   make-limited-mailbox
    41   make-unbuffered-mailbox
    4239  make-mailbox
    4340  mailbox?
    4441  mailbox-name
    4542  mailbox-empty?
    46   mailbox-full?
    4743  mailbox-count
    48   mailbox-limit
    49   mailbox-read-waiting?
    50   mailbox-write-waiting?
    51   mailbox-read-waiters
    52   mailbox-write-waiters
     44  mailbox-waiting?
     45  mailbox-waiters
    5346  mailbox-send!
    54   mailbox-read-wait!
    55   mailbox-write-wait!
     47  mailbox-wait!
    5648  mailbox-receive!
    5749  mailbox-push-back!
    … …  
    6557  mailbox-cursor-rewound?
    6658  mailbox-cursor-unwound?
    67   mailbox-cursor-extract-and-rewind!
    68   ;deprecated
    69   mailbox-waiting?
    70   mailbox-waiters
    71   mailbox-wait!)
     59  mailbox-cursor-extract-and-rewind!)
    7260
    7361(import scheme
    7462  (chicken base)
    75   (chicken fixnum)
    7663  (chicken syntax)
    7764  (chicken condition)
    … …  
    8067  (only (chicken format) printf)
    8168  (only (chicken string) ->string)
    82   (only (srfi 1) append! reverse! list-copy last-pair)
     69  (only (srfi 1) append! delete! list-copy last-pair)
    8370  (only (srfi 18)
    84     time? current-thread thread-signal! thread-sleep! thread-suspend! thread-resume!))
    85 
    86 ;;; Typoes
    87 
    88 (define-type srfi-18-time   (struct time))
    89 (define-type time-number    (or fixnum float))
    90 (define-type timeout        (or time-number srfi-18-time))
    91 (define-type unique-object  (vector-of symbol))
    92 (define-type buffering      (or boolean fixnum))
    93 (define-type mailbox        (struct mailbox))
    94 (define-type mailbox-cursor (struct mailbox-cursor))
    95 
    96 (: mailbox-timeout-condition?         (* -> boolean : condition))
    97 
    98 (: make-unlimited-mailbox             (#!optional * -> mailbox))
    99 (: make-limited-mailbox               (fixnum #!optional * -> mailbox))
    100 (: make-unbuffered-mailbox            (#!optional * -> mailbox))
    101 (: make-mailbox                       (#!optional * buffering -> mailbox))
    102 
    103 (: mailbox?                           (* -> boolean : mailbox))
    104 (: mailbox-name                       (mailbox --> *))
    105 (: mailbox-empty?                     (mailbox -> boolean))
    106 (: mailbox-full?                      (mailbox -> boolean))
    107 (: mailbox-count                      (mailbox -> fixnum))
    108 (: mailbox-limit                      (mailbox --> fixnum))
    109 (: mailbox-read-waiting?              (mailbox -> boolean))
    110 (: mailbox-write-waiting?             (mailbox -> boolean))
    111 (: mailbox-waiting?                   (deprecated mailbox-write-waiting?))
    112 (: mailbox-read-waiters               (mailbox -> list))
    113 (: mailbox-write-waiters              (mailbox -> list))
    114 (: mailbox-waiters                    (deprecated mailbox-write-waiters))
    115 
    116 (: mailbox-send!                      (mailbox * -> void))
    117 (: mailbox-read-wait!                 (mailbox #!optional timeout -> void))
    118 (: mailbox-write-wait!                (mailbox #!optional timeout -> void))
    119 (: mailbox-wait!                      (deprecated mailbox-write-wait!))
    120 (: mailbox-receive!                   (mailbox #!optional timeout * -> *))
    121 (: mailbox-push-back!                 (mailbox * -> void))
    122 (: mailbox-push-back-list!            (mailbox list -> void))
    123 
    124 (: make-mailbox-cursor                (mailbox -> mailbox-cursor))
    125 
    126 (: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
    127 (: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
    128 (: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
    129 (: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
    130 
    131 (: mailbox-cursor-rewind              (mailbox-cursor -> void))
    132 (: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
    133 (: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
     71    time?
     72    current-thread
     73    thread-signal! thread-sleep!
     74    thread-suspend! thread-resume!))
    13475
    13576;;; Support
    … …  
    228169        (lambda (k) e0 e1 ...)))))
    229170
    230 ;;fx-utils
    231 
    232 (define (fxneg? n) (fx< n 0))
    233 (define (fxabs n) (if (fxneg? n) (fxneg n) n))
    234 
    235 ;;check-errors
     171;;(only type-errors define-error-type)
    236172
    237173(define (make-bad-argument-message #!optional argnam)
    … …  
    252188  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
    253189
    254 (define-inline (%list? x) (list? x))
    255190(include-relative "inline-type-checks")
    256191
    257 ;;moremacros
    258 
    259 (define (->boolean obj) (and obj #t))
    260 
    261 ;;thread-utils
    262 
    263 (define (thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
    264 (define (thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
    265 (define (thread-unblock! th) (##sys#thread-unblock! th))
     192;;
     193
     194(define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
     195(define-inline (%thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
     196
     197(define-inline (%->boolean obj) (and obj #t))
     198
     199(define-inline (%make-unique-object #!optional (id 'unique)) (vector id))
    266200
    267201;; Time Support
    268202
    269 (define (time-number? x)  (or (fixnum? x) (flonum? x)))
    270 (define (timeout? x)      (or (time-number? x) (time? x)))
     203(define-inline (%time-number? obj)
     204  (or (fixnum? obj) (flonum? obj)) )
     205
     206(define-inline (%timeout? obj)
     207  (or (%time-number? obj) (time? obj)) )
    271208
    272209(define (error-timeout loc obj #!optional argnam)
    273210  (##sys#signal-hook #:type-error loc (make-error-type-message 'timeout argnam) obj) )
    274211
    275 ;chgd to drop `%' prefix
    276 (define-inline (%timeout? x) (timeout? x))
     212(define (timeout? obj) (%timeout? obj))
     213
    277214(define-inline-check-type timeout)
    278215
    … …  
    280217
    281218(include-relative "inline-queue")
     219
     220;;; Typoes
     221
     222(define-type srfi-18-time   (struct time))
     223(define-type mailbox        (struct mailbox))
     224(define-type mailbox-cursor (struct mailbox-cursor))
     225(define-type time-number    (or fixnum float))
     226(define-type timeout        (or time-number srfi-18-time))
     227(define-type unique-object  (vector-of symbol))
     228
     229(: mailbox-timeout-condition?         (* -> boolean : condition))
     230(: make-mailbox                       (#!optional * -> mailbox))
     231(: mailbox?                           (* -> boolean : mailbox))
     232(: mailbox-name                       (mailbox --> *))
     233(: mailbox-empty?                     (mailbox -> boolean))
     234(: mailbox-count                      (mailbox -> fixnum))
     235(: mailbox-waiting?                   (mailbox -> boolean))
     236(: mailbox-waiters                    (mailbox -> list))
     237(: mailbox-send!                      (mailbox * -> void))
     238(: mailbox-wait!                      (mailbox #!optional timeout -> void))
     239(: mailbox-receive!                   (mailbox #!optional timeout * -> *))
     240(: mailbox-push-back!                 (mailbox * -> void))
     241(: mailbox-push-back-list!            (mailbox list -> void))
     242(: make-mailbox-cursor                (mailbox -> mailbox-cursor))
     243(: mailbox-cursor?                    (* -> boolean : mailbox-cursor))
     244(: mailbox-cursor-mailbox             (mailbox-cursor --> mailbox))
     245(: mailbox-cursor-rewound?            (mailbox-cursor -> boolean))
     246(: mailbox-cursor-unwound?            (mailbox-cursor -> boolean))
     247(: mailbox-cursor-rewind              (mailbox-cursor -> void))
     248(: mailbox-cursor-next                (mailbox-cursor #!optional timeout * -> *))
     249(: mailbox-cursor-extract-and-rewind! (mailbox-cursor -> void))
    282250
    283251;;; Mailbox
    … …  
    286254(define mailbox 'mailbox)
    287255(define-record-type-variant mailbox (unsafe unchecked inline)
    288   (%make-mailbox nm qu rd wt)
     256  (%raw-make-mailbox nm qu wt)
    289257  (%mailbox?)
    290258  (nm %mailbox-name)
    291259  (qu %mailbox-queue)
    292   (wt %mailbox-read-waiters)
    293   (wt %mailbox-write-waiters) )
    294 
    295 (define (*make-mailbox loc nm lm)
    296   (unless (valid-queue-limit? lm)
    297     (error loc "invalid limit" lm nm) )
    298   (%make-mailbox nm
    299     (make-empty-queue lm)
    300     (make-empty-queue-unlimited)
    301     (make-empty-queue-unlimited)) )
     260  (wt %mailbox-waiters %mailbox-waiters-set!) )
     261
     262(define-inline (%make-mailbox nm)
     263  (%raw-make-mailbox nm (%make-empty-queue) '()) )
    302264
    303265(define (error-mailbox loc obj #!optional argnam)
    … …  
    308270;; Message queue
    309271
    310 (define (mailbox-queue-empty? mb #!optional (n 0))
    311   (queue-empty? (%mailbox-queue mb) n) )
    312 
    313 (define (mailbox-queue-full? mb #!optional (n 0))
    314   (queue-full? (%mailbox-queue mb) n) )
    315 
    316 (define (mailbox-queue-count mb)
    317   (queue-count (%mailbox-queue mb)) )
    318 
    319 (define (mailbox-queue-limit mb)
    320   (queue-limit (%mailbox-queue mb)) )
    321 
    322 (define (mailbox-queue-add! mb x)
    323   (queue-add! (%mailbox-queue mb) x) )
    324 
    325 (define (mailbox-queue-remove! mb)
    326   (queue-remove! (%mailbox-queue mb)) )
    327 
    328 (define (mailbox-queue-push-back! mb x)
    329   (queue-push-back! (%mailbox-queue mb) x) )
    330 
    331 (define (mailbox-queue-push-back-list! mb ls)
    332   (queue-push-back-list! (%mailbox-queue mb) ls) )
     272(define-inline (%mailbox-queue-first-pair mb)
     273  (%queue-first-pair (%mailbox-queue mb)) )
     274
     275(define-inline (%mailbox-queue-last-pair mb)
     276  (%queue-last-pair (%mailbox-queue mb)) )
     277
     278(define-inline (%mailbox-queue-empty? mb)
     279  (%queue-empty? (%mailbox-queue mb)) )
     280
     281(define-inline (%mailbox-queue-count mb)
     282  (%queue-count (%mailbox-queue mb)) )
     283
     284(define-inline (%mailbox-queue-add! mb x)
     285  (%queue-add! (%mailbox-queue mb) x) )
     286
     287(define-inline (%mailbox-queue-remove! mb)
     288  (%queue-remove! (%mailbox-queue mb)) )
     289
     290(define-inline (%mailbox-queue-push-back! mb x)
     291  (%queue-push-back! (%mailbox-queue mb) x) )
     292
     293(define-inline (%mailbox-queue-push-back-list! mb ls)
     294  (%queue-push-back-list! (%mailbox-queue mb) ls) )
    333295
    334296;; Waiting threads
    335297
    336 (define (mailbox-waiter-queue-name mb wq)
    337   (cond
    338     ((%mailbox-read-waiters mb) 'read)
    339     ((%mailbox-write-waiters mb) 'write)
    340     (else
    341       (error 'mailbox-waiter-queue-name "not mailbox waiter" mb wq)) ) )
    342 
    343 ;read
    344 
    345 (define (mailbox-read-waiters-empty? mb)
    346   (queue-unlimited-empty? (%mailbox-read-waiters mb)) )
    347 
    348 (define (mailbox-read-waiters-full? mb)
    349   (queue-unlimited-full? (%mailbox-read-waiters mb)) )
    350 
    351 (define (mailbox-read-waiters-count mb)
    352  (queue-unlimited-count (%mailbox-read-waiters mb)) )
    353 
    354 (define (mailbox-read-waiters-add! mb th)
    355   (queue-unlimited-add! (%mailbox-read-waiters mb) th) )
    356 
    357 (define (mailbox-read-waiters-delete! mb th)
    358   (queue-unlimited-delete! (%mailbox-read-waiters mb) th) )
    359 
    360 (define (mailbox-read-waiters-pop! mb)
    361   (queue-unlimited-remove! (%mailbox-read-waiters mb)) )
    362 
    363 (define (mailbox-read-waiters->list mb)
    364   (queue-unlimited->list (%mailbox-read-waiters mb)) )
    365 
    366 ;write
    367 
    368 (define (mailbox-write-waiters-empty? mb)
    369   (queue-unlimited-empty? (%mailbox-write-waiters mb)) )
    370 
    371 (define (mailbox-write-waiters-count mb)
    372  (queue-unlimited-count (%mailbox-write-waiters mb)) )
    373 
    374 (define (mailbox-write-waiters-add! mb th)
    375   (queue-unlimited-add! (%mailbox-write-waiters mb) th) )
    376 
    377 (define (mailbox-write-waiters-delete! mb th)
    378   (queue-unlimited-delete! (%mailbox-write-waiters mb) th) )
    379 
    380 (define (mailbox-write-waiters-pop! mb)
    381   (queue-unlimited-remove! (%mailbox-write-waiters mb)) )
    382 
    383 (define (mailbox-write-waiters->list mb)
    384   (queue-unlimited->list (%mailbox-write-waiters mb)) )
     298(define-inline (%mailbox-waiters-empty? mb)
     299  (null? (%mailbox-waiters mb)) )
     300
     301(define-inline (%mailbox-waiters-count mb)
     302  (length (%mailbox-waiters mb)) )
     303
     304(define-inline (%mailbox-waiters-add! mb th)
     305  (%mailbox-waiters-set! mb (append! (%mailbox-waiters mb) (cons th '()))) )
     306
     307(define-inline (%mailbox-waiters-delete! mb th)
     308  (%mailbox-waiters-set! mb (delete! th (%mailbox-waiters mb))) )
     309
     310(define-inline (%mailbox-waiters-pop! mb)
     311  (let ((ts (%mailbox-waiters mb)))
     312    (%mailbox-waiters-set! mb (cdr ts))
     313    (car ts) ) )
    385314
    386315;;; Mailbox Cursor Support
    … …  
    389318(define mailbox-cursor 'mailbox-cursor)
    390319(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    391   (%make-mailbox-cursor mb cr)
     320  (%raw-make-mailbox-cursor np pp mb)
    392321  (%mailbox-cursor?)
    393   (mb %mailbox-cursor-mailbox)
    394   (cr %mailbox-cursor-queue-cursor) )
    395 
    396 (define (*make-mailbox-cursor mb)
    397   (%make-mailbox-cursor mb (make-queue-cursor (%mailbox-queue mb))) )
    398 
    399 (define (error-mailbox-cursor loc obj #!optional nam)
    400   (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor nam) obj))
     322  (np %mailbox-cursor-next-pair %mailbox-cursor-next-pair-set!)
     323  (pp %mailbox-cursor-prev-pair %mailbox-cursor-prev-pair-set!)
     324  (mb %mailbox-cursor-mailbox) )
     325
     326(define-inline (%make-mailbox-cursor mb)
     327  (%raw-make-mailbox-cursor '() #f mb) )
     328
     329(define (error-mailbox-cursor loc obj #!optional argnam)
     330  (##sys#signal-hook #:type-error loc (make-error-type-message 'mailbox-cursor argnam) obj) )
    401331
    402332(define-inline-check-type mailbox-cursor)
    403333
    404 (define (mailbox-cursor-queue mbc)
    405   (%mailbox-queue (%mailbox-cursor-mailbox mbc)) )
    406 
    407 (define (*mailbox-cursor-winding? mbc)
    408   (queue-cursor-winding? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    409 
    410 (define (*mailbox-cursor-unwound? mbc)
    411   (queue-cursor-unwound? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    412 
    413 (define (*mailbox-cursor-rewind! mbc)
    414   (queue-cursor-rewind! (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    415 
    416 (define (*mailbox-cursor-extract! mbc)
    417   (queue-cursor-extract! (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
     334(define-inline (%mailbox-cursor-winding? mbc)
     335  (%->boolean (%mailbox-cursor-prev-pair mbc)) )
     336
     337(define-inline (%mailbox-cursor-next-pair-empty! mbc)
     338  (%mailbox-cursor-next-pair-set! mbc '()) )
     339
     340(define-inline (%mailbox-cursor-prev-pair-clear! mbc)
     341  (%mailbox-cursor-prev-pair-set! mbc #f) )
     342
     343(define-inline (%mailbox-cursor-rewind! mbc)
     344  (%mailbox-cursor-next-pair-empty! mbc)
     345  (%mailbox-cursor-prev-pair-clear! mbc) )
     346
     347(define-inline (%mailbox-cursor-extract! mbc)
     348  ;unless 'mailbox-cursor-next' has been called don't remove
     349  (and-let* ((prev-pair (%mailbox-cursor-prev-pair mbc)))
     350    (%queue-extract-pair! (%mailbox-queue (%mailbox-cursor-mailbox mbc)) prev-pair) ) )
    418351
    419352;;;
    420353
    421354;Unique objects used as tags
    422 (define UNBLOCKED-TAG (vector 'unblocked))
    423 (define SEQ-FAIL-TAG (vector 'seq-fail))
    424 (define NO-TOVAL-TAG (vector 'timeout-value))
     355(define UNBLOCKED-TAG (%make-unique-object 'unblocked))
     356(define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
     357(define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
    425358#; ;XXX
    426 (define MESSAGE-WAITING-TAG (vector 'message-waiting))
     359(define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
    427360
    428361;;; Mailbox Exceptions
    429362
    430 (define (optional-timeout-value x #!optional (def (void)))
     363(define-inline (optional-timeout-value x #!optional (def (void)))
    431364  (if (eq? x NO-TOVAL-TAG) def x) )
    432365
    433 (define (make-mailbox-timeout-condition loc mb wq timout timout-value)
     366(define (make-mailbox-timeout-condition loc mb timout timout-value)
    434367  (let ((tv (optional-timeout-value timout-value)))
    435368    (make-composite-condition
    … …  
    439372        'arguments (list timout tv))
    440373      (make-property-condition 'mailbox 'box mb)
    441       (make-property-condition 'direction 'waiter (mailbox-waiter-queue-name mb wq))
    442374      (make-property-condition 'timeout 'time timout 'value tv)) ) )
    443375
    444376;;; Mailbox Threading
    445377
    446 ;; Activate thread (for some mailbox)
    447 
    448 (define (restart-thread! th)
    449   ;
    450   (if (not (thread-blocked? th))
    451     ;then restart
    452     (thread-resume! th)
    453     ;else wake early if sleeping
    454     ;all others dropped on the floor
    455     (when (thread-blocked-for-timeout? th)
    456       ;ready the thread
    457       (thread-unblock! th)
    458       ;tell 'wait-mailbox-thread!' we unblocked early
    459       (thread-signal! th UNBLOCKED-TAG) ) )
    460   ;ensure void return
    461   (void) )
     378;; Select next waiting thread for the mailbox
     379
     380(define-inline (%mailbox-waiters-pop!? mb)
     381  (and (not (%mailbox-waiters-empty? mb)) (%mailbox-waiters-pop! mb)) )
     382
     383(define (ready-mailbox-thread! mb)
     384  ;ready oldest waiting thread
     385  (and-let* ((th (%mailbox-waiters-pop!? mb)))
     386    ;ready the thread based on wait mode
     387    (if (not (%thread-blocked? th))
     388      ;then restart
     389      (thread-resume! th)
     390      ;else wake early if sleeping
     391      ;all others dropped on the floor
     392      (when (%thread-blocked-for-timeout? th)
     393        ;ready the thread
     394        (##sys#thread-unblock! th)
     395        ;tell 'wait-mailbox-thread!' we unblocked early
     396        (thread-signal! th UNBLOCKED-TAG) ) ) )
     397    (void) )
    462398
    463399;; Sleep current thread until timeout, known condition,
    464400;; or some other condition
    465401
    466 (define (thread-sleep/unblock! tim unblocked-tag)
     402(define (thread-sleep/maybe-unblock! tim unblocked-tag)
    467403;(print "mailbox sleep/maybe-unblock!: " tim " " unblocked-tag)
    468404  ;sleep current thread for desired seconds, unless unblocked "early".
    … …  
    475411          (signal exp) ) )
    476412      (lambda ()
    477         (thread-sleep! tim)
    478         #t) ) ) )
     413        (thread-sleep! tim) #t) ) ) )
    479414
    480415;; Wait current thread on the mailbox until timeout, available message
    481416;; or some other condition
    482417
    483 (define (wait-mailbox-thread! loc mb wq timout timout-value)
     418(define (wait-mailbox-thread! loc mb timout timout-value)
    484419  ;
    485420  ;no available message due to timeout
    … …  
    490425        (thread-signal!
    491426          (current-thread)
    492           (make-mailbox-timeout-condition loc mb wq timout timout-value))
     427          (make-mailbox-timeout-condition loc mb timout timout-value))
    493428        SEQ-FAIL-TAG ) ) )
    494429  ;
    495430  ;push current thread on mailbox waiting queue
    496   (queue-unlimited-add! wq (current-thread))
     431  (%mailbox-waiters-add! mb (current-thread))
    497432  ;waiting action
    498433  (cond
    … …  
    503438          ;
    504439          (cond
    505             ((thread-sleep/unblock! timout UNBLOCKED-TAG)
     440            ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    506441              ;timed-out, so no message
    507442              ;remove from wait queue
    508               (queue-unlimited-delete! wq (current-thread))
     443              (%mailbox-waiters-delete! mb (current-thread))
    509444              ;indicate no available message
    510445              (timeout-exit!) )
    … …  
    516451          (if (eq? (current-thread) ##sys#primordial-thread)
    517452            (begin
    518               (queue-unlimited-delete! wq (current-thread))
     453              (%mailbox-waiters-delete! mb (current-thread))
    519454              (warning "mailbox attempt to sleep primordial-thread" mb)
    520455              (timeout-exit!) )
    521456            (cond
    522               ((thread-sleep/unblock! timout UNBLOCKED-TAG)
     457              ((thread-sleep/maybe-unblock! timout UNBLOCKED-TAG)
    523458                ;timed-out, so no message
    524459                ;remove from wait queue
    525                 (queue-unlimited-delete! wq (current-thread))
     460                (%mailbox-waiters-delete! mb (current-thread))
    526461                ;indicate no available message
    527462                (timeout-exit!) )
    … …  
    538473
    539474;Note that the arguments, except the ?expr0 ..., must be base values.
    540 
    541 (define-syntax wait-mailbox-read!
     475(define-syntax on-mailbox-available
    542476  (syntax-rules ()
    543     ((wait-mailbox-read! ?loc ?mb ?n ?timout ?timout-value ?expr0 ?expr1  ...)
    544       (let ((_mb ?mb) (_n ?n) (_to ?timout) (_tv ?timout-value))
    545         (let ((wq (%mailbox-read-waiters _mb)))
    546           (let waiting ()
    547             (cond
    548               ((mailbox-queue-full? _mb _n)
    549                 (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    550                   ;when a thread ready then check mailbox again, could be empty.
    551                   (if (eq? UNBLOCKED-TAG res)
    552                     (waiting)
    553                     ;else some sort of problem
    554                     res ) ) )
    555               (else
    556                 ?expr0 ?expr1 ... ) ) ) ) ) ) ) )
    557 
    558 (define-syntax wait-mailbox-write!
    559   (syntax-rules ()
    560     ((wait-mailbox-write! ?loc ?mb ?n ?timout ?timout-value ?expr0 ?expr1 ...)
    561       (let ((_mb ?mb) (_n ?n) (_to ?timout) (_tv ?timout-value))
    562         (let ((wq (%mailbox-write-waiters _mb)))
    563           (let waiting ()
    564             (cond
    565               ((mailbox-queue-empty? _mb _n)
    566                 (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    567                   ;when a thread ready then check mailbox again, could be empty.
    568                   (if (eq? UNBLOCKED-TAG res)
    569                     (waiting)
    570                     ;else some sort of problem
    571                     res ) ) )
    572               (else
    573                 ?expr0 ?expr1 ... ) ) ) ) ) ) ) )
    574 
    575 ;; Select next waiting thread for the mailbox
    576 
    577 (define (ready-mailbox-reader! mb)
    578   ;ready oldest waiting thread
    579   (unless (mailbox-write-waiters-empty? mb)
    580     (restart-thread! (mailbox-write-waiters-pop! mb)))
    581   (void) )
    582 
    583 (define (ready-mailbox-writer! mb)
    584   ;ready oldest waiting thread
    585   (unless (mailbox-read-waiters-empty? mb)
    586     (restart-thread! (mailbox-read-waiters-pop! mb)))
    587   (void) )
     477    ((_ ?loc ?mb ?timout ?timout-value ?expr0 ...)
     478      (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
     479        (let waiting ()
     480          (cond
     481            ((%mailbox-queue-empty? _mb)
     482              (let ((res (wait-mailbox-thread! ?loc _mb _to _tv)))
     483                ;when a thread ready then check mailbox again, could be empty.
     484                (if (eq? UNBLOCKED-TAG res)
     485                  (waiting)
     486                  ;else some sort of problem
     487                  res ) ) )
     488            (else
     489              ?expr0 ... ) ) ) ) ) ) )
     490
     491#; ;XXX
     492(define (wait-mailbox-if-empty! loc mb timout timout-value)
     493  (on-mailbox-available loc mb timout timout-value
     494    MESSAGE-WAITING-TAG ) )
    588495
    589496;;; Mailbox
    … …  
    599506;; Mailbox Constructor
    600507
    601 (define (make-unlimited-mailbox #!optional (nm (gensym 'mailbox)))
    602   (*make-mailbox 'make-unlimited-mailbox nm #f) )
    603 
    604 (define (make-limited-mailbox lm #!optional (nm (gensym 'mailbox)))
    605   (*make-mailbox 'make-limited-mailbox nm lm) )
    606 
    607 (define (make-unbuffered-mailbox #!optional (nm (gensym 'mailbox)))
    608   (*make-mailbox 'make-unbuffered-mailbox nm #t) )
    609 
    610 (define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
    611   (*make-mailbox 'make-mailbox nm lm) )
    612 
    613 ;; Mailbox Properties
     508(define (make-mailbox #!optional (nm (gensym 'mailbox)))
     509  (%make-mailbox nm) )
    614510
    615511(define (mailbox? obj)
    616512  (%mailbox? obj) )
    617513
     514;; Mailbox Properties
     515
    618516(define (mailbox-name mb)
    619517  (%mailbox-name (%check-mailbox 'mailbox-name mb)) )
    620518
    621519(define (mailbox-empty? mb)
    622   (mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    623 
    624 (define (mailbox-full? mb)
    625   (mailbox-queue-full? (%check-mailbox 'mailbox-empty? mb)) )
     520  (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    626521
    627522(define (mailbox-count mb)
    628   (mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
    629 
    630 (define (mailbox-limit mb)
    631   (mailbox-queue-limit (%check-mailbox 'mailbox-count mb)) )
    632 
    633 (define (mailbox-read-waiting? mb)
    634   (not (mailbox-read-waiters-empty? (%check-mailbox 'mailbox-read-waiting? mb))) )
    635 
    636 (define (mailbox-write-waiting? mb)
    637   (not (mailbox-write-waiters-empty? (%check-mailbox 'mailbox-write-waiting? mb))) )
    638 
    639 (define mailbox-waiting? mailbox-write-waiters-empty?)
    640 
    641 (define (mailbox-write-waiters mb)
    642   (mailbox-write-waiters->list (%check-mailbox 'mailbox-write-waiters mb)) )
    643 
    644 (define (mailbox-read-waiters mb)
    645   (mailbox-read-waiters->list (%check-mailbox 'mailbox-read-waiters mb)) )
    646 
    647 (define mailbox-waiters mailbox-write-waiters)
     523  (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
     524
     525(define (mailbox-waiting? mb)
     526  (not (null? (%mailbox-waiters (%check-mailbox 'mailbox-waiting? mb)))) )
     527
     528(define (mailbox-waiters mb)
     529  (list-copy (%mailbox-waiters (%check-mailbox 'mailbox-waiters mb))) )
    648530
    649531;; Mailbox Operations
    650532
    651 (define (mailbox-send! mb x #!optional timout (timout-value NO-TOVAL-TAG))
    652   (wait-mailbox-read! 'mailbox-send!
    653     ;wait until
    654     (%check-mailbox 'mailbox-send! mb) 0 timout timout-value
    655     ;then
    656     (mailbox-queue-add! mb x)
    657     (ready-mailbox-reader! mb) ) )
    658 
    659 (define (mailbox-read-wait! mb #!optional timout)
    660   (when timout (%check-timeout 'mailbox-read-wait! timout))
    661   (wait-mailbox-read! 'mailbox-read-wait!
    662     ;wait until
    663     (%check-mailbox 'mailbox-read-wait! mb) 0 timout NO-TOVAL-TAG
    664     ;then
     533(define (mailbox-send! mb x)
     534  (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
     535  (ready-mailbox-thread! mb) )
     536
     537(define (mailbox-wait! mb #!optional timout)
     538  (when timout (%check-timeout 'mailbox-wait! timout))
     539  (on-mailbox-available 'mailbox-wait!
     540    (%check-mailbox 'mailbox-wait! mb)
     541    timout NO-TOVAL-TAG
    665542    (void) ) )
    666 
    667 (define (mailbox-write-wait! mb #!optional timout)
    668   (when timout (%check-timeout 'mailbox-write-wait! timout))
    669   (wait-mailbox-write! 'mailbox-write-wait!
    670     ;wait until
    671     (%check-mailbox 'mailbox-write-wait! mb) 0 timout NO-TOVAL-TAG
    672     ;then
    673     (void) ) )
    674 
    675 (define mailbox-wait! mailbox-write-wait!)
    676543
    677544(define (mailbox-receive! mb #!optional timout (timout-value NO-TOVAL-TAG))
    678545  (when timout (%check-timeout 'mailbox-receive! timout))
    679   (wait-mailbox-write! 'mailbox-receive!
    680     ;wait until
    681     (%check-mailbox 'mailbox-receive! mb) 0 timout timout-value
    682     ;then
    683     (let ((v (mailbox-queue-remove! mb)))
    684       (ready-mailbox-writer! mb)
    685       v ) ) )
    686 
    687 (define (mailbox-push-back! mb x #!optional timout (timout-value NO-TOVAL-TAG))
    688   (wait-mailbox-read! 'mailbox-push-back!
    689     ;wait until
    690     (%check-mailbox 'mailbox-push-back! mb) 0 timout timout-value
    691     ;then
    692     (mailbox-queue-push-back! mb x)
    693     (ready-mailbox-reader! mb) ) )
    694 
    695 (define (mailbox-push-back-list! mb ls #!optional timout (timout-value NO-TOVAL-TAG))
    696   (%check-list 'mailbox-push-back-list! ls)
    697   (unless (zero? (length ls))
    698     (wait-mailbox-read! 'mailbox-push-backlist!
    699       ;wait until
    700       (%check-mailbox 'mailbox-push-back-list! mb) (fx- (length ls) 1) timout timout-value
    701       ;then
    702       (mailbox-queue-push-back-list! mb ls)
    703       (ready-mailbox-reader! mb) ) ) )
     546  (on-mailbox-available 'mailbox-receive!
     547    (%check-mailbox 'mailbox-receive! mb)
     548    timout timout-value
     549    (%mailbox-queue-remove! mb) ) )
     550
     551(define (mailbox-push-back! mb x)
     552  (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
     553  (ready-mailbox-thread! mb) )
     554
     555(define (mailbox-push-back-list! mb ls)
     556  (%mailbox-queue-push-back-list!
     557    (%check-mailbox 'mailbox-send! mb)
     558    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
     559  (ready-mailbox-thread! mb) )
    704560
    705561;; Read/Print Syntax
    … …  
    708564  (with-output-to-port out
    709565    (lambda ()
    710       (printf "#<mailbox ~S limit: ~A queued: ~A waiters: ~A/~A>"
     566      (printf "#<mailbox ~A queued: ~A waiters: ~A>"
    711567        (%mailbox-name mb)
    712         (mailbox-queue-limit mb)
    713         (mailbox-queue-count mb)
    714         (mailbox-read-waiters-count mb)
    715         (mailbox-write-waiters-count mb)) ) ) )
     568        (%mailbox-queue-count mb)
     569        (%mailbox-waiters-count mb)) ) ) )
    716570
    717571;;; Mailbox Cursor
    … …  
    720574
    721575(define (make-mailbox-cursor mb)
    722   (*make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
     576  (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
    723577
    724578;; Mailbox Cursor Properties
    … …  
    731585
    732586(define (mailbox-cursor-rewound? mbc)
    733   (not (*mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
     587  (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
    734588
    735589(define (mailbox-cursor-unwound? mbc)
    736   (*mailbox-cursor-unwound? (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)) )
     590  (null? (%mailbox-cursor-next-pair (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc))) )
    737591
    738592;; Mailbox Cursor Operations
    739593
    740594(define (mailbox-cursor-rewind mbc)
    741   (*mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
     595  (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
    742596
    743597(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
    744598  (when timout (%check-timeout 'mailbox-cursor-next timout))
    745   (let* (
    746     (mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc)))
    747     (mq (%mailbox-queue mb))
    748     (mc (%mailbox-cursor-queue-cursor mbc)) )
     599  (let ((mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc))))
    749600    ;seed rewound cursor
    750     (unless (queue-cursor-winding? mq mc)
    751       (queue-cursor-start! mq mc) )
     601    (unless (%mailbox-cursor-winding? mbc)
     602      (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-first-pair mb)) )
    752603    ;pull next item from queue at cursor
    753604    (let scanning ()
    754       (let ((item (queue-cursor-next! mq mc)))
     605      (let ((curr-pair (%mailbox-cursor-next-pair mbc)))
    755606        ;anything next?
    756         (if (not (eof-object? item))
    757           ;then next item
    758           item
     607        (if (not (null? curr-pair))
     608          ;then peek into the queue for the next item
     609          (let ((item (car curr-pair)))
     610            (%mailbox-cursor-prev-pair-set! mbc curr-pair)
     611            (%mailbox-cursor-next-pair-set! mbc (cdr curr-pair))
     612            item )
    759613          ;else wait for something in the mailbox
    760           (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb
    761                       (%mailbox-write-waiters mb) timout timout-value)))
     614          (let ((res (wait-mailbox-thread! 'mailbox-cursor-next mb timout timout-value)))
    762615            (cond
    763616              ;continue scanning?
    764617              ((eq? UNBLOCKED-TAG res)
    765                 (queue-cursor-continue! mq mc)
     618                (%mailbox-cursor-next-pair-set! mbc (%mailbox-queue-last-pair mb))
    766619                (scanning) )
    767620              ;some problem (timeout maybe)
    … …  
    770623
    771624(define (mailbox-cursor-extract-and-rewind! mbc)
    772   (*mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
    773   (*mailbox-cursor-rewind! mbc)
    774   (ready-mailbox-writer! (%mailbox-cursor-mailbox mbc)) )
     625  (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
     626  (%mailbox-cursor-rewind! mbc) )
    775627
    776628;; Read/Print Syntax
    … …  
    781633      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
    782634      (%mailbox-name (%mailbox-cursor-mailbox mbc))
    783       (cond
    784         ((*mailbox-cursor-unwound? mbc) "unwound")
    785         ((*mailbox-cursor-winding? mbc) "winding")
    786         (else                           "rewound"))) ) ) )
     635      (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
    787636
    788637;;;

  • release/5/mailbox/trunk/tests/mailbox-cursor-test.scm

    r39747 r39773  
    33;;;
    44
    5 (import (chicken condition) (srfi 18) mailbox)
     5(import mailbox)
     6(import srfi-18)
    67
    78;;; Test support
    89
    9 ;(define-constant MESSAGE-LIMIT 5)
    10 (define-constant MESSAGE-LIMIT 3)
     10(define-constant MESSAGE-LIMIT 5)
    1111
    12 ;(define-constant TIMEOUT 4)    ;slow but otherwise ok
    13 ;(define-constant TIMEOUT 0.5)
    14 (define-constant TIMEOUT 0.25)
     12(define-constant TIMEOUT #;0.5 0.25)
    1513
    1614(define (current-thread-name) (thread-name (current-thread)))
    … …  
    3129  (apply print (current-thread-name) " - " args)
    3230  #; ;only 2 threads!
    33   (critical-section (apply print (current-thread-name) " - " args) ) )
     31        (critical-section (apply print (current-thread-name) " - " args) ) )
    3432
    3533(define (makmsg x) (cons (current-thread-name) x))
    … …  
    4240;;
    4341
    44 (define (test-mailbox-one wrtcnt knd mb1 lmt tmo)
    45 
    46   (define totcnt (* wrtcnt lmt))
     42(let ((mailbox-one (make-mailbox 'one)))
    4743
    4844  (define (writer-thread-body)
    49     (define (send-it msg)
    50       (thread-labeled-print "Send " msg " at " (current-seconds) " sec")
    51       (mailbox-send! mb1 msg) )
    52     (thread-labeled-print "Started")
     45    (thread-labeled-print "Started!")
    5346    (let loop ((cnt 0))
    54       ;#; ;FIXME w/o even unlimited deadlocks!
    55       (thread-sleep! tmo)
    56       (if (= lmt cnt)
    57         (begin
    58           (send-it (makmsg 'quit))
    59           (unless (< 1 wrtcnt) (send-it (makmsg 'quit))) )
    60         (begin
    61           (send-it (makmsg cnt))
    62           (loop (add1 cnt))) ) ) )
     47      (thread-sleep! TIMEOUT)
     48      (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
     49          (begin
     50            (mailbox-send! mailbox-one (makmsg cnt))
     51            (loop (add1 cnt))) ) ) )
    6352
    6453  (define (make-reader-thread-body test)
    6554    (lambda ()
    6655      (thread-labeled-print "Started!")
    67       (let ((mbc (make-mailbox-cursor mb1)))
     56      (let ((mbc (make-mailbox-cursor mailbox-one)))
    6857        (let loop ()
    6958          (let ((msg (mailbox-cursor-next mbc)))
    70             (thread-labeled-print "Next (" totcnt "): " msg " at " (current-seconds) " sec")
    71             ;FIXME must process msgs in FIFO order, not LIFO order
    72             (cond
    73               ((eq? 'quit (msgval msg))
    74                 (if (zero? totcnt)
    75                   (begin
    76                     (thread-labeled-print "Quit - Removing: " msg)
    77                     (mailbox-cursor-extract-and-rewind! mbc) )
    78                   (loop) ) )
    79               ((test msg)
    80                 (thread-labeled-print "Match - Removing: " msg)
    81                 (mailbox-cursor-extract-and-rewind! mbc)
    82                 (set! totcnt (sub1 totcnt))
    83                 (loop) )
    84               (else
    85                 (loop) ) ) ) ) ) ) )
     59            (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
     60            (unless (eq? 'quit (msgval msg))
     61              (when (test msg)
     62                (thread-labeled-print "Test Match - Removing Message: " msg)
     63                (mailbox-cursor-extract-and-rewind! mbc) )
     64              (loop) ) ) ) ) ) )
    8665
    8766  ;;
    8867
    89   (define writer-thread-one)
    90   (define writer-thread-two)
    91   (when (< 0 wrtcnt) (set! writer-thread-one (make-thread writer-thread-body 'Writer-One)))
    92   (when (< 1 wrtcnt) (set! writer-thread-two (make-thread writer-thread-body 'Writer-Two)))
     68  (define writer-thread-one (make-thread writer-thread-body 'Writer-One))
     69
     70  (define writer-thread-two (make-thread writer-thread-body 'Writer-Two))
    9371
    9472  (define reader-thread-one
    … …  
    10583
    10684  (newline)
    107   (print "** Test Mailbox " knd " Cursor **")
    108   (print "Writers = " wrtcnt " Messages = " lmt " Timeout = " tmo " seconds")
     85  (print "** Test mailbox-cursor **")
     86  (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
    10987  (newline)
    11088
    11189  (thread-start! reader-thread-one)
    11290  (thread-start! reader-thread-two)
    113   (when (< 0 wrtcnt) (thread-start! writer-thread-one))
    114   (when (< 1 wrtcnt) (thread-start! writer-thread-two))
     91  (thread-start! writer-thread-one)
     92  (thread-start! writer-thread-two)
    11593
    116   (when (< 0 wrtcnt) (thread-join! writer-thread-one))
    117   (when (< 1 wrtcnt) (thread-join! writer-thread-two))
     94  (thread-join! writer-thread-one)
     95  (thread-join! writer-thread-two)
    11896  (thread-join! reader-thread-one)
    11997  (thread-join! reader-thread-two) )
    12098
    121 (test-mailbox-one 2 "Unlimited"   (make-unlimited-mailbox 'unlimited-one) MESSAGE-LIMIT TIMEOUT)
    122 (test-mailbox-one 2 "Limited"     (make-limited-mailbox 1 'limited-one) MESSAGE-LIMIT TIMEOUT)
    123 (test-mailbox-one 1 "Unbuffered"  (make-unbuffered-mailbox 'unbuffered-one) MESSAGE-LIMIT TIMEOUT)
    124 
    125 (newline)
    126 

  • release/5/mailbox/trunk/tests/mailbox-primordial-test.scm

    r39724 r39773  
    11;from caolan
    22
    3 (import (chicken condition) (srfi 18) mailbox)
     3(import (chicken condition))
     4(import (srfi 18))
     5(import mailbox)
    46
    57;;
    … …  
    4244
    4345(thread-join! test-thread-1)
    44 
    45 (newline)

  • release/5/mailbox/trunk/tests/reader-writer-test.scm

    r39731 r39773  
    33;;;
    44
    5 (import (chicken condition) (srfi 18) mailbox)
     5(import mailbox)
     6(import srfi-18)
    67
    78;;; Test support
    89
    9 ;(define-constant MESSAGE-LIMIT 5)
    10 (define-constant MESSAGE-LIMIT 3)
     10(define-constant MESSAGE-LIMIT 5)
    1111
    1212;(define-constant TIMEOUT 4)    ;slow but otherwise ok
    … …  
    3131  (apply print (current-thread-name) " - " args)
    3232  #; ;only 2 threads!
    33   (critical-section (apply print (current-thread-name) " - " args) ) )
     33        (critical-section (apply print (current-thread-name) " - " args) ) )
    3434
    3535(define (makmsg x) (cons (current-thread-name) x))
    … …  
    4040;;; Test mailbox
    4141
    42 (define (test-mailbox-one knd mb1 lmt tmo)
     42(let ((mailbox-one (make-mailbox 'one)))
    4343
    4444  (define writer-thread-one
    … …  
    4747        (thread-labeled-print "Started!")
    4848        (let loop ((cnt 0))
    49           (thread-labeled-print "Send! at " (current-seconds) " sec")
    50           (mailbox-send! mb1 (makmsg cnt))
    51           ;work
    52           (let ((sleep@seconds (current-seconds)))
    53             (thread-labeled-print "Sleep at " sleep@seconds " sec")
    54             (thread-sleep! tmo)
    55             (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec") )
    56           (if (= lmt cnt)
    57             (mailbox-send! mb1 (makmsg 'quit))
    58             (loop (add1 cnt)) ) ) )
     49          (thread-labeled-print "Sending at " (current-seconds) " sec")
     50          (mailbox-send! mailbox-one (makmsg cnt))
     51          (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
     52              (let ((sleep@seconds (current-seconds)))
     53                (thread-labeled-print "Sleep at " sleep@seconds " sec")
     54                (thread-sleep! TIMEOUT)
     55                (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
     56                (loop (add1 cnt)) ) ) ) )
    5957      'Writer-One) )
    6058
    … …  
    6765            (condition-case
    6866                (begin
    69                   (thread-labeled-print "Receive! at " rcv@sec  " sec")
    70                   (let ((msg (mailbox-receive! mb1 tmo)))
     67                  (thread-labeled-print "Receiving at " rcv@sec  " sec")
     68                  (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
    7169                    (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
    7270                    (unless (eq? 'quit (msgval msg))
    … …  
    8482
    8583  (newline)
    86   (print "** Test Mailbox " knd " **")
    87   (print "Message Limit = " lmt " Timeout = " tmo " seconds")
     84  (print "** Test mailbox **")
     85  (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
    8886  (newline)
    8987
    … …  
    9391  (thread-join! writer-thread-one)
    9492  (thread-join! reader-thread-one) )
    95 
    96 (test-mailbox-one "Unlimited"   (make-unlimited-mailbox 'unlimited-one) MESSAGE-LIMIT TIMEOUT)
    97 (test-mailbox-one "Limited"     (make-limited-mailbox 1 'limited-one) MESSAGE-LIMIT TIMEOUT)
    98 (test-mailbox-one "Unbuffered"  (make-unbuffered-mailbox 'unbuffered-one) MESSAGE-LIMIT TIMEOUT)
    99 
    100 (newline)
Note: See TracChangeset for help on using the changeset viewer.