Changeset 20999 in project


Ignore:
Timestamp:
10/25/10 01:26:49 (10 years ago)
Author:
Kon Lovett
Message:

Exit code for test. Propagates exception from closer.

Location:
release/4/timed-resource/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/timed-resource/trunk/tests/run.scm

    r20954 r20999  
    88    (define-constant ACTIVE-SECONDS 1.0)
    99
    10     (define +opened+ 0)
    11     (define +closed+ 0)
     10    (define +opened+ 0) ;For Testing Only
     11    (define +closed+ 0) ;For Testing Only
    1212   
    1313    (define random-blob
     
    1515              (make-timed-resource
    1616                (lambda ()
    17                   (set! +opened+ (add1 +opened+))
     17                  (set! +opened+ (add1 +opened+)) ;For Testing Only
    1818                  (open-input-file "/dev/random" #:binary))
    1919                (lambda (port)
    20                   (set! +closed+ (add1 +closed+))
     20                  (set! +closed+ (add1 +closed+)) ;For Testing Only
    2121                  (close-output-port port))
    2222                ACTIVE-SECONDS)))
     
    3737      ;Better be closed now!
    3838      (test "Resource Closed" +closed+ +opened+) ) ) )
     39
     40(unless (zero? (test-failure-count)) (exit 1))
  • release/4/timed-resource/trunk/timed-resource.scm

    r20954 r20999  
    7777(define (timed-resource-close tr)
    7878  (let ((res (timed-resource-item tr)))
     79    ;Drop the ref just in case the closer blows up
    7980    (timed-resource-item-set! tr #f)
    8081    ((@timed-resource-close tr) res) ) )
    8182
    82 (define (timed-resource-open tr)
    83   (let ((res ((@timed-resource-open tr))))
    84     (timed-resource-item-set! tr res)
    85     res ) )
    86 
    87 (define (checked-timed-resource-close tr)
    88   (handle-exceptions exn
    89       (print-exception-error exn)
    90     (timed-resource-close tr) ) )
     83(define (timed-resource-open! tr)
     84  (timed-resource-item-set! tr ((@timed-resource-open tr))) )
     85
     86;catchs & returns exception conditions
     87(define (checked-timed-resource-close tr succflag)
     88  (call-with-current-continuation
     89    (lambda (return)
     90      (with-exception-handler
     91        (lambda (exn) (return exn))
     92        (lambda () (timed-resource-close tr) succflag)))) )
    9193
    9294;; Set of timed resources
     
    102104
    103105(define UNBLOCKED-TAG '#(timed-resource-unblocked))
    104 
     106(define CLOSED-TAG '#(timed-resource-closed))
     107
     108;Note that the set of timed resource objects is kept only for shutdown
     109;processing.
    105110(define (shutdown-timed-resources!)
    106111  (set! +shutdown?+ #t)
     
    114119            (thread-unblock! th)
    115120            (thread-signal! th UNBLOCKED-TAG)
    116             ;Don't wait forever.
    117121            (thread-join! th +timeout+) ) )
    118122        trs) ) ) )
     
    122126  (let ((th (timed-resource-thread tr)))
    123127    (thread-terminate! th)
    124     (when (timed-resource-item tr) (checked-timed-resource-close tr))
     128    (when (timed-resource-item tr)
     129      (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
     130        (unless (eq? CLOSED-TAG res) (print-exception-error res)) ) )
    125131    (handle-exceptions exn
    126         (cond ((and (uncaught-exception? exn)
    127                     (terminated-thread-exception? (uncaught-exception-reason exn)))
    128                 ) ;Expecting so ignore
    129               (else
    130                 (print-exception-error exn th) ) )
    131       (thread-join! th +timeout+) ) ) )
     132        (cond
     133          ((and (uncaught-exception? exn)
     134                (terminated-thread-exception? (uncaught-exception-reason exn)))
     135            ) ;Expecting so ignore
     136          (else
     137            (print-exception-error exn th) ) )
     138      (thread-join! th) ) ) )
    132139
    133140(define (setup-timed-resource)
     
    142149  (%set!/synch (trs +timed-resources+) (delete! tr trs eq?)) )
    143150
     151;returns CLOSED-TAG for success, any other object is an exception
     152(define (release-timed-resource! tr)
     153  (let ((th (timed-resource-thread tr)))
     154    #;(assert (eq? (current-thread) th)) ;used only by a tr!
     155    ;(can use weaker synch since close is checked)
     156    (%record/synch timed-resource tr
     157      ;(returns any exception conditions or CLOSED-TAG for success)
     158      (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
     159        (cond
     160          ;When teminating anyway no exceptions but make a note of the problem
     161          ((or +shutdown?+ (thread-reaper-shutdown?))
     162            (print-exception-error res th)
     163            CLOSED-TAG )
     164          (else
     165            (remove-timed-resource! tr)
     166            (thread-reap! th)
     167            res ) ) ) ) ) )
     168
    144169;; The timer thread
    145170
    146171(define (make-timed-resource-timer-thunk tr)
    147172  (lambda ()
    148     (let ((early? #f))
    149       ;We're active
    150       (add-timed-resource! tr)
    151       ;Allow "timeout" seconds of access
    152       (handle-exceptions exn
    153           ;Unless unblocked early we have a real exception
    154           (if (eq? UNBLOCKED-TAG exn) (set! early? #t)
    155             (signal exn) )
    156         (thread-sleep! (timed-resource-timeout tr)) )
    157       ;Release the resource (can use weaker synch since close is checked)
    158       (%record/synch timed-resource tr
    159         (checked-timed-resource-close tr)
    160         (unless (or +shutdown?+ (thread-reaper-shutdown?))
    161           (remove-timed-resource! tr)
    162           #;(assert (eq? (current-thread) (timed-resource-thread tr)))
    163           (thread-reap! (timed-resource-thread tr)) ) ) ) ) )
     173    ;We're active
     174    (add-timed-resource! tr)
     175    ;Allow "timeout" seconds of access
     176    (handle-exceptions exn
     177        ;Early unblock only "handled exception"
     178        (unless (eq? UNBLOCKED-TAG exn) (abort exn))
     179      (thread-sleep! (timed-resource-timeout tr)) )
     180    ;Release the resource but propagate any exceptions
     181    (let ((res (release-timed-resource! tr)))
     182      (unless (eq? CLOSED-TAG res) (abort res)) ) ) )
    164183
    165184(define (start-timed-resource-timer! tr)
     
    175194  ;Open resource before starting the timer thread so the overhead doesn't count
    176195  ;(and any exceptions can propagate in caller's thread)
    177   (let ((res (timed-resource-open tr)))
    178     (start-timed-resource-timer! tr)
    179     res ) )
     196  (timed-resource-open! tr)
     197  (start-timed-resource-timer! tr)
     198  (timed-resource-item tr) )
    180199
    181200;; Get a resource object
Note: See TracChangeset for help on using the changeset viewer.