Changeset 35441 in project


Ignore:
Timestamp:
04/26/18 03:10:52 (6 months ago)
Author:
kon
Message:

re-flow, add types

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

Legend:

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

    r35275 r35441  
    55;; Issues
    66;;
    7 ;; (- Uses thread-terminate!) - not anymore
    87
    98; Chicken Generic Arithmetic!
     
    1211
    1312(;export
    14   timed-resource-timeout
     13  default-timed-resource-timeout
    1514  make-timed-resource
    16   timed-resource?
     15  timed-resource? check-timed-resource error-timed-resource
    1716  timed-resource-name
    18   with-timed-resource )
     17  with-timed-resource
     18  ;deprecated
     19  timed-resource-timeout)
    1920
    2021(import scheme chicken)
     
    2223 (only data-structures ->string)
    2324  (only srfi-1 delete!)
     25  (only thread-utils print-exception-error thread-unblock!)
     26  (only thread-reaper thread-reaper-shutdown? thread-reap!)
     27  (only record-variants define-record-type-variant)
     28  (only miscmacros let/cc define-parameter)
    2429  (only srfi-18
    2530    make-thread
     
    3439  (only type-checks
    3540    check-procedure check-number check-positive-number
    36     define-check+error-type)
    37   (only thread-utils
    38     print-exception-error
    39     thread-unblock!)
    40   (only thread-reaper
    41     thread-reaper-shutdown? thread-reap!)
    42   (only record-variants
    43     define-record-type-variant)
    44   miscmacros)
     41    define-check+error-type))
    4542
    4643;;
     44
     45(define-type timed-resource (struct timed-resource))
    4746
    4847(define-record-type-variant timed-resource (unsafe unchecked inline)
     
    5655  (it timed-resource-item timed-resource-item-set!) )
    5756
     57;;
     58
    5859(define-check+error-type timed-resource %timed-resource?)
    5960
     61(: timed-resource? (* -> boolean : timed-resource))
     62;
    6063(define (timed-resource? obj)
    6164  (%timed-resource? obj) )
    6265
     66(: timed-resource-name (timed-resource --> *))
     67;
    6368(define (timed-resource-name tr)
    6469  ;not completely happy with this
     
    7681  (timed-resource-item-set! tr ((@timed-resource-open tr))) )
    7782
    78 ;catchs & returns exception conditions
     83;catches & returns exception conditions
    7984(define (checked-timed-resource-close tr succflag)
    8085  (let/cc return
     
    8893
    8994(define +timed-resources+ #f) ;The set of timed resource objects
     95
    9096(define +shutdown?+ #f)       ;Program shutdown?
    91 (define +timeout+ DEFAULT-SHUTDOWN-TIMEOUT)
    9297
    9398;Cleanly shutdown remaining timed-resources.
     
    110115            (thread-unblock! th)
    111116            (thread-signal! th UNBLOCKED-TAG)
    112             (thread-join! th +timeout+) ) )
     117            (thread-join! th (default-timed-resource-timeout)) ) )
    113118        trs) ) ) )
    114119
    115120#; ;UNUSED
    116121(define (timed-resource-terminate! tr)
    117   (let ((th (timed-resource-thread tr)))
     122  (let (
     123    (th (timed-resource-thread tr)) )
    118124    (thread-terminate! th)
    119125    (when (timed-resource-item tr)
    120       (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
    121         (unless (eq? CLOSED-TAG res) (print-exception-error res)) ) )
     126      (let (
     127        (res (checked-timed-resource-close tr CLOSED-TAG)) )
     128        (unless (eq? CLOSED-TAG res)
     129          (print-exception-error res) ) ) )
    122130    (handle-exceptions exn
    123131        (cond
    124           ((and (uncaught-exception? exn)
    125                 (terminated-thread-exception? (uncaught-exception-reason exn)))
    126             ) ;Expecting so ignore
     132          ((and
     133            (uncaught-exception? exn)
     134            (terminated-thread-exception? (uncaught-exception-reason exn)))
     135            ;expecting so ignore
     136            (void) )
    127137          (else
    128138            (print-exception-error exn) ) )
     
    134144
    135145(define (add-timed-resource! tr)
    136   (unless +timed-resources+ (setup-timed-resource)) ;Only done once
     146  (unless +timed-resources+ (setup-timed-resource)) ;done once
    137147  (%set!/synch (trs +timed-resources+) (cons tr trs)) )
    138148
     
    144154;returns CLOSED-TAG for success, otherwise an exception object
    145155(define (release-timed-resource! tr)
    146   (let ((th (timed-resource-thread tr)))
    147     #;(assert (eq? (current-thread) th)) ;used only by a tr!
    148     ;(can use weaker synch since close catchs exceptions)
    149     (%record/synch timed-resource tr
    150       ;(returns any exception conditions or CLOSED-TAG for success)
    151       (let ((res (checked-timed-resource-close tr CLOSED-TAG)))
    152         (cond
    153           ;When teminating anyway no exceptions but make a note of any problem
    154           ((or +shutdown?+ (thread-reaper-shutdown?))
    155             (unless (eq? CLOSED-TAG res)
    156               (print-exception-error res th) )
    157             CLOSED-TAG )
    158           (else
    159             (remove-timed-resource! tr)
    160             (thread-reap! th)
    161             res ) ) ) ) ) )
    162 
    163 (define (make-timed-resource-timer-thunk tr)
    164   (lambda ()
    165     ;We're active
    166     (add-timed-resource! tr)
    167     ;Allow "timeout" seconds of access
    168     (handle-exceptions
    169       ;as
    170       exn
    171       ;with
    172       (unless (eq? UNBLOCKED-TAG exn) ;early unblock only "handled exception"
    173         (abort exn) )
    174       ;in
    175       (thread-sleep! (timed-resource-timeout tr)) )
    176     ;release the resource but propagate any exceptions
    177     (let ((res (release-timed-resource! tr)))
    178       (unless (eq? CLOSED-TAG res)
    179         (abort res) ) ) ) )
     156  ;(assert (eq? (current-thread) (timed-resource-thread tr))) ;used only by a tr!
     157  ;(can use weaker synch since close catches exceptions)
     158  (%record/synch timed-resource tr
     159    ;(returns any exception conditions or CLOSED-TAG for success)
     160    (let (
     161      (res (checked-timed-resource-close tr CLOSED-TAG))
     162      (th (timed-resource-thread tr)) )
     163      (cond
     164        ;when teminating anyway no exceptions but make a note of any problem
     165        ((or +shutdown?+ (thread-reaper-shutdown?))
     166          (unless (eq? CLOSED-TAG res)
     167            (print-exception-error res th) )
     168          CLOSED-TAG )
     169        (else
     170          (remove-timed-resource! tr)
     171          (thread-reap! th)
     172          res ) ) ) ) )
     173
     174(define ((make-timed-resource-timer-thunk tr))
     175  ;We're active
     176  (add-timed-resource! tr)
     177  ;allow "timeout" seconds of access
     178  (handle-exceptions
     179    ;as
     180    exn
     181    ;with
     182    (unless (eq? UNBLOCKED-TAG exn) ;early unblock only "handled exception"
     183      (abort exn) )
     184    ;in
     185    (thread-sleep! (timed-resource-timeout tr)) )
     186  ;release the resource but propagate any exceptions
     187  (let ((res (release-timed-resource! tr)))
     188    (unless (eq? CLOSED-TAG res)
     189      (abort res) ) ) )
    180190
    181191(define (start-timed-resource-timer! tr)
    182   (let ((th
    183           (make-thread
    184             (make-timed-resource-timer-thunk tr)
    185             (timed-resource-name tr))))
     192  (let (
     193    (th
     194      (make-thread
     195        (make-timed-resource-timer-thunk tr)
     196        (timed-resource-name tr))) )
    186197    (timed-resource-thread-set! tr th)
    187198    (thread-start! th) ) )
     
    206217
    207218(define (make-timed-resource-name name)
    208   (gensym name #;(string-append (->string name) "-")) )
     219  (gensym name) ) ;(string-append (->string name) "-")
    209220
    210221;;;
    211222
    212 (define (timed-resource-timeout . args)
    213   (if (null? args)
    214     +timeout+
    215     (let ((to (car args)))
    216       (set! +timeout+
    217         (and to (check-positive-number 'timed-resource-timeout to))) ) ) )
    218 
     223(: default-timed-resource-timeout (#!optional (or boolean number) -> (or boolean number)))
     224;
     225(define-parameter default-timed-resource-timeout DEFAULT-SHUTDOWN-TIMEOUT (lambda (x)
     226  (and x (check-positive-number 'default-timed-resource-timeout x))))
     227
     228(: make-timed-resource (procedure procedure number #!optional * --> timed-resource))
     229;
    219230(define (make-timed-resource opener closer timeout #!optional (name 'timed-resource))
    220231  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ;Shouldn't be necessary
    221     (check-procedure 'make-timed-resource opener 'open-procedure)
    222     (check-procedure 'make-timed-resource closer 'close-procedure)
    223     (check-number 'make-timed-resource timeout 'timeout)
    224232    (%make-timed-resource
    225       opener closer timeout
     233      (check-procedure 'make-timed-resource opener 'open-procedure)
     234      (check-procedure 'make-timed-resource closer 'close-procedure)
     235      (check-number 'make-timed-resource timeout 'timeout)
    226236      (make-mutex (make-timed-resource-name name))
    227237      #f #f) ) )
    228238
     239(: with-timed-resource (timed-resource procedure -> void))
     240;
    229241(define (with-timed-resource tr proc)
    230242  (unless (or +shutdown?+ (thread-reaper-shutdown?)) ;Shouldn't be necessary
     
    233245    (record/synch timed-resource tr (proc (timed-resource-aquire tr))) ) )
    234246
     247;;;
     248
     249(: timed-resource-timeout (deprecated default-timed-resource-timeout))
     250(define timed-resource-timeout default-timed-resource-timeout)
     251
    235252) ;module timed-resource
  • release/4/timed-resource/trunk/timed-resource.setup

    r34417 r35441  
    55(verify-extension-name "timed-resource")
    66
    7 (setup-shared-extension-module 'timed-resource (extension-version "1.0.3")
     7(setup-shared-extension-module 'timed-resource (extension-version "1.1.0")
    88  #:inline? #t
    99  #:types? #t
Note: See TracChangeset for help on using the changeset viewer.