Changeset 35002 in project


Ignore:
Timestamp:
01/11/18 05:09:28 (11 months ago)
Author:
kon
Message:

rm b&d junk , test easier to read

Location:
release/4/thread-utils/trunk
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • release/4/thread-utils/trunk/atomic-value.scm

    r35000 r35002  
    112112  (make-<atom> (make-<atom>-wrapper next) ) )
    113113
    114 ;initial possible w/ a mode
     114;initial possible w/ a'la mode
    115115(define (make-<atom>-wrapper next #!optional (initial (default-atom-value)))
    116116  (let (
     
    119119    (define wrapper
    120120      (case-lambda
     121        ;get value
    121122        (()
    122123          +value+ )
     124        ;set value
    123125        ((ival)
    124126          (set! +value+ (next +value+ ival))
     127          ;state change
    125128          wrapper )
     129        ;set next
    126130        ((mode wrap)
    127131          (let (
    128132            (next-next
    129133              (case mode
    130                 ((before #:before)
     134                ((before)
    131135                  (lambda (o n) (next o (wrap o n))) )
    132                 ((after #:after)
     136                ((after)
    133137                  (lambda (o n) (wrap o (next o n))) )
    134                 ((around #:around)
    135                   (lambda (o n) (wrap o (next o (wrap o n)))) ) ) ) )
     138                ((around)
     139                  (lambda (o n) (wrap o (next o (wrap o n)))) )
     140                (else
     141                  (error 'atomic-value-wrapper "invalid mode" mode wrap) ) ) ) )
    136142            (set! next next-next) )
     143          ;state change
    137144          wrapper ) ) )
    138     ;
     145    ;the wrapping procedure
    139146    wrapper ) )
    140147
     
    316323  (check-procedure 'atom-mutate mutt 'mutate)
    317324  (<atom>-synch (check-<atom> 'atom-mutate atm)
    318     (<atom>-wrap atm #:after (lambda (_ n) (mutt n)))) )
     325    (<atom>-wrap atm 'before (lambda (_ n) (mutt n)))) )
    319326
    320327;(* --> boolean)
     
    322329  (check-procedure 'atom-validate vald? 'valid?)
    323330  (<atom>-synch (check-<atom> 'atom-validate atm)
    324     (<atom>-wrap atm #:after (lambda (o n) (if (vald? n) n o)))) )
     331    (<atom>-wrap atm 'after (lambda (o n) (if (vald? n) n o)))) )
    325332
    326333;(* * --> *)
     
    329336  (check-procedure 'atom-watch wtch 'watch)
    330337  (<atom>-synch (check-<atom> 'atom-apply! atm)
    331     (<atom>-wrap atm mode wtch)) )
     338    (<atom>-wrap atm 'around wtch)) )
    332339
    333340;;
     
    339346;
    340347(define: (atom-value-set! (atm <atom>) (val *))
    341   (<atom>-synch-value-set! (check-<atom> 'atom-value-set! atm) val)
    342   ;
    343   (void) )
     348  (<atom>-synch-value-set! (check-<atom> 'atom-value-set! atm) val) )
    344349
    345350;;
     
    359364    (check-<atom> 'atom-set! atm)
    360365    _old
    361     (_new val))
    362   ;
    363   (void) )
     366    (_new val)) )
    364367
    365368;
     
    368371    (check-<atom> 'atom-apply! atm)
    369372    (check-procedure 'atom-apply! func)
    370     args)
    371   ;
    372   (void) )
     373    args) )
    373374
    374375;
     
    377378    (check-<atom> 'atom-call! atm)
    378379    (check-procedure 'atom-call! func)
    379     args)
    380   ;
    381   (void) )
     380    args) )
    382381
    383382;;
     
    389388    old
    390389    (check-procedure 'atom-wait-and-apply! func)
    391     args)
    392   ;
    393   (void) )
     390    args) )
    394391
    395392;
     
    399396    old
    400397    (check-procedure 'atom-wait-and-call! func)
    401     args)
    402   ;
    403   (void) )
     398    args) )
    404399
    405400;; Clojure-like
  • release/4/thread-utils/trunk/tests/atomic-value-test.scm

    r35001 r35002  
    44  test
    55  atomic-value
    6   srfi-1 srfi-18
     6  srfi-1
     7  srfi-18
    78  data-structures)
    89
    910;;;
    1011
    11 (cond-expand (chicken-4 (use numbers)))
     12;;
    1213
    13 #| ;UNTIL RELEASED
    14 (use typed-define)
     14(define (thread-join-all! ts)
     15  (for-each thread-join! ts) )
     16
     17;;
     18
     19(cond-expand
     20  (typed-define
     21    (use typed-define)  ;shouldn't be necessary
     22    ;
     23    (define: (atom-add1! (atm <atom>)) -> number
     24      (atom-call! atm add1) )
     25    ;
     26    (define: (atom-sub1! (atm <atom>)) -> number
     27      (atom-call! atm sub1) ) )
     28  (else
     29    ;
     30    (define (atom-add1! atm)
     31      (atom-call! atm add1) )
     32    ;
     33    (define (atom-sub1! atm)
     34      (atom-call! atm sub1) ) ) )
     35
     36; test versions
     37(define-inline (atom-set!^ a v)
     38  (atom-set! a v)
     39  (atom-value a) )
    1540;
    16 (define: (atom-add1! (atm <atom>)) -> number
    17   (atom-call! atm add1) )
     41(define-inline (atom-add1!^ a)
     42  (atom-add1! a)
     43  (atom-value a) )
    1844;
    19 (define: (atom-sub1! (atm <atom>)) -> number
    20   (atom-call! atm sub1) )
    21 |#
    22 ;
    23 (define (atom-add1! atm)
    24   (atom-call! atm add1) )
    25 ;
    26 (define (atom-sub1! atm)
    27   (atom-call! atm sub1) )
     45(define-inline (atom-sub1!^ a)
     46  (atom-sub1! a)
     47  (atom-value a) )
     48
     49;;
     50
     51(define-constant *ms/sec* 1000.0)
     52
     53(define-constant *random-wait-limit* 10)  ;ms
     54
     55(define (random-wait-seconds #!optional (lim *random-wait-limit*))
     56  (/ (random lim) *ms/sec*) )
     57
     58(define (thread-random-sleep! #!optional (lim *random-wait-limit*))
     59  (thread-sleep! (random-wait-seconds lim)) )
    2860
    2961;;;
    30 
    31 (define-constant *ms/sec* 1000)
    3262
    3363;;
     
    6393(test-group "counter"
    6494  (let ((a (make-atom)))
    65     (test 0 (begin (atom-set! a 0) (atom-value a)))
    66     (test 1 (begin (atom-add1! a) (atom-value a)))
    67     (test 0 (begin (atom-sub1! a) (atom-value a))) )
     95    (test 0 (atom-set!^ a 0))
     96    (test 1 (atom-add1!^ a))
     97    (test 0 (atom-sub1!^ a)) )
    6898)
    6999
     
    74104(test-group "counter w/ mutator"
    75105  (let ((a (atom-mutate (atom 0) add1)))                ;     +1
    76     (test 1 (begin (atom-set! a 0) (atom-value a)))     ;0    +1
    77     (test 3 (begin (atom-add1! a) (atom-value a)))      ;1 +1 +1
    78     (test 3 (begin (atom-sub1! a) (atom-value a))) )    ;3 -1 +1
     106    (test 1 (atom-set!^ a 0))     ;0    +1
     107    (test 3 (atom-add1!^ a))      ;1 +1 +1
     108    (test 3 (atom-sub1!^ a)) )    ;3 -1 +1
    79109)
    80110
    81111;;
    82112
     113;
     114
    83115(define-constant *loop-limit* 100000)
    84 (define-constant *wait-limit* 10)
    85116
    86 (define (random-time)
    87   (fp/ (exact->inexact (random *wait-limit*)) (exact->inexact *ms/sec*))
    88   #; ;much slower ;-)
    89   (exact->inexact (/ (random *wait-limit*) *ms/sec*)) )
    90 
    91 (define (random-sleep!)
    92   (thread-sleep! (random-time)) )
     117(define (random-activation-atom-add1 atm)
     118  (thread-random-sleep!)
     119  (atom-add1! atm) )
    93120
    94121(define (make-random-activation-atom-add1-thread atm n)
    95122  (make-thread
    96     (lambda () (random-sleep!) (atom-add1! atm))
    97     (string-append "random-activation-atom-add1-thread-" (number->string n))) )
     123    (cut random-activation-atom-add1 atm)
     124    (conc 'random-activation-atom-add1-thread- (number->string n))) )
    98125
    99126(define (make-random-activation-atom-add1-threads atm lim)
     
    107134    (make-random-activation-atom-add1-threads atm lim)) )
    108135
     136;
     137
    109138(test-begin (conc *loop-limit* " threads; please wait"))
    110 (test-group (conc "with " *loop-limit* " updaters w/ random waiting <= " *wait-limit* "ms")
    111   (let ((counter (atom 0)))
     139(let* (
     140  (counter (atom 0) )
     141  (ts (make-random-activation-atom-add1-threads counter *loop-limit*) ) )
     142  ;
     143  (test-group (conc *loop-limit* " updaters w/ random(" *random-wait-limit* "ms" ") waiting")
    112144    ;run all the mutators & enjoin to primordial
    113     (for-each thread-join! (run-random-activation-atom-add1-threads counter *loop-limit*))
     145    (thread-join-all! (map thread-start! ts))
    114146    ;each should have left their mark
    115     (test *loop-limit* (atom-value counter)) )
     147    (test *loop-limit* (atom-value counter))
     148  )
    116149)
    117150(test-end)
Note: See TracChangeset for help on using the changeset viewer.