Changeset 39718 in project


Ignore:
Timestamp:
03/15/21 18:03:09 (4 months ago)
Author:
Kon Lovett
Message:

queue depth limit by record (wip)

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

Legend:

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

    r39717 r39718  
    77;; & (include "chicken-primitive-object-inlines")
    88
    9 ;; Support
     9;; Queue Specific
    1010
    11 ;;
    12 
    13 (define-constant QUEUE-UNLIMITED -1)
     11;(define-constant QUEUE-UNLIMITED -1)
    1412(define-constant QUEUE-UNBUFFERED 0)
    1513
    1614;the identifier needs to be defined by somebody
    17 (define queue 'queue)
    18 (define-record-type-variant queue (unsafe unchecked inline)
    19   (%make-queue lm ln hd tl)
    20   (%queue?)
    21   (lm %queue-limit %queue-limit-set!)
    22   (ln %queue-count %queue-count-set!)
    23   (hd %queue-first-pair %queue-first-pair-set!)
    24   (tl %queue-last-pair %queue-last-pair-set!) )
     15(define queue-unlimited 'queue-unlimited)
     16(define-record-type-variant queue-unlimited (unsafe unchecked inline)
     17  (%make-queue-unlimited lm ln hd tl)
     18  (%queue-unlimited?)
     19  (lm %queue-unlimited-limit %queue-unlimited-limit-set!)
     20  (ln %queue-unlimited-count %queue-unlimited-count-set!)
     21  (hd %queue-unlimited-first-pair %queue-unlimited-first-pair-set!)
     22  (tl %queue-unlimited-last-pair %queue-unlimited-last-pair-set!) )
    2523
    26 (define-inline (%make-queue-limited lm) (%make-queue lm 0 '() '()))
    27 (define-inline (%make-queue-unlimited)  (%make-queue-limited QUEUE-UNLIMITED))
    28 (define-inline (%make-queue-unbuffered) (%make-queue-limited QUEUE-UNBUFFERED))
     24;; Queue Generic
    2925
    30 (define-inline (%queue-unlimited? q)  (fx= QUEUE-UNLIMITED (%queue-limit q)) )
    31 (define-inline (%queue-unbuffered? q) (fx= QUEUE-UNBUFFERED (%queue-limit q)) )
    32 (define-inline (%queue-limited? q)    (not (or (%queue-unbuffered? q) (%queue-unlimited? q))) )
     26(define-inline (%valid-queue-limit? lm)
     27  (or (boolean? lm) (and (fixnum? lm) (positive? lm))) )
    3328
    34 (define-inline (%make-limited-queue lm)
     29(define-inline (%make-empty-queue lm)
     30  ;(assert (%valid-queue-limit? lm))
    3531  (cond
    36     ((not lm)       (%make-queue-unlimited))
    37     ((boolean? lm)  (%make-queue-unbuffered))
    38     ((fixnum? lm)   (%make-queue-limited lm))
    39     (else
    40       (error '%make-limited-queue "invalid limit" lm))) )
     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)) ) )
    4165
    4266;nominal `size' of the queue, not literal
    4367(define-inline (%queue-size q)
    4468  (cond
    45     ((%queue-unbuffered? q) 0)
    4669    ((%queue-unlimited? q)  most-positive-fixnum)
    47     (else                   (%queue-limit q)) ) )
     70    #;((%queue-limited? q)    (%queue-limit q))
     71    #;(else                   0) ) )
    4872
    4973(define-inline (%queue-empty? q)  (fx= (%queue-count q) 0))
    5074(define-inline (%queue-full? q)   (fx>= (%queue-count q) (%queue-size q)))
    5175
    52 (define-inline (%queue-limited-room q)
    53   (if (%queue-unbuffered? q)
    54     (if (fx= 0 (%queue-count q)) 1 0)
    55     (fx- (%queue-limit q) (%queue-count q)) ) )
    56 
    5776(define-inline (%queue-room q)
    58   (if (%queue-unlimited? q)
    59     most-positive-fixnum
    60     (%queue-limited-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)) ) )
    6181
    6282(define-inline (%queue-room? q rq) (fx<= rq (%queue-room q)))
    6383
    64 (define-inline (%queue-count-inc! q) (%queue-count-set! q (fx+ 1 (%queue-count q))))
    65 (define-inline (%queue-count-dec! q) (%queue-count-set! q (fx- 1 (%queue-count q))))
     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)))
    6686
    67 ;; Operations
     87(define-inline (%queue-count-inc! q) (%queue-count-add! q 1))
     88(define-inline (%queue-count-dec! q) (%queue-count-sub! q 1))
    6889
    69 (define-inline (%queue-add! q item)
    70   (if (%queue-full? q)
    71     (error '%queue-add! "queue full")
    72     (let ((new-pair (cons item '())))
    73       (if (null? (%queue-first-pair q))
    74         (%queue-first-pair-set! q new-pair)
    75         (set-cdr! (%queue-last-pair q) new-pair) )
    76       (%queue-last-pair-set! q new-pair)
    77       (%queue-count-inc! q) ) ) )
     90;; Operation Specific
    7891
    79 (define-inline (%queue-remove! q)
    80   (if (%queue-empty? q)
    81     (error '%queue-remove! "queue empty")
    82     (let* ((first-pair (%queue-first-pair q))
    83            (next-pair (cdr first-pair)))
    84       (%queue-first-pair-set! q next-pair)
    85       (when (null? next-pair) (%queue-last-pair-set! q '()))
    86       (%queue-count-dec! q)
    87       (car first-pair) ) ) )
     92(define-inline (%queue-unlimited-add! q v)
     93  (let ((new-pair (cons v '())))
     94    (if (null? (%queue-unlimited-first-pair q))
     95      (%queue-unlimited-first-pair-set! q new-pair)
     96      (set-cdr! (%queue-unlimited-last-pair q) new-pair) )
     97    (%queue-unlimited-last-pair-set! q new-pair) ) )
    8898
    89 (define-inline (%queue-push-back! q item)
    90   (if (%queue-full? q)
    91     (error '%queue-push-back! "queue full")
    92     (let ((newlist (cons item (%queue-first-pair q))))
    93       (%queue-first-pair-set! q newlist)
    94       (when (null? (%queue-last-pair q)) (%queue-last-pair-set! q newlist) )
    95       (%queue-count-inc! q) ) ) )
     99(define-inline (%queue-unlimited-remove! q)
     100  (let* ((first-pair (%queue-unlimited-first-pair q))
     101         (next-pair (cdr first-pair)))
     102    (%queue-unlimited-first-pair-set! q next-pair)
     103    (when (null? next-pair) (%queue-unlimited-last-pair-set! q '()))
     104    (car first-pair) ) )
    96105
    97 (define-inline (%queue-push-back-list! q itemlist)
    98   (if (not (%queue-room? q (length itemlist)))
    99     (error '%queue-push-back-list! "queue short" (%queue-limited-room q))
    100     (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
    101       (%queue-first-pair-set! q newlist)
    102       (if (null? newlist)
    103         (%queue-last-pair-set! q '())
    104         (%queue-last-pair-set! q (last-pair newlist) ) )
    105       (%queue-count-set! q (+ (length itemlist) (%queue-count q))) ) ) )
     106(define-inline (%queue-unlimited-push-back! q v)
     107  (let ((newlist (cons v (%queue-unlimited-first-pair q))))
     108    (%queue-unlimited-first-pair-set! q newlist)
     109    (when (null? (%queue-unlimited-last-pair q))
     110      (%queue-unlimited-last-pair-set! q newlist) ) ) )
    106111
    107 (define-inline (%queue-extract-pair! q targ-pair)
     112(define-inline (%queue-unlimited-push-back-list! q ls)
     113  (let ((newlist (append! (list-copy ls) (%queue-unlimited-first-pair q))))
     114    (%queue-unlimited-first-pair-set! q newlist)
     115    (if (null? newlist)
     116      (%queue-unlimited-last-pair-set! q '())
     117      (%queue-unlimited-last-pair-set! q (last-pair newlist) ) ) ) )
     118
     119(define-inline (%queue-unlimited-extract-pair! q targ-pair)
    108120  ;scan queue list until we find the item to remove
    109   (let scanning ((this-pair (%queue-first-pair q)) (prev-pair '()))
     121  (let scanning ((this-pair (%queue-unlimited-first-pair q)) (prev-pair '()))
    110122    ;keep scanning until found
    111123    (cond
     
    120132          ;at the head of the list, or in the body?
    121133          (if (null? prev-pair)
    122             (%queue-first-pair-set! q next-pair)
     134            (%queue-unlimited-first-pair-set! q next-pair)
    123135            (set-cdr! prev-pair next-pair) )
    124136          ;when the cut pair is the last item update the last pair ref.
    125           (when (eq? this-pair (%queue-last-pair q)) (%queue-last-pair-set! q prev-pair))
    126           (%queue-count-dec! q) ) )
     137          (when (eq? this-pair (%queue-unlimited-last-pair q))
     138            (%queue-unlimited-last-pair-set! q prev-pair) ) ) )
    127139      ;not found
    128140      (else
    129141        (scanning (cdr this-pair) this-pair) ) ) ) )
     142
     143;; Operation Generic
     144
     145(define-inline (%queue-add! q v)
     146  (cond
     147    ((%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)
     156  (cond
     157    ((%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)
     167  (cond
     168    ((%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                 ()) ) )
     185
     186;;FIXME should be Queue Cursor
     187
     188(define-inline (%queue-first-pair q) (%queue-unlimited-first-pair q))
     189(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) )
  • release/5/mailbox/trunk/mailbox.scm

    r39717 r39718  
    264264
    265265(define-inline (%make-mailbox nm lm)
    266   (%raw-make-mailbox nm (%make-limited-queue lm) '()) )
     266  (unless (%valid-queue-limit? lm)
     267    (error '%make-mailbox "invalid limit" lm nm) )
     268  (%raw-make-mailbox nm (%make-empty-queue lm) '()) )
    267269
    268270(define (error-mailbox loc obj #!optional argnam)
Note: See TracChangeset for help on using the changeset viewer.