Ignore:
Timestamp:
03/15/21 07:29:12 (5 months ago)
Author:
Kon Lovett
Message:

queue depth limit by type (wip)

File:
1 edited

Legend:

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

    r39716 r39717  
    1111;;
    1212
     13(define-constant QUEUE-UNLIMITED -1)
     14(define-constant QUEUE-UNBUFFERED 0)
     15
    1316;the identifier needs to be defined by somebody
    1417(define queue 'queue)
     
    2124  (tl %queue-last-pair %queue-last-pair-set!) )
    2225
    23 (define-constant QUEUE-UNLIMITED -1)
    24 (define-constant QUEUE-UNBUFFERED 0)
     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))
     29
     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))) )
     33
     34(define-inline (%make-limited-queue lm)
     35  (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))) )
     41
     42;nominal `size' of the queue, not literal
     43(define-inline (%queue-size q)
     44  (cond
     45    ((%queue-unbuffered? q) 0)
     46    ((%queue-unlimited? q)  most-positive-fixnum)
     47    (else                   (%queue-limit q)) ) )
     48
     49(define-inline (%queue-empty? q)  (fx= (%queue-count q) 0))
     50(define-inline (%queue-full? q)   (fx>= (%queue-count q) (%queue-size q)))
     51
     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
     57(define-inline (%queue-room q)
     58  (if (%queue-unlimited? q)
     59    most-positive-fixnum
     60    (%queue-limited-room q) ) )
     61
     62(define-inline (%queue-room? q rq) (fx<= rq (%queue-room q)))
    2563
    2664(define-inline (%queue-count-inc! q) (%queue-count-set! q (fx+ 1 (%queue-count q))))
    2765(define-inline (%queue-count-dec! q) (%queue-count-set! q (fx- 1 (%queue-count q))))
    28 
    29 (define-inline (%make-empty-queue #!optional (lm QUEUE-UNLIMITED))
    30   (%make-queue lm 0 '() '()) )
    31 
    32 (define-inline (%queue-room q)
    33   (fx- (%queue-limit q) (%queue-count q)) )
    34 
    35 (define-inline (%queue-full? q)
    36   (and
    37     (not (fx= QUEUE-UNLIMITED (%queue-limit q)))
    38     (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
    39       (fx= (%queue-count q) 1)
    40       (fx= (%queue-count q) (%queue-limit q)) ) ) )
    41 
    42 (define-inline (%queue-room? q rq)
    43   (or
    44     (fx= QUEUE-UNLIMITED (%queue-limit q))
    45     (if (fx= QUEUE-UNBUFFERED (%queue-limit q))
    46       (and (fx= (%queue-count q) 0) (fx= rq 1))
    47       (fx<= rq (%queue-room q)) ) ) )
    48 
    49 (define-inline (%queue-empty? q)
    50   (fx= 0 (%queue-count q)) )
    5166
    5267;; Operations
     
    5469(define-inline (%queue-add! q item)
    5570  (if (%queue-full? q)
    56     (warning 'queue-add! "queue full")
     71    (error '%queue-add! "queue full")
    5772    (let ((new-pair (cons item '())))
    5873      (if (null? (%queue-first-pair q))
     
    6479(define-inline (%queue-remove! q)
    6580  (if (%queue-empty? q)
    66     (warning 'queue-remove! "queue empty")
     81    (error '%queue-remove! "queue empty")
    6782    (let* ((first-pair (%queue-first-pair q))
    6883           (next-pair (cdr first-pair)))
     
    7489(define-inline (%queue-push-back! q item)
    7590  (if (%queue-full? q)
    76     (warning 'queue-push-back! "queue full")
     91    (error '%queue-push-back! "queue full")
    7792    (let ((newlist (cons item (%queue-first-pair q))))
    7893      (%queue-first-pair-set! q newlist)
     
    8297(define-inline (%queue-push-back-list! q itemlist)
    8398  (if (not (%queue-room? q (length itemlist)))
    84     (warning 'queue-push-back-list! "queue short" (%queue-room q))
     99    (error '%queue-push-back-list! "queue short" (%queue-limited-room q))
    85100    (let ((newlist (append! (list-copy itemlist) (%queue-first-pair q))))
    86101      (%queue-first-pair-set! q newlist)
     
    98113      ((null? this-pair)
    99114        ;note that the pair to extract is in fact gone so ...
    100         (warning "cannot find queue pair to extract; simultaneous operations?"))
     115        (error "cannot find queue pair to extract; simultaneous operations?"))
    101116      ;found?
    102117      ((eq? this-pair targ-pair)
Note: See TracChangeset for help on using the changeset viewer.