Changeset 34015 in project for release/4


Ignore:
Timestamp:
04/23/17 09:05:00 (3 years ago)
Author:
Kon Lovett
Message:

Rename registration -> source-registration. Fix {{random-source-entropy-source-set!}}, must accept {{#f}} {{entropy-source}}. Fix broken srfi-27-vector.

Location:
release/4/srfi-27
Files:
3 deleted
12 edited
26 copied
1 moved

Legend:

Unmodified
Added
Removed
  • release/4/srfi-27/tags/3.2.3/entropy-port.scm

    r34012 r34015  
    1515
    1616(import
    17   (only type-checks check-input-port check-procedure check-symbol check-string)
     17  (only type-checks check-input-port check-procedure check-symbol check-string check-number)
    1818  (only type-errors warning-argument-type))
    1919(require-library type-checks type-errors)
     
    2323;;
    2424
    25 (define ((make-open-binary-input-file namstr)) (open-input-file namstr #:binary))
     25(define (make-open-binary-input-file namstr)
     26  (lambda ()
     27    (open-input-file namstr #:binary)) )
    2628
    2729;;
     
    9193
    9294(define (*make-entropy-source/port-open opener name docu)
    93   (let ((to (entropy-port-lifetime)))
    94     (if to
     95  (let ((timeout (entropy-port-lifetime)))
     96    (if timeout
    9597      ;then auto-close on timeout
    96       (*make-entropy-source/port-open-timed opener to name docu)
     98      (*make-entropy-source/port-open-timed opener timeout name docu)
    9799      ;else keep open
    98100      (let ((port (opener)))
     
    121123          (name (gensym 'port-))
    122124          (docu "Entropy from an open port"))
    123   (check-input-port 'make-entropy-source/port port)
    124   (check-symbol 'make-entropy-source/port name 'name)
    125   (check-string 'make-entropy-source/port docu 'documentation)
    126   (*make-entropy-source/port port name docu) )
     125  (*make-entropy-source/port
     126    (check-input-port 'make-entropy-source/port port)
     127    (check-symbol 'make-entropy-source/port name 'name)
     128    (check-string 'make-entropy-source/port docu 'documentation)) )
    127129
    128130;;; Entropy from port, timed or fixed (parameterized by entropy-port-lifetime)
     
    132134          (name (gensym 'port-))
    133135          (docu "Entropy from port"))
    134   (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
    135   (check-symbol 'make-entropy-source/port-open name 'name)
    136   (check-string 'make-entropy-source/port-open docu 'documentation)
    137   (*make-entropy-source/port-open opener name docu) )
     136  (*make-entropy-source/port-open
     137    (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
     138    (check-symbol 'make-entropy-source/port-open name 'name)
     139    (check-string 'make-entropy-source/port-open docu 'documentation)) )
    138140
    139141;;; Make TImed Port Entropy Source
     
    143145          (name (gensym 'timed-port-))
    144146          (docu "Entropy from timed open port"))
    145   (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
    146   ;(check- timeout 'timeout)
    147   (check-symbol 'make-entropy-source/port-open-timed name 'name)
    148   (check-string 'make-entropy-source/port-open-timed docu 'documentation)
    149   (*make-entropy-source/port-open-timed opener timeout name docu) )
     147  (*make-entropy-source/port-open-timed
     148    (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
     149    (check-number 'make-entropy-source/port-open-timed timeout 'timeout)
     150    (check-symbol 'make-entropy-source/port-open-timed name 'name)
     151    (check-string 'make-entropy-source/port-open-timed docu 'documentation)) )
    150152
    151153;;;
    152154
    153 (define (make-entropy-open-file namstr)
    154   (make-open-binary-input-file namstr) )
     155;binary mode by default (only at the moment)
     156(define make-entropy-open-file make-open-binary-input-file)
    155157
    156158;;; Entropy from some file (binary)
     
    160162          (name (gensym 'file-))
    161163          (docu (string-append "Entropy from file \"" namstr "\"")))
    162   (check-string 'make-entropy-source/file namstr 'filename)
    163   (check-symbol 'make-entropy-source/file name 'name)
    164   (check-string 'make-entropy-source/file docu 'documentation)
    165   (*make-entropy-source/port-open (make-entropy-open-file namstr) name docu) )
     164  (*make-entropy-source/port-open
     165    (make-entropy-open-file (check-string 'make-entropy-source/file namstr 'filename))
     166    (check-symbol 'make-entropy-source/file name 'name)
     167    (check-string 'make-entropy-source/file docu 'documentation)) )
    166168
    167169(define (make-entropy-source/file-timed namstr timeout
     
    169171          (name (gensym 'file-))
    170172          (docu (string-append "Entropy from file \"" namstr "\"")))
    171   (check-string 'make-entropy-source/file-timed namstr 'filename)
    172   ;(check- timeout 'timeout)
    173   (check-symbol 'make-entropy-source/file-timed name 'name)
    174   (check-string 'make-entropy-source/file-timed docu 'documentation)
    175   (*make-entropy-source/port-open-timed (make-entropy-open-file namstr) timeout name docu) )
     173  (*make-entropy-source/port-open-timed
     174    (make-entropy-open-file (check-string 'make-entropy-source/file-timed namstr 'filename))
     175    (check-number 'make-entropy-source/file-timed timeout 'timeout)
     176    (check-symbol 'make-entropy-source/file-timed name 'name)
     177    (check-string 'make-entropy-source/file-timed docu 'documentation)) )
    176178
    177179) ;module entropy-port
  • release/4/srfi-27/tags/3.2.3/entropy-source.scm

    r34012 r34015  
    3131(require-library data-structures srfi-1 type-checks)
    3232
    33 (use registration)
     33(use source-registration)
    3434
    3535;;
     
    6262;; Entropy Source Constructor Registry
    6363
    64 (define +reg+ (make-registration 'entropy-source '()))
     64(define +reg+ (make-source-registration 'entropy-source '()))
    6565
    6666(define (registered-entropy-sources)
    67   ((@registration-key +reg+)) )
     67  ((@source-registration-key +reg+)) )
    6868
    6969(define (registered-entropy-source name)
    70   ((@registration-ref +reg+) name) )
     70  ((@source-registration-ref +reg+) name) )
    7171
    7272(define (unregister-entropy-source name)
    73   ((@registration-deref! +reg+) name) )
     73  ((@source-registration-deref! +reg+) name) )
    7474
    7575(define (register-entropy-source! name ctor)
    76   ((@registration-register! +reg+) name ctor) )
     76  ((@source-registration-register! +reg+) name ctor) )
    7777
    7878) ;entropy-source
  • release/4/srfi-27/tags/3.2.3/entropy-support.scm

    r34012 r34015  
    149149          (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    150150            (cond
    151               ((< len BYTES/F64)                      0.0)
    152               ((good_positive_double f64buf #$tmpdbl) tmpdbl)
    153               (else                                   (loop) ) ) ) ) ) ) ) )
     151              ((< len BYTES/F64)
     152                0.0 )
     153              ((good_positive_double f64buf #$tmpdbl)
     154                tmpdbl )
     155              (else
     156                (loop) ) ) ) ) ) ) ) )
    154157
    155158(define port-entropic-f64
  • release/4/srfi-27/tags/3.2.3/random-source.scm

    r34012 r34015  
    3030(require-library data-structures srfi-1 type-checks)
    3131
    32 (use registration)
     32(use source-registration)
    3333
    3434;;
     
    6161;; Random Source Constructor Registry
    6262
    63 (define +reg+ (make-registration 'random-source '()))
     63(define +reg+ (make-source-registration 'random-source '()))
    6464
    6565(define (registered-random-sources)
    66   ((@registration-key +reg+)) )
     66  ((@source-registration-key +reg+)) )
    6767
    6868(define (registered-random-source name)
    69   ((@registration-ref +reg+) name) )
     69  ((@source-registration-ref +reg+) name) )
    7070
    7171(define (unregister-random-source name)
    72   ((@registration-deref! +reg+) name) )
     72  ((@source-registration-deref! +reg+) name) )
    7373
    7474(define (register-random-source! name ctor)
    75   ((@registration-register! +reg+) name ctor) )
     75  ((@source-registration-register! +reg+) name ctor) )
    7676
    7777) ;module random-source
  • release/4/srfi-27/tags/3.2.3/source-registration.scm

    r34012 r34015  
    1 ;;;; registration.scm
     1;;;; source-registration.scm
    22;;;; Kon Lovett, Feb '17
    33;;;; Kon Lovett, Oct '09
    44
    5 (module registration
     5(module source-registration
    66
    77(;export
    8   make-registration
    9   registration? check-registration error-registration
    10   @registration-key @registration-ref @registration-deref! @registration-register!)
     8  make-source-registration
     9  source-registration? check-source-registration error-source-registration
     10  @source-registration-key @source-registration-ref @source-registration-deref! @source-registration-register!)
    1111
    1212(import scheme chicken)
     
    2828;;
    2929
    30 (define-record-type registration
    31   (*make-registration nam srcs keys ref deref! reg!)
    32   registration?
    33   (nam    *registration-name)
    34   (srcs   *registration-sources *registration-sources-set!)
    35   (keys   @registration-key)
    36   (ref    @registration-ref)
    37   (deref! @registration-deref!)
    38   (reg!   @registration-register!) )
     30(define-record-type source-registration
     31  (*make-source-registration nam srcs keys ref deref! reg!)
     32  source-registration?
     33  (nam    *source-registration-name)
     34  (srcs   *source-registration-sources *source-registration-sources-set!)
     35  (keys   @source-registration-key)
     36  (ref    @source-registration-ref)
     37  (deref! @source-registration-deref!)
     38  (reg!   @source-registration-register!) )
    3939
    40 (define-check+error-type registration)
     40(define-check+error-type source-registration)
    4141
    4242;;
    4343
    44 (define (make-registration name sources)
     44(define (make-source-registration name sources)
    4545  (letrec ((reg
    46             (*make-registration
    47               (check-symbol 'make-registration name "name")
    48               (check-list 'make-registration sources "sources")
     46            (*make-source-registration
     47              (check-symbol 'make-source-registration name "name")
     48              (check-list 'make-source-registration sources "sources")
    4949              (lambda ()
    50                 (alist-keys (*registration-sources reg)) )
     50                (alist-keys (*source-registration-sources reg)) )
    5151              (lambda (name)
    5252                (alist-ref
    53                   (check-symbol 'registration-ref name)
    54                   (*registration-sources reg)
     53                  (check-symbol 'source-registration-ref name)
     54                  (*source-registration-sources reg)
    5555                  eq? #f) )
    5656              (lambda (name)
    57                 (*registration-sources-set!
     57                (*source-registration-sources-set!
    5858                  reg
    5959                  (alist-delete!
    60                     (check-symbol 'registration-deref! name)
    61                     (*registration-sources reg)
     60                    (check-symbol 'source-registration-deref! name)
     61                    (*source-registration-sources reg)
    6262                    eq?)) )
    6363              (lambda (name ctor)
    64                 (*registration-sources-set!
     64                (*source-registration-sources-set!
    6565                  reg
    6666                  (alist-update!
    67                     (check-symbol 'registration-register!! name)
    68                     (check-procedure 'registration-register! ctor)
    69                     (*registration-sources reg)
     67                    (check-symbol 'source-registration-register!! name)
     68                    (check-procedure 'source-registration-register! ctor)
     69                    (*source-registration-sources reg)
    7070                    eq?)))) ) )
    7171    reg ) )
    7272
    73 ) ;module registration
     73) ;module source-registration
  • release/4/srfi-27/tags/3.2.3/srfi-27-distributions.scm

    r34012 r34015  
    109109
    110110(define (make-random-normals
    111           #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     111          #!key
     112                                        (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    112113  (check-real 'make-random-normals mu 'mu)
    113114  (check-nonzero-real 'make-random-normals sigma 'sigma)
     
    128129
    129130(define (make-random-exponentials
    130           #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     131          #!key
     132                                        (mu 1.0) (randoms (make-uniform-random-reals)))
    131133  (check-real-unit 'make-random-exponentials mu 'mu)
    132134  (check-procedure 'make-random-exponentials randoms 'randoms)
     
    152154
    153155(define (make-random-triangles
    154           #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
     156          #!key
     157                                        (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
    155158  (check-real 'make-random-triangles s 's)
    156159  (check-real 'make-random-triangles m 'm)
     
    174177
    175178(define (make-random-poissons
    176           #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     179          #!key
     180                                        (mu 1.0) (randoms (make-uniform-random-reals)))
    177181  (check-nonnegative-real 'make-random-poissons mu 'mu)
    178182  (check-procedure 'make-random-poissons randoms 'randoms)
     
    190194
    191195(define (make-random-bernoullis
    192           #!key (p 0.5) (randoms (make-uniform-random-reals)))
     196          #!key
     197                                        (p 0.5) (randoms (make-uniform-random-reals)))
    193198  (check-real-unit 'make-random-bernoullis p 'p)
    194199  (check-procedure 'make-random-bernoullis randoms 'randoms)
     
    213218
    214219(define (make-random-binomials
    215           #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
     220          #!key
     221                                        (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
    216222  (check-cardinal-integer 'make-random-binomials t 't)
    217223  (check-real-unit 'make-random-binomials p 'p)
     
    229235
    230236(define (make-random-geometrics
    231           #!key (p 0.5) (randoms (make-uniform-random-reals)))
     237          #!key
     238                                        (p 0.5) (randoms (make-uniform-random-reals)))
    232239  (check-real-unit 'make-random-geometrics p 'p)
    233240  (check-procedure 'make-random-geometrics randoms 'randoms)
     
    246253
    247254(define (make-random-lognormals
    248           #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     255          #!key
     256                                        (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    249257  (check-nonzero-real 'make-random-lognormals mu 'mu)
    250258  (check-nonnegative-real 'make-random-lognormals sigma 'sigma)
     
    260268
    261269(define (make-random-cauchys
    262           #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     270          #!key
     271                                        (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    263272  (check-real 'make-random-cauchys median 'median)
    264273  (check-positive-real 'make-random-cauchys sigma 'sigma)
     
    304313
    305314(define (make-random-gammas
    306           #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
     315          #!key
     316                                        (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
    307317  (check-positive-real 'make-random-gammas alpha 'alpha)
    308318  (check-positive-real 'make-random-gammas theta 'theta)
     
    318328
    319329(define (make-random-erlangs
    320           #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
     330          #!key
     331                                        (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
    321332  (check-positive-real 'make-random-erlangs alpha 'alpha)
    322333  (check-positive-real 'make-random-erlangs theta 'theta)
     
    333344
    334345(define (make-random-paretos
    335           #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
     346          #!key
     347                                        (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
    336348  (check-positive-real 'make-random-paretos alpha 'alpha)
    337349  (check-positive-real 'make-random-paretos xmin 'xmin)
     
    351363
    352364(define (make-random-levys
    353           #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
     365          #!key
     366                                        (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
    354367  (check-nonnegative-real 'make-random-levys delta 'delta)
    355368  (check-positive-real 'make-random-levys gamma 'gamma)
     
    367380
    368381(define (make-random-weibulls
    369           #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
     382          #!key
     383                                        (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
    370384  (check-positive-real 'make-random-weibulls shape 'shape)
    371385  (check-positive-real 'make-random-weibulls scale 'scale)
  • release/4/srfi-27/tags/3.2.3/srfi-27-uniform-random.scm

    r34012 r34015  
    3737;;; Uniform random integers in [low high] by precision
    3838
    39 (define (*make-uniform-random-integers low high precision rand)
     39(define (*make-uniform-random-integers low high prec rndint)
    4040  (let ((dist (- high low)))
    41     (if (< dist precision)
    42       (constantly precision)
    43       (let ((range (quotient (+ dist 1) precision)))
     41    (if (< dist prec)
     42      (constantly prec)
     43      (let ((rng (quotient (+ dist 1) prec)))
    4444        (cond
    45           ((= 0 range)
     45          ((= 0 rng)
    4646            (constantly 0) )
    4747          ((= 0 low)
    48             (if (= 1 precision)
     48            (if (= 1 prec)
    4949              (lambda ()
    50                 (rand range)
     50                (rndint rng) )
    5151              (lambda ()
    52                 (* (rand range) precision) ) ) ) )
     52                (* (rndint rng) prec) ) ) )
    5353          (else
    5454            (lambda ()
    55               (+ low (* (rand range) precision) ) ) ) ) ) ) ) )
     55              (+ low (* (rndint rng) prec) ) ) ) ) ) ) ) )
    5656
    5757(define (make-uniform-random-integers
     
    6060          (source (current-random-source)))
    6161  (check-random-source 'make-uniform-random-integers source 'source)
    62   (unless high
    63     (set! high (- (*random-source-maximum-range source) 1)) )
    64   (check-integer 'make-uniform-random-integers high 'high)
    65   (check-integer 'make-uniform-random-integers low 'low)
    66   (check-positive-integer 'make-uniform-random-integers precision 'precision)
    67   (values
    68     (*make-uniform-random-integers low high precision ((@random-source-make-integers source)))
    69     (lambda ()
    70       (values high low precision source)) ) )
     62  (let ((high (or high (- (*random-source-maximum-range source) 1))))
     63    (check-integer 'make-uniform-random-integers high 'high)
     64    (check-integer 'make-uniform-random-integers low 'low)
     65    (check-positive-integer 'make-uniform-random-integers precision 'precision)
     66    (values
     67      (*make-uniform-random-integers
     68        low high precision
     69        ((@random-source-make-integers source)))
     70      (lambda ()
     71        (values high low precision source)) ) ) )
    7172
    7273;;; Uniform random reals in (0.0 1.0) by precion
  • release/4/srfi-27/tags/3.2.3/srfi-27-vector-support.scm

    r34011 r34015  
    5353
    5454#;
    55 (define ((make-filled! veclenf vecsetf) vec gen #!optional (start 0) (end (veclenf vec)))
    56   (do ((idx start (fx+ idx 1)))
    57       ((fx= end idx) vec)
    58     (vecsetf vec idx (gen)) ) )
     55(define (make-filled! veclenf vecsetf)
     56  (lambda (vec gen #!optional (start 0) (end (veclenf vec)))
     57    (do ((idx start (fx+ idx 1)))
     58        ((fx= end idx) vec)
     59      (vecsetf vec idx (gen)) ) ) )
    5960
    60 (define ((make-mapi!/1 veclenf vecref vecsetf) proc vec)
    61   (let ((len (veclenf vec)))
    62     (do ((i 0 (fx+ i 1)))
    63         ((fx= i len) vec)
    64       (vecsetf vec i (proc i (vecref vec i))) ) ) )
     61(define (make-mapi!/1 veclenf vecref vecsetf)
     62  (lambda (proc vec)
     63    (let ((len (veclenf vec)))
     64      (do ((i 0 (fx+ i 1)))
     65          ((fx= i len) vec)
     66        (vecsetf vec i (proc i (vecref vec i))) ) ) ) )
    6567
    66 (define ((make-foldi/1 veclenf vecref) proc init vec)
    67   (let ((len (veclenf vec)))
    68     (do ((i 0 (fx+ i 1) )
    69          (acc init (proc i acc (vecref vec i)) ) )
    70         ((fx= i len) acc) ) ) )
     68(define (make-foldi/1 veclenf vecref)
     69  (lambda (proc init vec)
     70    (let ((len (veclenf vec)))
     71      (do ((i 0 (fx+ i 1) )
     72           (acc init (proc i acc (vecref vec i)) ) )
     73          ((fx= i len) acc) ) ) ) )
    7174
    7275;;
     
    98101;;; Vector% Support
    99102
     103(define (vector-fold/1 vec proc seed)
     104  (vector-fold (cut proc #f <> <>) seed vec) )
     105
     106(define (vector-map!/1 vec proc)
     107  (vector-map! (cut proc #f <>) vec) )
     108
    100109#; ;NOT YET
    101 (define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))
     110(define (array-rank/1? obj)
     111  (and (array? obj) (fx= 1 (array-rank obj))))
    102112
    103113(define (acceptable-vector? obj)
     
    114124  obj )
    115125
    116 (define ((make-oper vec-oper f32vec-oper f64vec-oper) vec . args)
    117   (cond
    118     ((vector? vec)        (apply vec-oper vec args))
    119     ((f32vector? vec)     (apply f32vec-oper vec args))
    120     ((f64vector? vec)     (apply f64vec-oper vec args))
    121     #; ;NOT YET
    122     ((array-rank/1? vec)  (apply arr-rnk-1 vec args)) ;arr-rnk-1-oper
    123     (else
    124       (error-vector #f vec))) )
     126(define (make-oper vec-oper f32vec-oper f64vec-oper)
     127  (lambda (vec . args)
     128    (cond
     129      ((vector? vec)
     130        (apply vec-oper vec args) )
     131      ((f32vector? vec)
     132        (apply f32vec-oper vec args) )
     133      ((f64vector? vec)
     134        (apply f64vec-oper vec args) )
     135      #; ;NOT YET
     136      ((array-rank/1? vec)
     137        ;arr-rnk-1-oper
     138        (apply arr-rnk-1 vec args) )
     139      (else
     140        (error-vector #f vec)) ) ) )
     141
     142;;
    125143
    126144(define vector%-length
     
    128146
    129147(define vector%-mapi!/1
    130   (make-oper vector-map! f32vector-mapi!/1 f64vector-mapi!/1) )  ;(lambda (vec proc ) (array-map! vec (cut proc #f <>)))
     148  ;(lambda (vec proc) (array-map! vec (cut proc #f <>)))
     149  (make-oper vector-map!/1 f32vector-mapi!/1 f64vector-mapi!/1) )
    131150
    132151(define vector%-foldi/1
    133   (make-oper vector-fold f32vector-foldi/1 f64vector-foldi/1) )  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     152  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     153  (make-oper vector-fold/1 f32vector-foldi/1 f64vector-foldi/1) )
    134154
    135155(define vector%-filled!
    136   (make-oper vector-filled! f32vector-filled! f64vector-filled!) )  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
     156  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
     157  (make-oper vector-filled! f32vector-filled! f64vector-filled!) )
    137158
    138159(define (vector%-scale! vec factor)
    139   (vector%-mapi!/1 (lambda (i elt) (* elt factor)) vec) )
     160  (vector%-mapi!/1 vec (lambda (i elt) (* elt factor))) )
    140161
    141162(define (vector%-sum-squares vec)
    142   (vector%-foldi/1 (lambda (i sum elt) (+ sum (* elt elt))) 0 vec) )
     163  (vector%-foldi/1 vec (lambda (i sum elt) (+ sum (* elt elt))) 0) )
    143164
    144165) ;module srfi-27-vector-support
  • release/4/srfi-27/tags/3.2.3/srfi-27-vector.scm

    r34012 r34015  
    2121
    2222(import
    23   (only type-checks check-cardinal-integer check-vector)
     23  (only type-checks check-cardinal-integer check-vector check-procedure)
    2424  (only type-errors error-vector)
    2525  random-source
    2626  srfi-27-uniform-random
    2727  srfi-27-distributions
    28   srfi-27-vector-support)
     28  srfi-27-vector-support
     29  srfi-27)
    2930(require-library
    3031  type-checks type-errors
    3132  random-source
    3233  srfi-27-uniform-random srfi-27-distributions
    33   srfi-27-vector-support)
     34  srfi-27-vector-support
     35  srfi-27)
    3436
    3537;;;
     
    5254;Section 3.4.2
    5355;
    54 (define (*random-permutation! vec randoms)
     56(define (*random-permutation! vec rndint)
    5557  (let ((n (vector-length vec)))
    5658    (vector-iota-set! vec n)
    5759    (do ((k n (fx- k 1)))
    58         ((fx= k 1) vec)
     60        ((fx= k 1)
     61          vec )
    5962      (let* ((i (fx- k 1))
    60              (j (randoms k))
     63             (j (rndint n))
    6164             (xi (vector-ref vec i))
    6265             (xj (vector-ref vec j)) )
     
    6467        (vector-set! vec j xi) ) ) ) )
    6568
    66 (define (make-random-permutations #!key (randoms (make-uniform-random-integers)))
     69(define (make-random-permutations #!key (randoms random-integer))
    6770  (lambda (n)
    68     (check-cardinal-integer 'make-random-permutations n 'length)
    69     (*random-permutation! (make-vector n 0) randoms)) )
     71    (*random-permutation!
     72      (make-vector
     73        (check-cardinal-integer 'make-random-permutations n 'length)
     74        0)
     75      (check-procedure 'make-random-permutations randoms 'randoms))) )
    7076
    71 (define (random-permutation! vec #!key (randoms (make-uniform-random-integers)))
    72   (check-vector 'random-permutation! vec)
    73   (*random-permutation! vec randoms) )
     77(define (random-permutation! vec #!key (randoms random-integer))
     78  (*random-permutation!
     79    (check-vector 'random-permutation! vec)
     80    (check-procedure 'random-permutation! randoms 'randoms)) )
    7481
    7582;;
    7683
    77 (define (make-random-vector #!key (randoms (make-uniform-random-reals)))
     84(define (make-random-vector #!key (randoms random-real))
    7885  (lambda (n)
    79     (check-cardinal-integer 'random-vector n 'length)
    80     (vector-filled! (make-vector n) randoms)) )
     86    (vector-filled!
     87      (make-vector
     88        (check-cardinal-integer 'random-vector n 'length))
     89      (check-procedure 'make-random-vector randoms 'randoms))) )
    8190
    82 (define (random-vector! vec #!key (randoms (make-uniform-random-reals)))
    83   (check-vector% 'random-vector! vec)
    84   (vector%-filled! vec randoms) )
     91(define (random-vector! vec #!key (randoms random-real))
     92  (vector%-filled!
     93    (check-vector% 'random-vector! vec)
     94    (check-procedure 'random-vector! randoms 'randoms)) )
    8595
    8696;;; Normal vectors
     
    95105(define (**random-hollow-sphere! vec norms)
    96106  (vector%-filled! vec norms)
    97   (vector%-scale! vec (*reciprocal (sqrt (vector%-sum-squares vec)))) )
     107  (vector%-scale! vec (*reciprocal (sqrt (vector%-sum-squares vec))))
     108  vec )
    98109
    99110(define (*random-hollow-sphere! vec mu sigma randoms)
    100   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     111  (let-values (
     112      ((norms pl)
     113        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    101114    (**random-hollow-sphere! vec norms) ) )
    102115
    103 (define (make-random-hollow-sphere #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    104   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     116(define (make-random-hollow-sphere
     117            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     118  (let-values (
     119      ((norms pl)
     120        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    105121    (lambda (n)
    106       (check-cardinal-integer 'random-hollow-sphere n 'length)
    107       (**random-hollow-sphere! (make-vector n) norms) ) ) )
     122      (**random-hollow-sphere!
     123        (make-vector (check-cardinal-integer 'random-hollow-sphere n 'length))
     124        norms) ) ) )
    108125
    109 (define (random-hollow-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    110   (check-vector% 'random-hollow-sphere! vec)
    111   (*random-hollow-sphere! vec mu sigma randoms) )
     126(define (random-hollow-sphere!
     127            vec
     128            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     129  (*random-hollow-sphere!
     130    (check-vector% 'random-hollow-sphere! vec)
     131    mu sigma randoms) )
    112132
    113133;;
     
    120140(define (**random-solid-sphere! vec randoms norms)
    121141  (**random-hollow-sphere! vec norms)
    122   (vector%-scale! vec (expt (randoms) (*reciprocal (vector%-length vec)))) )
     142  (vector%-scale! vec (expt (randoms) (*reciprocal (vector%-length vec))))
     143  vec )
    123144
    124145(define (*random-solid-sphere! vec mu sigma randoms)
    125   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     146  (let-values (
     147      ((norms pl)
     148        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    126149    (**random-solid-sphere! vec randoms norms) ) )
    127150
    128 (define (make-random-solid-sphere #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    129   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     151(define (make-random-solid-sphere
     152            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     153  (let-values (
     154      ((norms pl)
     155        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    130156    (lambda (n)
    131       (check-cardinal-integer 'random-solid-sphere n 'length)
    132       (**random-solid-sphere! (make-vector n) randoms norms) ) ) )
     157      (**random-solid-sphere!
     158        (make-vector (check-cardinal-integer 'random-solid-sphere n 'length))
     159        randoms norms) ) ) )
    133160
    134 (define (random-solid-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    135   (check-vector% 'random-solid-sphere! vec)
    136   (*random-solid-sphere! vec mu sigma randoms) )
     161(define (random-solid-sphere!
     162            vec
     163            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     164  (*random-solid-sphere!
     165    (check-vector% 'random-solid-sphere! vec)
     166    mu sigma randoms) )
    137167
    138168) ;module srfi-27-vector
  • release/4/srfi-27/tags/3.2.3/srfi-27.meta

    r34011 r34015  
    2323 "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm"
    2424 "entropy-windows.scm" "moa.scm" "entropy-support.scm"
    25  "registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm"
     25 "source-registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm"
    2626 "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
  • release/4/srfi-27/tags/3.2.3/srfi-27.scm

    r34011 r34015  
    7676    (cond
    7777      ((entropy-source? x)
    78         x)
     78        x )
    7979      (else
    8080        (warning-argument-type 'current-entropy-source x 'entropy-source)
    8181        (current-entropy-source) ) ) ) )
    8282
    83 (define make-entropy-source
    84   (case-lambda
    85     (()
    86       ((@entropy-source-constructor (current-entropy-source))) )
    87     ((es)
    88       (let ((ctor
    89               (cond
    90                 ((entropy-source? es)
    91                   (@entropy-source-constructor es) )
    92                 ((symbol? es)
    93                   (let ((ctor (registered-entropy-source es)))
    94                     (or
    95                       ctor
    96                       (error 'make-entropy-source "unregistered entropy-source name" es) ) ) )
    97                 (else
    98                   (error-argument-type
    99                     'make-entropy-source es
    100                     "valid entropy-source or registered entropy-source name") ) ) ) )
    101         (ctor) ) ) ) )
    102 
    103 #;
    10483(define (make-entropy-source #!optional (es (current-entropy-source)))
    10584  (let ((ctor
     
    11695
    11796(define (new-entropy-source es)
    118   (check-entropy-source 'new-entropy-source es)
    119   ((@entropy-source-constructor es)) )
     97  ((@entropy-source-constructor (check-entropy-source 'new-entropy-source es))) )
    12098
    12199(define (entropy-source-name es)
    122   (check-entropy-source 'entropy-source-name es)
    123   (*entropy-source-name es) )
     100  (*entropy-source-name (check-entropy-source 'entropy-source-name es)) )
    124101
    125102(define entropy-source-kind entropy-source-name)
    126103
    127104(define (entropy-source-documentation es)
    128   (check-entropy-source 'entropy-source-documentation es)
    129   (*entropy-source-documentation es) )
     105  (*entropy-source-documentation
     106    (check-entropy-source 'entropy-source-documentation es)) )
    130107
    131108(define (entropy-source-u8vector es n #!optional vec)
    132   (check-entropy-source 'entropy-source-u8vector es)
    133   (check-positive-fixnum 'entropy-source-u8vector n)
    134   (when vec (check-u8vector 'entropy-source-u8vector vec))
    135   ((@entropy-source-u8vector es) n vec) )
     109  ((@entropy-source-u8vector (check-entropy-source 'entropy-source-u8vector es))
     110    (check-positive-fixnum 'entropy-source-u8vector n)
     111    (and vec (check-u8vector 'entropy-source-u8vector vec))) )
    136112
    137113(define (entropy-source-f64vector es n #!optional vec)
    138   (check-entropy-source 'entropy-source-f64vector es)
    139   (check-positive-fixnum 'entropy-source-f64vector n)
    140   (when vec (check-f64vector 'entropy-source-f64vector vec))
    141   ((@entropy-source-f64vector es) n vec) )
     114  ((@entropy-source-f64vector (check-entropy-source 'entropy-source-f64vector es))
     115    (check-positive-fixnum 'entropy-source-f64vector n)
     116    (and vec (check-f64vector 'entropy-source-f64vector vec))) )
    142117
    143118(define (entropy-source-u8 es)
    144   (check-entropy-source 'entropy-source-u8 es)
    145   (@entropy-source-u8 es) )
     119  (@entropy-source-u8 (check-entropy-source 'entropy-source-u8 es)) )
    146120
    147121(define (entropy-source-f64 es)
    148   (check-entropy-source 'entropy-source-f64 es)
    149   (@entropy-source-f64 es) )
     122  (@entropy-source-f64 (check-entropy-source 'entropy-source-f64 es)) )
    150123
    151124;;; Random Source
     
    154127  (let ((rndint ((@random-source-make-integers rs))))
    155128    (lambda (n)
    156       (check-cardinal-integer 'make-u8vector n 'length)
    157       (u8vector-filled! (make-u8vector n) (lambda () (rndint 256))) ) ) )
     129      (u8vector-filled!
     130        (make-u8vector (check-cardinal-integer 'random-source-make-u8vector n 'length))
     131        (lambda () (rndint 256))) ) ) )
    158132
    159133(define (*random-source-make-f64vectors rs prec)
    160134  (let ((rnd ((@random-source-make-reals rs) prec)))
    161135    (lambda (n)
    162       (check-cardinal-integer 'make-f64vector n 'length)
    163       (f64vector-filled! (make-f64vector n) rnd) ) ) )
     136      (f64vector-filled!
     137        (make-f64vector (check-cardinal-integer 'random-source-make-f64vector n 'length))
     138        rnd) ) ) )
    164139
    165140;;
     
    185160    (cond
    186161      ((random-source? x)
    187         x)
     162        x )
    188163      (else
    189164        (warning-argument-type 'current-random-source x 'random-source)
    190165        (current-random-source) ) ) ) )
    191166
    192 (define make-random-source
    193   (case-lambda
    194     (()
    195       ((@random-source-constructor (current-random-source))) )
    196     ((es)
    197       (let ((ctor
    198               (cond
    199                 ((random-source? es)
    200                   (@random-source-constructor es) )
    201                 ((symbol? es)
    202                   (registered-random-source es) )
    203                 (else
    204                   (error-argument-type
    205                     'make-random-source es
    206                     "valid random-source or registered random-source name") ) ) ) )
    207         (ctor) ) ) ) )
    208 
    209 #;
    210 (define (make-random-source #!optional (es (current-random-source)))
     167(define (make-random-source #!optional (rs (current-random-source)))
    211168  (let ((ctor
    212169          (cond
    213             ((random-source? es)
    214               (@random-source-constructor es) )
    215             ((symbol? es)
    216               (registered-random-source es) )
     170            ((random-source? rs)
     171              (@random-source-constructor rs) )
     172            ((symbol? rs)
     173              (registered-random-source rs) )
    217174            (else
    218175              (error-argument-type
    219                 'make-random-source es
     176                'make-random-source rs
    220177                "valid random-source or registered random-source name") ) ) ) )
    221178    (ctor) ) )
    222179
    223 (define (new-random-source es)
    224   (check-random-source 'new-random-source es)
    225   ((@random-source-constructor es)) )
     180(define (new-random-source rs)
     181  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
    226182
    227183(define (random-source-name rs)
    228   (check-random-source 'random-source-name rs)
    229   (*random-source-name rs) )
     184  (*random-source-name
     185    (check-random-source 'random-source-name rs)) )
    230186
    231187(define random-source-kind random-source-name)
    232188
    233189(define (random-source-documentation rs)
    234   (check-random-source 'random-source-documentation rs)
    235   (*random-source-documentation rs) )
     190  (*random-source-documentation
     191    (check-random-source 'random-source-documentation rs)) )
    236192
    237193(define (random-source-log2-period rs)
    238   (check-random-source 'random-source-log2-period rs)
    239   (*random-source-log2-period rs) )
     194  (*random-source-log2-period
     195    (check-random-source 'random-source-log2-period rs)) )
    240196
    241197(define (random-source-maximum-range rs)
    242   (check-random-source 'random-source-maximum-range rs)
    243   (*random-source-maximum-range rs) )
     198  (*random-source-maximum-range
     199    (check-random-source 'random-source-maximum-range rs)) )
    244200
    245201(define (random-source-entropy-source rs)
    246   (check-random-source 'random-source-entropy-source rs)
    247   (*random-source-entropy-source rs) )
     202  (*random-source-entropy-source
     203    (check-random-source 'random-source-entropy-source rs)) )
    248204
    249205(define (random-source-entropy-source-set! rs es)
    250   (check-random-source 'random-source-entropy-source-set! rs)
    251   (check-entropy-source 'random-source-entropy-source-set! es)
    252   (*random-source-entropy-source-set! rs es) )
     206  (*random-source-entropy-source-set!
     207    (check-random-source 'random-source-entropy-source-set! rs)
     208    ;#f indicates no set entropy-source
     209    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )
    253210
    254211(define (random-source-state-ref rs)
    255   (check-random-source 'random-source-state-ref rs)
    256   ((@random-source-state-ref rs)) )
     212  ((@random-source-state-ref (check-random-source 'random-source-state-ref rs))) )
    257213
    258214(define (random-source-state-set! rs state)
    259   (check-random-source 'random-source-state-set! rs)
    260   ((@random-source-state-set! rs) state) )
     215  ((@random-source-state-set! (check-random-source 'random-source-state-set! rs))
     216    state) )
    261217
    262218(define (random-source-randomize! rs #!optional es)
    263219  (check-random-source 'random-source-randomize! rs)
    264   (when es (check-entropy-source 'random-source-randomize! es))
    265220  ((@random-source-randomize! rs)
    266     (or es (*random-source-entropy-source rs) (current-entropy-source))) )
     221    (or
     222      (and es (check-entropy-source 'random-source-randomize! es))
     223      (*random-source-entropy-source rs)
     224      (current-entropy-source))) )
    267225
    268226(define (random-source-pseudo-randomize! rs i j)
    269   (check-random-source 'random-source-pseudo-randomize! rs)
    270   (check-cardinal-integer 'random-source-pseudo-randomize! i)
    271   (check-cardinal-integer 'random-source-pseudo-randomize! j)
    272   ((@random-source-pseudo-randomize! rs) i j) )
     227  ((@random-source-pseudo-randomize! (check-random-source 'random-source-pseudo-randomize! rs))
     228    (check-cardinal-integer 'random-source-pseudo-randomize! i)
     229    (check-cardinal-integer 'random-source-pseudo-randomize! j)) )
    273230
    274231(define (random-source-make-integers rs)
    275   (check-random-source 'random-source-make-integers rs)
    276   ((@random-source-make-integers rs)) )
     232  ((@random-source-make-integers (check-random-source 'random-source-make-integers rs))) )
    277233
    278234(define (random-source-make-reals rs #!optional prec)
    279   (check-random-source 'random-source-make-reals rs)
    280   (when prec (check-real-precision 'random-source-make-reals prec 'precision))
    281   ((@random-source-make-reals rs) prec) )
     235  ((@random-source-make-reals (check-random-source 'random-source-make-reals rs))
     236    (and prec (check-real-precision 'random-source-make-reals prec 'precision))) )
    282237
    283238(define (random-source-make-u8vectors rs)
    284   (check-random-source 'random-source-make-u8vectors rs)
    285   (*random-source-make-u8vectors rs) )
     239  (*random-source-make-u8vectors
     240    (check-random-source 'random-source-make-u8vectors rs)) )
    286241
    287242(define (random-source-make-f64vectors rs #!optional prec)
    288   (check-random-source 'random-source-make-f64vectors rs)
    289   (when prec (check-real-precision 'random-source-make-f64vectors prec 'precision))
    290   (*random-source-make-f64vectors rs prec) )
     243  (*random-source-make-f64vectors
     244    (check-random-source 'random-source-make-f64vectors rs)
     245    (and prec (check-real-precision 'random-source-make-f64vectors prec 'precision))) )
    291246
    292247) ;module srfi-27
  • release/4/srfi-27/tags/3.2.3/srfi-27.setup

    r34012 r34015  
    77;; Utility Modules
    88
    9 (setup-shared-extension-module 'fp-extn (extension-version "3.2.2")
     9(setup-shared-extension-module 'fp-extn (extension-version "3.2.3")
    1010  #:inline? #t
    1111  #:types? #t
     
    1414    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    1515
    16 (setup-shared-extension-module 'registration (extension-version "3.2.2")
     16(setup-shared-extension-module 'source-registration (extension-version "3.2.3")
    1717  #:inline? #t
    1818  #:types? #t
     
    2121    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2222
    23 (setup-shared-extension-module 'srfi-27-numbers (extension-version "3.2.2")
     23(setup-shared-extension-module 'srfi-27-numbers (extension-version "3.2.3")
    2424  #:inline? #t
    2525  #:types? #t
     
    2828    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2929
    30 (setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.2.2")
     30(setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.2.3")
    3131  #:inline? #t
    3232  #:types? #t
     
    3737;; Entropy Source Modules
    3838
    39 (setup-shared-extension-module 'entropy-source (extension-version "3.2.2")
     39(setup-shared-extension-module 'entropy-source (extension-version "3.2.3")
    4040  #:inline? #t
    4141  #:types? #t
     
    4444    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    4545
    46 (setup-shared-extension-module 'entropy-support (extension-version "3.2.2")
     46(setup-shared-extension-module 'entropy-support (extension-version "3.2.3")
    4747  #:inline? #t
    4848  #:types? #t
     
    5151    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    5252
    53 (setup-shared-extension-module 'entropy-clock (extension-version "3.2.2")
     53(setup-shared-extension-module 'entropy-clock (extension-version "3.2.3")
    5454  #:inline? #t
    5555  #:types? #t
     
    5858    -no-procedure-checks) )
    5959
    60 (setup-shared-extension-module 'entropy-procedure (extension-version "3.2.2")
     60(setup-shared-extension-module 'entropy-procedure (extension-version "3.2.3")
    6161  #:inline? #t
    6262  #:types? #t
     
    6565    -no-procedure-checks) )
    6666
    67 (setup-shared-extension-module 'entropy-port (extension-version "3.2.2")
     67(setup-shared-extension-module 'entropy-port (extension-version "3.2.3")
    6868  #:inline? #t
    6969  #:types? #t
     
    7373
    7474#+unix
    75 (setup-shared-extension-module 'entropy-unix (extension-version "3.2.2")
     75(setup-shared-extension-module 'entropy-unix (extension-version "3.2.3")
    7676  #:inline? #t
    7777  #:types? #t
     
    8181
    8282#+windows
    83 (setup-shared-extension-module 'entropy-windows (extension-version "3.2.2")
     83(setup-shared-extension-module 'entropy-windows (extension-version "3.2.3")
    8484  #:inline? #t
    8585  #:types? #t
     
    9090;; Random Source Modules
    9191
    92 (setup-shared-extension-module 'random-source (extension-version "3.2.2")
     92(setup-shared-extension-module 'random-source (extension-version "3.2.3")
    9393  #:inline? #t
    9494  #:types? #t
     
    9797    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    9898
    99 (setup-shared-extension-module 'mrg32k3a (extension-version "3.2.2")
     99(setup-shared-extension-module 'mrg32k3a (extension-version "3.2.3")
    100100  #:inline? #t
    101101  #:types? #t
     
    105105    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    106106
    107 (setup-shared-extension-module 'mwc (extension-version "3.2.2")
     107(setup-shared-extension-module 'mwc (extension-version "3.2.3")
    108108  #:inline? #t
    109109  #:types? #t
     
    112112    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    113113
    114 (setup-shared-extension-module 'moa (extension-version "3.2.2")
     114(setup-shared-extension-module 'moa (extension-version "3.2.3")
    115115  #:inline? #t
    116116  #:types? #t
     
    119119    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    120120
    121 (setup-shared-extension-module 'composite-random-source (extension-version "3.2.2")
     121(setup-shared-extension-module 'composite-random-source (extension-version "3.2.3")
    122122  #:inline? #t
    123123  #:types? #t
     
    128128;; Main Modules
    129129
    130 (setup-shared-extension-module 'srfi-27 (extension-version "3.2.2")
     130(setup-shared-extension-module 'srfi-27 (extension-version "3.2.3")
    131131  #:inline? #t
    132132  #:types? #t
     
    135135    -no-procedure-checks) )
    136136
    137 (setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.2.2")
     137(setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.2.3")
    138138  #:inline? #t
    139139  #:types? #t
     
    142142    #;-no-procedure-checks) )
    143143
    144 (setup-shared-extension-module 'srfi-27-distributions (extension-version "3.2.2")
     144(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.2.3")
    145145  #:inline? #t
    146146  #:types? #t
     
    149149    -no-procedure-checks) )
    150150
    151 (setup-shared-extension-module 'srfi-27-vector (extension-version "3.2.2")
     151(setup-shared-extension-module 'srfi-27-vector (extension-version "3.2.3")
    152152  #:inline? #t
    153153  #:types? #t
  • release/4/srfi-27/tags/3.2.3/tests/run.scm

    r34012 r34015  
    11
    22(use test)
     3
     4;;
     5
    36(use srfi-27)
    4 (use srfi-4)
    57
    6 (newline)
     8;(print "Current Random Source: " (random-source-kind (current-random-source)))
     9;(print "Current Entropy Source: " (entropy-source-kind (current-entropy-source)))
     10;(newline)
    711
    812(test-begin "SRFI 27")
    913
    10 (test-group "Testing random SRFI-4 vector"
    11   (print "Random Source: " (random-source-kind (current-random-source)))
    12   (print "Entropy Source: " (entropy-source-kind (current-entropy-source)))
     14;;
    1315
    14   (let ((v10 (random-u8vector 10)))
    15     (newline)
    16     ;(print "u8vector: " v10)
    17     (test "random-u8vector ?" #t (u8vector? v10))
    18     (test "random-u8vector 10" 10 (u8vector-length v10)) )
     16(use random-source entropy-source)
    1917
    20   (let ((v10 (random-f64vector 10)))
    21     (newline)
    22     ;(print "f64vector: " v10)
    23     (test "random-f64vector ?" #t (f64vector? v10))
    24     (test "random-f64vector 10" 10 (f64vector-length v10)) ) )
     18(test-group "basics"
     19  (test-assert (random-source? default-random-source))
     20  (test-assert (random-source? (current-random-source)))
     21  (test-assert (entropy-source? (current-entropy-source)))
     22
     23  (test-assert (procedure? random-integer))
     24  (test-assert (procedure? random-real))
     25)
     26
     27;;
     28
     29(use srfi-4)
     30
     31(test-group "SRFI-4 vector"
     32
     33  (test-group "u8vector"
     34    ;(test-assert (procedure? random-u8vector))
     35    (let ((v10 (random-u8vector 10)))
     36      (test #t (u8vector? v10))
     37      (test 10 (u8vector-length v10)) ) )
     38
     39  (test-group "f64vector"
     40    ;(test-assert (procedure? random-f64vector))
     41    (let ((v10 (random-f64vector 10)))
     42      (test #t (f64vector? v10))
     43      (test 10 (f64vector-length v10)) ) )
     44)
     45
     46;;
    2547
    2648(use srfi-27-uniform-random)
    2749
    28 (test-group "make-uniform-random-integers"
    29   (let-values (
    30       ((gen init)
    31         (make-uniform-random-integers high: 27 low: 16 precision: 2)))
    32     (let-values (((high low precision source) (init)))
    33       (test-assert (= 27 high))
    34       (test-assert (= 16 low))
    35       (test-assert (= 2 precision))
    36       (do ((i 0 (add1 i))
    37            (rv (gen) (gen)) )
    38           ((= 100 i))
    39         (unless (<= 16 rv) (test-assert (<= 16 rv)))
    40         (unless (<= rv 27) (test-assert (<= rv 27)))
    41         (unless (zero? (modulo rv 2)) (test-assert (zero? (modulo rv 2)))) ) ) ) )
     50(test-group "uniform-random"
    4251
    43 ;FIXME needs real test
    44 (test-group "make-uniform-random-reals"
    45   (let-values (
    46       ((gen init)
    47         (make-uniform-random-reals precision: 0.000000000003)))
    48     (let-values (((precision source) (init)))
    49       (test-assert (= 0.000000000003 precision))
    50       ;(flonum-print-precision 53)
    51       (do ((i 0 (add1 i))
    52            (rv (gen) (gen)) )
    53           ((= 100 i))
    54           ) ) ) )
     52  (test-group "integers"
     53    (let-values (
     54        ((gen init)
     55          (make-uniform-random-integers high: 27 low: 16 precision: 2)))
     56      (let-values (((high low precision source) (init)))
     57        (test-assert (= 27 high))
     58        (test-assert (= 16 low))
     59        (test-assert (= 2 precision))
     60        (do ((i 0 (add1 i))
     61             (rv (gen) (gen)) )
     62            ((= 100 i))
     63          (unless (<= 16 rv) (test-assert (<= 16 rv)))
     64          (unless (<= rv 27) (test-assert (<= rv 27)))
     65          (unless (zero? (modulo rv 2)) (test-assert (zero? (modulo rv 2)))) ) ) ) )
     66
     67  ;FIXME needs real test
     68  (test-group "reals"
     69    (let-values (
     70        ((gen init)
     71          (make-uniform-random-reals precision: 0.000000000003)))
     72      (let-values (((precision source) (init)))
     73        (test-assert (= 0.000000000003 precision))
     74        ;(flonum-print-precision 53)
     75        (do ((i 0 (add1 i))
     76             (rv (gen) (gen)) )
     77            ((= 100 i))
     78            ) ) ) )
     79)
     80
     81;;
     82
     83(use srfi-27-vector)
     84
     85(test-group "vector"
     86
     87  (test-group "random-permutations"
     88    (let ((gen (make-random-permutations)))
     89      (test-assert (procedure? gen))
     90      (let ((vec (gen 10)))
     91        (test-assert (vector? vec))
     92        (test 10 (vector-length vec)) ) ) )
     93
     94  (test-group "random-vector"
     95    (let ((gen (make-random-vector)))
     96      (test-assert (procedure? gen))
     97      (let ((vec (gen 10)))
     98        (test-assert (vector? vec))
     99        (test 10 (vector-length vec)) ) ) )
     100
     101  (test-group "random-hollow-sphere"
     102    (let ((gen (make-random-hollow-sphere)))
     103      (test-assert (procedure? gen))
     104      (let ((vec (gen 10)))
     105        (test-assert (vector? vec))
     106        (test 10 (vector-length vec)) ) ) )
     107
     108  (test-group "random-solid-sphere"
     109    (let ((gen (make-random-solid-sphere)))
     110      (test-assert (procedure? gen))
     111      (let ((vec (gen 10)))
     112        (test-assert (vector? vec))
     113        (test 10 (vector-length vec)) ) ) )
     114)
    55115
    56116(test-end "SRFI 27")
     117
     118;;
    57119
    58120(use utils)
  • release/4/srfi-27/trunk/entropy-port.scm

    r34012 r34015  
    1515
    1616(import
    17   (only type-checks check-input-port check-procedure check-symbol check-string)
     17  (only type-checks check-input-port check-procedure check-symbol check-string check-number)
    1818  (only type-errors warning-argument-type))
    1919(require-library type-checks type-errors)
     
    2323;;
    2424
    25 (define ((make-open-binary-input-file namstr)) (open-input-file namstr #:binary))
     25(define (make-open-binary-input-file namstr)
     26  (lambda ()
     27    (open-input-file namstr #:binary)) )
    2628
    2729;;
     
    9193
    9294(define (*make-entropy-source/port-open opener name docu)
    93   (let ((to (entropy-port-lifetime)))
    94     (if to
     95  (let ((timeout (entropy-port-lifetime)))
     96    (if timeout
    9597      ;then auto-close on timeout
    96       (*make-entropy-source/port-open-timed opener to name docu)
     98      (*make-entropy-source/port-open-timed opener timeout name docu)
    9799      ;else keep open
    98100      (let ((port (opener)))
     
    121123          (name (gensym 'port-))
    122124          (docu "Entropy from an open port"))
    123   (check-input-port 'make-entropy-source/port port)
    124   (check-symbol 'make-entropy-source/port name 'name)
    125   (check-string 'make-entropy-source/port docu 'documentation)
    126   (*make-entropy-source/port port name docu) )
     125  (*make-entropy-source/port
     126    (check-input-port 'make-entropy-source/port port)
     127    (check-symbol 'make-entropy-source/port name 'name)
     128    (check-string 'make-entropy-source/port docu 'documentation)) )
    127129
    128130;;; Entropy from port, timed or fixed (parameterized by entropy-port-lifetime)
     
    132134          (name (gensym 'port-))
    133135          (docu "Entropy from port"))
    134   (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
    135   (check-symbol 'make-entropy-source/port-open name 'name)
    136   (check-string 'make-entropy-source/port-open docu 'documentation)
    137   (*make-entropy-source/port-open opener name docu) )
     136  (*make-entropy-source/port-open
     137    (check-procedure 'make-entropy-source/port-open opener 'open-procedure)
     138    (check-symbol 'make-entropy-source/port-open name 'name)
     139    (check-string 'make-entropy-source/port-open docu 'documentation)) )
    138140
    139141;;; Make TImed Port Entropy Source
     
    143145          (name (gensym 'timed-port-))
    144146          (docu "Entropy from timed open port"))
    145   (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
    146   ;(check- timeout 'timeout)
    147   (check-symbol 'make-entropy-source/port-open-timed name 'name)
    148   (check-string 'make-entropy-source/port-open-timed docu 'documentation)
    149   (*make-entropy-source/port-open-timed opener timeout name docu) )
     147  (*make-entropy-source/port-open-timed
     148    (check-procedure 'make-entropy-source/port-open-timed opener 'open-procedure)
     149    (check-number 'make-entropy-source/port-open-timed timeout 'timeout)
     150    (check-symbol 'make-entropy-source/port-open-timed name 'name)
     151    (check-string 'make-entropy-source/port-open-timed docu 'documentation)) )
    150152
    151153;;;
    152154
    153 (define (make-entropy-open-file namstr)
    154   (make-open-binary-input-file namstr) )
     155;binary mode by default (only at the moment)
     156(define make-entropy-open-file make-open-binary-input-file)
    155157
    156158;;; Entropy from some file (binary)
     
    160162          (name (gensym 'file-))
    161163          (docu (string-append "Entropy from file \"" namstr "\"")))
    162   (check-string 'make-entropy-source/file namstr 'filename)
    163   (check-symbol 'make-entropy-source/file name 'name)
    164   (check-string 'make-entropy-source/file docu 'documentation)
    165   (*make-entropy-source/port-open (make-entropy-open-file namstr) name docu) )
     164  (*make-entropy-source/port-open
     165    (make-entropy-open-file (check-string 'make-entropy-source/file namstr 'filename))
     166    (check-symbol 'make-entropy-source/file name 'name)
     167    (check-string 'make-entropy-source/file docu 'documentation)) )
    166168
    167169(define (make-entropy-source/file-timed namstr timeout
     
    169171          (name (gensym 'file-))
    170172          (docu (string-append "Entropy from file \"" namstr "\"")))
    171   (check-string 'make-entropy-source/file-timed namstr 'filename)
    172   ;(check- timeout 'timeout)
    173   (check-symbol 'make-entropy-source/file-timed name 'name)
    174   (check-string 'make-entropy-source/file-timed docu 'documentation)
    175   (*make-entropy-source/port-open-timed (make-entropy-open-file namstr) timeout name docu) )
     173  (*make-entropy-source/port-open-timed
     174    (make-entropy-open-file (check-string 'make-entropy-source/file-timed namstr 'filename))
     175    (check-number 'make-entropy-source/file-timed timeout 'timeout)
     176    (check-symbol 'make-entropy-source/file-timed name 'name)
     177    (check-string 'make-entropy-source/file-timed docu 'documentation)) )
    176178
    177179) ;module entropy-port
  • release/4/srfi-27/trunk/entropy-source.scm

    r34012 r34015  
    3131(require-library data-structures srfi-1 type-checks)
    3232
    33 (use registration)
     33(use source-registration)
    3434
    3535;;
     
    6262;; Entropy Source Constructor Registry
    6363
    64 (define +reg+ (make-registration 'entropy-source '()))
     64(define +reg+ (make-source-registration 'entropy-source '()))
    6565
    6666(define (registered-entropy-sources)
    67   ((@registration-key +reg+)) )
     67  ((@source-registration-key +reg+)) )
    6868
    6969(define (registered-entropy-source name)
    70   ((@registration-ref +reg+) name) )
     70  ((@source-registration-ref +reg+) name) )
    7171
    7272(define (unregister-entropy-source name)
    73   ((@registration-deref! +reg+) name) )
     73  ((@source-registration-deref! +reg+) name) )
    7474
    7575(define (register-entropy-source! name ctor)
    76   ((@registration-register! +reg+) name ctor) )
     76  ((@source-registration-register! +reg+) name ctor) )
    7777
    7878) ;entropy-source
  • release/4/srfi-27/trunk/entropy-support.scm

    r34012 r34015  
    149149          (let ((len (read-u8vector! BYTES/F64 f64buf port)))
    150150            (cond
    151               ((< len BYTES/F64)                      0.0)
    152               ((good_positive_double f64buf #$tmpdbl) tmpdbl)
    153               (else                                   (loop) ) ) ) ) ) ) ) )
     151              ((< len BYTES/F64)
     152                0.0 )
     153              ((good_positive_double f64buf #$tmpdbl)
     154                tmpdbl )
     155              (else
     156                (loop) ) ) ) ) ) ) ) )
    154157
    155158(define port-entropic-f64
  • release/4/srfi-27/trunk/random-source.scm

    r34012 r34015  
    3030(require-library data-structures srfi-1 type-checks)
    3131
    32 (use registration)
     32(use source-registration)
    3333
    3434;;
     
    6161;; Random Source Constructor Registry
    6262
    63 (define +reg+ (make-registration 'random-source '()))
     63(define +reg+ (make-source-registration 'random-source '()))
    6464
    6565(define (registered-random-sources)
    66   ((@registration-key +reg+)) )
     66  ((@source-registration-key +reg+)) )
    6767
    6868(define (registered-random-source name)
    69   ((@registration-ref +reg+) name) )
     69  ((@source-registration-ref +reg+) name) )
    7070
    7171(define (unregister-random-source name)
    72   ((@registration-deref! +reg+) name) )
     72  ((@source-registration-deref! +reg+) name) )
    7373
    7474(define (register-random-source! name ctor)
    75   ((@registration-register! +reg+) name ctor) )
     75  ((@source-registration-register! +reg+) name ctor) )
    7676
    7777) ;module random-source
  • release/4/srfi-27/trunk/source-registration.scm

    r34014 r34015  
    1 ;;;; registration.scm
     1;;;; source-registration.scm
    22;;;; Kon Lovett, Feb '17
    33;;;; Kon Lovett, Oct '09
    44
    5 (module registration
     5(module source-registration
    66
    77(;export
    8   make-registration
    9   registration? check-registration error-registration
    10   @registration-key @registration-ref @registration-deref! @registration-register!)
     8  make-source-registration
     9  source-registration? check-source-registration error-source-registration
     10  @source-registration-key @source-registration-ref @source-registration-deref! @source-registration-register!)
    1111
    1212(import scheme chicken)
     
    2828;;
    2929
    30 (define-record-type registration
    31   (*make-registration nam srcs keys ref deref! reg!)
    32   registration?
    33   (nam    *registration-name)
    34   (srcs   *registration-sources *registration-sources-set!)
    35   (keys   @registration-key)
    36   (ref    @registration-ref)
    37   (deref! @registration-deref!)
    38   (reg!   @registration-register!) )
     30(define-record-type source-registration
     31  (*make-source-registration nam srcs keys ref deref! reg!)
     32  source-registration?
     33  (nam    *source-registration-name)
     34  (srcs   *source-registration-sources *source-registration-sources-set!)
     35  (keys   @source-registration-key)
     36  (ref    @source-registration-ref)
     37  (deref! @source-registration-deref!)
     38  (reg!   @source-registration-register!) )
    3939
    40 (define-check+error-type registration)
     40(define-check+error-type source-registration)
    4141
    4242;;
    4343
    44 (define (make-registration name sources)
     44(define (make-source-registration name sources)
    4545  (letrec ((reg
    46             (*make-registration
    47               (check-symbol 'make-registration name "name")
    48               (check-list 'make-registration sources "sources")
     46            (*make-source-registration
     47              (check-symbol 'make-source-registration name "name")
     48              (check-list 'make-source-registration sources "sources")
    4949              (lambda ()
    50                 (alist-keys (*registration-sources reg)) )
     50                (alist-keys (*source-registration-sources reg)) )
    5151              (lambda (name)
    5252                (alist-ref
    53                   (check-symbol 'registration-ref name)
    54                   (*registration-sources reg)
     53                  (check-symbol 'source-registration-ref name)
     54                  (*source-registration-sources reg)
    5555                  eq? #f) )
    5656              (lambda (name)
    57                 (*registration-sources-set!
     57                (*source-registration-sources-set!
    5858                  reg
    5959                  (alist-delete!
    60                     (check-symbol 'registration-deref! name)
    61                     (*registration-sources reg)
     60                    (check-symbol 'source-registration-deref! name)
     61                    (*source-registration-sources reg)
    6262                    eq?)) )
    6363              (lambda (name ctor)
    64                 (*registration-sources-set!
     64                (*source-registration-sources-set!
    6565                  reg
    6666                  (alist-update!
    67                     (check-symbol 'registration-register!! name)
    68                     (check-procedure 'registration-register! ctor)
    69                     (*registration-sources reg)
     67                    (check-symbol 'source-registration-register!! name)
     68                    (check-procedure 'source-registration-register! ctor)
     69                    (*source-registration-sources reg)
    7070                    eq?)))) ) )
    7171    reg ) )
    7272
    73 ) ;module registration
     73) ;module source-registration
  • release/4/srfi-27/trunk/srfi-27-distributions.scm

    r34012 r34015  
    109109
    110110(define (make-random-normals
    111           #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     111          #!key
     112                                        (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    112113  (check-real 'make-random-normals mu 'mu)
    113114  (check-nonzero-real 'make-random-normals sigma 'sigma)
     
    128129
    129130(define (make-random-exponentials
    130           #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     131          #!key
     132                                        (mu 1.0) (randoms (make-uniform-random-reals)))
    131133  (check-real-unit 'make-random-exponentials mu 'mu)
    132134  (check-procedure 'make-random-exponentials randoms 'randoms)
     
    152154
    153155(define (make-random-triangles
    154           #!key (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
     156          #!key
     157                                        (s 0.0) (m 0.5) (l 1.0) (randoms (make-uniform-random-reals)))
    155158  (check-real 'make-random-triangles s 's)
    156159  (check-real 'make-random-triangles m 'm)
     
    174177
    175178(define (make-random-poissons
    176           #!key (mu 1.0) (randoms (make-uniform-random-reals)))
     179          #!key
     180                                        (mu 1.0) (randoms (make-uniform-random-reals)))
    177181  (check-nonnegative-real 'make-random-poissons mu 'mu)
    178182  (check-procedure 'make-random-poissons randoms 'randoms)
     
    190194
    191195(define (make-random-bernoullis
    192           #!key (p 0.5) (randoms (make-uniform-random-reals)))
     196          #!key
     197                                        (p 0.5) (randoms (make-uniform-random-reals)))
    193198  (check-real-unit 'make-random-bernoullis p 'p)
    194199  (check-procedure 'make-random-bernoullis randoms 'randoms)
     
    213218
    214219(define (make-random-binomials
    215           #!key (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
     220          #!key
     221                                        (t 1) (p 0.5) (randoms (make-uniform-random-reals)))
    216222  (check-cardinal-integer 'make-random-binomials t 't)
    217223  (check-real-unit 'make-random-binomials p 'p)
     
    229235
    230236(define (make-random-geometrics
    231           #!key (p 0.5) (randoms (make-uniform-random-reals)))
     237          #!key
     238                                        (p 0.5) (randoms (make-uniform-random-reals)))
    232239  (check-real-unit 'make-random-geometrics p 'p)
    233240  (check-procedure 'make-random-geometrics randoms 'randoms)
     
    246253
    247254(define (make-random-lognormals
    248           #!key (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     255          #!key
     256                                        (mu 1.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    249257  (check-nonzero-real 'make-random-lognormals mu 'mu)
    250258  (check-nonnegative-real 'make-random-lognormals sigma 'sigma)
     
    260268
    261269(define (make-random-cauchys
    262           #!key (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     270          #!key
     271                                        (median 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    263272  (check-real 'make-random-cauchys median 'median)
    264273  (check-positive-real 'make-random-cauchys sigma 'sigma)
     
    304313
    305314(define (make-random-gammas
    306           #!key (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
     315          #!key
     316                                        (alpha 1.0) (theta 1.0) (randoms (make-uniform-random-reals)))
    307317  (check-positive-real 'make-random-gammas alpha 'alpha)
    308318  (check-positive-real 'make-random-gammas theta 'theta)
     
    318328
    319329(define (make-random-erlangs
    320           #!key (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
     330          #!key
     331                                        (alpha 1) (theta 1.0) (randoms (make-uniform-random-reals)))
    321332  (check-positive-real 'make-random-erlangs alpha 'alpha)
    322333  (check-positive-real 'make-random-erlangs theta 'theta)
     
    333344
    334345(define (make-random-paretos
    335           #!key (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
     346          #!key
     347                                        (alpha 1.0) (xmin 1.0) (randoms (make-uniform-random-reals)))
    336348  (check-positive-real 'make-random-paretos alpha 'alpha)
    337349  (check-positive-real 'make-random-paretos xmin 'xmin)
     
    351363
    352364(define (make-random-levys
    353           #!key (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
     365          #!key
     366                                        (gamma 1.0) (delta 0.0) (randoms (make-uniform-random-reals)))
    354367  (check-nonnegative-real 'make-random-levys delta 'delta)
    355368  (check-positive-real 'make-random-levys gamma 'gamma)
     
    367380
    368381(define (make-random-weibulls
    369           #!key (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
     382          #!key
     383                                        (shape 1.0) (scale 1.0) (randoms (make-uniform-random-reals)))
    370384  (check-positive-real 'make-random-weibulls shape 'shape)
    371385  (check-positive-real 'make-random-weibulls scale 'scale)
  • release/4/srfi-27/trunk/srfi-27-uniform-random.scm

    r34012 r34015  
    3737;;; Uniform random integers in [low high] by precision
    3838
    39 (define (*make-uniform-random-integers low high precision rand)
     39(define (*make-uniform-random-integers low high prec rndint)
    4040  (let ((dist (- high low)))
    41     (if (< dist precision)
    42       (constantly precision)
    43       (let ((range (quotient (+ dist 1) precision)))
     41    (if (< dist prec)
     42      (constantly prec)
     43      (let ((rng (quotient (+ dist 1) prec)))
    4444        (cond
    45           ((= 0 range)
     45          ((= 0 rng)
    4646            (constantly 0) )
    4747          ((= 0 low)
    48             (if (= 1 precision)
     48            (if (= 1 prec)
    4949              (lambda ()
    50                 (rand range)
     50                (rndint rng) )
    5151              (lambda ()
    52                 (* (rand range) precision) ) ) ) )
     52                (* (rndint rng) prec) ) ) )
    5353          (else
    5454            (lambda ()
    55               (+ low (* (rand range) precision) ) ) ) ) ) ) ) )
     55              (+ low (* (rndint rng) prec) ) ) ) ) ) ) ) )
    5656
    5757(define (make-uniform-random-integers
     
    6060          (source (current-random-source)))
    6161  (check-random-source 'make-uniform-random-integers source 'source)
    62   (unless high
    63     (set! high (- (*random-source-maximum-range source) 1)) )
    64   (check-integer 'make-uniform-random-integers high 'high)
    65   (check-integer 'make-uniform-random-integers low 'low)
    66   (check-positive-integer 'make-uniform-random-integers precision 'precision)
    67   (values
    68     (*make-uniform-random-integers low high precision ((@random-source-make-integers source)))
    69     (lambda ()
    70       (values high low precision source)) ) )
     62  (let ((high (or high (- (*random-source-maximum-range source) 1))))
     63    (check-integer 'make-uniform-random-integers high 'high)
     64    (check-integer 'make-uniform-random-integers low 'low)
     65    (check-positive-integer 'make-uniform-random-integers precision 'precision)
     66    (values
     67      (*make-uniform-random-integers
     68        low high precision
     69        ((@random-source-make-integers source)))
     70      (lambda ()
     71        (values high low precision source)) ) ) )
    7172
    7273;;; Uniform random reals in (0.0 1.0) by precion
  • release/4/srfi-27/trunk/srfi-27-vector-support.scm

    r34011 r34015  
    5353
    5454#;
    55 (define ((make-filled! veclenf vecsetf) vec gen #!optional (start 0) (end (veclenf vec)))
    56   (do ((idx start (fx+ idx 1)))
    57       ((fx= end idx) vec)
    58     (vecsetf vec idx (gen)) ) )
     55(define (make-filled! veclenf vecsetf)
     56  (lambda (vec gen #!optional (start 0) (end (veclenf vec)))
     57    (do ((idx start (fx+ idx 1)))
     58        ((fx= end idx) vec)
     59      (vecsetf vec idx (gen)) ) ) )
    5960
    60 (define ((make-mapi!/1 veclenf vecref vecsetf) proc vec)
    61   (let ((len (veclenf vec)))
    62     (do ((i 0 (fx+ i 1)))
    63         ((fx= i len) vec)
    64       (vecsetf vec i (proc i (vecref vec i))) ) ) )
     61(define (make-mapi!/1 veclenf vecref vecsetf)
     62  (lambda (proc vec)
     63    (let ((len (veclenf vec)))
     64      (do ((i 0 (fx+ i 1)))
     65          ((fx= i len) vec)
     66        (vecsetf vec i (proc i (vecref vec i))) ) ) ) )
    6567
    66 (define ((make-foldi/1 veclenf vecref) proc init vec)
    67   (let ((len (veclenf vec)))
    68     (do ((i 0 (fx+ i 1) )
    69          (acc init (proc i acc (vecref vec i)) ) )
    70         ((fx= i len) acc) ) ) )
     68(define (make-foldi/1 veclenf vecref)
     69  (lambda (proc init vec)
     70    (let ((len (veclenf vec)))
     71      (do ((i 0 (fx+ i 1) )
     72           (acc init (proc i acc (vecref vec i)) ) )
     73          ((fx= i len) acc) ) ) ) )
    7174
    7275;;
     
    98101;;; Vector% Support
    99102
     103(define (vector-fold/1 vec proc seed)
     104  (vector-fold (cut proc #f <> <>) seed vec) )
     105
     106(define (vector-map!/1 vec proc)
     107  (vector-map! (cut proc #f <>) vec) )
     108
    100109#; ;NOT YET
    101 (define (array-rank/1? obj) (and (array? obj) (fx= 1 (array-rank obj))))
     110(define (array-rank/1? obj)
     111  (and (array? obj) (fx= 1 (array-rank obj))))
    102112
    103113(define (acceptable-vector? obj)
     
    114124  obj )
    115125
    116 (define ((make-oper vec-oper f32vec-oper f64vec-oper) vec . args)
    117   (cond
    118     ((vector? vec)        (apply vec-oper vec args))
    119     ((f32vector? vec)     (apply f32vec-oper vec args))
    120     ((f64vector? vec)     (apply f64vec-oper vec args))
    121     #; ;NOT YET
    122     ((array-rank/1? vec)  (apply arr-rnk-1 vec args)) ;arr-rnk-1-oper
    123     (else
    124       (error-vector #f vec))) )
     126(define (make-oper vec-oper f32vec-oper f64vec-oper)
     127  (lambda (vec . args)
     128    (cond
     129      ((vector? vec)
     130        (apply vec-oper vec args) )
     131      ((f32vector? vec)
     132        (apply f32vec-oper vec args) )
     133      ((f64vector? vec)
     134        (apply f64vec-oper vec args) )
     135      #; ;NOT YET
     136      ((array-rank/1? vec)
     137        ;arr-rnk-1-oper
     138        (apply arr-rnk-1 vec args) )
     139      (else
     140        (error-vector #f vec)) ) ) )
     141
     142;;
    125143
    126144(define vector%-length
     
    128146
    129147(define vector%-mapi!/1
    130   (make-oper vector-map! f32vector-mapi!/1 f64vector-mapi!/1) )  ;(lambda (vec proc ) (array-map! vec (cut proc #f <>)))
     148  ;(lambda (vec proc) (array-map! vec (cut proc #f <>)))
     149  (make-oper vector-map!/1 f32vector-mapi!/1 f64vector-mapi!/1) )
    131150
    132151(define vector%-foldi/1
    133   (make-oper vector-fold f32vector-foldi/1 f64vector-foldi/1) )  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     152  ;(lambda (vec proc seed) (array-fold (cut proc #f <> <>) seed vec))
     153  (make-oper vector-fold/1 f32vector-foldi/1 f64vector-foldi/1) )
    134154
    135155(define vector%-filled!
    136   (make-oper vector-filled! f32vector-filled! f64vector-filled!) )  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
     156  ;(lambda (vec func) (array-fold (lambda (x y) (func)) #f vec))
     157  (make-oper vector-filled! f32vector-filled! f64vector-filled!) )
    137158
    138159(define (vector%-scale! vec factor)
    139   (vector%-mapi!/1 (lambda (i elt) (* elt factor)) vec) )
     160  (vector%-mapi!/1 vec (lambda (i elt) (* elt factor))) )
    140161
    141162(define (vector%-sum-squares vec)
    142   (vector%-foldi/1 (lambda (i sum elt) (+ sum (* elt elt))) 0 vec) )
     163  (vector%-foldi/1 vec (lambda (i sum elt) (+ sum (* elt elt))) 0) )
    143164
    144165) ;module srfi-27-vector-support
  • release/4/srfi-27/trunk/srfi-27-vector.scm

    r34012 r34015  
    2121
    2222(import
    23   (only type-checks check-cardinal-integer check-vector)
     23  (only type-checks check-cardinal-integer check-vector check-procedure)
    2424  (only type-errors error-vector)
    2525  random-source
    2626  srfi-27-uniform-random
    2727  srfi-27-distributions
    28   srfi-27-vector-support)
     28  srfi-27-vector-support
     29  srfi-27)
    2930(require-library
    3031  type-checks type-errors
    3132  random-source
    3233  srfi-27-uniform-random srfi-27-distributions
    33   srfi-27-vector-support)
     34  srfi-27-vector-support
     35  srfi-27)
    3436
    3537;;;
     
    5254;Section 3.4.2
    5355;
    54 (define (*random-permutation! vec randoms)
     56(define (*random-permutation! vec rndint)
    5557  (let ((n (vector-length vec)))
    5658    (vector-iota-set! vec n)
    5759    (do ((k n (fx- k 1)))
    58         ((fx= k 1) vec)
     60        ((fx= k 1)
     61          vec )
    5962      (let* ((i (fx- k 1))
    60              (j (randoms k))
     63             (j (rndint n))
    6164             (xi (vector-ref vec i))
    6265             (xj (vector-ref vec j)) )
     
    6467        (vector-set! vec j xi) ) ) ) )
    6568
    66 (define (make-random-permutations #!key (randoms (make-uniform-random-integers)))
     69(define (make-random-permutations #!key (randoms random-integer))
    6770  (lambda (n)
    68     (check-cardinal-integer 'make-random-permutations n 'length)
    69     (*random-permutation! (make-vector n 0) randoms)) )
     71    (*random-permutation!
     72      (make-vector
     73        (check-cardinal-integer 'make-random-permutations n 'length)
     74        0)
     75      (check-procedure 'make-random-permutations randoms 'randoms))) )
    7076
    71 (define (random-permutation! vec #!key (randoms (make-uniform-random-integers)))
    72   (check-vector 'random-permutation! vec)
    73   (*random-permutation! vec randoms) )
     77(define (random-permutation! vec #!key (randoms random-integer))
     78  (*random-permutation!
     79    (check-vector 'random-permutation! vec)
     80    (check-procedure 'random-permutation! randoms 'randoms)) )
    7481
    7582;;
    7683
    77 (define (make-random-vector #!key (randoms (make-uniform-random-reals)))
     84(define (make-random-vector #!key (randoms random-real))
    7885  (lambda (n)
    79     (check-cardinal-integer 'random-vector n 'length)
    80     (vector-filled! (make-vector n) randoms)) )
     86    (vector-filled!
     87      (make-vector
     88        (check-cardinal-integer 'random-vector n 'length))
     89      (check-procedure 'make-random-vector randoms 'randoms))) )
    8190
    82 (define (random-vector! vec #!key (randoms (make-uniform-random-reals)))
    83   (check-vector% 'random-vector! vec)
    84   (vector%-filled! vec randoms) )
     91(define (random-vector! vec #!key (randoms random-real))
     92  (vector%-filled!
     93    (check-vector% 'random-vector! vec)
     94    (check-procedure 'random-vector! randoms 'randoms)) )
    8595
    8696;;; Normal vectors
     
    95105(define (**random-hollow-sphere! vec norms)
    96106  (vector%-filled! vec norms)
    97   (vector%-scale! vec (*reciprocal (sqrt (vector%-sum-squares vec)))) )
     107  (vector%-scale! vec (*reciprocal (sqrt (vector%-sum-squares vec))))
     108  vec )
    98109
    99110(define (*random-hollow-sphere! vec mu sigma randoms)
    100   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     111  (let-values (
     112      ((norms pl)
     113        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    101114    (**random-hollow-sphere! vec norms) ) )
    102115
    103 (define (make-random-hollow-sphere #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    104   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     116(define (make-random-hollow-sphere
     117            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     118  (let-values (
     119      ((norms pl)
     120        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    105121    (lambda (n)
    106       (check-cardinal-integer 'random-hollow-sphere n 'length)
    107       (**random-hollow-sphere! (make-vector n) norms) ) ) )
     122      (**random-hollow-sphere!
     123        (make-vector (check-cardinal-integer 'random-hollow-sphere n 'length))
     124        norms) ) ) )
    108125
    109 (define (random-hollow-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    110   (check-vector% 'random-hollow-sphere! vec)
    111   (*random-hollow-sphere! vec mu sigma randoms) )
     126(define (random-hollow-sphere!
     127            vec
     128            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     129  (*random-hollow-sphere!
     130    (check-vector% 'random-hollow-sphere! vec)
     131    mu sigma randoms) )
    112132
    113133;;
     
    120140(define (**random-solid-sphere! vec randoms norms)
    121141  (**random-hollow-sphere! vec norms)
    122   (vector%-scale! vec (expt (randoms) (*reciprocal (vector%-length vec)))) )
     142  (vector%-scale! vec (expt (randoms) (*reciprocal (vector%-length vec))))
     143  vec )
    123144
    124145(define (*random-solid-sphere! vec mu sigma randoms)
    125   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     146  (let-values (
     147      ((norms pl)
     148        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    126149    (**random-solid-sphere! vec randoms norms) ) )
    127150
    128 (define (make-random-solid-sphere #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    129   (let-values (((norms pl) (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
     151(define (make-random-solid-sphere
     152            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     153  (let-values (
     154      ((norms pl)
     155        (make-random-normals #:mu mu #:sigma sigma #:randoms randoms)))
    130156    (lambda (n)
    131       (check-cardinal-integer 'random-solid-sphere n 'length)
    132       (**random-solid-sphere! (make-vector n) randoms norms) ) ) )
     157      (**random-solid-sphere!
     158        (make-vector (check-cardinal-integer 'random-solid-sphere n 'length))
     159        randoms norms) ) ) )
    133160
    134 (define (random-solid-sphere! vec #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
    135   (check-vector% 'random-solid-sphere! vec)
    136   (*random-solid-sphere! vec mu sigma randoms) )
     161(define (random-solid-sphere!
     162            vec
     163            #!key (mu 0.0) (sigma 1.0) (randoms (make-uniform-random-reals)))
     164  (*random-solid-sphere!
     165    (check-vector% 'random-solid-sphere! vec)
     166    mu sigma randoms) )
    137167
    138168) ;module srfi-27-vector
  • release/4/srfi-27/trunk/srfi-27.meta

    r34011 r34015  
    2323 "srfi-27-distributions.scm" "srfi-27-vector.scm" "srfi-27.scm"
    2424 "entropy-windows.scm" "moa.scm" "entropy-support.scm"
    25  "registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm"
     25 "source-registration.scm" "tests/test-diehard.scm" "tests/test-confidence.scm"
    2626 "tests/test-mrg32k3a.scm" "tests/run.scm" "entropy-port.scm") )
  • release/4/srfi-27/trunk/srfi-27.scm

    r34011 r34015  
    7676    (cond
    7777      ((entropy-source? x)
    78         x)
     78        x )
    7979      (else
    8080        (warning-argument-type 'current-entropy-source x 'entropy-source)
    8181        (current-entropy-source) ) ) ) )
    8282
    83 (define make-entropy-source
    84   (case-lambda
    85     (()
    86       ((@entropy-source-constructor (current-entropy-source))) )
    87     ((es)
    88       (let ((ctor
    89               (cond
    90                 ((entropy-source? es)
    91                   (@entropy-source-constructor es) )
    92                 ((symbol? es)
    93                   (let ((ctor (registered-entropy-source es)))
    94                     (or
    95                       ctor
    96                       (error 'make-entropy-source "unregistered entropy-source name" es) ) ) )
    97                 (else
    98                   (error-argument-type
    99                     'make-entropy-source es
    100                     "valid entropy-source or registered entropy-source name") ) ) ) )
    101         (ctor) ) ) ) )
    102 
    103 #;
    10483(define (make-entropy-source #!optional (es (current-entropy-source)))
    10584  (let ((ctor
     
    11695
    11796(define (new-entropy-source es)
    118   (check-entropy-source 'new-entropy-source es)
    119   ((@entropy-source-constructor es)) )
     97  ((@entropy-source-constructor (check-entropy-source 'new-entropy-source es))) )
    12098
    12199(define (entropy-source-name es)
    122   (check-entropy-source 'entropy-source-name es)
    123   (*entropy-source-name es) )
     100  (*entropy-source-name (check-entropy-source 'entropy-source-name es)) )
    124101
    125102(define entropy-source-kind entropy-source-name)
    126103
    127104(define (entropy-source-documentation es)
    128   (check-entropy-source 'entropy-source-documentation es)
    129   (*entropy-source-documentation es) )
     105  (*entropy-source-documentation
     106    (check-entropy-source 'entropy-source-documentation es)) )
    130107
    131108(define (entropy-source-u8vector es n #!optional vec)
    132   (check-entropy-source 'entropy-source-u8vector es)
    133   (check-positive-fixnum 'entropy-source-u8vector n)
    134   (when vec (check-u8vector 'entropy-source-u8vector vec))
    135   ((@entropy-source-u8vector es) n vec) )
     109  ((@entropy-source-u8vector (check-entropy-source 'entropy-source-u8vector es))
     110    (check-positive-fixnum 'entropy-source-u8vector n)
     111    (and vec (check-u8vector 'entropy-source-u8vector vec))) )
    136112
    137113(define (entropy-source-f64vector es n #!optional vec)
    138   (check-entropy-source 'entropy-source-f64vector es)
    139   (check-positive-fixnum 'entropy-source-f64vector n)
    140   (when vec (check-f64vector 'entropy-source-f64vector vec))
    141   ((@entropy-source-f64vector es) n vec) )
     114  ((@entropy-source-f64vector (check-entropy-source 'entropy-source-f64vector es))
     115    (check-positive-fixnum 'entropy-source-f64vector n)
     116    (and vec (check-f64vector 'entropy-source-f64vector vec))) )
    142117
    143118(define (entropy-source-u8 es)
    144   (check-entropy-source 'entropy-source-u8 es)
    145   (@entropy-source-u8 es) )
     119  (@entropy-source-u8 (check-entropy-source 'entropy-source-u8 es)) )
    146120
    147121(define (entropy-source-f64 es)
    148   (check-entropy-source 'entropy-source-f64 es)
    149   (@entropy-source-f64 es) )
     122  (@entropy-source-f64 (check-entropy-source 'entropy-source-f64 es)) )
    150123
    151124;;; Random Source
     
    154127  (let ((rndint ((@random-source-make-integers rs))))
    155128    (lambda (n)
    156       (check-cardinal-integer 'make-u8vector n 'length)
    157       (u8vector-filled! (make-u8vector n) (lambda () (rndint 256))) ) ) )
     129      (u8vector-filled!
     130        (make-u8vector (check-cardinal-integer 'random-source-make-u8vector n 'length))
     131        (lambda () (rndint 256))) ) ) )
    158132
    159133(define (*random-source-make-f64vectors rs prec)
    160134  (let ((rnd ((@random-source-make-reals rs) prec)))
    161135    (lambda (n)
    162       (check-cardinal-integer 'make-f64vector n 'length)
    163       (f64vector-filled! (make-f64vector n) rnd) ) ) )
     136      (f64vector-filled!
     137        (make-f64vector (check-cardinal-integer 'random-source-make-f64vector n 'length))
     138        rnd) ) ) )
    164139
    165140;;
     
    185160    (cond
    186161      ((random-source? x)
    187         x)
     162        x )
    188163      (else
    189164        (warning-argument-type 'current-random-source x 'random-source)
    190165        (current-random-source) ) ) ) )
    191166
    192 (define make-random-source
    193   (case-lambda
    194     (()
    195       ((@random-source-constructor (current-random-source))) )
    196     ((es)
    197       (let ((ctor
    198               (cond
    199                 ((random-source? es)
    200                   (@random-source-constructor es) )
    201                 ((symbol? es)
    202                   (registered-random-source es) )
    203                 (else
    204                   (error-argument-type
    205                     'make-random-source es
    206                     "valid random-source or registered random-source name") ) ) ) )
    207         (ctor) ) ) ) )
    208 
    209 #;
    210 (define (make-random-source #!optional (es (current-random-source)))
     167(define (make-random-source #!optional (rs (current-random-source)))
    211168  (let ((ctor
    212169          (cond
    213             ((random-source? es)
    214               (@random-source-constructor es) )
    215             ((symbol? es)
    216               (registered-random-source es) )
     170            ((random-source? rs)
     171              (@random-source-constructor rs) )
     172            ((symbol? rs)
     173              (registered-random-source rs) )
    217174            (else
    218175              (error-argument-type
    219                 'make-random-source es
     176                'make-random-source rs
    220177                "valid random-source or registered random-source name") ) ) ) )
    221178    (ctor) ) )
    222179
    223 (define (new-random-source es)
    224   (check-random-source 'new-random-source es)
    225   ((@random-source-constructor es)) )
     180(define (new-random-source rs)
     181  ((@random-source-constructor (check-random-source 'new-random-source rs))) )
    226182
    227183(define (random-source-name rs)
    228   (check-random-source 'random-source-name rs)
    229   (*random-source-name rs) )
     184  (*random-source-name
     185    (check-random-source 'random-source-name rs)) )
    230186
    231187(define random-source-kind random-source-name)
    232188
    233189(define (random-source-documentation rs)
    234   (check-random-source 'random-source-documentation rs)
    235   (*random-source-documentation rs) )
     190  (*random-source-documentation
     191    (check-random-source 'random-source-documentation rs)) )
    236192
    237193(define (random-source-log2-period rs)
    238   (check-random-source 'random-source-log2-period rs)
    239   (*random-source-log2-period rs) )
     194  (*random-source-log2-period
     195    (check-random-source 'random-source-log2-period rs)) )
    240196
    241197(define (random-source-maximum-range rs)
    242   (check-random-source 'random-source-maximum-range rs)
    243   (*random-source-maximum-range rs) )
     198  (*random-source-maximum-range
     199    (check-random-source 'random-source-maximum-range rs)) )
    244200
    245201(define (random-source-entropy-source rs)
    246   (check-random-source 'random-source-entropy-source rs)
    247   (*random-source-entropy-source rs) )
     202  (*random-source-entropy-source
     203    (check-random-source 'random-source-entropy-source rs)) )
    248204
    249205(define (random-source-entropy-source-set! rs es)
    250   (check-random-source 'random-source-entropy-source-set! rs)
    251   (check-entropy-source 'random-source-entropy-source-set! es)
    252   (*random-source-entropy-source-set! rs es) )
     206  (*random-source-entropy-source-set!
     207    (check-random-source 'random-source-entropy-source-set! rs)
     208    ;#f indicates no set entropy-source
     209    (and es (check-entropy-source 'random-source-entropy-source-set! es))) )
    253210
    254211(define (random-source-state-ref rs)
    255   (check-random-source 'random-source-state-ref rs)
    256   ((@random-source-state-ref rs)) )
     212  ((@random-source-state-ref (check-random-source 'random-source-state-ref rs))) )
    257213
    258214(define (random-source-state-set! rs state)
    259   (check-random-source 'random-source-state-set! rs)
    260   ((@random-source-state-set! rs) state) )
     215  ((@random-source-state-set! (check-random-source 'random-source-state-set! rs))
     216    state) )
    261217
    262218(define (random-source-randomize! rs #!optional es)
    263219  (check-random-source 'random-source-randomize! rs)
    264   (when es (check-entropy-source 'random-source-randomize! es))
    265220  ((@random-source-randomize! rs)
    266     (or es (*random-source-entropy-source rs) (current-entropy-source))) )
     221    (or
     222      (and es (check-entropy-source 'random-source-randomize! es))
     223      (*random-source-entropy-source rs)
     224      (current-entropy-source))) )
    267225
    268226(define (random-source-pseudo-randomize! rs i j)
    269   (check-random-source 'random-source-pseudo-randomize! rs)
    270   (check-cardinal-integer 'random-source-pseudo-randomize! i)
    271   (check-cardinal-integer 'random-source-pseudo-randomize! j)
    272   ((@random-source-pseudo-randomize! rs) i j) )
     227  ((@random-source-pseudo-randomize! (check-random-source 'random-source-pseudo-randomize! rs))
     228    (check-cardinal-integer 'random-source-pseudo-randomize! i)
     229    (check-cardinal-integer 'random-source-pseudo-randomize! j)) )
    273230
    274231(define (random-source-make-integers rs)
    275   (check-random-source 'random-source-make-integers rs)
    276   ((@random-source-make-integers rs)) )
     232  ((@random-source-make-integers (check-random-source 'random-source-make-integers rs))) )
    277233
    278234(define (random-source-make-reals rs #!optional prec)
    279   (check-random-source 'random-source-make-reals rs)
    280   (when prec (check-real-precision 'random-source-make-reals prec 'precision))
    281   ((@random-source-make-reals rs) prec) )
     235  ((@random-source-make-reals (check-random-source 'random-source-make-reals rs))
     236    (and prec (check-real-precision 'random-source-make-reals prec 'precision))) )
    282237
    283238(define (random-source-make-u8vectors rs)
    284   (check-random-source 'random-source-make-u8vectors rs)
    285   (*random-source-make-u8vectors rs) )
     239  (*random-source-make-u8vectors
     240    (check-random-source 'random-source-make-u8vectors rs)) )
    286241
    287242(define (random-source-make-f64vectors rs #!optional prec)
    288   (check-random-source 'random-source-make-f64vectors rs)
    289   (when prec (check-real-precision 'random-source-make-f64vectors prec 'precision))
    290   (*random-source-make-f64vectors rs prec) )
     243  (*random-source-make-f64vectors
     244    (check-random-source 'random-source-make-f64vectors rs)
     245    (and prec (check-real-precision 'random-source-make-f64vectors prec 'precision))) )
    291246
    292247) ;module srfi-27
  • release/4/srfi-27/trunk/srfi-27.setup

    r34012 r34015  
    77;; Utility Modules
    88
    9 (setup-shared-extension-module 'fp-extn (extension-version "3.2.2")
     9(setup-shared-extension-module 'fp-extn (extension-version "3.2.3")
    1010  #:inline? #t
    1111  #:types? #t
     
    1414    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    1515
    16 (setup-shared-extension-module 'registration (extension-version "3.2.2")
     16(setup-shared-extension-module 'source-registration (extension-version "3.2.3")
    1717  #:inline? #t
    1818  #:types? #t
     
    2121    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2222
    23 (setup-shared-extension-module 'srfi-27-numbers (extension-version "3.2.2")
     23(setup-shared-extension-module 'srfi-27-numbers (extension-version "3.2.3")
    2424  #:inline? #t
    2525  #:types? #t
     
    2828    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    2929
    30 (setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.2.2")
     30(setup-shared-extension-module 'srfi-27-vector-support (extension-version "3.2.3")
    3131  #:inline? #t
    3232  #:types? #t
     
    3737;; Entropy Source Modules
    3838
    39 (setup-shared-extension-module 'entropy-source (extension-version "3.2.2")
     39(setup-shared-extension-module 'entropy-source (extension-version "3.2.3")
    4040  #:inline? #t
    4141  #:types? #t
     
    4444    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    4545
    46 (setup-shared-extension-module 'entropy-support (extension-version "3.2.2")
     46(setup-shared-extension-module 'entropy-support (extension-version "3.2.3")
    4747  #:inline? #t
    4848  #:types? #t
     
    5151    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    5252
    53 (setup-shared-extension-module 'entropy-clock (extension-version "3.2.2")
     53(setup-shared-extension-module 'entropy-clock (extension-version "3.2.3")
    5454  #:inline? #t
    5555  #:types? #t
     
    5858    -no-procedure-checks) )
    5959
    60 (setup-shared-extension-module 'entropy-procedure (extension-version "3.2.2")
     60(setup-shared-extension-module 'entropy-procedure (extension-version "3.2.3")
    6161  #:inline? #t
    6262  #:types? #t
     
    6565    -no-procedure-checks) )
    6666
    67 (setup-shared-extension-module 'entropy-port (extension-version "3.2.2")
     67(setup-shared-extension-module 'entropy-port (extension-version "3.2.3")
    6868  #:inline? #t
    6969  #:types? #t
     
    7373
    7474#+unix
    75 (setup-shared-extension-module 'entropy-unix (extension-version "3.2.2")
     75(setup-shared-extension-module 'entropy-unix (extension-version "3.2.3")
    7676  #:inline? #t
    7777  #:types? #t
     
    8181
    8282#+windows
    83 (setup-shared-extension-module 'entropy-windows (extension-version "3.2.2")
     83(setup-shared-extension-module 'entropy-windows (extension-version "3.2.3")
    8484  #:inline? #t
    8585  #:types? #t
     
    9090;; Random Source Modules
    9191
    92 (setup-shared-extension-module 'random-source (extension-version "3.2.2")
     92(setup-shared-extension-module 'random-source (extension-version "3.2.3")
    9393  #:inline? #t
    9494  #:types? #t
     
    9797    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    9898
    99 (setup-shared-extension-module 'mrg32k3a (extension-version "3.2.2")
     99(setup-shared-extension-module 'mrg32k3a (extension-version "3.2.3")
    100100  #:inline? #t
    101101  #:types? #t
     
    105105    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    106106
    107 (setup-shared-extension-module 'mwc (extension-version "3.2.2")
     107(setup-shared-extension-module 'mwc (extension-version "3.2.3")
    108108  #:inline? #t
    109109  #:types? #t
     
    112112    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    113113
    114 (setup-shared-extension-module 'moa (extension-version "3.2.2")
     114(setup-shared-extension-module 'moa (extension-version "3.2.3")
    115115  #:inline? #t
    116116  #:types? #t
     
    119119    -no-procedure-checks -no-argc-checks -no-bound-checks) )
    120120
    121 (setup-shared-extension-module 'composite-random-source (extension-version "3.2.2")
     121(setup-shared-extension-module 'composite-random-source (extension-version "3.2.3")
    122122  #:inline? #t
    123123  #:types? #t
     
    128128;; Main Modules
    129129
    130 (setup-shared-extension-module 'srfi-27 (extension-version "3.2.2")
     130(setup-shared-extension-module 'srfi-27 (extension-version "3.2.3")
    131131  #:inline? #t
    132132  #:types? #t
     
    135135    -no-procedure-checks) )
    136136
    137 (setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.2.2")
     137(setup-shared-extension-module 'srfi-27-uniform-random (extension-version "3.2.3")
    138138  #:inline? #t
    139139  #:types? #t
     
    142142    #;-no-procedure-checks) )
    143143
    144 (setup-shared-extension-module 'srfi-27-distributions (extension-version "3.2.2")
     144(setup-shared-extension-module 'srfi-27-distributions (extension-version "3.2.3")
    145145  #:inline? #t
    146146  #:types? #t
     
    149149    -no-procedure-checks) )
    150150
    151 (setup-shared-extension-module 'srfi-27-vector (extension-version "3.2.2")
     151(setup-shared-extension-module 'srfi-27-vector (extension-version "3.2.3")
    152152  #:inline? #t
    153153  #:types? #t
  • release/4/srfi-27/trunk/tests/run.scm

    r34012 r34015  
    11
    22(use test)
     3
     4;;
     5
    36(use srfi-27)
    4 (use srfi-4)
    57
    6 (newline)
     8;(print "Current Random Source: " (random-source-kind (current-random-source)))
     9;(print "Current Entropy Source: " (entropy-source-kind (current-entropy-source)))
     10;(newline)
    711
    812(test-begin "SRFI 27")
    913
    10 (test-group "Testing random SRFI-4 vector"
    11   (print "Random Source: " (random-source-kind (current-random-source)))
    12   (print "Entropy Source: " (entropy-source-kind (current-entropy-source)))
     14;;
    1315
    14   (let ((v10 (random-u8vector 10)))
    15     (newline)
    16     ;(print "u8vector: " v10)
    17     (test "random-u8vector ?" #t (u8vector? v10))
    18     (test "random-u8vector 10" 10 (u8vector-length v10)) )
     16(use random-source entropy-source)
    1917
    20   (let ((v10 (random-f64vector 10)))
    21     (newline)
    22     ;(print "f64vector: " v10)
    23     (test "random-f64vector ?" #t (f64vector? v10))
    24     (test "random-f64vector 10" 10 (f64vector-length v10)) ) )
     18(test-group "basics"
     19  (test-assert (random-source? default-random-source))
     20  (test-assert (random-source? (current-random-source)))
     21  (test-assert (entropy-source? (current-entropy-source)))
     22
     23  (test-assert (procedure? random-integer))
     24  (test-assert (procedure? random-real))
     25)
     26
     27;;
     28
     29(use srfi-4)
     30
     31(test-group "SRFI-4 vector"
     32
     33  (test-group "u8vector"
     34    ;(test-assert (procedure? random-u8vector))
     35    (let ((v10 (random-u8vector 10)))
     36      (test #t (u8vector? v10))
     37      (test 10 (u8vector-length v10)) ) )
     38
     39  (test-group "f64vector"
     40    ;(test-assert (procedure? random-f64vector))
     41    (let ((v10 (random-f64vector 10)))
     42      (test #t (f64vector? v10))
     43      (test 10 (f64vector-length v10)) ) )
     44)
     45
     46;;
    2547
    2648(use srfi-27-uniform-random)
    2749
    28 (test-group "make-uniform-random-integers"
    29   (let-values (
    30       ((gen init)
    31         (make-uniform-random-integers high: 27 low: 16 precision: 2)))
    32     (let-values (((high low precision source) (init)))
    33       (test-assert (= 27 high))
    34       (test-assert (= 16 low))
    35       (test-assert (= 2 precision))
    36       (do ((i 0 (add1 i))
    37            (rv (gen) (gen)) )
    38           ((= 100 i))
    39         (unless (<= 16 rv) (test-assert (<= 16 rv)))
    40         (unless (<= rv 27) (test-assert (<= rv 27)))
    41         (unless (zero? (modulo rv 2)) (test-assert (zero? (modulo rv 2)))) ) ) ) )
     50(test-group "uniform-random"
    4251
    43 ;FIXME needs real test
    44 (test-group "make-uniform-random-reals"
    45   (let-values (
    46       ((gen init)
    47         (make-uniform-random-reals precision: 0.000000000003)))
    48     (let-values (((precision source) (init)))
    49       (test-assert (= 0.000000000003 precision))
    50       ;(flonum-print-precision 53)
    51       (do ((i 0 (add1 i))
    52            (rv (gen) (gen)) )
    53           ((= 100 i))
    54           ) ) ) )
     52  (test-group "integers"
     53    (let-values (
     54        ((gen init)
     55          (make-uniform-random-integers high: 27 low: 16 precision: 2)))
     56      (let-values (((high low precision source) (init)))
     57        (test-assert (= 27 high))
     58        (test-assert (= 16 low))
     59        (test-assert (= 2 precision))
     60        (do ((i 0 (add1 i))
     61             (rv (gen) (gen)) )
     62            ((= 100 i))
     63          (unless (<= 16 rv) (test-assert (<= 16 rv)))
     64          (unless (<= rv 27) (test-assert (<= rv 27)))
     65          (unless (zero? (modulo rv 2)) (test-assert (zero? (modulo rv 2)))) ) ) ) )
     66
     67  ;FIXME needs real test
     68  (test-group "reals"
     69    (let-values (
     70        ((gen init)
     71          (make-uniform-random-reals precision: 0.000000000003)))
     72      (let-values (((precision source) (init)))
     73        (test-assert (= 0.000000000003 precision))
     74        ;(flonum-print-precision 53)
     75        (do ((i 0 (add1 i))
     76             (rv (gen) (gen)) )
     77            ((= 100 i))
     78            ) ) ) )
     79)
     80
     81;;
     82
     83(use srfi-27-vector)
     84
     85(test-group "vector"
     86
     87  (test-group "random-permutations"
     88    (let ((gen (make-random-permutations)))
     89      (test-assert (procedure? gen))
     90      (let ((vec (gen 10)))
     91        (test-assert (vector? vec))
     92        (test 10 (vector-length vec)) ) ) )
     93
     94  (test-group "random-vector"
     95    (let ((gen (make-random-vector)))
     96      (test-assert (procedure? gen))
     97      (let ((vec (gen 10)))
     98        (test-assert (vector? vec))
     99        (test 10 (vector-length vec)) ) ) )
     100
     101  (test-group "random-hollow-sphere"
     102    (let ((gen (make-random-hollow-sphere)))
     103      (test-assert (procedure? gen))
     104      (let ((vec (gen 10)))
     105        (test-assert (vector? vec))
     106        (test 10 (vector-length vec)) ) ) )
     107
     108  (test-group "random-solid-sphere"
     109    (let ((gen (make-random-solid-sphere)))
     110      (test-assert (procedure? gen))
     111      (let ((vec (gen 10)))
     112        (test-assert (vector? vec))
     113        (test 10 (vector-length vec)) ) ) )
     114)
    55115
    56116(test-end "SRFI 27")
     117
     118;;
    57119
    58120(use utils)
Note: See TracChangeset for help on using the changeset viewer.