Changeset 16194 in project


Ignore:
Timestamp:
10/13/09 09:17:26 (10 years ago)
Author:
Kon Lovett
Message:

Save

Location:
release/4/srfi-27/trunk
Files:
1 added
2 deleted
6 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-27/trunk/entropy-fixed.scm

    r16190 r16194  
    6868    (lambda (f64cnt f64vec) (entropic-f64vector-filled f64cnt f64vec f64proc))) )
    6969
    70 (define (make-entropy-source/procedure f64proc
    71           #!optional
    72             (kind (gensym 'entropy-source-procedure:)
    73             (docu "Entropy from a procedure")))
    74   (make-entropy-source/procedures (lambda () (entropic-u8/f64 f64proc)) f64proc kind docu) )
     70(define (make-entropy-source/procedure f64proc . args)
     71  (apply make-entropy-source/procedures (lambda () (entropic-u8/f64 f64proc)) f64proc args) )
    7572
    7673) ;module entropy-fixed
  • release/4/srfi-27/trunk/entropy-windows.scm

    r16190 r16194  
    11;;;; entropy-windows.scm
    2 ;;;; Kon Lovett, Jan '07
     2;;;; Kon Lovett, Oct '09
    33
    4 (use syntax-case lexmod)
    5 (use entropy-primitives entropy-structures)
     4(module entropy-windows
    65
    7 (declare
    8   (usual-integrations)
    9   (inline)
    10   (export
    11     make-crypt-random-entropy-source
    12     crypt-random-entropy) )
     6  (;export
     7    make-random-entropy-source/crypt
     8    make-random-entropy-source/crypt+)
    139
    14 ;;;
     10  (import scheme
     11          chicken
     12          foreign
     13          entropy-support)
    1514
    16 (include "entropy-common")
     15  (require-library entropy-support)
    1716
    1817;;; Entropy from CryptContext
     
    2625
    2726static void
    28 set_last_errmsg ()
     27set_last_errmsg()
    2928{
    30   last_errcod = GetLastError ();
    31   FormatMessage (
    32     FORMAT_MESSAGE_ALLOCATE_BUFFER |
    33     FORMAT_MESSAGE_FROM_SYSTEM |
    34     FORMAT_MESSAGE_IGNORE_INSERTS,
     29  last_errcod = GetLastError();
     30  FormatMessage(
     31    FORMAT_MESSAGE_ALLOCATE_BUFFER
     32    | FORMAT_MESSAGE_FROM_SYSTEM
     33    | FORMAT_MESSAGE_IGNORE_INSERTS,
    3534    NULL,
    3635    last_errcod,
    37     MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
     36    MAKELANGID( LANG_NEUTRAL, SUBLANG_DEFAULT ),
    3837    (LPTSTR) &lpErrMsgBuf,
    3938    0, NULL );
     
    4140
    4241static char *
    43 get_last_errmsg ()
     42get_last_errmsg()
    4443{
    4544  return (char *) lpErrMsgBuf;
     
    4746
    4847static void
    49 rel_last_errmsg ()
     48rel_last_errmsg()
    5049{
    51   LocalFree (lpErrMsgBuf);
     50  LocalFree( lpErrMsgBuf );
    5251}
    5352
    5453static int
    55 get_crypt_prov(unsigned long * hProv)
     54get_crypt_prov( unsigned long * hProv )
    5655{
    57   if (CryptAcquireContext ((HCRYPTPROV *) hProv, NULL, NULL, PROV_RSA_FULL,
    58                            CRYPT_VERIFYCONTEXT | CRYPT_SILENT)) {
     56  if( CryptAcquireContext( (HCRYPTPROV *) hProv, NULL, NULL, PROV_RSA_FULL,
     57                           CRYPT_VERIFYCONTEXT | CRYPT_SILENT ) ) {
    5958    return 1;
    6059  } else {
    61     set_last_errmsg ();
     60    set_last_errmsg();
    6261    return 0;
    6362  }
     
    6564
    6665static int
    67 fill_rand_buff(unsigned long hProv, void * buff, int len)
     66fill_rand_buff( unsigned long hProv, void * buff, int len )
    6867{
    69   if (CryptGenRandom ((HCRYPTPROV) hProv, len, (unsigned char *) buff)) {
     68  if( CryptGenRandom( (HCRYPTPROV) hProv, len, (unsigned char *) buff ) ) {
    7069    return 1;
    7170  } else {
    72     set_last_errmsg ();
     71    set_last_errmsg();
    7372    return 0;
    7473  }
     
    7675
    7776static int
    78 rel_crypt_prov(unsigned long hProv)
     77rel_crypt_prov( unsigned long hProv )
    7978{
    80   if (CryptReleaseContext ((HCRYPTPROV) hProv, 0)) {
     79  if( CryptReleaseContext( (HCRYPTPROV) hProv, 0 ) ) {
    8180    return 1;
    8281  } else {
    83     set_last_errmsg ();
     82    set_last_errmsg();
    8483    return 0;
    8584  }
     
    9089
    9190(define open-crypt-random-port
    92   (let (
    93       [c-get-crypt-prov
    94         (foreign-lambda int get_crypt_prov (c-pointer unsigned-long))]
    95       [c-fill-rand-buff
    96         (foreign-lambda int fill_rand_buff unsigned-long c-pointer int)]
    97       [c-rel-crypt-prov
    98         (foreign-lambda int rel_crypt_prov unsigned-long)]
    99       [c-get-last-errmsg
    100         (foreign-lambda c-string get_last_errmsg)]
    101       [c-rel-last-errmsg
    102         (foreign-lambda void rel_last_errmsg)])
    103     (let (
    104         [chkerr
    105           (lambda (res msg)
    106             (unless res
    107               (let ([errmsg (c-get-last-errmsg)])
    108                 (c-rel-last-errmsg)
    109                 (error 'crypt-random-port msg errmsg))))])
     91  (let ((c-get-crypt-prov
     92          (foreign-lambda int get_crypt_prov (c-pointer unsigned-long)))
     93        (c-fill-rand-buff
     94          (foreign-lambda int fill_rand_buff unsigned-long c-pointer int))
     95        (c-rel-crypt-prov
     96          (foreign-lambda int rel_crypt_prov unsigned-long))
     97        (c-get-last-errmsg
     98          (foreign-lambda c-string get_last_errmsg))
     99        (c-rel-last-errmsg
     100          (foreign-lambda void rel_last_errmsg)) )
     101    (let ((chkerr
     102            (lambda (res msg)
     103              (unless res
     104                (let ((errmsg (c-get-last-errmsg)))
     105                  (c-rel-last-errmsg)
     106                  (error 'crypt-random-port msg errmsg))))))
    110107      (lambda (buflen)
    111         (let-location ([hprov unsigned-long])
    112           (chkerr (c-get-crypt-prov #$hprov)
    113                   "cannot acquire random provider")
    114           (let ([buf (make-string buflen)]
    115                 [len 0]
    116                 [pos 0])
    117             (let (
    118                 [fillbuff
    119                   (lambda ()
    120                     (when (fx>= pos len)
    121                       (chkerr (c-fill-rand-buff hprov #$buf buflen)
    122                               "cannot get random buffer")
    123                       (set! pos 0)
    124                       (set! len buflen)))]
    125                 [getchar
    126                   (lambda ()
    127                     (let ([ch (string-ref buf pos)])
    128                       (set! pos (fx+ pos 1))
    129                       ch))])
     108        (let-location ((hprov unsigned-long))
     109          (chkerr (c-get-crypt-prov #$hprov) "cannot acquire random provider")
     110          (let ((buf (make-string buflen))
     111                (len 0)
     112                (pos 0) )
     113            (let ((fillbuff
     114                    (lambda ()
     115                      (when (fx>= pos len)
     116                        (chkerr (c-fill-rand-buff hprov #$buf buflen) "cannot get random buffer")
     117                        (set! pos 0)
     118                        (set! len buflen))))
     119                  (getchar
     120                    (lambda ()
     121                      (let ((ch (string-ref buf pos)))
     122                        (set! pos (fx+ pos 1))
     123                        ch))) )
    130124              (make-input-port
    131125                (lambda ()                    ;Read
     
    135129                  #t )
    136130                (lambda ()                    ;Close
    137                   (chkerr (c-rel-crypt-prov hprov)
    138                           "cannot release random provider") )
     131                  (chkerr (c-rel-crypt-prov hprov) "cannot release random provider") )
    139132                #;
    140133                (lambda (port n dest start)   ; Read-String
     
    143136;;;
    144137
    145 (define (make-crypt-random-entropy-source . rest)
    146   (let ([buflen (optional rest DEFAULT-CRYPT-BUFFLEN)])
    147     (make-timed-entropy-file-source
    148       (lambda ()
    149         (open-crypt-random-port buflen))
    150       "CryptRandom") ) )
     138(define (make-random-entropy-source/crypt+ buflen
     139          #!optional
     140            (kind #:crypt-random-entropy)
     141            (docu "Entropy from CryptRandom"))
     142  (make-timed-entropy-file-source
     143    (lambda () (open-crypt-random-port buflen))
     144    kind
     145    docu) )
    151146
    152 (define crypt-random-entropy
    153   ($make-entropy-source-structure make-crypt-random-entropy-source) )
     147(define (make-random-entropy-source/crypt . args)
     148  (apply make-random-entropy-source/crypt+ DEFAULT-CRYPT-BUFFLEN args) )
    154149
    155 (register-entropy-source-structure! crypt-random-entropy)
     150(register-entropy-source! #:crypt-random-entropy make-random-entropy-source/crypt)
     151
     152) ;module entropy-windows
  • release/4/srfi-27/trunk/fp-extn.scm

    r16190 r16194  
    44;;; For use in modules that perform full-numeric-tower arithmetic
    55
    6 (define-inline (fpfraction n)
    7   (##sys#flonum-fraction n) )
     6(define-inline (fpfraction n) (##sys#flonum-fraction n))
    87
    9 (define-inline (fpzero? n)
    10   (fp= 0.0 n) )
     8(define-inline (fpzero? n) (fp= 0.0 n))
    119
    12 (define-inline (fppositive? n)
    13   (fp< 0.0 n) )
     10(define-inline (fppositive? n) (fp< 0.0 n))
    1411
    15 (define-inline (fpnegative? n)
    16   (fp> 0.0 n) )
     12(define-inline (fpnegative? n) (fp> 0.0 n))
    1713
    18 (define-inline (fpinteger? n)
    19   (fpzero? (fpfraction n)) )
     14(define-inline (fpinteger? n) (fpzero? (fpfraction n)))
    2015
    21 (define-inline (fpeven? n)
    22   (and (fpinteger? n)
    23        (fpzero? (fpfraction (fp/ n 2.0)))) )
     16(define-inline (fpeven? n) (and (fpinteger? n) (fpzero? (fpfraction (fp/ n 2.0)))))
    2417
    25 (define-inline (fpodd? n)
    26   (and (fpinteger? n)
    27        (not (fpzero? (fpfraction (fp/ n 2.0))))) )
     18(define-inline (fpodd? n) (and (fpinteger? n) (not (fpzero? (fpfraction (fp/ n 2.0))))))
    2819
    29 (define-inline (fpabs n)
    30   (if (fpnegative? n)
    31       (fpneg n)
    32       n ) )
     20(define-inline (fpabs n) (if (fpnegative? n) (fpneg n) n))
    3321
    34 (define-inline (fptruncate n)
    35   (fp- n (fpfraction n)) )
     22(define-inline (fptruncate n) (##sys#truncate n))
    3623
    37 (define-inline (fpfloor n)
    38   (if (fpzero? n)
    39       0.0
    40       (let ([nt (fptruncate n)])
    41         (if (fppositive? n)
    42             nt
    43             (fp- nt 1.0) ) ) ) )
     24(define-inline (fpfloor n) (##sys#floor n))
    4425
    45 (define-inline (fpmodulo x y)
    46   (fp- x (fp* (fpfloor (fp/ x y)) y)) )
     26(define-inline (fpmodulo x y) (fp- x (fp* (fpfloor (fp/ x y)) y)))
    4727
    48 (define-inline (fpquotient x y)
    49   (fptruncate (fp/ x y)) )
     28(define-inline (fpquotient x y) (fptruncate (fp/ x y)))
    5029
    51 (define-inline (fpremainder x y)
    52   (fp- x (fp* (fpquotient x y) y)) )
     30(define-inline (fpremainder x y) (fp- x (fp* (fpquotient x y) y)))
  • release/4/srfi-27/trunk/srfi-27-large-numbers.scm

    r16191 r16194  
    99    random-large-real)
    1010
    11   (import (expect scheme
     11  (import (except scheme
    1212            <= < + * - / quotient expt integer? exact? zero? even? exact->inexact)
    1313          chicken
  • release/4/srfi-27/trunk/srfi-27.meta

    r16190 r16194  
    77 (doc-from-wiki)
    88 (synopsis "Sources of Random Bits")
    9  (needs setup-helper dollar easyffi miscmacros vector-lib numbers synch lexmod job-worker syntax-case mathh)
     9 (needs setup-helper dollar easyffi miscmacros vector-lib numbers synch mathh)
    1010 (files
    1111  "tests"
    12   "srfi-27.scm"
    1312        "fp-extn.scm"
    14         "mrg32k3a-primitives.scm"
    1513        "mrg32k3a.scm"
    16         "mwc-primitives.scm"
    1714        "mwc.scm"
    18         "moa-primitives.scm"
    1915        "moa.scm"
    20         "entropy-primitives.scm"
    21         "entropy-structures.scm"
    22         "entropy-common.scm"
     16        "entropy-support.scm"
     17        "entropy-source.scm"
    2318        "entropy-clock.scm"
    2419        "entropy-unix.scm"
    2520        "entropy-windows.scm"
    2621        "entropy-fixed.scm"
    27         "entropy-parameters.scm"
    28         "srfi-27-structures.scm"
     22        "random-source.scm"
    2923        "srfi-27-distributions.scm"
    30         "srfi-27-parameters.scm"
    3124        "srfi-27-large-numbers.scm"
     25        "srfi-27.scm"
    3226  "srfi-27.setup") )
  • release/4/srfi-27/trunk/srfi-27.setup

    r16190 r16194  
    55(verify-extension-name "srfi-27")
    66
    7 entropy-structures
     7(setup-shared-extension-module 'entropy-source
    88
    9 entropy-primitives
     9(setup-shared-extension-module 'entropy-support
    1010
    11 entropy-clock
     11(setup-shared-extension-module 'entropy-clock
    1212
    13 (cond-expand
    14   [unix
    15     entropy-unix ]
    16   [windows
    17     entropy-windows ] )
     13(setup-shared-extension-module 'entropy-fixed
    1814
    19 entropy-fixed *version*)
     15#+unix
     16(setup-shared-extension-module 'entropy-unix
    2017
    21 entropy-parameters *version*)
     18#+windows
     19(setup-shared-extension-module 'entropy-windows
    2220
    23 srfi-27-structures *version*)
     21(setup-shared-extension-module 'random-source
    2422
    25 srfi-27-large-numbers
     23(setup-shared-extension-module 'srfi-27-large-numbers
    2624
    27 mrg32k3a-primitives +easyffi +dollar
    28 mrg32k3a
     25(setup-shared-extension-module 'mrg32k3a
    2926
    30 mwc-primitives +easyffi +dollar
    31 mwc
     27(setup-shared-extension-module 'mwc
    3228
    33 moa-primitives +easyffi +dollar
    34 moa
     29(setup-shared-extension-module 'moa
    3530
    36 srfi-27-parameters
     31(setup-shared-extension-module 'srfi-27 (extension-version "0.0.0"))
    3732
    38 srfi-27-distributions
    39 
    40 (setup-shared-extension-module (extension-name) (extension-version "0.0.0"))
     33(setup-shared-extension-module 'srfi-27-distributions
Note: See TracChangeset for help on using the changeset viewer.