Changeset 14058 in project


Ignore:
Timestamp:
04/03/09 15:48:54 (11 years ago)
Author:
Kon Lovett
Message:

Bug fix.

Location:
release/3/srfi-27/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-27/trunk/entropy-primitives.scm

    r8337 r14058  
    3535
    3636static int
    37 good_double (const void *p, double *dtmp)
     37good_double( const void *p, double *dtmp )
    3838{
    3939/* This could cause an alignment fault! */
    4040# ifdef C_SIXTY_FOUR
    41   *dtmp = (double *) p;
     41  *dtmp = *((double *) p);
    4242# else
    4343  ((uint32_t *) dtmp)[0] = ((uint32_t *) p)[0];
    4444  ((uint32_t *) dtmp)[1] = ((uint32_t *) p)[1];
    4545# endif
    46   if (isnormal (*dtmp)) {
    47     *dtmp = fabs (*dtmp);
     46  if (isnormal( *dtmp )) {
     47    *dtmp = fabs( *dtmp );
    4848    return 1;
    4949  } else {
     
    5353<#
    5454
    55 (define-inline (string->u8vector str)
    56   (blob->u8vector (string->blob str)))
    57 
    58 (define BYTES/F64 (foreign-value "sizeof(double)" int))
     55(define-inline (string->u8vector str) (blob->u8vector (string->blob str)))
     56
     57(define BYTES/F64 (foreign-value "sizeof( double )" int))
    5958
    6059;;; Common Routines
    6160
    62 (define-inline (check-u8vector-args u8cnt u8vec)
     61(define-inline (%check-u8vector-args u8cnt u8vec)
    6362  (unless (and (fixnum? u8cnt) (fx< 0 u8cnt))
    6463    (error "invalid count" u8cnt))
     
    6968      (error "insufficient size" u8cnt u8vec))))
    7069
    71 (define-inline (check-f64vector-args f64cnt f64vec)
     70(define-inline (%check-f64vector-args f64cnt f64vec)
    7271  (unless (and (fixnum? f64cnt) (fx< 0 f64cnt))
    7372    (error "invalid count" f64cnt))
     
    7877      (error "insufficient size" f64cnt f64vec))))
    7978
    80 (define-inline (entropic-u8vector-fill! u8cnt u8vec u8gen)
    81   (let loop ([idx 0])
    82     (if (fx= u8cnt idx)
    83         u8vec
     79(define-inline (%entropic-u8vector-fill! u8cnt u8vec u8gen)
     80  (let loop ((idx 0))
     81    (if (fx= u8cnt idx) u8vec
    8482        (begin
    8583          (u8vector-set! u8vec idx (u8gen))
    8684          (loop (fx+ idx 1)))) )  )
    8785
    88 (define-inline (entropic-f64vector-fill! f64cnt f64vec f64gen)
    89   (let loop ([idx 0])
    90     (if (fx= f64cnt idx)
    91         f64vec
     86(define-inline (%entropic-f64vector-fill! f64cnt f64vec f64gen)
     87  (let loop ((idx 0))
     88    (if (fx= f64cnt idx) f64vec
    9289        (begin
    9390          (f64vector-set! f64vec idx (f64gen))
    9491          (loop (fx+ idx 1)))) )  )
    9592
    96 (define-inline (entropic-u8vector-fill!/f64 u8cnt u8vec f64gen)
    97   (let ([f64cnt (fx/ u8cnt BYTES/F64)]
    98         [remu8cnt (fxmod u8cnt BYTES/F64)])
    99     (move-memory!
    100       (entropic-f64vector-fill! f64cnt (make-f64vector f64cnt) f64gen)
    101       u8vec
    102       (fx- u8cnt remu8cnt))
     93(define-inline (%entropic-u8vector-fill!/f64 u8cnt u8vec f64gen)
     94  (let ((f64cnt (fx/ u8cnt BYTES/F64))
     95        (remu8cnt (fxmod u8cnt BYTES/F64)))
     96    (let ((f64vec (%entropic-f64vector-fill! f64cnt (make-f64vector f64cnt) f64gen)))
     97      (move-memory! f64vec u8vec (fx- u8cnt remu8cnt)) )
    10398    ;Leave remaining elements as they are
    10499    u8vec ) )
     
    107102
    108103(define (entropic-u8vector/source entsrc u8cnt . u8vec)
    109   (check-u8vector-args u8cnt (optional u8vec #f))
     104  (%check-u8vector-args u8cnt (optional u8vec #f))
    110105  (apply (%entropy-source-u8vector entsrc) u8cnt u8vec) )
    111106
    112107(define (entropic-f64vector/source entsrc f64cnt . f64vec)
    113   (check-f64vector-args f64cnt (optional f64vec #f))
     108  (%check-f64vector-args f64cnt (optional f64vec #f))
    114109  (apply (%entropy-source-f64vector entsrc) f64cnt f64vec) )
    115110
    116 (define (entropic-u8/f64 f64gen)
    117   (fxmod (inexact->exact (f64gen)) 256) )
     111(define (entropic-u8/f64 f64gen) (fxmod (inexact->exact (f64gen)) 256))
    118112
    119113(define (entropic-u8vector-filled u8cnt u8vec u8gen)
    120   (entropic-u8vector-fill! u8cnt (or u8vec (make-u8vector u8cnt)) u8gen) )
     114  (%entropic-u8vector-fill! u8cnt (or u8vec (make-u8vector u8cnt)) u8gen) )
    121115
    122116(define (entropic-u8vector-filled/f64 u8cnt u8vec f64gen)
    123   (entropic-u8vector-fill!/f64 u8cnt (or u8vec (make-u8vector u8cnt)) f64gen) )
     117  (%entropic-u8vector-fill!/f64 u8cnt (or u8vec (make-u8vector u8cnt)) f64gen) )
    124118
    125119(define (entropic-f64vector-filled f64cnt f64vec f64gen)
    126   (entropic-f64vector-fill! f64cnt (or f64vec (make-f64vector f64cnt)) f64gen) )
     120  (%entropic-f64vector-fill! f64cnt (or f64vec (make-f64vector f64cnt)) f64gen) )
    127121
    128122;;; Entropy from port
    129123
    130 (define (port-entropic-u8 port)
    131   (read-char port) )
     124(define (port-entropic-u8 port) (read-char port))
    132125
    133126(define port-entropic-f64
    134   (let ([good-f64 (foreign-lambda double good_double c-pointer (c-pointer double))])
     127  (let ((good-f64 (foreign-lambda double good_double c-pointer (c-pointer double))))
    135128    (lambda (port)
    136129      (let loop ()
    137         (let-location ([tmpdbl double])
    138           (let ([str (read-string BYTES/F64 port)])
    139             (if (good-f64 #$str #$tmpdbl)
    140                 tmpdbl
    141                 (loop)) ) ) ) ) ) )
     130        (let-location ((tmpdbl double))
     131          (let ((str (read-string BYTES/F64 port)))
     132            (if (good-f64 #$str #$tmpdbl) tmpdbl
     133                (loop) ) ) ) ) ) ) )
    142134
    143135(define (port-entropic-u8vector port u8cnt u8vec)
    144   (let ([str (read-string u8cnt port)])
    145     (if u8vec
     136  (let ((str (read-string u8cnt port)))
     137    (if (not u8vec) (string->u8vector str)
    146138        (begin
    147139          (move-memory! str u8vec u8cnt)
    148           u8vector)
    149         (string->u8vector str))) )
     140          u8vec ) ) ) )
    150141
    151142(define (port-entropic-f64vector port f64cnt f64vec f64gen)
     
    161152  DEFAULT-ENTROPY-PORT-CLOSE-SECONDS
    162153  (lambda (x)
    163     (cond [(and (or (fixnum? x) (flonum? x))
    164                 (positive? x))
    165             x]
    166           [else
    167             (warning "invalid seconds value" x)
    168             (current-entropy-port-close-seconds)] ) ) )
     154    (cond ((and (or (fixnum? x) (flonum? x)) (positive? x))
     155            x)
     156          (else
     157            (warning 'current-entropy-port-close-seconds "invalid seconds value" x)
     158            (current-entropy-port-close-seconds)) ) ) )
    169159
    170160;; Timeout Job Data
     
    177167
    178168(define timer-associates
    179   (let ([*synched-associates* #f])
     169  (let ((*synched-associates* #f))
    180170    (lambda (oper synched-assoc)
    181171      ; Initialize
     
    200190      ; Body
    201191      (switch oper
    202         ['start
    203           (%set!/synch [associates *synched-associates*]
     192        ('start
     193          (%set!/synch (associates *synched-associates*)
    204194            ; Cannot unblock a reaped asscociate so cannot stop early,
    205195            ; thus must disable reaping for this asscociate.
    206196            (%synch-with synched-assoc associate
    207               (parameterize ([current-associate-reaping #f])
     197              (parameterize ((current-associate-reaping #f))
    208198                (associate-start! associate) ) )
    209199            ; Add to list
    210             (cons synched-assoc associates) ) ]
    211         ['stop
    212           (%set!/synch [associates *synched-associates*]
     200            (cons synched-assoc associates) ) )
     201        ('stop
     202          (%set!/synch (associates *synched-associates*)
    213203            ; Stop now
    214204            (%synch-with synched-assoc associate
    215205              (associate-stop! associate) )
    216206            ; Delete from list
    217             (remove! (cut eq? synched-assoc <>) associates) ) ] ) ) ) )
     207            (remove! (cut eq? synched-assoc <>) associates) ) ) ) ) ) )
    218208
    219209;; Create & start a timed port
     
    221211(define (make-timed-port-associate tag port clsprc)
    222212  (make-object/synch
    223     (let ([associate
    224             (make-timeout-associate tag clsprc (current-entropy-port-close-seconds))])
     213    (let ((associate
     214            (make-timeout-associate tag clsprc (current-entropy-port-close-seconds))))
    225215      (associate-data-override! associate
    226216                                port  ; TPA-PORT
     
    231221
    232222(define (start-new-timed-port tag port clsprc)
    233   (let ([synched-assoc (make-timed-port-associate tag port clsprc)])
     223  (let ((synched-assoc (make-timed-port-associate tag port clsprc)))
    234224    (timer-associates 'start synched-assoc)
    235225    synched-assoc ) )
     
    273263
    274264(define (make-timed-entropy-file-source opnprc knd)
    275   (let ([*synched-assoc* #f])
     265  (let ((*synched-assoc* #f))
    276266    (letrec (
    277         [drop-this-timed-port
     267        (drop-this-timed-port
    278268          (lambda ()
    279             (set! *synched-assoc* (drop-timed-port *synched-assoc* close-input-port)) ) ]
    280         [with-this-timed-port
     269            (set! *synched-assoc* (drop-timed-port *synched-assoc* close-input-port)) ) )
     270        (with-this-timed-port
    281271          (lambda (proc)
    282272            (unless *synched-assoc*
    283273              (set! *synched-assoc* (start-new-timed-port knd (opnprc) drop-this-timed-port)) )
    284             (with-timed-port *synched-assoc* proc) ) ] )
     274            (with-timed-port *synched-assoc* proc) ) ) )
    285275      ;
    286276      (%make-entropy-source knd
  • release/3/srfi-27/trunk/srfi-27-eggdoc.scm

    r8437 r14058  
    557557
    558558    (history
     559      (version "2.5" "Fix for 'entropy-primitives' on 64bit machines (Thanks to Shawn Rutledge).")
     560      (version "2.4" "")
    559561      (version "2.3" "Fix for MOA & MWC, wasn't initializing the state correctly. Minor speedup for MRG32k3a & large-numbers. Added make-combined-random-source & *make-combined-random-source.")
    560562      (version "2.2" ""entropy-fixed" wasn't installed! Bug fix for timed file entropy sources. Added 'random-source-randomize!/entropy'.")
  • release/3/srfi-27/trunk/srfi-27.html

    r8439 r14058  
    627627<h3>Version</h3>
    628628<ul>
     629<li>2.5 Fix for 'entropy-primitives' on 64bit machines (Thanks to Shawn Rutledge).</li>
     630<li>2.4 </li>
    629631<li>2.3 Fix for MOA &amp; MWC, wasn't initializing the state correctly. Minor speedup for MRG32k3a &amp; large-numbers. Added make-combined-random-source &amp; *make-combined-random-source.</li>
    630632<li>2.2 entropy-fixed wasn't installed! Bug fix for timed file entropy sources. Added 'random-source-randomize!/entropy'.</li>
Note: See TracChangeset for help on using the changeset viewer.