Changeset 39745 in project


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

handle buffer full on write (limited/unbuffred), caller handles limits, check for 0 push-back list length

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

Legend:

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

    r39744 r39745  
    110110  (queue-unlimited-cursor-next-pair-set! c (queue-unlimited-first-pair q)) )
    111111
    112 ;#!eof | *
    113112(define (queue-unlimited-cursor-next! q c)
    114113  (let ((curr-pair (queue-unlimited-cursor-next-pair c)))
     
    260259  (queue-limited-cursor-index-set! c (queue-limited-start q)) )
    261260
    262 ;#!eof | *
    263261(define (queue-limited-cursor-next! q c)
    264262  (cond
     
    370368  (queue-unbuffered-cursor-index-set! c 0) )
    371369
    372 ;#!eof | *
    373370(define (queue-unbuffered-cursor-next! q c)
    374371  (cond
     
    450447(define (queue-full-error loc q v) (error loc "queue full" q v))
    451448
    452 (define (queue-add!? q v)
    453   (if (queue-full? q)
    454     (values #f (void))
    455     (values #t
    456       (cond
    457         ((queue-unlimited? q)  (queue-unlimited-add! q v))
    458         ((queue-limited? q)    (queue-limited-add! q v))
    459         (else                  (queue-unbuffered-add! q v)))) ) )
    460 
    461 (define (queue-remove!? q)
    462   (if (queue-empty? q)
    463     (values #f (void))
    464     (values #t
    465       (cond
    466         ((queue-unlimited? q)  (queue-unlimited-remove! q))
    467         ((queue-limited? q)    (queue-limited-remove! q))
    468         (else                  (queue-unbuffered-remove! q)))) ) )
    469 
    470 (define (queue-push-back!? q v)
    471   (if (queue-full? q)
    472     (values #f (void))
    473     (values #t
    474       (cond
    475         ((queue-unlimited? q)  (queue-unlimited-push-back! q v))
    476         ((queue-limited? q)    (queue-limited-push-back! q v))
    477         (else                  (queue-unbuffered-push-back! q v)))) ) )
    478 
    479 (define (queue-push-back-list!? q ls)
    480   (if (queue-full? q (length ls))
    481     (values #f (void))
    482     (values #t
    483       (cond
    484         ((queue-unlimited? q)  (queue-unlimited-push-back-list! q ls))
    485         ((queue-limited? q)    (queue-limited-push-back-list! q ls))
    486         (else                  (queue-unbuffered-push-back-list! q ls)))) ) )
    487 
    488 (define (queue-add! q v
    489                   #!optional
    490                   (on-full (lambda () (queue-full-error 'queue-add! q v))))
    491   (let loop ()
    492     (let-values (((succ? val) (queue-add!? q v)))
    493       (unless succ?
    494         (on-full)
    495         (loop) )
    496       val ) ) )
    497 
    498 (define (queue-remove! q
    499                   #!optional
    500                   (on-empty (lambda () (queue-empty-error 'queue-remove! q))))
    501   (let loop ()
    502     (let-values (((succ? val) (queue-remove!? q)))
    503       (unless succ?
    504         (on-empty)
    505         (loop) )
    506       val ) ) )
    507 
    508 (define (queue-push-back! q v
    509                   #!optional
    510                   (on-full (lambda () (queue-full-error 'queue-push-back! q v))))
    511   (let loop ()
    512     (let-values (((succ? val) (queue-push-back!? q v)))
    513       (unless succ?
    514         (on-full)
    515         (loop) )
    516       val ) ) )
    517 
    518 (define (queue-push-back-list! q ls
    519                   #!optional
    520                   (on-full (lambda () (queue-full-error 'queue-push-back-list! q ls))))
    521   (let loop ()
    522     (let-values (((succ? val) (queue-push-back-list!? q ls)))
    523       (unless succ?
    524         (on-full)
    525         (loop) )
    526       val ) ) )
     449(define (queue-add! q v)
     450  (cond
     451    ((queue-unlimited? q)  (queue-unlimited-add! q v))
     452    ((queue-limited? q)    (queue-limited-add! q v))
     453    (else                  (queue-unbuffered-add! q v))) )
     454
     455(define (queue-remove! q)
     456  (cond
     457    ((queue-unlimited? q)  (queue-unlimited-remove! q))
     458    ((queue-limited? q)    (queue-limited-remove! q))
     459    (else                  (queue-unbuffered-remove! q))) )
     460
     461(define (queue-push-back! q v)
     462  (cond
     463    ((queue-unlimited? q)  (queue-unlimited-push-back! q v))
     464    ((queue-limited? q)    (queue-limited-push-back! q v))
     465    (else                  (queue-unbuffered-push-back! q v))) )
     466
     467(define (queue-push-back-list! q ls)
     468  (cond
     469    ((queue-unlimited? q)  (queue-unlimited-push-back-list! q ls))
     470    ((queue-limited? q)    (queue-limited-push-back-list! q ls))
     471    (else                  (queue-unbuffered-push-back-list! q ls))) )
    527472
    528473(define (make-queue-cursor q)
     
    556501    (else                  (queue-unbuffered-cursor-start! q c)) ))
    557502
    558 ;#!eof | *
    559503(define (queue-cursor-next! q c)
    560504 (cond
  • release/5/mailbox/trunk/mailbox.scm

    r39743 r39745  
    304304;; Message queue
    305305
    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)) )
     306(define (mailbox-queue-empty? mb #!optional (n 0))
     307  (queue-empty? (%mailbox-queue mb) n) )
     308
     309(define (mailbox-queue-full? mb #!optional (n 0))
     310  (queue-full? (%mailbox-queue mb) n) )
    311311
    312312(define (mailbox-queue-count mb)
     
    537537(define-syntax wait-mailbox-read!
    538538  (syntax-rules ()
    539     ((wait-mailbox-read! ?loc ?mb ?timout ?timout-value ?expr0 ?expr1  ...)
    540       (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
     539    ((wait-mailbox-read! ?loc ?mb ?n ?timout ?timout-value ?expr0 ?expr1  ...)
     540      (let ((_mb ?mb) (_n ?n) (_to ?timout) (_tv ?timout-value))
    541541        (let ((wq (%mailbox-read-waiters _mb)))
    542542          (let waiting ()
    543543            (cond
    544               ((mailbox-queue-full? _mb)
     544              ((mailbox-queue-full? _mb _n)
    545545                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    546546                  ;when a thread ready then check mailbox again, could be empty.
     
    554554(define-syntax wait-mailbox-write!
    555555  (syntax-rules ()
    556     ((wait-mailbox-write! ?loc ?mb ?timout ?timout-value ?expr0 ?expr1 ...)
    557       (let ((_mb ?mb) (_to ?timout) (_tv ?timout-value))
     556    ((wait-mailbox-write! ?loc ?mb ?n ?timout ?timout-value ?expr0 ?expr1 ...)
     557      (let ((_mb ?mb) (_n ?n) (_to ?timout) (_tv ?timout-value))
    558558        (let ((wq (%mailbox-write-waiters _mb)))
    559559          (let waiting ()
    560560            (cond
    561               ((mailbox-queue-empty? _mb)
     561              ((mailbox-queue-empty? _mb _n)
    562562                (let ((res (wait-mailbox-thread! ?loc _mb wq _to _tv)))
    563563                  ;when a thread ready then check mailbox again, could be empty.
     
    645645;; Mailbox Operations
    646646
    647 (define (mailbox-send! mb x)
    648   (mailbox-queue-add! (%check-mailbox 'mailbox-send! mb) x)
    649   (ready-mailbox-reader! mb) )
     647(define (mailbox-send! mb x #!optional timout (timout-value NO-TOVAL-TAG))
     648  (wait-mailbox-read! 'mailbox-send!
     649    ;wait until
     650    (%check-mailbox 'mailbox-send! mb) 0 timout timout-value
     651    ;then
     652    (mailbox-queue-add! mb x)
     653    (ready-mailbox-reader! mb) ) )
    650654
    651655(define (mailbox-wait! mb #!optional timout)
     
    653657  (wait-mailbox-write! 'mailbox-wait!
    654658    ;wait until
    655     (%check-mailbox 'mailbox-wait! mb) timout NO-TOVAL-TAG
     659    (%check-mailbox 'mailbox-wait! mb) 0 timout NO-TOVAL-TAG
    656660    ;then
    657661    (void) ) )
     
    661665  (wait-mailbox-write! 'mailbox-receive!
    662666    ;wait until
    663     (%check-mailbox 'mailbox-receive! mb) timout timout-value
     667    (%check-mailbox 'mailbox-receive! mb) 0 timout timout-value
    664668    ;then
    665     (mailbox-queue-remove! mb) ) )
    666 
    667 (define (mailbox-push-back! mb x)
    668   (mailbox-queue-push-back! (%check-mailbox 'mailbox-send! mb) x)
    669   (ready-mailbox-reader! mb) )
    670 
    671 (define (mailbox-push-back-list! mb ls)
    672   (mailbox-queue-push-back-list!
    673     (%check-mailbox 'mailbox-send! mb)
    674     (%check-list 'mailbox-push-back-list! ls 'mailbox-send!))
    675   (ready-mailbox-reader! mb) )
     669    (let ((v (mailbox-queue-remove! mb)))
     670      (ready-mailbox-writer! mb)
     671      v ) ) )
     672
     673(define (mailbox-push-back! mb x #!optional timout (timout-value NO-TOVAL-TAG))
     674  (wait-mailbox-read! 'mailbox-push-back!
     675    ;wait until
     676    (%check-mailbox 'mailbox-push-back! mb) 0 timout timout-value
     677    ;then
     678    (mailbox-queue-push-back! mb x)
     679    (ready-mailbox-reader! mb) ) )
     680
     681(define (mailbox-push-back-list! mb ls #!optional timout (timout-value NO-TOVAL-TAG))
     682  (%check-list 'mailbox-push-back-list! ls)
     683  (unless (zero? (length ls))
     684    (wait-mailbox-read! 'mailbox-push-backlist!
     685      ;wait until
     686      (%check-mailbox 'mailbox-push-back-list! mb) (fx- (length ls) 1) timout timout-value
     687      ;then
     688      (mailbox-queue-push-back-list! mb ls)
     689      (ready-mailbox-reader! mb) ) ) )
    676690
    677691;; Read/Print Syntax
Note: See TracChangeset for help on using the changeset viewer.