Changeset 39719 in project


Ignore:
Timestamp:
03/15/21 21:10:45 (6 weeks ago)
Author:
Kon Lovett
Message:

queue depth limit objects (wip, cursor tbd)

File:
1 edited

Legend:

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

    r39718 r39719  
    77;; & (include "chicken-primitive-object-inlines")
    88
    9 ;; Queue Specific
    10 
    11 ;(define-constant QUEUE-UNLIMITED -1)
    12 (define-constant QUEUE-UNBUFFERED 0)
     9;; Queue Unlimited
    1310
    1411;the identifier needs to be defined by somebody
    1512(define queue-unlimited 'queue-unlimited)
    1613(define-record-type-variant queue-unlimited (unsafe unchecked inline)
    17   (%make-queue-unlimited lm ln hd tl)
     14  (%make-queue-unlimited ln hd tl)
    1815  (%queue-unlimited?)
    19   (lm %queue-unlimited-limit %queue-unlimited-limit-set!)
    2016  (ln %queue-unlimited-count %queue-unlimited-count-set!)
    2117  (hd %queue-unlimited-first-pair %queue-unlimited-first-pair-set!)
    2218  (tl %queue-unlimited-last-pair %queue-unlimited-last-pair-set!) )
    2319
    24 ;; Queue Generic
    25 
    26 (define-inline (%valid-queue-limit? lm)
    27   (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
    28 
    29 (define-inline (%make-empty-queue lm)
    30   ;(assert (%valid-queue-limit? lm))
    31   (cond
    32     ((not lm)       (%make-queue-unlimited lm 0 '() '()))
    33     #;((fixnum? lm)   (%make-queue-limited 0 (make-vector lm (void))))
    34     #;(else           (%make-queue-unbuffered 0 (void))) ) )
    35 
    36 (define-inline (%queue? x)
    37   (or
    38     (%queue-unlimited? q)
    39     #;(%queue-limited? q)
    40     #;(%queue-unbuffered? q) ) )
    41 
    42 (define (%queue-limit q)
    43   (cond
    44     ((%queue-unlimited? q)  (%queue-unlimited-limit q))
    45     #;((%queue-limited? q)    (%queue-limited-limit q))
    46     #;(else                   (%queue-unbuffered-limit q)) ) )
    47 
    48 (define (%queue-limit-set! q v)
    49   (cond
    50     ((%queue-unlimited? q)  (%queue-unlimited-limit-set! q v))
    51     #;((%queue-limited? q)    (%queue-limited-limit-set! q v))
    52     #;(else                   (%queue-unbuffered-limit-set! q v)) ) )
    53 
    54 (define (%queue-count q)
    55   (cond
    56     ((%queue-unlimited? q)  (%queue-unlimited-count q))
    57     #;((%queue-limited? q)    (%queue-limited-count q))
    58     #;(else                   (%queue-unbuffered-count q)) ) )
    59 
    60 (define (%queue-count-set! q v)
    61   (cond
    62     ((%queue-unlimited? q)  (%queue-unlimited-count-set! q v))
    63     #;((%queue-limited? q)    (%queue-limited-count-set! q v))
    64     #;(else                   (%queue-unbuffered-count-set! q v)) ) )
    65 
    66 ;nominal `size' of the queue, not literal
    67 (define-inline (%queue-size q)
    68   (cond
    69     ((%queue-unlimited? q)  most-positive-fixnum)
    70     #;((%queue-limited? q)    (%queue-limit q))
    71     #;(else                   0) ) )
    72 
    73 (define-inline (%queue-empty? q)  (fx= (%queue-count q) 0))
    74 (define-inline (%queue-full? q)   (fx>= (%queue-count q) (%queue-size q)))
    75 
    76 (define-inline (%queue-room q)
    77   (cond
    78     ((%queue-unlimited? q)  most-positive-fixnum)
    79     #;((%queue-limited? q)    (fx- (%queue-limit q) (%queue-count q)))
    80     #;(else                   (if (fx= 0 (%queue-count q)) 1 0)) ) )
    81 
    82 (define-inline (%queue-room? q rq) (fx<= rq (%queue-room q)))
    83 
    84 (define-inline (%queue-count-add! q n) (%queue-count-set! q (fx+ (%queue-count q) n)))
    85 (define-inline (%queue-count-sub! q n) (%queue-count-set! q (fx- (%queue-count q) n)))
    86 
    87 (define-inline (%queue-count-inc! q) (%queue-count-add! q 1))
    88 (define-inline (%queue-count-dec! q) (%queue-count-sub! q 1))
    89 
    90 ;; Operation Specific
     20(define-inline (%queue-unlimited-limit q) most-positive-fixnum)
     21
     22(define-inline (%queue-unlimited-limit-set! q v)
     23  (error '%queue-unlimited-limit-set! "immutable" v))
     24
     25(define-inline (%queue-unlimited-count-add! q n)
     26  (%queue-unlimited-count-set! q (fx+ (%queue-unlimited-count q) n)) )
     27
     28(define-inline (%queue-unlimited-count-sub! q n)
     29  (%queue-unlimited-count-set! q (fx- (%queue-unlimited-count q) n)) )
     30
     31(define-inline (%queue-unlimited-count-inc! q) (%queue-unlimited-count-add! q 1))
     32(define-inline (%queue-unlimited-count-dec! q) (%queue-unlimited-count-sub! q 1))
     33
     34(define-inline (%queue-unlimited-room q) most-positive-fixnum)
    9135
    9236(define-inline (%queue-unlimited-add! q v)
     
    9539      (%queue-unlimited-first-pair-set! q new-pair)
    9640      (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
    97     (%queue-unlimited-last-pair-set! q new-pair) ) )
     41    (%queue-unlimited-last-pair-set! q new-pair)
     42    (%queue-unlimited-count-inc! q)) )
    9843
    9944(define-inline (%queue-unlimited-remove! q)
     
    10247    (%queue-unlimited-first-pair-set! q next-pair)
    10348    (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
     49    (%queue-unlimited-count-dec! q)
    10450    (car first-pair) ) )
    10551
     
    10854    (%queue-unlimited-first-pair-set! q newlist)
    10955    (when (null? (%queue-unlimited-last-pair q))
    110       (%queue-unlimited-last-pair-set! q newlist) ) ) )
     56      (%queue-unlimited-last-pair-set! q newlist) )
     57    (%queue-unlimited-count-inc! q) ) )
    11158
    11259(define-inline (%queue-unlimited-push-back-list! q ls)
     
    11562    (if (null? newlist)
    11663      (%queue-unlimited-last-pair-set! q '())
    117       (%queue-unlimited-last-pair-set! q (last-pair newlist) ) ) ) )
     64      (%queue-unlimited-last-pair-set! q (last-pair newlist) ) )
     65    (%queue-unlimited-count-add! q (length ls)) ) )
    11866
    11967(define-inline (%queue-unlimited-extract-pair! q targ-pair)
     
    13684          ;when the cut pair is the last item update the last pair ref.
    13785          (when (eq? this-pair (%queue-unlimited-last-pair q))
    138             (%queue-unlimited-last-pair-set! q prev-pair) ) ) )
     86            (%queue-unlimited-last-pair-set! q prev-pair) )
     87          (%queue-unlimited-count-dec! q) ) )
    13988      ;not found
    14089      (else
    14190        (scanning (cdr this-pair) this-pair) ) ) ) )
    14291
    143 ;; Operation Generic
    144 
    145 (define-inline (%queue-add! q v)
     92;; Queue Limited
     93
     94;the identifier needs to be defined by somebody
     95(define queue-limited 'queue-limited)
     96(define-record-type-variant queue-limited (unsafe unchecked inline)
     97  (%make-queue-limited vc st ed)
     98  (%queue-limited?)
     99  (vc %queue-limited-vector %queue-limited-vector-set!)
     100  (st %queue-limited-start %queue-limited-start-set!)
     101  (ed %queue-limited-end %queue-limited-end-set!) )
     102
     103;circular buffer: vec[n] s <= e: s = e -> empty, s < e -> some, |e - s| = n -> full
     104;
     105; inc i: (i + 1)          mod (n+1)
     106; dec i: (i + ((n+1)-1))  mod (n+1)
     107
     108(define-inline (%queue-limited-peek q i)
     109  (vector-ref (%queue-limited-vector q) i) )
     110
     111(define-inline (%queue-limited-poke! q i v)
     112  (vector-set! (%queue-limited-vector q) i v) )
     113
     114(define-inline (%queue-limited-limit q)
     115  (vector-length (%queue-limited-vector q)) )
     116
     117(define-inline (%queue-limited-index-add1 q i)
     118  (fxmod (fx+ i 1) (fx+ (%queue-limited-limit q) 1)) )
     119
     120(define-inline (%queue-limited-limit-set! q v)
     121  (error '%queue-limited-limit-set! "immutable" v) )
     122
     123(define-inline (fxabs n) (if (< n 0) (fxneg n) n))
     124
     125(define-inline (%queue-limited-count q)
     126  (fxabs (fx- (%queue-limited-end q) (%queue-limited-start q))) )
     127
     128(define-inline (%queue-limited-count-set! q v)
     129  (error '%queue-limited-count-set! "immutable" v) )
     130
     131(define-inline (%queue-limited-room q)
     132  (fx- (%queue-limited-limit q) (%queue-limited-count q)) )
     133
     134(define-inline (%queue-limited-empty? q #!optional (n 0))
     135  (fx<= (fx- (%queue-limited-count q) n) 0) )
     136
     137(define-inline (%queue-limited-full? q #!optional (n 0))
     138  (fx>= (fx+ (%queue-limited-count q) n) (%queue-limited-limit q)) )
     139
     140(define-inline (%queue-limited-add! q v)
     141  (when (fx= (%queue-limited-end q) (%queue-limited-limit q))
     142    (%queue-limited-end-set! q 0) )
     143  (%queue-limited-poke! q (%queue-limited-end q) v)
     144  (%queue-limited-end-set! q (%queue-limited-index-add1 q (%queue-limited-end q))) )
     145
     146(define-inline (%queue-limited-remove! q)
     147  (when (fx= (%queue-limited-start q) (%queue-limited-limit q))
     148    (%queue-limited-start-set! q 0) )
     149  (let ((v (%queue-limited-peek q (%queue-limited-start q))))
     150    (%queue-limited-start-set! q (%queue-limited-index-add1 q (%queue-limited-start q)))
     151    v ) )
     152
     153(define-inline (%queue-limited-push-back! q v)
     154  (error '%queue-limited-push-back! "unsupported" q v) )
     155
     156(define-inline (%queue-limited-push-back-list! q ls)
     157  (error '%queue-limited-push-back-list! "unsupported" q ls) )
     158
     159(define-inline (%queue-limited-extract-target! q targ)
     160  (void) )
     161
     162;; Queue Unbuffered
     163
     164;the identifier needs to be defined by somebody
     165(define queue-unbuffered 'queue-unbuffered)
     166(define-record-type-variant queue-unbuffered (unsafe unchecked inline)
     167  (%make-queue-unbuffered vd vl)
     168  (%queue-unbuffered?)
     169  (vd %queue-unbuffered-maybe? %queue-unbuffered-maybe-set!)
     170  (vl %queue-unbuffered-value %queue-unbuffered-value-set!) )
     171
     172(define-inline (%queue-unbuffered-limit q) 1)
     173
     174(define-inline (%queue-unbuffered-limit-set! q v)
     175  (error '%queue-unbuffered-limit-set! "immutable" v) )
     176
     177(define-inline (%queue-unbuffered-count q)
     178  (if (%queue-unbuffered-maybe? q) 1 0) )
     179
     180(define-inline (%queue-unbuffered-count-set! q v)
     181  (error '%queue-unbuffered-count-set! "immutable" v) )
     182
     183(define-inline (%queue-unbuffered-room q)
     184  (if (%queue-unbuffered-maybe? q) 0 1) )
     185
     186(define-inline (%queue-unbuffered-add! q v)
     187  (%queue-unbuffered-maybe-set! q #t)
     188  (%queue-unbuffered-value-set! q v) )
     189
     190(define-inline (%queue-unbuffered-remove! q)
     191  (%queue-unbuffered-maybe-set! q #f)
     192  (%queue-unbuffered-value-set! q (void)) )
     193
     194(define-inline (%queue-unbuffered-push-back! q v)
     195  (%queue-unbuffered-add! q v) )
     196
     197(define-inline (%queue-unbuffered-push-back-list! q ls)
     198  (%queue-unbuffered-add! q (car ls)) )
     199
     200(define-inline (%queue-unbuffered-extract-target! q targ)
     201  (void) )
     202
     203;; Queue Generic
     204
     205(define-inline (%valid-queue-limit? lm)
     206  (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
     207
     208(define-inline (%make-empty-queue lm)
     209  ;(assert (%valid-queue-limit? lm))
     210  (cond
     211    ((not lm)       (%make-queue-unlimited 0 '() '()))
     212    ((fixnum? lm)   (%make-queue-limited (make-vector lm (void)) 0 0))
     213    (else           (%make-queue-unbuffered #f (void))) ) )
     214
     215(define-inline (%queue? x)
     216  (or
     217    (%queue-unlimited? q)
     218    (%queue-limited? q)
     219    (%queue-unbuffered? q) ) )
     220
     221(define (%queue-limit q)
     222  (cond
     223    ((%queue-unlimited? q)  (%queue-unlimited-limit q))
     224    ((%queue-limited? q)    (%queue-limited-limit q))
     225    (else                   (%queue-unbuffered-limit q)) ) )
     226
     227(define (%queue-limit-set! q v)
     228  (cond
     229    ((%queue-unlimited? q)  (%queue-unlimited-limit-set! q v))
     230    ((%queue-limited? q)    (%queue-limited-limit-set! q v))
     231    (else                   (%queue-unbuffered-limit-set! q v)) ) )
     232
     233(define (%queue-count q)
     234  (cond
     235    ((%queue-unlimited? q)  (%queue-unlimited-count q))
     236    ((%queue-limited? q)    (%queue-limited-count q))
     237    (else                   (%queue-unbuffered-count q)) ) )
     238
     239(define (%queue-count-set! q v)
     240  (cond
     241    ((%queue-unlimited? q)  (%queue-unlimited-count-set! q v))
     242    ((%queue-limited? q)    (%queue-limited-count-set! q v))
     243    (else                   (%queue-unbuffered-count-set! q v)) ) )
     244
     245(define-inline (%queue-room q)
     246  (cond
     247    ((%queue-unlimited? q)  (%queue-unlimited-room q))
     248    ((%queue-limited? q)    (%queue-limited-room q))
     249    (else                   (%queue-unbuffered-room q)) ) )
     250
     251(define-inline (%queue-empty? q #!optional (n 0))
     252  (fx<= (fx- (%queue-count q) n) 0) )
     253
     254(define-inline (%queue-full? q #!optional (n 0))
     255  (fx>= (fx+ (%queue-count q) n) (%queue-limit q)) )
     256
     257(define (queue-empty-error loc q) (error loc "queue empty" q))
     258(define (queue-full-error loc q v) (error loc "queue full" q v))
     259
     260(define-inline (%queue-add! q v
     261                  #!optional
     262                  (on-full (lambda () (queue-full-error '%queue-add! q v))))
    146263  (cond
    147264    ((%queue-full? q)
    148       (error '%queue-add! "queue full") )
    149     ((%queue-unlimited? q)
    150       (%queue-unlimited-add! q v)
    151       (%queue-count-inc! q) )
    152     #;((%queue-limited? q)  ())
    153     #;(else                 ()) ) )
    154 
    155 (define-inline (%queue-remove! q)
     265      (on-full))
     266    ((%queue-unlimited? q)  (%queue-unlimited-add! q v))
     267    ((%queue-limited? q)    (%queue-limited-add! q v))
     268    (else                   (%queue-unbuffered-add! q v)) ) )
     269
     270(define-inline (%queue-remove! q
     271                  #!optional
     272                  (on-empty (lambda () (queue-empty-error '%queue-remove! q))))
    156273  (cond
    157274    ((%queue-empty? q)
    158       (error '%queue-remove! "queue empty") )
    159     ((%queue-unlimited? q)
    160       (let ((v (%queue-unlimited-remove! q)))
    161         (%queue-count-dec! q)
    162         v ) )
    163     #;((%queue-limited? q)  ())
    164     #;(else                 ()) ) )
    165 
    166 (define-inline (%queue-push-back! q v)
     275      (on-empty))
     276    ((%queue-unlimited? q)  (%queue-unlimited-remove! q))
     277    ((%queue-limited? q)    (%queue-limited-remove! q))
     278    (else                   (%queue-unbuffered-remove! q)) ) )
     279
     280(define-inline (%queue-push-back! q v
     281                  #!optional
     282                  (on-full (lambda () (queue-full-error '%queue-push-back! q v))))
    167283  (cond
    168284    ((%queue-full? q)
    169       (error '%queue-push-back! "queue full") )
    170     ((%queue-unlimited? q)
    171       (%queue-unlimited-push-back! q v)
    172       (%queue-count-inc! q) )
    173     #;((%queue-limited? q)  ())
    174     #;(else                 ()) ) )
    175 
    176 (define-inline (%queue-push-back-list! q ls)
    177   (cond
    178     ((not (%queue-room? q (length ls)))
    179       (error '%queue-push-back-list! "queue short" (%queue-room q)) )
    180     ((%queue-unlimited? q)
    181       (%queue-unlimited-push-back-list! q ls)
    182       (%queue-count-add! q (length ls)) )
    183     #;((%queue-limited? q)  ())
    184     #;(else                 ()) ) )
     285      (on-full))
     286    ((%queue-unlimited? q)  (%queue-unlimited-push-back! q v))
     287    ((%queue-limited? q)    (%queue-limited-push-back! q v))
     288    (else                   (%queue-unbuffered-push-back! q v)) ) )
     289
     290(define-inline (%queue-push-back-list! q ls
     291                  #!optional
     292                  (on-full (lambda () (queue-full-error '%queue-push-back-list! q ls))))
     293  (cond
     294    ((%queue-full? q (length ls))
     295      (on-full))
     296    ((%queue-unlimited? q)  (%queue-unlimited-push-back-list! q ls))
     297    ((%queue-limited? q)    (%queue-limited-push-back-list! q ls))
     298    (else                   (%queue-unbuffered-push-back-list! q ls)) ) )
    185299
    186300;;FIXME should be Queue Cursor
     
    188302(define-inline (%queue-first-pair q) (%queue-unlimited-first-pair q))
    189303(define-inline (%queue-last-pair q) (%queue-unlimited-last-pair q))
    190 
    191 (define-inline (%queue-extract-pair! q t)
    192   (%queue-unlimited-extract-pair! q t)
    193   (%queue-count-dec! q) )
     304(define-inline (%queue-extract-pair! q t) (%queue-unlimited-extract-pair! q t))
Note: See TracChangeset for help on using the changeset viewer.