Changeset 39747 in project


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

fix unwound name, cursor has 3 states, extract means can write

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

Legend:

Unmodified
Added
Removed
  • release/5/mailbox/trunk/mailbox.scm

    r39746 r39747  
    408408  (queue-cursor-winding? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    409409
    410 (define (*mmailbox-cursor-unwound? mbc)
     410(define (*mailbox-cursor-unwound? mbc)
    411411  (queue-cursor-unwound? (mailbox-cursor-queue mbc) (%mailbox-cursor-queue-cursor mbc)) )
    412412
     
    734734
    735735(define (mailbox-cursor-unwound? mbc)
    736   (*mmailbox-cursor-unwound? (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)) )
     736  (*mailbox-cursor-unwound? (%check-mailbox-cursor 'mailbox-cursor-unwound? mbc)) )
    737737
    738738;; Mailbox Cursor Operations
     
    771771(define (mailbox-cursor-extract-and-rewind! mbc)
    772772  (*mailbox-cursor-extract! (%check-mailbox-cursor 'mailbox-cursor-extract-and-rewind! mbc))
    773   (*mailbox-cursor-rewind! mbc) )
     773  (*mailbox-cursor-rewind! mbc)
     774  (ready-mailbox-writer! (%mailbox-cursor-mailbox mbc)) )
    774775
    775776;; Read/Print Syntax
     
    780781      (printf "#<mailbox-cursor mailbox: ~A status: ~A>"
    781782      (%mailbox-name (%mailbox-cursor-mailbox mbc))
    782       (if (*mailbox-cursor-winding? mbc) "winding" "rewound")) ) ) )
     783      (cond
     784        ((*mailbox-cursor-unwound? mbc) "unwound")
     785        ((*mailbox-cursor-winding? mbc) "winding")
     786        (else                           "rewound"))) ) ) )
    783787
    784788;;;
  • release/5/mailbox/trunk/tests/mailbox-cursor-test.scm

    r39746 r39747  
    4242;;
    4343
    44 (define (test-mailbox-one knd mb1 lmt tmo)
     44(define (test-mailbox-one wrtcnt knd mb1 lmt tmo)
     45
     46  (define totcnt (* wrtcnt lmt))
    4547
    4648  (define (writer-thread-body)
     
    5355      (thread-sleep! tmo)
    5456      (if (= lmt cnt)
    55         (send-it (makmsg 'quit))
     57        (begin
     58          (send-it (makmsg 'quit))
     59          (unless (< 1 wrtcnt) (send-it (makmsg 'quit))) )
    5660        (begin
    5761          (send-it (makmsg cnt))
     
    6468        (let loop ()
    6569          (let ((msg (mailbox-cursor-next mbc)))
    66             (thread-labeled-print "Next at " (current-seconds) " sec")
     70            (thread-labeled-print "Next (" totcnt "): " msg " at " (current-seconds) " sec")
    6771            ;FIXME must process msgs in FIFO order, not LIFO order
    68             (if (eq? 'quit (msgval msg))
    69               (begin
    70                 (thread-labeled-print "Quit - Removing: " msg)
    71                 (mailbox-cursor-extract-and-rewind! mbc) )
    72               (begin
    73                 (when (test msg)
    74                   (thread-labeled-print "Match - Removing: " msg)
    75                   (mailbox-cursor-extract-and-rewind! mbc) )
     72            (cond
     73              ((eq? 'quit (msgval msg))
     74                (if (zero? totcnt)
     75                  (begin
     76                    (thread-labeled-print "Quit - Removing: " msg)
     77                    (mailbox-cursor-extract-and-rewind! mbc) )
     78                  (loop) ) )
     79              ((test msg)
     80                (thread-labeled-print "Match - Removing: " msg)
     81                (mailbox-cursor-extract-and-rewind! mbc)
     82                (set! totcnt (sub1 totcnt))
     83                (loop) )
     84              (else
    7685                (loop) ) ) ) ) ) ) )
    7786
    7887  ;;
    7988
    80   (define writer-thread-one (make-thread writer-thread-body 'Writer-One))
    81 
    82   (define writer-thread-two (make-thread writer-thread-body 'Writer-Two))
     89  (define writer-thread-one)
     90  (define writer-thread-two)
     91  (when (< 0 wrtcnt) (set! writer-thread-one (make-thread writer-thread-body 'Writer-One)))
     92  (when (< 1 wrtcnt) (set! writer-thread-two (make-thread writer-thread-body 'Writer-Two)))
    8393
    8494  (define reader-thread-one
     
    96106  (newline)
    97107  (print "** Test Mailbox " knd " Cursor **")
    98   (print "Message Limit = " lmt " Timeout = " tmo " seconds")
     108  (print "Writers = " wrtcnt " Messages = " lmt " Timeout = " tmo " seconds")
    99109  (newline)
    100110
    101111  (thread-start! reader-thread-one)
    102112  (thread-start! reader-thread-two)
    103   (thread-start! writer-thread-one)
    104   (thread-start! writer-thread-two)
     113  (when (< 0 wrtcnt) (thread-start! writer-thread-one))
     114  (when (< 1 wrtcnt) (thread-start! writer-thread-two))
    105115
    106   (thread-join! writer-thread-one)
    107   (thread-join! writer-thread-two)
     116  (when (< 0 wrtcnt) (thread-join! writer-thread-one))
     117  (when (< 1 wrtcnt) (thread-join! writer-thread-two))
    108118  (thread-join! reader-thread-one)
    109119  (thread-join! reader-thread-two) )
    110120
    111 (test-mailbox-one "Unlimited"   (make-unlimited-mailbox 'unlimited-one) MESSAGE-LIMIT TIMEOUT)
    112 (test-mailbox-one "Limited"     (make-limited-mailbox 1 'limited-one) MESSAGE-LIMIT TIMEOUT)
    113 (test-mailbox-one "Unbuffered"  (make-unbuffered-mailbox 'unbuffered-one) MESSAGE-LIMIT TIMEOUT)
     121(test-mailbox-one 2 "Unlimited"   (make-unlimited-mailbox 'unlimited-one) MESSAGE-LIMIT TIMEOUT)
     122(test-mailbox-one 2 "Limited"     (make-limited-mailbox 1 'limited-one) MESSAGE-LIMIT TIMEOUT)
     123(test-mailbox-one 1 "Unbuffered"  (make-unbuffered-mailbox 'unbuffered-one) MESSAGE-LIMIT TIMEOUT)
    114124
    115125(newline)
Note: See TracChangeset for help on using the changeset viewer.