Changeset 13502 in project


Ignore:
Timestamp:
03/05/09 07:49:46 (11 years ago)
Author:
Kon Lovett
Message:

Save.

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

Legend:

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

    r13499 r13502  
    3939
    4040
    41 (define-inline (%current-thread)
    42   ##sys#current-thread )
    43 
    4441;;; Queue Support
    4542
     
    106103  (%queue-last-pair (%mailbox-queue mb)) )
    107104
    108 ;; Waiting threads queue
     105;; Waiting threads
    109106
    110107(define-inline (%mailbox-waiters mb)
     
    279276(define (make-mailbox-timeout-condition loc to-tim to-def)
    280277  (make-composite-condition
    281    (make-property-condition 'exn 'location loc 'arguments (list to-tim to-def))
     278   (make-property-condition 'exn
     279    'location loc
     280    'arguments (if (%undefined-value? to-def) (list to-tim) (list to-tim to-def)))
    282281   (make-property-condition 'mailbox)
    283282   (make-property-condition 'timeout)) )
     
    325324            ; Timeout result
    326325            (cond
    327               [(%undefined? to-def) ; Signal an timeout exception
     326              [(%undefined-value? to-def) ; Signal an timeout exception
    328327                (thread-signal!
    329328                  (%current-thread)
     
    401400  (check-timeout 'mailbox-receive! to-tim)
    402401  (let ([res (wait-mailbox-if-empty! 'mailbox-receive! mb to-tim to-def)])
    403     (if (%undefined? res)
     402    (if (%undefined-value? res)
    404403        (%mailbox-queue-remove! mb)
    405404        res ) ) )
     
    468467            (let ([res (mailbox-waiter 'mailbox-cursor-next mb to-tim to-def)])
    469468              (cond
    470                 [(%undefined? res)  ; then still scanning
     469                [(%undefined-value? res)  ; then still scanning
    471470                  (%mailbox-cursor-next-pair-set! mbc (cursor-pair-getter))
    472471                  (scanning (%mailbox-cursor-next-pair mbc)) ]
  • release/4/mailbox/trunk/tests/run.scm

    r13499 r13502  
     1;;;; mailbox tests/run.scm
    12
     3;;;
     4
     5(require-extension mailbox)
     6(import mailbox)
     7
     8(require-library srfi-18)
     9(import srfi-18)
     10
     11
     12;;; Test support
     13
     14(define-constant MESSAGE-LIMIT 5)
     15
     16(define-constant TIMEOUT 0.5 #;0.25)
     17
     18(define (current-thread-name)
     19        (thread-name (current-thread)) )
     20
     21(define (current-seconds)
     22        (time->seconds (current-time)) )
     23
     24(define *critical-section* (make-mutex (gensym 'critical-section)))
     25
     26(define-syntax critical-section
     27  (syntax-rules (*critical-section*)
     28    [(_ ?body ...)
     29      (dynamic-wind
     30        (lambda () (mutex-lock! *critical-section*))
     31        (lambda () ?body ...)
     32        (lambda () (mutex-unlock! *critical-section*)) ) ] ) )
     33
     34(define (thread-labeled-print . args)
     35        (critical-section (apply print "Thread " (current-thread-name) " - " args) ) )
     36
     37
     38;;; Test mailbox
     39
     40(define mailbox-one (make-mailbox 'one))
     41
     42(define writer-thread-one
     43        (make-thread
     44                (lambda ()
     45                        (thread-labeled-print "Started!")
     46                        (let loop ([cnt 0])
     47                                (thread-labeled-print "Sleep @ " (current-seconds))
     48                                (thread-sleep! TIMEOUT)
     49                                (thread-labeled-print "Awake @ " (current-seconds))
     50                                (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
     51                                (if (= MESSAGE-LIMIT cnt)
     52            (mailbox-send! mailbox-one 'quit)
     53            (loop (add1 cnt))) ) )
     54                'writer-one) )
     55
     56(define reader-thread-one
     57        (make-thread
     58                (lambda ()
     59                        (thread-labeled-print "Started!")
     60                        (let loop ()
     61                                (condition-case
     62                                                (begin
     63                                                        (thread-labeled-print "Receiving @ " (current-seconds))
     64                                                        (let ([msg (mailbox-receive! mailbox-one 0.25 #;0.5)])
     65                                                                (thread-labeled-print " Message: " msg)
     66                                                                (unless (eq? 'quit msg) (loop) ) ) )
     67                                        [(exn mailbox timeout)
     68                                                (thread-labeled-print "Timed Out @ " (current-seconds))
     69                                                (loop)]
     70                                        [exp ()
     71                                                (thread-labeled-print "Exception: " exp)]) ) )
     72                'reader-one) )
     73
     74(thread-start! writer-thread-one)
     75(thread-start! reader-thread-one)
     76
     77(thread-join! writer-thread-one)
     78(thread-join! reader-thread-one)
     79
     80
     81;;; Test mailbox-cursor
     82
     83(define mailbox-one (make-mailbox 'one))
     84
     85(define writer-thread-one
     86        (make-thread
     87                (lambda ()
     88                        (thread-labeled-print "Started!")
     89                        (let loop ([cnt 0])
     90                                (thread-sleep! TIMEOUT)
     91                                (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
     92                                (if (= MESSAGE-LIMIT cnt)
     93            (mailbox-send! mailbox-one 'quit)
     94            (loop (add1 cnt))) ) )
     95                'writer-one) )
     96
     97(define writer-thread-two
     98        (make-thread
     99                (lambda ()
     100                        (thread-labeled-print "Started!")
     101                        (let loop ([cnt 0])
     102                                (thread-sleep! TIMEOUT)
     103                                (mailbox-send! mailbox-one (cons (current-thread-name) cnt))
     104                                (if (= MESSAGE-LIMIT cnt)
     105            (mailbox-send! mailbox-one 'quit)
     106            (loop (add1 cnt))) ) )
     107                'writer-two) )
     108
     109(define reader-thread-one
     110        (make-thread
     111                (lambda ()
     112                        (thread-labeled-print "Started!")
     113                        (let ([mbc (make-mailbox-cursor mailbox-one)])
     114                                (let loop ([msg (mailbox-cursor-next mbc)])
     115                                        (thread-labeled-print "Message: " msg)
     116                                        (unless (eq? 'quit msg)
     117                                                (when (and (even? (cdr msg)) (not (zero? (modulo (cdr msg) MESSAGE-LIMIT))))
     118                                                        (thread-labeled-print "Removing Message: " msg)
     119                                                        (mailbox-cursor-extract-and-rewind! mbc) )
     120                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
     121                'reader-one) )
     122
     123(define reader-thread-two
     124        (make-thread
     125                (lambda ()
     126                        (thread-labeled-print "Started!")
     127                        (let ([mbc (make-mailbox-cursor mailbox-one)])
     128                                (let loop ([msg (mailbox-cursor-next mbc)])
     129                                        (thread-labeled-print "Message: " msg)
     130                                        (unless (eq? 'quit msg)
     131                                                (when (odd? (cdr msg))
     132                                                        (thread-labeled-print "Removing Message: " msg)
     133                                                        (mailbox-cursor-extract-and-rewind! mbc) )
     134                                                (loop (mailbox-cursor-next mbc)) ) ) ) )
     135                'reader-two) )
     136
     137(thread-start! writer-thread-one)
     138(thread-start! writer-thread-two)
     139(thread-start! reader-thread-one)
     140(thread-start! reader-thread-two)
     141
     142(thread-join! writer-thread-one)
     143(thread-join! writer-thread-two)
     144(thread-join! reader-thread-one)
     145(thread-join! reader-thread-two)
     146
Note: See TracChangeset for help on using the changeset viewer.