Changeset 39724 in project


Ignore:
Timestamp:
03/16/21 20:14:14 (2 months ago)
Author:
Kon Lovett
Message:

fix rw1 test, test rw1 w/ unlimited/limited/unbuffered

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

Legend:

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

    r39723 r39724  
    254254
    255255(define-inline (%queue-unbuffered-remove! q)
    256   (%queue-unbuffered-maybe-set! q #f)
    257   (%queue-unbuffered-value-set! q (void)) )
     256  (let ((v (%queue-unbuffered-value q)))
     257    (%queue-unbuffered-maybe-set! q #f)
     258    (%queue-unbuffered-value-set! q (void))
     259    v ) )
    258260
    259261(define-inline (%queue-unbuffered-push-back! q v)
  • release/5/mailbox/trunk/mailbox.scm

    r39723 r39724  
    270270  (wt %mailbox-waiters %mailbox-waiters-set!) )
    271271
    272 (define-inline (%make-mailbox nm lm)
     272(define-inline (%make-mailbox loc nm lm)
    273273  (unless (%valid-queue-limit? lm)
    274     (error '%make-mailbox "invalid limit" lm nm) )
     274    (error loc "invalid limit" lm nm) )
    275275  (%raw-make-mailbox nm (%make-empty-queue lm) '()) )
    276276
     
    517517
    518518(define (make-unlimited-mailbox #!optional (nm (gensym 'mailbox)))
    519   (%make-mailbox nm #f) )
     519  (%make-mailbox 'make-unlimited-mailbox nm #f) )
    520520
    521521(define (make-limited-mailbox lm #!optional (nm (gensym 'mailbox)))
    522   (%make-mailbox nm lm) )
     522  (%make-mailbox 'make-limited-mailbox nm lm) )
    523523
    524524(define (make-unbuffered-mailbox #!optional (nm (gensym 'mailbox)))
    525   (%make-mailbox nm #t) )
     525  (%make-mailbox 'make-unbuffered-mailbox nm #t) )
    526526
    527527(define (make-mailbox #!optional (nm (gensym 'mailbox)) (lm #f))
    528   (%make-mailbox nm lm) )
     528  (%make-mailbox 'make-mailbox nm lm) )
    529529
    530530;; Mailbox Properties
  • release/5/mailbox/trunk/tests/mailbox-cursor-test.scm

    r39700 r39724  
    33;;;
    44
    5 (import mailbox)
    6 (import srfi-18)
     5(import (chicken condition) (srfi 18) mailbox)
    76
    87;;; Test support
     
    2928  (apply print (current-thread-name) " - " args)
    3029  #; ;only 2 threads!
    31         (critical-section (apply print (current-thread-name) " - " args) ) )
     30  (critical-section (apply print (current-thread-name) " - " args) ) )
    3231
    3332(define (makmsg x) (cons (current-thread-name) x))
     
    4039;;
    4140
    42 (let ((mailbox-one (make-mailbox 'one)))
     41(let ((mailbox-one (make-unlimited-mailbox 'one)))
    4342
    4443  (define (writer-thread-body)
     
    4645    (let loop ((cnt 0))
    4746      (thread-sleep! TIMEOUT)
    48       (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
    49           (begin
    50             (mailbox-send! mailbox-one (makmsg cnt))
    51             (loop (add1 cnt))) ) ) )
     47      (if (= MESSAGE-LIMIT cnt)
     48        (mailbox-send! mailbox-one (makmsg 'quit))
     49        (let ((msg (makmsg cnt)))
     50          (thread-labeled-print "Send! at " (current-seconds) " sec")
     51          (mailbox-send! mailbox-one msg)
     52          (loop (add1 cnt))) ) ) )
    5253
    5354  (define (make-reader-thread-body test)
     
    5758        (let loop ()
    5859          (let ((msg (mailbox-cursor-next mbc)))
    59             (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
     60            (thread-labeled-print "Receive! at " (current-seconds)  " sec")
    6061            (unless (eq? 'quit (msgval msg))
    6162              (when (test msg)
     
    9798  (thread-join! reader-thread-two) )
    9899
     100(newline)
     101
  • release/5/mailbox/trunk/tests/mailbox-primordial-test.scm

    r39700 r39724  
    11;from caolan
    22
    3 (import (chicken condition))
    4 (import (srfi 18))
    5 (import mailbox)
     3(import (chicken condition) (srfi 18) mailbox)
    64
    75;;
     
    4442
    4543(thread-join! test-thread-1)
     44
     45(newline)
  • release/5/mailbox/trunk/tests/reader-writer-test.scm

    r39721 r39724  
    33;;;
    44
    5 (import (chicken condition) (srfi-18) mailbox)
     5(import (chicken condition) (srfi 18) mailbox)
    66
    77;;; Test support
    88
    9 (define-constant MESSAGE-LIMIT 5)
     9;(define-constant MESSAGE-LIMIT 5)
     10(define-constant MESSAGE-LIMIT 3)
    1011
    1112;(define-constant TIMEOUT 4)    ;slow but otherwise ok
     
    3031  (apply print (current-thread-name) " - " args)
    3132  #; ;only 2 threads!
    32         (critical-section (apply print (current-thread-name) " - " args) ) )
     33  (critical-section (apply print (current-thread-name) " - " args) ) )
    3334
    3435(define (makmsg x) (cons (current-thread-name) x))
     
    3940;;; Test mailbox
    4041
    41 (let ((mailbox-one (make-mailbox 'one)))
     42(define (test-mailbox-one knd mb1 lmt tmo)
    4243
    4344  (define writer-thread-one
     
    4647        (thread-labeled-print "Started!")
    4748        (let loop ((cnt 0))
    48           (thread-labeled-print "Sending at " (current-seconds) " sec")
    49           (mailbox-send! mailbox-one (makmsg cnt))
    50           (if (= MESSAGE-LIMIT cnt) (mailbox-send! mailbox-one (makmsg 'quit))
    51               (let ((sleep@seconds (current-seconds)))
    52                 (thread-labeled-print "Sleep at " sleep@seconds " sec")
    53                 (thread-sleep! TIMEOUT)
    54                 (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec")
    55                 (loop (add1 cnt)) ) ) ) )
     49          (thread-labeled-print "Send! at " (current-seconds) " sec")
     50          (mailbox-send! mb1 (makmsg cnt))
     51          ;work
     52          (let ((sleep@seconds (current-seconds)))
     53            (thread-labeled-print "Sleep at " sleep@seconds " sec")
     54            (thread-sleep! tmo)
     55            (thread-labeled-print "Awake after " (- (current-seconds) sleep@seconds) " sec") )
     56          (if (= lmt cnt)
     57            (mailbox-send! mb1 (makmsg 'quit))
     58            (loop (add1 cnt)) ) ) )
    5659      'Writer-One) )
    5760
     
    6467            (condition-case
    6568                (begin
    66                   (thread-labeled-print "Receiving at " rcv@sec  " sec")
    67                   (let ((msg (mailbox-receive! mailbox-one TIMEOUT)))
     69                  (thread-labeled-print "Receive! at " rcv@sec  " sec")
     70                  (let ((msg (mailbox-receive! mb1 tmo)))
    6871                    (thread-labeled-print "Message From " (msgfrm msg) " Is " (msgval msg))
    6972                    (unless (eq? 'quit (msgval msg))
     
    8184
    8285  (newline)
    83   (print "** Test mailbox **")
    84   (print "Message Limit = " MESSAGE-LIMIT " Timeout = " TIMEOUT " seconds")
     86  (print "** Test Mailbox " knd " **")
     87  (print "Message Limit = " lmt " Timeout = " tmo " seconds")
    8588  (newline)
    8689
     
    9093  (thread-join! writer-thread-one)
    9194  (thread-join! reader-thread-one) )
     95
     96(test-mailbox-one "Unlimited"   (make-unlimited-mailbox 'unlimited-one) MESSAGE-LIMIT TIMEOUT)
     97(test-mailbox-one "Limited"     (make-limited-mailbox 3 'limited-one) MESSAGE-LIMIT TIMEOUT)
     98(test-mailbox-one "Unbuffered"  (make-unbuffered-mailbox 'unbuffered-one) MESSAGE-LIMIT TIMEOUT)
     99
     100(newline)
Note: See TracChangeset for help on using the changeset viewer.