Changeset 39743 in project


Ignore:
Timestamp:
03/19/21 18:06:02 (5 weeks ago)
Author:
Kon Lovett
Message:

remove define-inline (except record-variant), cursor test states quit sender

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

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/trunk/inline-queue.scm

    r39734 r39743  
    11;;;; inline-queue.scm  -*- Scheme -*-
     2;;;; Kon Lovett, Mar '21
    23;;;; Kon Lovett, Jun '10
    34
    45;; Issues
    56;;
    6 ;; - Uses (chicken fixnum) & (only record-variants define-record-type-variant)
     7;; - Uses (chicken fixnum), (srfi 1), & record-variants
    78
    89;; Queue Unlimited
     
    1112(define queue-unlimited 'queue-unlimited)
    1213(define-record-type-variant queue-unlimited (unsafe unchecked inline)
    13   (%make-queue-unlimited ln hd tl)
    14   (%queue-unlimited?)
    15   (ln %queue-unlimited-count %queue-unlimited-count-set!)
    16   (hd %queue-unlimited-first-pair %queue-unlimited-first-pair-set!)
    17   (tl %queue-unlimited-last-pair %queue-unlimited-last-pair-set!) )
    18 
    19 (define-inline (%make-empty-queue-unlimited)
    20   (%make-queue-unlimited 0 '() '()) )
    21 
    22 (define-inline (%queue-unlimited-limit q) most-positive-fixnum)
    23 
    24 (define-inline (%queue-unlimited-room q) (%queue-unlimited-limit q))
    25 
    26 (define-inline (%queue-unlimited-limit-set! q v)
    27   (error '%queue-unlimited-limit-set! "immutable" v))
    28 
    29 (define-inline (%queue-unlimited-count-add! q n)
    30   (%queue-unlimited-count-set! q (fx+ (%queue-unlimited-count q) n)) )
    31 
    32 (define-inline (%queue-unlimited-count-sub! q n)
    33   (%queue-unlimited-count-set! q (fx- (%queue-unlimited-count q) n)) )
    34 
    35 (define-inline (%queue-unlimited-empty? q #!optional (n 0))
    36   (fx<= (fx- (%queue-unlimited-count q) n) 0) )
    37 
    38 (define-inline (%queue-unlimited-full? q #!optional (n 0))
     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!) )
     19
     20(define (make-empty-queue-unlimited)
     21  (make-queue-unlimited 0 '() '()) )
     22
     23(define (queue-unlimited-limit q) most-positive-fixnum)
     24
     25(define (queue-unlimited-room q) (queue-unlimited-limit q))
     26
     27(define (queue-unlimited-limit-set! q v)
     28  (error 'queue-unlimited-limit-set! "immutable" v) )
     29
     30(define (queue-unlimited-count-add! q n)
     31  (queue-unlimited-count-set! q (fx+ (queue-unlimited-count q) n)) )
     32
     33(define (queue-unlimited-count-sub! q n)
     34  (queue-unlimited-count-set! q (fx- (queue-unlimited-count q) n)) )
     35
     36(define (queue-unlimited-empty? q #!optional (n 0))
     37  (fx<= (fx- (queue-unlimited-count q) n) 0) )
     38
     39(define (queue-unlimited-full? q #!optional (n 0))
    3940  #f )
    4041
    41 (define-inline (%queue-unlimited-extract-pair! q targ-pair)
     42(define (queue-unlimited-extract-pair! q targ-pair)
    4243  ;scan queue list until we find the item to remove
    43   (let scanning ((this-pair (%queue-unlimited-first-pair q)) (prev-pair '()))
     44  (let scanning ((this-pair (queue-unlimited-first-pair q)) (prev-pair '()))
    4445    ;keep scanning until found
    4546    (cond
     
    5455          ;at the head of the list, or in the body?
    5556          (if (null? prev-pair)
    56             (%queue-unlimited-first-pair-set! q next-pair)
     57            (queue-unlimited-first-pair-set! q next-pair)
    5758            (set-cdr! prev-pair next-pair) )
    5859          ;when the cut pair is the last item update the last pair ref.
    59           (when (eq? this-pair (%queue-unlimited-last-pair q))
    60             (%queue-unlimited-last-pair-set! q prev-pair) )
    61           (%queue-unlimited-count-sub! q 1) ) )
     60          (when (eq? this-pair (queue-unlimited-last-pair q))
     61            (queue-unlimited-last-pair-set! q prev-pair) )
     62          (queue-unlimited-count-sub! q 1) ) )
    6263      ;not found
    6364      (else
    6465        (scanning (cdr this-pair) this-pair) ) ) ) )
    6566
    66 (define-inline (%queue-unlimited-add! q v)
     67(define (queue-unlimited-add! q v)
    6768  (let ((new-pair (cons v '())))
    68     (if (null? (%queue-unlimited-first-pair q))
    69       (%queue-unlimited-first-pair-set! q new-pair)
    70       (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
    71     (%queue-unlimited-last-pair-set! q new-pair)
    72     (%queue-unlimited-count-add! q 1)) )
    73 
    74 (define-inline (%queue-unlimited-remove! q)
    75   (let* ((first-pair (%queue-unlimited-first-pair q))
     69    (if (null? (queue-unlimited-first-pair q))
     70      (queue-unlimited-first-pair-set! q new-pair)
     71      (set-cdr! (queue-unlimited-last-pair q) new-pair) )
     72    (queue-unlimited-last-pair-set! q new-pair)
     73    (queue-unlimited-count-add! q 1)) )
     74
     75(define (queue-unlimited-remove! q)
     76  (let* ((first-pair (queue-unlimited-first-pair q))
    7677         (next-pair (cdr first-pair)))
    77     (%queue-unlimited-first-pair-set! q next-pair)
    78     (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
    79     (%queue-unlimited-count-sub! q 1)
     78    (queue-unlimited-first-pair-set! q next-pair)
     79    (when (null? next-pair) (queue-unlimited-last-pair-set! q '()))
     80    (queue-unlimited-count-sub! q 1)
    8081    (car first-pair) ) )
    8182
    82 (define-inline (%queue-unlimited-push-back! q v)
    83   (let ((newlist (cons v (%queue-unlimited-first-pair q))))
    84     (%queue-unlimited-first-pair-set! q newlist)
    85     (when (null? (%queue-unlimited-last-pair q))
    86       (%queue-unlimited-last-pair-set! q newlist) )
    87     (%queue-unlimited-count-add! q 1) ) )
    88 
    89 (define-inline (%queue-unlimited-push-back-list! q ls)
    90   (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
    91     (%queue-unlimited-first-pair-set! q newlist)
     83(define (queue-unlimited-push-back! q v)
     84  (let ((newlist (cons v (queue-unlimited-first-pair q))))
     85    (queue-unlimited-first-pair-set! q newlist)
     86    (when (null? (queue-unlimited-last-pair q))
     87      (queue-unlimited-last-pair-set! q newlist) )
     88    (queue-unlimited-count-add! q 1) ) )
     89
     90(define (queue-unlimited-push-back-list! q ls)
     91  (let ((newlist (append! (list-copy ls) (queue-unlimited-first-pair q))))
     92    (queue-unlimited-first-pair-set! q newlist)
    9293    (if (null? newlist)
    93       (%queue-unlimited-last-pair-set! q '())
    94       (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
    95     (%queue-unlimited-count-add! q (length ls)) ) )
    96 
    97 (define-inline (%make-queue-unlimited-cursor) (cons '() #f))
    98 (define-inline (%queue-unlimited-cursor? c) (pair? c))
    99 (define-inline (%queue-unlimited-cursor-next-pair c) (car c))
    100 (define-inline (%queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
    101 (define-inline (%queue-unlimited-cursor-prev-pair c) (cdr c))
    102 (define-inline (%queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
    103 
    104 (define-inline (%queue-unlimited-cursor-winding? q c)
    105   (%->boolean (%queue-unlimited-cursor-prev-pair c)) )
    106 
    107 (define-inline (%queue-unlimited-cursor-unwound? q c)
    108   (null? (%queue-unlimited-cursor-next-pair c)) )
    109 
    110 (define-inline (%queue-unlimited-cursor-start! q c)
    111   ;(%queue-unlimited-cursor-prev-pair-set! c #f)
    112   (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-first-pair q)) )
     94      (queue-unlimited-last-pair-set! q '())
     95      (queue-unlimited-last-pair-set! q (last-pair newlist) ) )
     96    (queue-unlimited-count-add! q (length ls)) ) )
     97
     98(define (make-queue-unlimited-cursor) (cons '() #f))
     99(define (queue-unlimited-cursor? c) (pair? c))
     100(define (queue-unlimited-cursor-next-pair c) (car c))
     101(define (queue-unlimited-cursor-next-pair-set! c v) (set-car! c v))
     102(define (queue-unlimited-cursor-prev-pair c) (cdr c))
     103(define (queue-unlimited-cursor-prev-pair-set! c v) (set-cdr! c v))
     104
     105(define (queue-unlimited-cursor-winding? q c)
     106  (->boolean (queue-unlimited-cursor-prev-pair c)) )
     107
     108(define (queue-unlimited-cursor-unwound? q c)
     109  (null? (queue-unlimited-cursor-next-pair c)) )
     110
     111(define (queue-unlimited-cursor-start! q c)
     112  ;(queue-unlimited-cursor-prev-pair-set! c #f)
     113  (queue-unlimited-cursor-next-pair-set! c (queue-unlimited-first-pair q)) )
    113114
    114115;#!eof | *
    115 (define-inline (%queue-unlimited-cursor-next! q c)
    116   (let ((curr-pair (%queue-unlimited-cursor-next-pair c)))
     116(define (queue-unlimited-cursor-next! q c)
     117  (let ((curr-pair (queue-unlimited-cursor-next-pair c)))
    117118    ;anything next?
    118119    (if (null? curr-pair)
     
    120121      ;then peek into the queue for the next item
    121122      (let ((item (car curr-pair)))
    122         (%queue-unlimited-cursor-prev-pair-set! c curr-pair)
    123         (%queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
     123        (queue-unlimited-cursor-prev-pair-set! c curr-pair)
     124        (queue-unlimited-cursor-next-pair-set! c (cdr curr-pair))
    124125        item ) ) ) )
    125126
    126 (define-inline (%queue-unlimited-cursor-continue! q c)
     127(define (queue-unlimited-cursor-continue! q c)
    127128  ;NOTE assumes 1 next item, so prev-pair is still correct
    128   (%queue-unlimited-cursor-next-pair-set! c (%queue-unlimited-last-pair q)) )
    129 
    130 (define-inline (%queue-unlimited-cursor-rewind! q c)
    131   (%queue-unlimited-cursor-prev-pair-set! c #f)
    132   (%queue-unlimited-cursor-next-pair-set! c '()) )
    133 
    134 (define-inline (%queue-unlimited-cursor-extract! q c)
     129  (queue-unlimited-cursor-next-pair-set! c (queue-unlimited-last-pair q)) )
     130
     131(define (queue-unlimited-cursor-rewind! q c)
     132  (queue-unlimited-cursor-prev-pair-set! c #f)
     133  (queue-unlimited-cursor-next-pair-set! c '()) )
     134
     135(define (queue-unlimited-cursor-extract! q c)
    135136  ;unless 'mailbox-cursor-next' has been called don't remove
    136   (and-let* ((prev-pair (%queue-unlimited-cursor-prev-pair c)))
    137     (%queue-unlimited-extract-pair! q prev-pair) ) )
    138 
    139 (define-inline (%queue-unlimited-delete! q x)
    140   (let ((c (%make-queue-unlimited-cursor)))
    141     (%queue-unlimited-cursor-start! q c)
     137  (and-let* ((prev-pair (queue-unlimited-cursor-prev-pair c)))
     138    (queue-unlimited-extract-pair! q prev-pair) ) )
     139
     140(define (queue-unlimited-delete! q x)
     141  (let ((c (make-queue-unlimited-cursor)))
     142    (queue-unlimited-cursor-start! q c)
    142143    (let loop ()
    143       (let ((y (%queue-unlimited-cursor-next! q c)))
     144      (let ((y (queue-unlimited-cursor-next! q c)))
    144145        (cond
    145146          ((eof-object? y)
    146147            #f )
    147148          ((eq? x y)
    148             (%queue-unlimited-cursor-extract! q c)
     149            (queue-unlimited-cursor-extract! q c)
    149150            #t )
    150151          (else
    151152            (loop) ) ) ) ) ) )
    152153
    153 (define-inline (%queue-unlimited->list q)
    154   (let ((c (%make-queue-unlimited-cursor)))
    155     (%queue-unlimited-cursor-start! q c)
     154(define (queue-unlimited->list q)
     155  (let ((c (make-queue-unlimited-cursor)))
     156    (queue-unlimited-cursor-start! q c)
    156157    (let loop ((ls '()))
    157       (let ((y (%queue-unlimited-cursor-next! q c)))
     158      (let ((y (queue-unlimited-cursor-next! q c)))
    158159        (cond
    159160          ((eof-object? y)
     
    172173(define queue-limited 'queue-limited)
    173174(define-record-type-variant queue-limited (unsafe unchecked inline)
    174   (%make-queue-limited vc st ed)
    175   (%queue-limited?)
    176   (vc %queue-limited-vector %queue-limited-vector-set!)
    177   (st %queue-limited-start %queue-limited-start-set!)
    178   (ed %queue-limited-end %queue-limited-end-set!) )
    179 
    180 (define-inline (%make-empty-queue-limited lm)
     175  (make-queue-limited vc st ed)
     176  (queue-limited?)
     177  (vc queue-limited-vector queue-limited-vector-set!)
     178  (st queue-limited-start queue-limited-start-set!)
     179  (ed queue-limited-end queue-limited-end-set!) )
     180
     181(define (make-empty-queue-limited lm)
    181182  ;limit of 2 is lower-bound otherwise always s = e!
    182183  ;limit + 1 so
    183   (%make-queue-limited (make-vector (fx+ (fxmax 2 lm) 1) (void)) 0 0) )
    184 
    185 (define-inline (%queue-limited-peek q i)    (vector-ref (%queue-limited-vector q) i))
    186 (define-inline (%queue-limited-poke! q i v) (vector-set! (%queue-limited-vector q) i v))
    187 
    188 (define-inline (%queue-limited-limit q)
    189   (fx- (vector-length (%queue-limited-vector q)) 1) )
    190 
    191 (define-inline (%queue-limited-limit-set! q v)
    192   (error '%queue-limited-limit-set! "immutable" v) )
    193 
    194 (define-inline (%queue-limited-index-inc q i)
    195   (fxmod (fx+ i 1) (%queue-limited-limit q)) )
    196 
    197 (define-inline (%queue-limited-index-dec q i)
    198   (fxmod (fx+ i (fx- (%queue-limited-limit q) 1)) (%queue-limited-limit q)) )
    199 
    200 (define-inline (%queue-limited-start-inc! q)
    201   (%queue-limited-start-set! q (%queue-limited-index-inc q (%queue-limited-start q))) )
    202 
    203 (define-inline (%queue-limited-start-dec! q)
    204   (%queue-limited-start-set! q (%queue-limited-index-dec q (%queue-limited-start q))) )
    205 
    206 (define-inline (%queue-limited-end-inc! q)
    207   (%queue-limited-end-set! q (%queue-limited-index-inc q (%queue-limited-end q))) )
    208 
    209 (define-inline (%queue-limited-end-dec! q)
    210   (%queue-limited-end-set! q (%queue-limited-index-dec q (%queue-limited-end q))) )
    211 
    212 (define-inline (%queue-limited-count q)
    213   (fxabs (fx- (%queue-limited-end q) (%queue-limited-start q))) )
    214 
    215 (define-inline (%queue-limited-count-set! q v)
    216   (error '%queue-limited-count-set! "immutable" v) )
    217 
    218 (define-inline (%queue-limited-empty? q #!optional (n 0))
    219   (fx<= (fx- (%queue-limited-count q) n) 0) )
    220 
    221 (define-inline (%queue-limited-full? q #!optional (n 0))
    222   (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
    223 
    224 (define-inline (%queue-limited-room q)
    225   (fx- (%queue-limited-limit q) (%queue-limited-count q)) )
    226 
    227 (define-inline (%queue-limited-empty? q #!optional (n 0))
    228   (fx<= (fx- (%queue-limited-count q) n) 0) )
    229 
    230 (define-inline (%queue-limited-full? q #!optional (n 0))
    231   (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
    232 
    233 (define-inline (%queue-limited-add! q v)
    234   (%queue-limited-poke! q (%queue-limited-end q) v)
    235   (%queue-limited-end-inc! q) )
    236 
    237 (define-inline (%queue-limited-remove! q)
    238   (let ((v (%queue-limited-peek q (%queue-limited-start q))))
    239     (%queue-limited-start-inc! q)
     184  (make-queue-limited (make-vector (fx+ (fxmax 2 lm) 1) (void)) 0 0) )
     185
     186(define (queue-limited-peek q i)    (vector-ref (queue-limited-vector q) i))
     187(define (queue-limited-poke! q i v) (vector-set! (queue-limited-vector q) i v))
     188
     189(define (queue-limited-limit q)
     190  (fx- (vector-length (queue-limited-vector q)) 1) )
     191
     192(define (queue-limited-limit-set! q v)
     193  (error 'queue-limited-limit-set! "immutable" v) )
     194
     195(define (queue-limited-index-inc q i)
     196  (fxmod (fx+ i 1) (queue-limited-limit q)) )
     197
     198(define (queue-limited-index-dec q i)
     199  (fxmod (fx+ i (fx- (queue-limited-limit q) 1)) (queue-limited-limit q)) )
     200
     201(define (queue-limited-start-inc! q)
     202  (queue-limited-start-set! q (queue-limited-index-inc q (queue-limited-start q))) )
     203
     204(define (queue-limited-start-dec! q)
     205  (queue-limited-start-set! q (queue-limited-index-dec q (queue-limited-start q))) )
     206
     207(define (queue-limited-end-inc! q)
     208  (queue-limited-end-set! q (queue-limited-index-inc q (queue-limited-end q))) )
     209
     210(define (queue-limited-end-dec! q)
     211  (queue-limited-end-set! q (queue-limited-index-dec q (queue-limited-end q))) )
     212
     213(define (queue-limited-count q)
     214  (fxabs (fx- (queue-limited-end q) (queue-limited-start q))) )
     215
     216(define (queue-limited-count-set! q v)
     217  (error 'queue-limited-count-set! "immutable" v) )
     218
     219(define (queue-limited-empty? q #!optional (n 0))
     220  (fx<= (fx- (queue-limited-count q) n) 0) )
     221
     222(define (queue-limited-full? q #!optional (n 0))
     223  (fx>= (fx+ (queue-limited-count q) n) (queue-limited-limit q)) )
     224
     225(define (queue-limited-room q)
     226  (fx- (queue-limited-limit q) (queue-limited-count q)) )
     227
     228(define (queue-limited-empty? q #!optional (n 0))
     229  (fx<= (fx- (queue-limited-count q) n) 0) )
     230
     231(define (queue-limited-full? q #!optional (n 0))
     232  (fx>= (fx+ (queue-limited-count q) n) (queue-limited-limit q)) )
     233
     234(define (queue-limited-add! q v)
     235  (queue-limited-poke! q (queue-limited-end q) v)
     236  (queue-limited-end-inc! q) )
     237
     238(define (queue-limited-remove! q)
     239  (let ((v (queue-limited-peek q (queue-limited-start q))))
     240    (queue-limited-start-inc! q)
    240241    v ) )
    241242
    242 (define-inline (%queue-limited-push-back! q v)
    243   (%queue-limited-start-dec! q)
    244   (%queue-limited-poke! q (%queue-limited-start q) v) )
    245 
    246 (define-inline (%queue-limited-push-back-list! q ls)
     243(define (queue-limited-push-back! q v)
     244  (queue-limited-start-dec! q)
     245  (queue-limited-poke! q (queue-limited-start q) v) )
     246
     247(define (queue-limited-push-back-list! q ls)
    247248  ;assert enough room at the inn!
    248249  ;move "down" from start to start-1; kinda like extract below
    249   (let loop ((i (%queue-limited-start q)) (ls (reverse ls)))
     250  (let loop ((i (queue-limited-start q)) (ls (reverse ls)))
    250251    (if (null? ls)
    251       (%queue-limited-start-set! q i)
    252       (let ((i-1 (%queue-limited-index-dec q i)))
    253         (%queue-limited-poke! q i-1 (car ls))
     252      (queue-limited-start-set! q i)
     253      (let ((i-1 (queue-limited-index-dec q i)))
     254        (queue-limited-poke! q i-1 (car ls))
    254255        (loop i-1 (cdr ls)) ) ) ) )
    255256
    256 (define-inline (%make-queue-limited-cursor) (cons -1 (void)))
    257 (define-inline (%queue-limited-cursor? c) (pair? c))
    258 (define-inline (%queue-limited-cursor-index c) (car c))
    259 (define-inline (%queue-limited-cursor-index-set! c v) (set-car! c v))
    260 
    261 (define-inline (%queue-limited-cursor-winding? q c)
    262   (fx<= 0 (%queue-limited-cursor-index c)) )
    263 
    264 (define-inline (%queue-limited-cursor-unwound? q c)
    265   (fx= (%queue-limited-end q) (%queue-limited-cursor-index c)) )
    266 
    267 (define-inline (%queue-limited-cursor-start! q c)
    268   (%queue-limited-cursor-index-set! c (%queue-limited-start q)) )
     257(define (make-queue-limited-cursor) (cons -1 (void)))
     258(define (queue-limited-cursor? c) (pair? c))
     259(define (queue-limited-cursor-index c) (car c))
     260(define (queue-limited-cursor-index-set! c v) (set-car! c v))
     261
     262(define (queue-limited-cursor-winding? q c)
     263  (fx<= 0 (queue-limited-cursor-index c)) )
     264
     265(define (queue-limited-cursor-unwound? q c)
     266  (fx= (queue-limited-end q) (queue-limited-cursor-index c)) )
     267
     268(define (queue-limited-cursor-start! q c)
     269  (queue-limited-cursor-index-set! c (queue-limited-start q)) )
    269270
    270271;#!eof | *
    271 (define-inline (%queue-limited-cursor-next! q c)
    272   (cond
    273     ((%queue-limited-cursor-unwound? q c) #!eof)
     272(define (queue-limited-cursor-next! q c)
     273  (cond
     274    ((queue-limited-cursor-unwound? q c) #!eof)
    274275    (else
    275       (let ((v (%queue-limited-peek q (%queue-limited-cursor-index c))))
    276         (%queue-limited-cursor-index-set! c
    277           (%queue-limited-index-inc q (%queue-limited-cursor-index c)))
     276      (let ((v (queue-limited-peek q (queue-limited-cursor-index c))))
     277        (queue-limited-cursor-index-set! c
     278          (queue-limited-index-inc q (queue-limited-cursor-index c)))
    278279        v ) ) ) )
    279280
    280 (define-inline (%queue-limited-cursor-continue! q c)
    281   ;#; ;assert index is end - 1
    282   (%queue-limited-cursor-index-set! c
    283     (%queue-limited-index-dec q (%queue-limited-cursor-index c)))
    284   #; ;assert index is end - 1
    285   (%queue-limited-cursor-index-set! c
    286     (%queue-limited-index-dec q (%queue-limited-end q))) )
    287 
    288 (define-inline (%queue-limited-cursor-rewind! q c)
    289   (%queue-limited-cursor-index-set! c -1) )
    290 
    291 (define-inline (%queue-limited-cursor-extract! q c)
     281(define (queue-limited-cursor-continue! q c)
     282  (queue-limited-cursor-index-set! c
     283    (queue-limited-index-dec q (queue-limited-cursor-index c))) )
     284
     285(define (queue-limited-cursor-rewind! q c)
     286  (queue-limited-cursor-index-set! c -1) )
     287
     288(define (queue-limited-cursor-extract! q c)
    292289  ;unless 'mailbox-cursor-next' has been called don't remove
    293   (when (%queue-limited-cursor-winding? q c)
     290  (when (queue-limited-cursor-winding? q c)
    294291    ;move "up" from i-1 to i until i = start
    295     (let loop ((i (%queue-limited-index-dec q (%queue-limited-cursor-index c))))
    296       (let ((i-1 (%queue-limited-index-dec q i)))
    297         (%queue-limited-poke! q i (%queue-limited-peek q i-1))
    298         (if (fx= (%queue-limited-start q) i-1)
    299           (%queue-limited-start-set! q i)
     292    (let loop ((i (queue-limited-index-dec q (queue-limited-cursor-index c))))
     293      (let ((i-1 (queue-limited-index-dec q i)))
     294        (queue-limited-poke! q i (queue-limited-peek q i-1))
     295        (if (fx= (queue-limited-start q) i-1)
     296          (queue-limited-start-set! q i)
    300297          (loop i-1) ) ) ) ) )
     298
     299(define (queue-limited-delete! q x)
     300  (let ((c (make-queue-limited-cursor)))
     301    (queue-limited-cursor-start! q c)
     302    (let loop ()
     303      (let ((y (queue-limited-cursor-next! q c)))
     304        (cond
     305          ((eof-object? y)
     306            #f )
     307          ((eq? x y)
     308            (queue-limited-cursor-extract! q c)
     309            #t )
     310          (else
     311            (loop) ) ) ) ) ) )
     312
     313(define (queue-limited->list q)
     314  (let ((vc (queue-limited-vector q)) (st (queue-limited-start q)))
     315    (let loop ((ed (queue-limited-count q)) (ls '()))
     316      (if (fx= st ed)
     317        ls
     318        (let ((ed (queue-limited-index-dec q ed)))
     319          (loop ed (cons (vector-ref vc ed) ls)) ) ) ) ) )
    301320
    302321;; Queue Unbuffered
     
    305324(define queue-unbuffered 'queue-unbuffered)
    306325(define-record-type-variant queue-unbuffered (unsafe unchecked inline)
    307   (%make-queue-unbuffered vd vl)
    308   (%queue-unbuffered?)
    309   (vd %queue-unbuffered-maybe? %queue-unbuffered-maybe-set!)
    310   (vl %queue-unbuffered-value %queue-unbuffered-value-set!) )
    311 
    312 (define-inline (%make-empty-queue-unbuffered)
    313   (%make-queue-unbuffered #f (void)) )
    314 
    315 (define-inline (%queue-unbuffered-limit q) 1)
    316 
    317 (define-inline (%queue-unbuffered-limit-set! q v)
    318   (error '%queue-unbuffered-limit-set! "immutable" v) )
    319 
    320 (define-inline (%queue-unbuffered-count q)
    321   (if (%queue-unbuffered-maybe? q) 1 0) )
    322 
    323 (define-inline (%queue-unbuffered-count-set! q v)
    324   (error '%queue-unbuffered-count-set! "immutable" v) )
    325 
    326 (define-inline (%queue-unbuffered-empty? q #!optional (n 0))
     326  (make-queue-unbuffered vd vl)
     327  (queue-unbuffered?)
     328  (vd queue-unbuffered-maybe? queue-unbuffered-maybe-set!)
     329  (vl queue-unbuffered-value queue-unbuffered-value-set!) )
     330
     331(define (make-empty-queue-unbuffered)
     332  (make-queue-unbuffered #f (void)) )
     333
     334(define (queue-unbuffered-limit q) 1)
     335
     336(define (queue-unbuffered-limit-set! q v)
     337  (error 'queue-unbuffered-limit-set! "immutable" v) )
     338
     339(define (queue-unbuffered-count q)
     340  (if (queue-unbuffered-maybe? q) 1 0) )
     341
     342(define (queue-unbuffered-count-set! q v)
     343  (error 'queue-unbuffered-count-set! "immutable" v) )
     344
     345(define (queue-unbuffered-empty? q #!optional (n 0))
    327346  (or (fx< 0 n)
    328       (not (%queue-unbuffered-maybe? q))) )
    329 
    330 (define-inline (%queue-unbuffered-full? q #!optional (n 0))
     347      (not (queue-unbuffered-maybe? q))) )
     348
     349(define (queue-unbuffered-full? q #!optional (n 0))
    331350  (or (fx< 0 n)
    332       (%queue-unbuffered-maybe? q)) )
    333 
    334 (define-inline (%queue-unbuffered-room q)
    335   (if (%queue-unbuffered-maybe? q) 0 1) )
    336 
    337 (define-inline (%queue-unbuffered-add! q v)
    338   (%queue-unbuffered-maybe-set! q #t)
    339   (%queue-unbuffered-value-set! q v) )
    340 
    341 (define-inline (%queue-unbuffered-remove! q)
    342   (let ((v (%queue-unbuffered-value q)))
    343     (%queue-unbuffered-maybe-set! q #f)
    344     (%queue-unbuffered-value-set! q (void))
     351      (queue-unbuffered-maybe? q)) )
     352
     353(define (queue-unbuffered-room q)
     354  (if (queue-unbuffered-maybe? q) 0 1) )
     355
     356(define (queue-unbuffered-add! q v)
     357  (queue-unbuffered-maybe-set! q #t)
     358  (queue-unbuffered-value-set! q v) )
     359
     360(define (queue-unbuffered-remove! q)
     361  (let ((v (queue-unbuffered-value q)))
     362    (queue-unbuffered-maybe-set! q #f)
     363    (queue-unbuffered-value-set! q (void))
    345364    v ) )
    346365
    347 (define-inline (%queue-unbuffered-push-back! q v)
    348   (%queue-unbuffered-add! q v) )
    349 
    350 (define-inline (%queue-unbuffered-push-back-list! q ls)
     366(define (queue-unbuffered-push-back! q v)
     367  (queue-unbuffered-add! q v) )
     368
     369(define (queue-unbuffered-push-back-list! q ls)
    351370  ;assert length ls = 1
    352   (%queue-unbuffered-add! q (car ls)) )
    353 
    354 (define-inline (%make-queue-unbuffered-cursor) (cons -1 (void)))
    355 (define-inline (%queue-unbuffered-cursor? c) (pair? c))
    356 (define-inline (%queue-unbuffered-cursor-index c) (car c))
    357 (define-inline (%queue-unbuffered-cursor-index-set! c v) (set-car! c v))
    358 
    359 (define-inline (%queue-unbuffered-cursor-winding? q c)
    360   (fx<= 0 (%queue-unbuffered-cursor-index c)) )
    361 
    362 (define-inline (%queue-unbuffered-cursor-unwound? q c)
    363   (fx= 1 (%queue-unbuffered-cursor-index c)) )
    364 
    365 (define-inline (%queue-unbuffered-cursor-start! q c)
    366   (%queue-unbuffered-cursor-index-set! c 0) )
     371  (queue-unbuffered-add! q (car ls)) )
     372
     373(define (make-queue-unbuffered-cursor) (cons -1 (void)))
     374(define (queue-unbuffered-cursor? c) (pair? c))
     375(define (queue-unbuffered-cursor-index c) (car c))
     376(define (queue-unbuffered-cursor-index-set! c v) (set-car! c v))
     377
     378(define (queue-unbuffered-cursor-winding? q c)
     379  (fx<= 0 (queue-unbuffered-cursor-index c)) )
     380
     381(define (queue-unbuffered-cursor-unwound? q c)
     382  (fx= 1 (queue-unbuffered-cursor-index c)) )
     383
     384(define (queue-unbuffered-cursor-start! q c)
     385  (queue-unbuffered-cursor-index-set! c 0) )
    367386
    368387;#!eof | *
    369 (define-inline (%queue-unbuffered-cursor-next! q c)
    370   (cond
    371     ((%queue-unbuffered-cursor-unwound? q c) #!eof)
    372     ((not (%queue-unbuffered-maybe? q))       #!eof)
     388(define (queue-unbuffered-cursor-next! q c)
     389  (cond
     390    ((queue-unbuffered-cursor-unwound? q c) #!eof)
     391    ((not (queue-unbuffered-maybe? q))      #!eof)
    373392    (else
    374       (%queue-unbuffered-cursor-index-set! c 1)
    375       (%queue-unbuffered-value q) ) ) )
    376 
    377 (define-inline (%queue-unbuffered-cursor-continue! q c)
    378   (%queue-unbuffered-cursor-index-set! c 0) )
    379 
    380 (define-inline (%queue-unbuffered-cursor-rewind! q c)
    381   (%queue-unbuffered-cursor-index-set! c -1) )
    382 
    383 (define-inline (%queue-unbuffered-cursor-extract! q c)
     393      (queue-unbuffered-cursor-index-set! c 1)
     394      (queue-unbuffered-value q) ) ) )
     395
     396(define (queue-unbuffered-cursor-continue! q c)
     397  (queue-unbuffered-cursor-index-set! c 0) )
     398
     399(define (queue-unbuffered-cursor-rewind! q c)
     400  (queue-unbuffered-cursor-index-set! c -1) )
     401
     402(define (queue-unbuffered-cursor-extract! q c)
    384403  ;unless 'mailbox-cursor-next' has been called don't remove
    385   (when (%queue-unbuffered-cursor-winding? q c)
    386     (%queue-unbuffered-maybe-set! q #f) ) )
     404  (when (queue-unbuffered-cursor-winding? q c)
     405    (queue-unbuffered-maybe-set! q #f) ) )
     406
     407(define (queue-unbuffered-delete! q x)
     408  (when (and (queue-unbuffered-maybe? q) (eq? (queue-unbuffered-value q) x))
     409    (queue-unbuffered-maybe-set! q #f) ) )
     410
     411(define (queue-unbuffered->list q)
     412  (if (queue-unbuffered-maybe? q)
     413    (list (queue-unbuffered-value q ))
     414    '() ) )
    387415
    388416;; Queue Generic
    389417
    390 (define-inline (%valid-queue-limit? lm)
     418(define (valid-queue-limit? lm)
    391419  (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
    392420
    393 (define-inline (%make-empty-queue lm)
    394   ;(assert (%valid-queue-limit? lm))
    395   (cond
    396     ((not lm)       (%make-empty-queue-unlimited))
    397     ((fixnum? lm)   (%make-empty-queue-limited lm))
    398     (else           (%make-empty-queue-unbuffered)) ) )
    399 
    400 (define-inline (%queue? x)
     421(define (make-empty-queue lm)
     422  ;(assert (valid-queue-limit? lm))
     423  (cond
     424    ((not lm)       (make-empty-queue-unlimited))
     425    ((fixnum? lm)   (make-empty-queue-limited lm))
     426    (else           (make-empty-queue-unbuffered)) ) )
     427
     428(define (queue? x)
    401429  (or
    402     (%queue-unlimited? x)
    403     (%queue-limited? x)
    404     (%queue-unbuffered? x) ) )
    405 
    406 (define-inline (%queue-limit q)
    407   (cond
    408     ((%queue-unlimited? q)  (%queue-unlimited-limit q))
    409     ((%queue-limited? q)    (%queue-limited-limit q))
    410     (else                   (%queue-unbuffered-limit q)) ) )
    411 
    412 (define-inline (%queue-limit-set! q v)
    413   (cond
    414     ((%queue-unlimited? q)  (%queue-unlimited-limit-set! q v))
    415     ((%queue-limited? q)    (%queue-limited-limit-set! q v))
    416     (else                   (%queue-unbuffered-limit-set! q v)) ) )
    417 
    418 (define-inline (%queue-count q)
    419   (cond
    420     ((%queue-unlimited? q)  (%queue-unlimited-count q))
    421     ((%queue-limited? q)    (%queue-limited-count q))
    422     (else                   (%queue-unbuffered-count q)) ) )
    423 
    424 (define-inline (%queue-count-set! q v)
    425   (cond
    426     ((%queue-unlimited? q)  (%queue-unlimited-count-set! q v))
    427     ((%queue-limited? q)    (%queue-limited-count-set! q v))
    428     (else                   (%queue-unbuffered-count-set! q v)) ) )
    429 
    430 (define-inline (%queue-room q)
    431   (cond
    432     ((%queue-unlimited? q)  (%queue-unlimited-room q))
    433     ((%queue-limited? q)    (%queue-limited-room q))
    434     (else                   (%queue-unbuffered-room q)) ) )
    435 
    436 (define-inline (%queue-empty? q #!optional (n 0))
    437   (cond
    438     ((%queue-unlimited? q)  (%queue-unlimited-empty? q))
    439     ((%queue-limited? q)    (%queue-limited-empty? q))
    440     (else                   (%queue-unbuffered-empty? q)) ) )
    441 
    442 (define-inline (%queue-full? q #!optional (n 0))
    443   (cond
    444     ((%queue-unlimited? q)  (%queue-unlimited-full? q))
    445     ((%queue-limited? q)    (%queue-limited-full? q))
    446     (else                   (%queue-unbuffered-full? q)) ) )
     430    (queue-unlimited? x)
     431    (queue-limited? x)
     432    (queue-unbuffered? x) ) )
     433
     434(define (queue-limit q)
     435  (cond
     436    ((queue-unlimited? q)  (queue-unlimited-limit q))
     437    ((queue-limited? q)    (queue-limited-limit q))
     438    (else                  (queue-unbuffered-limit q)) ) )
     439
     440(define (queue-limit-set! q v)
     441  (cond
     442    ((queue-unlimited? q)  (queue-unlimited-limit-set! q v))
     443    ((queue-limited? q)    (queue-limited-limit-set! q v))
     444    (else                  (queue-unbuffered-limit-set! q v)) ) )
     445
     446(define (queue-count q)
     447  (cond
     448    ((queue-unlimited? q)  (queue-unlimited-count q))
     449    ((queue-limited? q)    (queue-limited-count q))
     450    (else                  (queue-unbuffered-count q)) ) )
     451
     452(define (queue-count-set! q v)
     453  (cond
     454    ((queue-unlimited? q)  (queue-unlimited-count-set! q v))
     455    ((queue-limited? q)    (queue-limited-count-set! q v))
     456    (else                  (queue-unbuffered-count-set! q v)) ) )
     457
     458(define (queue-room q)
     459  (cond
     460    ((queue-unlimited? q)  (queue-unlimited-room q))
     461    ((queue-limited? q)    (queue-limited-room q))
     462    (else                  (queue-unbuffered-room q)) ) )
     463
     464(define (queue-empty? q #!optional (n 0))
     465  (cond
     466    ((queue-unlimited? q)  (queue-unlimited-empty? q))
     467    ((queue-limited? q)    (queue-limited-empty? q))
     468    (else                  (queue-unbuffered-empty? q)) ) )
     469
     470(define (queue-full? q #!optional (n 0))
     471  (cond
     472    ((queue-unlimited? q)  (queue-unlimited-full? q))
     473    ((queue-limited? q)    (queue-limited-full? q))
     474    (else                  (queue-unbuffered-full? q)) ) )
    447475
    448476(define (queue-empty-error loc q) (error loc "queue empty" q))
    449477(define (queue-full-error loc q v) (error loc "queue full" q v))
    450478
    451 (define-inline (%queue-add!? q v)
    452   (if (%queue-full? q)
     479(define (queue-add!? q v)
     480  (if (queue-full? q)
    453481    (values #f (void))
    454482    (values #t
    455483      (cond
    456         ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
    457         ((%queue-limited? q)    (%queue-limited-add! q v))
    458         (else                   (%queue-unbuffered-add! q v)))) ) )
    459 
    460 (define-inline (%queue-remove!? q)
    461   (if (%queue-empty? q)
     484        ((queue-unlimited? q)  (queue-unlimited-add! q v))
     485        ((queue-limited? q)    (queue-limited-add! q v))
     486        (else                  (queue-unbuffered-add! q v)))) ) )
     487
     488(define (queue-remove!? q)
     489  (if (queue-empty? q)
    462490    (values #f (void))
    463491    (values #t
    464492      (cond
    465         ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
    466         ((%queue-limited? q)    (%queue-limited-remove! q))
    467         (else                   (%queue-unbuffered-remove! q)))) ) )
    468 
    469 (define-inline (%queue-push-back!? q v)
    470   (if (%queue-full? q)
     493        ((queue-unlimited? q)  (queue-unlimited-remove! q))
     494        ((queue-limited? q)    (queue-limited-remove! q))
     495        (else                  (queue-unbuffered-remove! q)))) ) )
     496
     497(define (queue-push-back!? q v)
     498  (if (queue-full? q)
    471499    (values #f (void))
    472500    (values #t
    473501      (cond
    474         ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
    475         ((%queue-limited? q)    (%queue-limited-push-back! q v))
    476         (else                   (%queue-unbuffered-push-back! q v)))) ) )
    477 
    478 (define-inline (%queue-push-back-list!? q ls)
    479   (if (%queue-full? q (length ls))
     502        ((queue-unlimited? q)  (queue-unlimited-push-back! q v))
     503        ((queue-limited? q)    (queue-limited-push-back! q v))
     504        (else                  (queue-unbuffered-push-back! q v)))) ) )
     505
     506(define (queue-push-back-list!? q ls)
     507  (if (queue-full? q (length ls))
    480508    (values #f (void))
    481509    (values #t
    482510      (cond
    483         ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
    484         ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
    485         (else                   (%queue-unbuffered-push-back-list! q ls)))) ) )
    486 
    487 (define-inline (%queue-add! q v
     511        ((queue-unlimited? q)  (queue-unlimited-push-back-list! q ls))
     512        ((queue-limited? q)    (queue-limited-push-back-list! q ls))
     513        (else                  (queue-unbuffered-push-back-list! q ls)))) ) )
     514
     515(define (queue-add! q v
    488516                  #!optional
    489                   (on-full (lambda () (queue-full-error '%queue-add! q v))))
     517                  (on-full (lambda () (queue-full-error 'queue-add! q v))))
    490518  (let loop ()
    491     (let-values (((succ? val) (%queue-add!? q v)))
     519    (let-values (((succ? val) (queue-add!? q v)))
    492520      (unless succ?
    493521        (on-full)
     
    495523      val ) ) )
    496524
    497 (define-inline (%queue-remove! q
     525(define (queue-remove! q
    498526                  #!optional
    499                   (on-empty (lambda () (queue-empty-error '%queue-remove! q))))
     527                  (on-empty (lambda () (queue-empty-error 'queue-remove! q))))
    500528  (let loop ()
    501     (let-values (((succ? val) (%queue-remove!? q)))
     529    (let-values (((succ? val) (queue-remove!? q)))
    502530      (unless succ?
    503531        (on-empty)
     
    505533      val ) ) )
    506534
    507 (define-inline (%queue-push-back! q v
     535(define (queue-push-back! q v
    508536                  #!optional
    509                   (on-full (lambda () (queue-full-error '%queue-push-back! q v))))
     537                  (on-full (lambda () (queue-full-error 'queue-push-back! q v))))
    510538  (let loop ()
    511     (let-values (((succ? val) (%queue-push-back!? q v)))
     539    (let-values (((succ? val) (queue-push-back!? q v)))
    512540      (unless succ?
    513541        (on-full)
     
    515543      val ) ) )
    516544
    517 (define-inline (%queue-push-back-list! q ls
     545(define (queue-push-back-list! q ls
    518546                  #!optional
    519                   (on-full (lambda () (queue-full-error '%queue-push-back-list! q ls))))
     547                  (on-full (lambda () (queue-full-error 'queue-push-back-list! q ls))))
    520548  (let loop ()
    521     (let-values (((succ? val) (%queue-push-back-list!? q ls)))
     549    (let-values (((succ? val) (queue-push-back-list!? q ls)))
    522550      (unless succ?
    523551        (on-full)
     
    525553      val ) ) )
    526554
    527 (define-inline (%make-queue-cursor q)
    528   (cond
    529     ((%queue-unlimited? q)  (%make-queue-unlimited-cursor))
    530     ((%queue-limited? q)    (%make-queue-limited-cursor))
    531     (else                   (%make-queue-unbuffered-cursor)) ) )
    532 
    533 (define-inline (%queue-cursor-winding? q c)
    534   (cond
    535     ((%queue-unlimited? q)  (%queue-unlimited-cursor-winding? q c))
    536     ((%queue-limited? q)    (%queue-limited-cursor-winding? q c))
    537     (else                   (%queue-unbuffered-cursor-winding? q c)) ) )
    538 
    539 (define-inline (%queue-cursor-unwound? q c)
    540   (cond
    541     ((%queue-unlimited? q)  (%queue-unlimited-cursor-unwound? q c))
    542     ((%queue-limited? q)    (%queue-limited-cursor-unwound? q c))
    543     (else                   (%queue-unbuffered-cursor-unwound? q c)) ) )
    544 
    545 (define-inline (%queue-cursor-rewind! q c)
    546   (cond
    547     ((%queue-unlimited? q)  (%queue-unlimited-cursor-rewind! q c))
    548     ((%queue-limited? q)    (%queue-limited-cursor-rewind! q c))
    549     (else                   (%queue-unbuffered-cursor-rewind! q c)) ) )
    550 
    551 (define-inline (%queue-cursor-start! q c)
    552   (cond
    553     ((%queue-unlimited? q)  (%queue-unlimited-cursor-start! q c))
    554     ((%queue-limited? q)    (%queue-limited-cursor-start! q c))
    555     (else                   (%queue-unbuffered-cursor-start! q c)) ))
     555(define (make-queue-cursor q)
     556  (cond
     557    ((queue-unlimited? q)  (make-queue-unlimited-cursor))
     558    ((queue-limited? q)    (make-queue-limited-cursor))
     559    (else                  (make-queue-unbuffered-cursor)) ) )
     560
     561(define (queue-cursor-winding? q c)
     562  (cond
     563    ((queue-unlimited? q)  (queue-unlimited-cursor-winding? q c))
     564    ((queue-limited? q)    (queue-limited-cursor-winding? q c))
     565    (else                  (queue-unbuffered-cursor-winding? q c)) ) )
     566
     567(define (queue-cursor-unwound? q c)
     568  (cond
     569    ((queue-unlimited? q)  (queue-unlimited-cursor-unwound? q c))
     570    ((queue-limited? q)    (queue-limited-cursor-unwound? q c))
     571    (else                  (queue-unbuffered-cursor-unwound? q c)) ) )
     572
     573(define (queue-cursor-rewind! q c)
     574  (cond
     575    ((queue-unlimited? q)  (queue-unlimited-cursor-rewind! q c))
     576    ((queue-limited? q)    (queue-limited-cursor-rewind! q c))
     577    (else                  (queue-unbuffered-cursor-rewind! q c)) ) )
     578
     579(define (queue-cursor-start! q c)
     580  (cond
     581    ((queue-unlimited? q)  (queue-unlimited-cursor-start! q c))
     582    ((queue-limited? q)    (queue-limited-cursor-start! q c))
     583    (else                  (queue-unbuffered-cursor-start! q c)) ))
    556584
    557585;#!eof | *
    558 (define-inline (%queue-cursor-next! q c)
     586(define (queue-cursor-next! q c)
    559587 (cond
    560     ((%queue-unlimited? q)  (%queue-unlimited-cursor-next! q c))
    561     ((%queue-limited? q)    (%queue-limited-cursor-next! q c))
    562     (else                   (%queue-unbuffered-cursor-next! q c)) ))
    563 
    564 (define-inline (%queue-cursor-continue! q c)
     588    ((queue-unlimited? q)  (queue-unlimited-cursor-next! q c))
     589    ((queue-limited? q)    (queue-limited-cursor-next! q c))
     590    (else                  (queue-unbuffered-cursor-next! q c)) ))
     591
     592(define (queue-cursor-continue! q c)
    565593 (cond
    566     ((%queue-unlimited? q)  (%queue-unlimited-cursor-continue! q c))
    567     ((%queue-limited? q)    (%queue-limited-cursor-continue! q c))
    568     (else                   (%queue-unbuffered-cursor-continue! q c)) ))
    569 
    570 (define-inline (%queue-cursor-extract! q c)
    571   (cond
    572     ((%queue-unlimited? q)  (%queue-unlimited-cursor-extract! q c))
    573     ((%queue-limited? q)    (%queue-limited-cursor-extract! q c))
    574     (else                   (%queue-unbuffered-cursor-extract! q c)) ) )
    575 
    576 (define-inline (%queue-delete! q x)
    577   (cond
    578     ((%queue-unlimited? q)  (%queue-unlimited-delete! q x))
    579     (else
    580       (let ((c (%make-queue-cursor)))
    581         (%queue-cursor-start! q c)
    582         (let loop ()
    583           (let ((y (%queue-cursor-next! q c)))
    584             (cond
    585               ((eof-object? y)
    586                 #f )
    587               ((eq? x y)
    588                 (%queue-cursor-extract! q c)
    589                 #t )
    590               (else
    591                 (loop) ) ) ) ) ) ) ) )
    592 
    593 (define-inline (%queue->list q)
    594   (cond
    595     ((%queue-unlimited? q)  (%queue-unlimited->list q))
    596     (else
    597       (let ((c (%make-queue-cursor)))
    598         (%queue-cursor-start! q c)
    599         (let loop ((ls '()))
    600           (let ((y (%queue-cursor-next! q c)))
    601             (cond
    602               ((eof-object? y)
    603                 (reverse! ls) )
    604               (else
    605                 (loop (cons y ls)) ) ) ) ) ) ) ) )
     594    ((queue-unlimited? q)  (queue-unlimited-cursor-continue! q c))
     595    ((queue-limited? q)    (queue-limited-cursor-continue! q c))
     596    (else                  (queue-unbuffered-cursor-continue! q c)) ))
     597
     598(define (queue-cursor-extract! q c)
     599  (cond
     600    ((queue-unlimited? q)  (queue-unlimited-cursor-extract! q c))
     601    ((queue-limited? q)    (queue-limited-cursor-extract! q c))
     602    (else                  (queue-unbuffered-cursor-extract! q c)) ) )
     603
     604(define (queue-delete! q x)
     605  (cond
     606    ((queue-unlimited? q)  (queue-unlimited-delete! q x))
     607    ((queue-limited? q)    (queue-limited-delete! q x))
     608    (else                  (queue-unbuffered-delete! q x)) ) )
     609
     610(define (queue->list q)
     611  (cond
     612    ((queue-unlimited? q)  (queue-unlimited->list q))
     613    ((queue-limited? q)    (queue-limited->list q))
     614    (else                  (queue-unbuffered->list q)) ) )
  • release/5/mailbox/trunk/inline-type-checks.scm

    r39708 r39743  
    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))) )
  • release/5/mailbox/trunk/mailbox.scm

    r39734 r39743  
    4747  mailbox-count
    4848  mailbox-limit
    49   mailbox-waiting?
     49  mailbox-read-waiting?
     50  mailbox-write-waiting?
    5051  mailbox-read-waiters
    5152  mailbox-write-waiters
     
    6566  mailbox-cursor-extract-and-rewind!
    6667  ;deprecated
     68  mailbox-waiting?
    6769  mailbox-waiters)
    6870
     
    103105(: mailbox-count                      (mailbox -> fixnum))
    104106(: mailbox-limit                      (mailbox --> fixnum))
    105 (: mailbox-waiting?                   (mailbox -> boolean))
     107(: mailbox-read-waiting?              (mailbox -> boolean))
     108(: mailbox-write-waiting?             (mailbox -> boolean))
     109(: mailbox-waiting?                   (deprecated mailbox-write-waiting?))
    106110(: mailbox-read-waiters               (mailbox -> list))
    107111(: mailbox-write-waiters              (mailbox -> list))
     
    222226;;fx-utils
    223227
    224 (define-inline (fxneg? n) (fx< n 0))
    225 (define-inline (fxabs n) (if (fxneg? n) (fxneg n) n))
    226 
    227 ;;(only type-errors define-error-type)
     228(define (fxneg? n) (fx< n 0))
     229(define (fxabs n) (if (fxneg? n) (fxneg n) n))
     230
     231;;check-errors
    228232
    229233(define (make-bad-argument-message #!optional argnam)
     
    244248  (##sys#signal-hook #:type-error loc obj (make-error-type-message 'list argnam) obj) )
    245249
     250(define-inline (%list? x) (list? x))
    246251(include-relative "inline-type-checks")
    247252
    248 ;;
    249 
    250 (define-inline (%thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
    251 (define-inline (%thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
    252 
    253 (define-inline (%->boolean obj) (and obj #t))
    254 
    255 (define-inline (%make-unique-object #!optional (id 'unique)) (vector id))
     253;;moremacros
     254
     255(define (->boolean obj) (and obj #t))
     256
     257;;thread-utils
     258
     259(define (thread-blocked? th) (eq? 'blocked (##sys#slot th 3)))
     260(define (thread-blocked-for-timeout? th) (and (##sys#slot th 4) (not (##sys#slot th 11))))
     261(define (thread-unblock! th) (##sys#thread-unblock! th))
    256262
    257263;; Time Support
    258264
    259 (define-inline (%time-number? x)  (or (fixnum? x) (flonum? x)))
    260 (define-inline (%timeout? x)      (or (%time-number? x) (time? x)))
     265(define (time-number? x)  (or (fixnum? x) (flonum? x)))
     266(define (timeout? x)      (or (time-number? x) (time? x)))
    261267
    262268(define (error-timeout loc obj #!optional argnam)
     
    264270
    265271;chgd to drop `%' prefix
    266 (define (timeout? obj) (%timeout? obj))
     272(define-inline (%timeout? x) (timeout? x))
    267273(define-inline-check-type timeout)
    268274
     
    276282(define mailbox 'mailbox)
    277283(define-record-type-variant mailbox (unsafe unchecked inline)
    278   (%raw-make-mailbox nm qu rd wt)
     284  (%make-mailbox nm qu rd wt)
    279285  (%mailbox?)
    280286  (nm %mailbox-name)
     
    283289  (wt %mailbox-write-waiters) )
    284290
    285 (define-inline (%make-mailbox loc nm lm)
    286   (unless (%valid-queue-limit? lm)
     291(define (*make-mailbox loc nm lm)
     292  (unless (valid-queue-limit? lm)
    287293    (error loc "invalid limit" lm nm) )
    288   (%raw-make-mailbox nm
    289     (%make-empty-queue lm)
    290     (%make-empty-queue-unlimited)
    291     (%make-empty-queue-unlimited)) )
     294  (%make-mailbox nm
     295    (make-empty-queue lm)
     296    (make-empty-queue-unlimited)
     297    (make-empty-queue-unlimited)) )
    292298
    293299(define (error-mailbox loc obj #!optional argnam)
     
    298304;; Message queue
    299305
    300 (define-inline (%mailbox-queue-empty? mb)
    301   (%queue-empty? (%mailbox-queue mb)) )
    302 
    303 (define-inline (%mailbox-queue-full? mb)
    304   (%queue-full? (%mailbox-queue mb)) )
    305 
    306 (define-inline (%mailbox-queue-count mb)
    307   (%queue-count (%mailbox-queue mb)) )
    308 
    309 (define-inline (%mailbox-queue-limit mb)
    310   (%queue-limit (%mailbox-queue mb)) )
    311 
    312 (define-inline (%mailbox-queue-add! mb x)
    313   (%queue-add! (%mailbox-queue mb) x) )
    314 
    315 (define-inline (%mailbox-queue-remove! mb)
    316   (%queue-remove! (%mailbox-queue mb)) )
    317 
    318 (define-inline (%mailbox-queue-push-back! mb x)
    319   (%queue-push-back! (%mailbox-queue mb) x) )
    320 
    321 (define-inline (%mailbox-queue-push-back-list! mb ls)
    322   (%queue-push-back-list! (%mailbox-queue mb) ls) )
     306(define (mailbox-queue-empty? mb)
     307  (queue-empty? (%mailbox-queue mb)) )
     308
     309(define (mailbox-queue-full? mb)
     310  (queue-full? (%mailbox-queue mb)) )
     311
     312(define (mailbox-queue-count mb)
     313  (queue-count (%mailbox-queue mb)) )
     314
     315(define (mailbox-queue-limit mb)
     316  (queue-limit (%mailbox-queue mb)) )
     317
     318(define (mailbox-queue-add! mb x)
     319  (queue-add! (%mailbox-queue mb) x) )
     320
     321(define (mailbox-queue-remove! mb)
     322  (queue-remove! (%mailbox-queue mb)) )
     323
     324(define (mailbox-queue-push-back! mb x)
     325  (queue-push-back! (%mailbox-queue mb) x) )
     326
     327(define (mailbox-queue-push-back-list! mb ls)
     328  (queue-push-back-list! (%mailbox-queue mb) ls) )
    323329
    324330;; Waiting threads
    325331
     332(define (mailbox-waiter-queue-name mb wq)
     333  (cond
     334    ((%mailbox-read-waiters mb) 'read)
     335    ((%mailbox-write-waiters mb) 'write)
     336    (else
     337      (error 'mailbox-waiter-queue-name "not mailbox waiter" mb wq)) ) )
     338
    326339;read
    327340
    328 (define-inline (%mailbox-read-waiters-empty? mb)
    329   (%queue-unlimited-empty? (%mailbox-read-waiters mb)) )
    330 
    331 (define-inline (%mailbox-read-waiters-full? mb)
    332   (%queue-unlimited-full? (%mailbox-read-waiters mb)) )
    333 
    334 (define-inline (%mailbox-read-waiters-count mb)
    335  (%queue-unlimited-count (%mailbox-read-waiters mb)) )
    336 
    337 (define-inline (%mailbox-read-waiters-add! mb th)
    338   (%queue-unlimited-add! (%mailbox-read-waiters mb) th) )
    339 
    340 (define-inline (%mailbox-read-waiters-delete! mb th)
    341   (%queue-unlimited-delete! (%mailbox-read-waiters mb) th) )
    342 
    343 (define-inline (%mailbox-read-waiters-pop! mb)
    344   (%queue-unlimited-remove! (%mailbox-read-waiters mb)) )
    345 
    346 (define (%mailbox-read-waiters->list mb)
    347   (%queue-unlimited->list (%mailbox-read-waiters mb)) )
     341(define (mailbox-read-waiters-empty? mb)
     342  (queue-unlimited-empty? (%mailbox-read-waiters mb)) )
     343
     344(define (mailbox-read-waiters-full? mb)
     345  (queue-unlimited-full? (%mailbox-read-waiters mb)) )
     346
     347(define (mailbox-read-waiters-count mb)
     348 (queue-unlimited-count (%mailbox-read-waiters mb)) )
     349
     350(define (mailbox-read-waiters-add! mb th)
     351  (queue-unlimited-add! (%mailbox-read-waiters mb) th) )
     352
     353(define (mailbox-read-waiters-delete! mb th)
     354  (queue-unlimited-delete! (%mailbox-read-waiters mb) th) )
     355
     356(define (mailbox-read-waiters-pop! mb)
     357  (queue-unlimited-remove! (%mailbox-read-waiters mb)) )
     358
     359(define (mailbox-read-waiters->list mb)
     360  (queue-unlimited->list (%mailbox-read-waiters mb)) )
    348361
    349362;write
    350363
    351 (define-inline (%mailbox-write-waiters-empty? mb)
    352   (%queue-unlimited-empty? (%mailbox-write-waiters mb)) )
    353 
    354 (define-inline (%mailbox-write-waiters-count mb)
    355  (%queue-unlimited-count (%mailbox-write-waiters mb)) )
    356 
    357 (define-inline (%mailbox-write-waiters-add! mb th)
    358   (%queue-unlimited-add! (%mailbox-write-waiters mb) th) )
    359 
    360 (define-inline (%mailbox-write-waiters-delete! mb th)
    361   (%queue-unlimited-delete! (%mailbox-write-waiters mb) th) )
    362 
    363 (define-inline (%mailbox-write-waiters-pop! mb)
    364   (%queue-unlimited-remove! (%mailbox-write-waiters mb)) )
    365 
    366 (define (%mailbox-write-waiters->list mb)
    367   (%queue-unlimited->list (%mailbox-write-waiters mb)) )
     364(define (mailbox-write-waiters-empty? mb)
     365  (queue-unlimited-empty? (%mailbox-write-waiters mb)) )
     366
     367(define (mailbox-write-waiters-count mb)
     368 (queue-unlimited-count (%mailbox-write-waiters mb)) )
     369
     370(define (mailbox-write-waiters-add! mb th)
     371  (queue-unlimited-add! (%mailbox-write-waiters mb) th) )
     372
     373(define (mailbox-write-waiters-delete! mb th)
     374  (queue-unlimited-delete! (%mailbox-write-waiters mb) th) )
     375
     376(define (mailbox-write-waiters-pop! mb)
     377  (queue-unlimited-remove! (%mailbox-write-waiters mb)) )
     378
     379(define (mailbox-write-waiters->list mb)
     380  (queue-unlimited->list (%mailbox-write-waiters mb)) )
    368381
    369382;;; Mailbox Cursor Support
     
    372385(define mailbox-cursor 'mailbox-cursor)
    373386(define-record-type-variant mailbox-cursor (unsafe unchecked inline)
    374   (%raw-make-mailbox-cursor mb st)
     387  (%make-mailbox-cursor mb cr)
    375388  (%mailbox-cursor?)
    376389  (mb %mailbox-cursor-mailbox)
    377   (st %mailbox-cursor-state) )
    378 
    379 (define-inline (%make-mailbox-cursor mb)
    380   (%raw-make-mailbox-cursor mb (%make-queue-cursor (%mailbox-queue mb))) )
     390  (cr %mailbox-cursor-queue-cursor) )
     391
     392(define (*make-mailbox-cursor mb)
     393  (%make-mailbox-cursor mb (make-queue-cursor (%mailbox-queue mb))) )
    381394
    382395(define (error-mailbox-cursor loc obj #!optional nam)
     
    385398(define-inline-check-type mailbox-cursor)
    386399
    387 (define-inline (%mailbox-cursor-queue mbc) (%mailbox-queue (%mailbox-cursor-mailbox mbc)))
    388 
    389 (define-inline (%mailbox-cursor-winding? mbc)
    390   (%queue-cursor-winding? (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    391 
    392 (define-inline (%mailbox-cursor-unwound? mbc)
    393   (%queue-cursor-unwound? (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    394 
    395 (define-inline (%mailbox-cursor-rewind! mbc)
    396   (%queue-cursor-rewind! (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
    397 
    398 (define-inline (%mailbox-cursor-extract! mbc)
    399   (%queue-cursor-extract! (%mailbox-cursor-queue mbc) (%mailbox-cursor-state mbc)) )
     400(define (mailbox-cursor-queue mbc)
     401  (%mailbox-queue (%mailbox-cursor-mailbox mbc)) )
     402
     403(define (*mailbox-cursor-winding? mbc)
     404  (queue-cursor-winding? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
     405
     406(define (*mmailbox-cursor-unwound? mbc)
     407  (queue-cursor-unwound? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
     408
     409(define (*mailbox-cursor-rewind! mbc)
     410  (queue-cursor-rewind! (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
     411
     412(define (*mailbox-cursor-extract! mbc)
     413  (queue-cursor-extract! (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    400414
    401415;;;
    402416
    403417;Unique objects used as tags
    404 (define UNBLOCKED-TAG (%make-unique-object 'unblocked))
    405 (define SEQ-FAIL-TAG (%make-unique-object 'seq-fail))
    406 (define NO-TOVAL-TAG (%make-unique-object 'timeout-value))
     418(define UNBLOCKED-TAG (vector 'unblocked))
     419(define SEQ-FAIL-TAG (vector 'seq-fail))
     420(define NO-TOVAL-TAG (vector 'timeout-value))
    407421#; ;XXX
    408 (define MESSAGE-WAITING-TAG (%make-unique-object 'message-waiting))
     422(define MESSAGE-WAITING-TAG (vector 'message-waiting))
    409423
    410424;;; Mailbox Exceptions
    411425
    412 (define-inline (%optional-timeout-value x #!optional (def (void)))
     426(define (optional-timeout-value x #!optional (def (void)))
    413427  (if (eq? x NO-TOVAL-TAG) def x) )
    414428
    415 (define (make-mailbox-timeout-condition loc mb timout timout-value)
    416   (let ((tv (%optional-timeout-value timout-value)))
     429(define (make-mailbox-timeout-condition loc mb wq timout timout-value)
     430  (let ((tv (optional-timeout-value timout-value)))
    417431    (make-composite-condition
    418432      (make-property-condition 'exn
     
    421435        'arguments (list timout tv))
    422436      (make-property-condition 'mailbox 'box mb)
     437      (make-property-condition 'direction 'waiter (mailbox-waiter-queue-name mb wq))
    423438      (make-property-condition 'timeout 'time timout 'value tv)) ) )
    424439
     
    429444(define (restart-thread! th)
    430445  ;
    431   (if (not (%thread-blocked? th))
     446  (if (not (thread-blocked? th))
    432447    ;then restart
    433448    (thread-resume! th)
    434449    ;else wake early if sleeping
    435450    ;all others dropped on the floor
    436     (when (%thread-blocked-for-timeout? th)
     451    (when (thread-blocked-for-timeout? th)
    437452      ;ready the thread
    438       (##sys#thread-unblock! th)
     453      (thread-unblock! th)
    439454      ;tell 'wait-mailbox-thread!' we unblocked early
    440455      (thread-signal! th UNBLOCKED-TAG) ) )
     
    459474        #t) ) ) )
    460475
    461 ;; Select next waiting thread for the mailbox
    462 
    463 (define (ready-mailbox-writer! mb)
    464   ;ready oldest waiting thread
    465   (unless (%mailbox-read-waiters-empty? mb)
    466     (restart-thread! (%mailbox-read-waiters-pop! mb)))
    467   (void) )
    468 
    469 (define (ready-mailbox-reader! mb)
    470   ;ready oldest waiting thread
    471   (unless (%mailbox-write-waiters-empty? mb)
    472     (restart-thread! (%mailbox-write-waiters-pop! mb)))
    473   (void) )
    474 
    475476;; Wait current thread on the mailbox until timeout, available message
    476477;; or some other condition
     
    485486        (thread-signal!
    486487          (current-thread)
    487           (make-mailbox-timeout-condition loc mb timout timout-value))
     488          (make-mailbox-timeout-condition loc mb wq timout timout-value))
    488489        SEQ-FAIL-TAG ) ) )
    489490  ;
    490491  ;push current thread on mailbox waiting queue
    491   (%queue-unlimited-add! wq (current-thread))
     492  (queue-unlimited-add! wq (current-thread))
    492493  ;waiting action
    493494  (cond
     
    501502              ;timed-out, so no message
    502503              ;remove from wait queue
    503               (%queue-unlimited-delete! wq (current-thread))
     504              (queue-unlimited-delete! wq (current-thread))
    504505              ;indicate no available message
    505506              (timeout-exit!) )
     
    511512          (if (eq? (current-thread) ##sys#primordial-thread)
    512513            (begin
    513               (%queue-unlimited-delete! wq (current-thread))
     514              (queue-unlimited-delete! wq (current-thread))
    514515              (warning "mailbox attempt to sleep primordial-thread" mb)
    515516              (timeout-exit!) )
     
    518519                ;timed-out, so no message
    519520                ;remove from wait queue
    520                 (%queue-unlimited-delete! wq (current-thread))
     521                (queue-unlimited-delete! wq (current-thread))
    521522                ;indicate no available message
    522523                (timeout-exit!) )
     
    541542          (let waiting ()
    542543            (cond
    543               ((%mailbox-queue-full? _mb)
     544              ((mailbox-queue-full? _mb)
    544545                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    545546                  ;when a thread ready then check mailbox again, could be empty.
     
    558559          (let waiting ()
    559560            (cond
    560               ((%mailbox-queue-empty? _mb)
     561              ((mailbox-queue-empty? _mb)
    561562                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    562563                  ;when a thread ready then check mailbox again, could be empty.
     
    568569                ?expr0 ?expr1 ... ) ) ) ) ) ) ) )
    569570
    570 #; ;XXX
    571 (define (wait-mailbox-if-empty! loc mb timout timout-value)
    572   (wait-mailbox-write! loc mb timout timout-value
    573     MESSAGE-WAITING-TAG ) )
     571;; Select next waiting thread for the mailbox
     572
     573(define (ready-mailbox-reader! mb)
     574  ;ready oldest waiting thread
     575  (unless (mailbox-write-waiters-empty? mb)
     576    (restart-thread! (mailbox-write-waiters-pop! mb)))
     577  (void) )
     578
     579(define (ready-mailbox-writer! mb)
     580  ;ready oldest waiting thread
     581  (unless (mailbox-read-waiters-empty? mb)
     582    (restart-thread! (mailbox-read-waiters-pop! mb)))
     583  (void) )
    574584
    575585;;; Mailbox
     
    586596
    587597(define (make-unlimited-mailbox #!optional (nm (gensym 'mailbox)))
    588   (%make-mailbox 'make-unlimited-mailbox nm #f) )
     598  (*make-mailbox 'make-unlimited-mailbox nm #f) )
    589599
    590600(define (make-limited-mailbox lm #!optional (nm (gensym 'mailbox)))
    591   (%make-mailbox 'make-limited-mailbox nm lm) )
     601  (*make-mailbox 'make-limited-mailbox nm lm) )
    592602
    593603(define (make-unbuffered-mailbox #!optional (nm (gensym 'mailbox)))
    594   (%make-mailbox 'make-unbuffered-mailbox nm #t) )
     604  (*make-mailbox 'make-unbuffered-mailbox nm #t) )
    595605
    596606(define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
    597   (%make-mailbox 'make-mailbox nm lm) )
     607  (*make-mailbox 'make-mailbox nm lm) )
    598608
    599609;; Mailbox Properties
     
    606616
    607617(define (mailbox-empty? mb)
    608   (%mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
     618  (mailbox-queue-empty? (%check-mailbox 'mailbox-empty? mb)) )
    609619
    610620(define (mailbox-full? mb)
    611   (%mailbox-queue-full? (%check-mailbox 'mailbox-empty? mb)) )
     621  (mailbox-queue-full? (%check-mailbox 'mailbox-empty? mb)) )
    612622
    613623(define (mailbox-count mb)
    614   (%mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
     624  (mailbox-queue-count (%check-mailbox 'mailbox-count mb)) )
    615625
    616626(define (mailbox-limit mb)
    617   (%mailbox-queue-limit (%check-mailbox 'mailbox-count mb)) )
    618 
    619 (define (mailbox-waiting? mb)
    620   (not (%mailbox-write-waiters-empty? (%check-mailbox 'mailbox-waiting? mb))) )
     627  (mailbox-queue-limit (%check-mailbox 'mailbox-count mb)) )
     628
     629(define (mailbox-read-waiting? mb)
     630  (not (mailbox-read-waiters-empty? (%check-mailbox 'mailbox-read-waiting? mb))) )
     631
     632(define (mailbox-write-waiting? mb)
     633  (not (mailbox-write-waiters-empty? (%check-mailbox 'mailbox-write-waiting? mb))) )
     634
     635(define mailbox-waiting? mailbox-write-waiters-empty?)
    621636
    622637(define (mailbox-write-waiters mb)
    623   (%mailbox-write-waiters->list (%check-mailbox 'mailbox-write-waiters mb)) )
     638  (mailbox-write-waiters->list (%check-mailbox 'mailbox-write-waiters mb)) )
    624639
    625640(define (mailbox-read-waiters mb)
    626   (%mailbox-read-waiters->list (%check-mailbox 'mailbox-read-waiters mb)) )
     641  (mailbox-read-waiters->list (%check-mailbox 'mailbox-read-waiters mb)) )
    627642
    628643(define mailbox-waiters mailbox-write-waiters)
     
    631646
    632647(define (mailbox-send! mb x)
    633   (%mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
     648  (mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
    634649  (ready-mailbox-reader! mb) )
    635650
     
    648663    (%check-mailbox 'mailbox-receive! mb) timout timout-value
    649664    ;then
    650     (%mailbox-queue-remove! mb) ) )
     665    (mailbox-queue-remove! mb) ) )
    651666
    652667(define (mailbox-push-back! mb x)
    653   (%mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
     668  (mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
    654669  (ready-mailbox-reader! mb) )
    655670
    656671(define (mailbox-push-back-list! mb ls)
    657   (%mailbox-queue-push-back-list!
     672  (mailbox-queue-push-back-list!
    658673    (%check-mailbox 'mailbox-send! mb)
    659674    (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
     
    667682      (printf "#<mailbox ~S limit: ~A queued: ~A waiters: ~A/~A>"
    668683        (%mailbox-name mb)
    669         (%mailbox-queue-limit mb)
    670         (%mailbox-queue-count mb)
    671         (%mailbox-read-waiters-count mb)
    672         (%mailbox-write-waiters-count mb)) ) ) )
     684        (mailbox-queue-limit mb)
     685        (mailbox-queue-count mb)
     686        (mailbox-read-waiters-count mb)
     687        (mailbox-write-waiters-count mb)) ) ) )
    673688
    674689;;; Mailbox Cursor
     
    677692
    678693(define (make-mailbox-cursor mb)
    679   (%make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
     694  (*make-mailbox-cursor (%check-mailbox 'make-mailbox-cursor mb)) )
    680695
    681696;; Mailbox Cursor Properties
     
    688703
    689704(define (mailbox-cursor-rewound? mbc)
    690   (not (%mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
     705  (not (*mailbox-cursor-winding? (%check-mailbox-cursor 'mailbox-cursor-rewound? mbc))) )
    691706
    692707(define (mailbox-cursor-unwound? mbc)
    693   (null?
    694     (%queue-unlimited-cursor-next-pair
    695       (%mailbox-cursor-state (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)))) )
     708  (*mmailbox-cursor-unwound? (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)) )
    696709
    697710;; Mailbox Cursor Operations
    698711
    699712(define (mailbox-cursor-rewind mbc)
    700   (%mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
     713  (*mailbox-cursor-rewind! (%check-mailbox-cursor 'mailbox-cursor-rewind mbc)) )
    701714
    702715(define (mailbox-cursor-next mbc #!optional timout (timout-value NO-TOVAL-TAG))
     
    705718    (mb (%mailbox-cursor-mailbox (%check-mailbox-cursor 'mailbox-cursor-next mbc)))
    706719    (mq (%mailbox-queue mb))
    707     (mc (%mailbox-cursor-state mbc)) )
     720    (mc (%mailbox-cursor-queue-cursor mbc)) )
    708721    ;seed rewound cursor
    709     (unless (%queue-cursor-winding? mq mc)
    710       (%queue-cursor-start! mq mc) )
     722    (unless (queue-cursor-winding? mq mc)
     723      (queue-cursor-start! mq mc) )
    711724    ;pull next item from queue at cursor
    712725    (let scanning ()
    713       (let ((item (%queue-cursor-next! mq mc)))
     726      (let ((item (queue-cursor-next! mq mc)))
    714727        ;anything next?
    715728        (if (not (eof-object? item))
     
    722735              ;continue scanning?
    723736              ((eq? UNBLOCKED-TAG res)
    724                 (%queue-cursor-continue! mq mc)
     737                (queue-cursor-continue! mq mc)
    725738                (scanning) )
    726739              ;some problem (timeout maybe)
     
    729742
    730743(define (mailbox-cursor-extract-and-rewind! mbc)
    731   (%mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
    732   (%mailbox-cursor-rewind! mbc) )
     744  (*mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
     745  (*mailbox-cursor-rewind! mbc) )
    733746
    734747;; Read/Print Syntax
     
    739752      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
    740753      (%mailbox-name (%mailbox-cursor-mailbox mbc))
    741       (if (%mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
     754      (if (*mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
    742755
    743756;;;
  • release/5/mailbox/trunk/tests/mailbox-cursor-test.scm

    r39731 r39743  
    4949      (thread-sleep! tmo)
    5050      (if (= lmt cnt)
    51         (mailbox-send! mb1 (makmsg 'quit))
     51        (begin
     52          (thread-labeled-print "Send! Quit at " (current-seconds) " sec")
     53          (mailbox-send! mb1 (makmsg 'quit)) )
    5254        (let ((msg (makmsg cnt)))
    5355          (thread-labeled-print "Send! at " (current-seconds) " sec")
     
    6264          (let ((msg (mailbox-cursor-next mbc)))
    6365            (thread-labeled-print "Receive! at " (current-seconds)  " sec")
    64             (unless (eq? 'quit (msgval msg))
    65               (when (test msg)
    66                 (thread-labeled-print "Test Match - Removing Message: " msg)
    67                 (mailbox-cursor-extract-and-rewind! mbc) )
    68               (loop) ) ) ) ) ) )
     66            (if (eq? 'quit (msgval msg))
     67              (thread-labeled-print "Test Quit: " msg)
     68              (begin
     69                (when (test msg)
     70                  (thread-labeled-print "Test Match - Removing Message: " msg)
     71                  (mailbox-cursor-extract-and-rewind! mbc) )
     72                (loop) ) ) ) ) ) ) )
    6973
    7074  ;;
Note: See TracChangeset for help on using the changeset viewer.