Changeset 39717 in project


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

queue depth limit by type (wip)

Location:
release/5/mailbox/trunk
Files:
2 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)
  • release/5/mailbox/trunk/mailbox.scm

    r39716 r39717  
    3737  mailbox-timeout-condition?
    3838  ;Mailbox API
     39  make-limited-mailbox
    3940  make-mailbox
    40   make-limited-mailbox
    4141  mailbox?
    4242  mailbox-name
     
    7272  (only (srfi 1) append! delete! list-copy last-pair)
    7373  (only (srfi 18)
    74     time?
    75     current-thread
    76     thread-signal! thread-sleep!
    77     thread-suspend! thread-resume!))
     74    time? current-thread thread-signal! thread-sleep! thread-suspend! thread-resume!))
    7875
    7976;;; Typoes
    8077
    8178(define-type srfi-18-time   (struct time))
    82 (define-type mailbox        (struct mailbox))
    83 (define-type mailbox-cursor (struct mailbox-cursor))
    8479(define-type time-number    (or fixnum float))
    8580(define-type timeout        (or time-number srfi-18-time))
    8681(define-type unique-object  (vector-of symbol))
     82(define-type buffering      (or boolean fixnum))
     83(define-type mailbox        (struct mailbox))
     84(define-type mailbox-cursor (struct mailbox-cursor))
    8785
    8886(: mailbox-timeout-condition?         (* -> boolean : condition))
    89 (: make-mailbox                       (#!optional * -> mailbox))
    90 (: make-limited-mailbox               (#!optional (or boolean fixnum) * -> mailbox))
     87(: make-limited-mailbox               (#!optional buffering * -> mailbox))
     88(: make-mailbox                       (#!optional * buffering -> mailbox))
    9189(: mailbox?                           (* -> boolean : mailbox))
    9290(: mailbox-name                       (mailbox --> *))
     
    266264
    267265(define-inline (%make-mailbox nm lm)
    268   (%raw-make-mailbox nm (%make-empty-queue lm) '()) )
     266  (%raw-make-mailbox nm (%make-limited-queue lm) '()) )
    269267
    270268(define (error-mailbox loc obj #!optional argnam)
     
    514512;; Mailbox Constructor
    515513
    516 (define (make-limited-mailbox #!optional lm (nm (gensym 'mailbox)))
    517   (%make-mailbox nm
    518     (cond
    519       ((not lm)     QUEUE-UNBUFFERED)
    520       ((fixnum? lm) lm)
    521       (else         QUEUE-UNLIMITED))) )
    522 
    523 (define (make-mailbox #!optional (nm (gensym 'mailbox)))
    524   (make-limited-mailbox #t nm) )
     514(define (make-limited-mailbox #!optional (lm #t) (nm (gensym 'mailbox)))
     515  (%make-mailbox nm lm) )
     516
     517(define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
     518  (make-limited-mailbox lm nm) )
    525519
    526520(define (mailbox? obj)
Note: See TracChangeset for help on using the changeset viewer.