Changeset 13610 in project


Ignore:
Timestamp:
03/09/09 05:12:49 (11 years ago)
Author:
Kon Lovett
Message:

Save.

Location:
release/4/err5rs-arithmetic/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-bitwise.scm

    r13606 r13610  
    289289;;
    290290
    291 (define-inline (%boolean->bit obj) (if obj 1 0))
     291(define-inline (%boolean->bit obj) (if obj #b1 #b0))
    292292
    293293(define-inline (%boolean->bit* obj)
    294   (if (and (%number obj) (%zero? obj)) 0
     294  (if (and (%number obj) (%zero? obj)) #b0
    295295      (%boolean->bit obj) ) )
    296296
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13606 r13610  
    1717          ##sys#check-inexact
    1818          ##sys#check-integer
    19           ##sys#check-number
    2019          ##sys#signal-hook ) )
    2120
     
    2726
    2827;TODO - add to chicken-primitive-object-inline
    29 
    30 (define-inline (%< x y) ((##core#primitive "C_lessp") x y))
    3128
    3229(define-inline (%finite? x) (##core#inline "C_i_finitep" x))
     
    4845(define-inline (%fpfraction x) ((##core#primitive "C_flonum_fraction") x))
    4946
    50 (define-inline (%fpneg x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
     47(define-inline (%fpnegate x y) (##core#inline_allocate ("C_a_i_flonum_negate" 4) x y))
    5148
    5249(define-inline (%fp- x y) (##core#inline_allocate ("C_a_i_flonum_difference" 4) x y))
     
    6764(define-inline (%fptan x) (##core#inline_allocate ("C_a_i_tan" 4) x))
    6865
     66(define-inline (%< x y) ((##core#primitive "C_lessp") x y))
     67
    6968(define-inline (%expt x y) ((##core#primitive "C_expt") x y))
    7069
     
    8483    (##sys#signal-hook #:type-error loc "bad argument type - not a non-negative integer" obj) ) )
    8584
    86 (define-inline (%check-number loc obj) (##sys#check-number obj loc))
     85(define-inline (%check-real loc obj)
     86  (unless (real? obj)
     87    (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) ) )
    8788
    8889;;
     
    9293(define-inline (%fpfold-1 loc func init lyst)
    9394  (%check-flonum loc init)
    94   (let loop ([ls lyst] [acc init])
     95  (let loop ((ls lyst) (acc init))
    9596          (if (%null? ls) acc
    96               (let ([cur (%car ls)])
     97              (let ((cur (%car ls)))
    9798          (%check-flonum loc cur)
    9899          (loop (%cdr ls) (func acc cur)) ) ) ) )
     
    100101(define-inline (%fpand-fold-1 loc func init lyst)
    101102  (%check-flonum loc init)
    102   (let loop ([ls lyst] [acc init])
     103  (let loop ((ls lyst) (acc init))
    103104          (or (%null? ls)
    104         (let ([cur (%car ls)])
     105        (let ((cur (%car ls)))
    105106          (%check-flonum loc cur)
    106107                (and (func acc cur)
     
    109110;;
    110111
    111 (define-inline (%fpquotient fpn fpd) (%fptruncate (%fp/ fpn fpd)))
    112 
    113 (define-inline (%fpremainder fpn fpd) (%fp- fpn (%fp* (%fpquotient fpn fpd) fpd)))
    114 
    115 (define-inline (%fpquotient-and-remainder  fpn fpd)
    116   (let ([quo (%fpquotient fpn fpd)])
     112(define-inline (%fpdiv fpn fpd) (%fptruncate (%fp/ fpn fpd)))
     113
     114(define-inline (%fpmod fpn fpd) (%fp- fpn (%fp* (%fpdiv fpn fpd) fpd)))
     115
     116(define-inline (%fpdiv-and-mod  fpn fpd)
     117  (let ((quo (%fpdiv fpn fpd)))
    117118    (values quo (%fp- fpn (%fp* quo fpd))) ) )
    118119
    119 (define-inline (%fpinteger? fp) (%integer? x))
     120(define-inline (%fpinteger? obj) (and (%flonum obj) (%integer? obj)))
    120121
    121122(define-inline (%fpnan? fp) (not (%fp= fp fp)))
    122123
    123 (define-inline (%fp=? x y) (%fp= x y))
    124 
     124(define-inline (%fp=? x y) (%fp= x y)) ;unnecessary but symmetrical
    125125(define-inline (%fp<? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp< x y)))
    126 
    127126(define-inline (%fp<=? x y) (or (and (%fp= -0.0 x) (%fp= 0.0 y)) (%fp<= x y)))
    128 
    129127(define-inline (%fp>? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp> x y)))
    130 
    131128(define-inline (%fp>=? x y) (or (and (%fp= 0.0 x) (%fp= -0.0 y)) (%fp>= x y)))
    132129
    133130(define-inline (%fpdiv0-and-mod0 fpn fpd)
    134   (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
    135     (cond [(%fp>=? fpd 0.0)
    136             (if (%fp<?
    137                  rem
    138                  (%fp/ fpd 2.0))
    139                 (if (%fp>=?
    140                      rem
    141                      (%fp/ fpd -2.0))
    142                     (values quo rem)
    143                     (values (%fp- quo 1.0)
    144                             (%fp+ rem fpd)) )
    145                 (values (%fp+ quo 1.0)
    146                         (%fp- rem fpd)) ) ]
    147           [(%fp<?
    148             rem
    149             (%fp/ fpd -2.0))
    150             (if (%fp>=?
    151                  rem
    152                  (%fp/ fpd 2.0))
    153                 (values quo rem)
    154                 (values (%fp+ quo 1.0)
    155                         (%fp- rem fpd)) ) ]
    156           [else
    157             (values (%fp- quo 1.0)
    158                     (%fp+ rem fpd)) ] ) ) )
     131  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
     132    (cond ((%fp>=? fpd 0.0)
     133           (if (%fp<? rem (%fp/ fpd 2.0))
     134               (if (%fp>=? rem (%fp/ fpd -2.0)) (values quo rem)
     135                   (values (%fp- quo 1.0) (%fp+ rem fpd)) )
     136               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
     137          ((%fp<? rem (%fp/ fpd -2.0))
     138           (if (%fp>=? rem (%fp/ fpd 2.0)) (values quo rem)
     139               (values (%fp+ quo 1.0) (%fp- rem fpd)) ) )
     140          (else
     141           (values (%fp- quo 1.0) (%fp+ rem fpd)) ) ) ) )
    159142
    160143(define-inline (%fpdiv0 fpn fpd)
    161   (let-values ([(quo rem) (%fpquotient-and-remainder  fpn fpd)])
    162     (cond [(%fp>=? fpd 0.0)
    163             (if (%fp<?
    164                  rem
    165                  (%fp/ fpd 2.0))
    166                 (if (%fp>=?
    167                      rem
    168                      (%fp/ fpd -2.0))
    169                     quo
    170                     (%fp- quo 1.0) )
    171                 (%fp+ quo 1.0) ) ]
    172           [(%fp<?
    173             rem
    174             (%fp/ fpd -2.0))
    175             (if (%fp>=?
    176                  rem
    177                  (%fp/ fpd 2.0))
    178                 quo
    179                 (%fp+ quo 1.0) ) ]
    180           [else
    181             (%fp- quo 1.0) ] ) ) )
     144  (let-values (((quo rem) (%fpdiv-and-mod  fpn fpd)))
     145    (cond ((%fp>=? fpd 0.0)
     146           (if (%fp<? rem (%fp/ fpd 2.0))
     147               (if (%fp>=? rem (%fp/ fpd -2.0)) quo
     148                   (%fp- quo 1.0) )
     149               (%fp+ quo 1.0) ) )
     150          ((%fp<? rem (%fp/ fpd -2.0))
     151           (if (%fp>=? rem (%fp/ fpd 2.0)) quo
     152               (%fp+ quo 1.0) ) )
     153          (else
     154           (%fp- quo 1.0) ) ) ) )
    182155
    183156(define-inline (%fpmod0 fpn fpd)
    184   (let ([rem (%fpremainder fpn fpd)])
    185     (cond [(%fp>=? fpd 0.0)
    186             (if (%fp<?
    187                  rem
    188                  (%fp/ fpd 2.0))
    189                 (if (%fp>=?
    190                      rem
    191                      (%fp/ fpd -2.0))
    192                     rem
    193                     (%fp+ rem fpd) )
    194                 (%fp- rem fpd) ) ]
    195           [(%fp<?
    196             rem
    197             (%fp/ fpd -2.0))
    198             (if (%fp>=?
    199                  rem
    200                  (%fp/ fpd 2.0))
    201                 rem
    202                 (%fp- rem fpd) )]
    203           [else
    204             (%fp+ rem fpd) ] ) ) )
     157  (let ((rem (%fpmod fpn fpd)))
     158    (cond ((%fp>=? fpd 0.0)
     159           (if (%fp<? rem (%fp/ fpd 2.0))
     160               (if (%fp>=? rem (%fp/ fpd -2.0)) rem
     161                   (%fp+ rem fpd) )
     162               (%fp- rem fpd) ) )
     163          ((%fp<? rem (%fp/ fpd -2.0))
     164           (if (%fp>=? rem (%fp/ fpd 2.0)) rem
     165               (%fp- rem fpd) ))
     166          (else
     167           (%fp+ rem fpd) ) ) ) )
    205168
    206169
     
    221184  fldiv flmod fldiv-and-mod fldiv0 flmod0 fldiv0-and-mod0
    222185  flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt
    223   flnumerator fldenominator)
     186  flnumerator fldenominator
     187  ; Extras
     188  flnegate)
    224189
    225190(import scheme chicken foreign srfi-1 mathh)
     
    243208;;;
    244209
     210;Doesn't support full-numeric-tower
    245211(define (real->flonum value)
    246212  (if (%flonum? value) value
    247213      (begin
    248         (%check-number 'real->flonum value)
     214        (%check-real 'real->flonum value)
    249215        (%exact->inexact value) ) ) )
    250216
     
    274240  (%check-flonum 'flcompare fl1)
    275241  (%check-flonum 'flcompare fl2)
    276         (cond [(%fp=? fl1 fl2)
    277                (cond [(%fp=? -0.0 fl1)  (if (%fp=? -0.0 fl1) 0 1)]
    278                [(%fp=? -0.0 fl2)  (if (%fp=? 0.0 fl1) -1 0)]
    279                      [else              0])]
    280               [(%fp<? fl1 fl2)
    281                -1]
    282               [else
    283                1 ] ) )
     242        (cond ((%fp=? fl1 fl2)
     243               (cond ((%fp=? -0.0 fl1)  (if (%fp=? -0.0 fl1) 0 1))
     244               ((%fp=? -0.0 fl2)  (if (%fp=? 0.0 fl1) -1 0))
     245                     (else              0)))
     246              ((%fp<? fl1 fl2)
     247               -1)
     248              (else
     249               1 ) ) )
    284250
    285251(define (flmax fl . fls)
     
    291257(define (flmax-and-min fl . fls)
    292258  (%check-flonum 'flmax-and-min fl)
    293         (let loop ([ls fls] [mx fl] [mn fl])
     259        (let loop ((ls fls) (mx fl) (mn fl))
    294260          (if (%null? ls) (values mx mn)
    295               (let ([cur (%car ls)])
     261              (let ((cur (%car ls)))
    296262                (%check-flonum 'flmax-and-min cur)
    297263          (loop (%cdr ls) (%fpmax mx cur) (%fpmin mn cur)) ) ) ) )
     
    314280(define (flnegative? fl)
    315281  (%check-flonum 'flnegative? fl)
    316         (or (%fp=? -0.0 fl)
    317       (%fp<? fl 0.0) ) )
     282        (or (%fp=? -0.0 fl) (%fp<? fl 0.0) ) )
    318283
    319284(define (flodd? fl)
     
    347312
    348313(define (fl- fl . fls)
    349   (if (%null? fls) (%fpneg fl)
     314  (if (%null? fls) (%fpnegate fl)
    350315      (%fpfold-1 'fl- %fp- fl fls) ) )
    351316
     
    381346  (%check-flonum 'fldiv fln)
    382347  (%check-flonum 'fldiv fld)
    383   (%fpquotient fln fld) )
     348  (%fpdiv fln fld) )
    384349
    385350(define (flmod fln fld)
    386351  (%check-flonum 'flmod fln)
    387352  (%check-flonum 'flmod fld)
    388   (%fpremainder fln fld) )
     353  (%fpmod fln fld) )
    389354
    390355(define (fldiv-and-mod fln fld)
    391356  (%check-flonum 'fldiv-and-mod fln)
    392357  (%check-flonum 'fldiv-and-mod fld)
    393   (%fpquotient-and-remainder  fln fld) )
     358  (%fpdiv-and-mod  fln fld) )
    394359
    395360(define (fldiv0 fln fld)
     
    414379(define (fllog fl #!optional base)
    415380  (define log/base  ;memoize log/base functions
    416     (let ([bases '()])
     381    (let ((bases '()))
    417382      (lambda (base)
    418         (let ([cell (assv base bases)])
     383        (let ((cell (assv base bases)))
    419384               (if cell (cdr cell)
    420                    (let ([func (make-log/base base)])
     385                   (let ((func (make-log/base base)))
    421386                     (set! bases (alist-cons base func bases))
    422387                     func ) ) ) ) ) )
     
    447412  (%fpacos fl) )
    448413
    449 (define (flatan fl . rest)
     414(define (flatan fl #!optional fld)
    450415  (%check-flonum 'flatan fl)
    451   (if (%null? rest) (%fpatan fl)
    452       (let ([fld (%car rest)])
     416  (if (not fld) (%fpatan fl)
     417      (begin
    453418        (%check-flonum 'flatan fld)
    454419        (%fpatan2 fl fld) ) ) )
     
    473438      1.0 ) )
    474439
     440
     441;;; Extras
     442
     443(define (flnegate fl)
     444  (%check-flonum 'flnegate fl)
     445  (%fpnegate fl) )
     446
    475447) ;module err5rs-arithmetic-bitwise
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.setup

    r13604 r13610  
    77(setup-shared-extension-module 'err5rs-arithmetic-bitwise (extension-version "1.0.0"))
    88
    9 (setup-shared-extension-module 'err5rs-arithmetic-fixnum (extension-version "1.0.0"))
     9(setup-shared-extension-module 'err5rs-arithmetic-fixnums (extension-version "1.0.0"))
    1010
    11 (setup-shared-extension-module 'err5rs-arithmetic-flonum (extension-version "1.0.0"))
     11(setup-shared-extension-module 'err5rs-arithmetic-flonums (extension-version "1.0.0"))
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r13604 r13610  
     1;;;; err5rs-arithmetic-test
     2
     3(require-extension test int-limits)
     4(require-extension err5rs-arithmetic-fixnums err5rs-arithmetic-flonums err5rs-arithmetic-bitwise)
     5
     6
     7#;
     8(test-group "Fixnum Functions"
     9)
     10
     11#;
     12(test-group "Flonum Functions"
     13)
     14
     15(test-group "Bitwise Functions"
     16
     17  (test-assert #b011 (bitwise-if #b100 #b000 #b111))
     18  (test-assert #b100 (bitwise-if #b011 #b000 #b100))
     19
     20  (test-assert #b100 (bitwise-if-not #b100 #b000 #b111))
     21  (test-assert #b000 (bitwise-if-not #b011 #b000 #b100))
     22  (test-assert #b110 (bitwise-if-not #b011 #b101 #b010))
     23
     24  (test-assert #t (bitwise-test? #b0010 #b0111))
     25  (test-assert #f (bitwise-test? #b0001 #b0100))
     26        (test-assert #f (bitwise-test? #b0100 #b1011))
     27        (test-assert #t (bitwise-test? #b0100 #b0111))
     28
     29        (test-assert 4 (bitwise-bit-count #b10101010))
     30        (test-assert 0 (bitwise-bit-count 0))
     31        (test-assert 1 (bitwise-bit-count -2))
     32
     33        (test-assert 8 (bitwise-length #b10101010))
     34        (test-assert 0 (bitwise-length 0))
     35        (test-assert 4 (bitwise-length #b1111))
     36        (test-assert 5 (bitwise-length -27))
     37
     38        (test-assert #t (bitwise-bit-set? #b1101 0))
     39        (test-assert #f (bitwise-bit-set? #b1101 1))
     40        (test-assert #t (bitwise-bit-set? #b1101 2))
     41        (test-assert #t (bitwise-bit-set? #b1101 3))
     42        (test-assert #f (bitwise-bit-set? #b1101 4))
     43
     44  (test-assert 0 (bitwise-last-bit-set 0))
     45  (test-assert 8 (bitwise-last-bit-set #b10111100))
     46  (test-assert machine-word-bits (bitwise-last-bit-set -1))
     47
     48        (test-assert -1 (bitwise-first-bit-set 0))
     49        (test-assert 0 (bitwise-first-bit-set -1))
     50        (test-assert 0 (bitwise-first-bit-set 1))
     51        (test-assert 1 (bitwise-first-bit-set -2))
     52        (test-assert 1 (bitwise-first-bit-set 2))
     53        (test-assert 0 (bitwise-first-bit-set -3))
     54        (test-assert 0 (bitwise-first-bit-set 3))
     55        (test-assert 2 (bitwise-first-bit-set -4))
     56        (test-assert 2 (bitwise-first-bit-set 4))
     57        (test-assert 0 (bitwise-first-bit-set -5))
     58        (test-assert 0 (bitwise-first-bit-set 5))
     59        (test-assert 1 (bitwise-first-bit-set -6))
     60        (test-assert 1 (bitwise-first-bit-set 6))
     61        (test-assert 0 (bitwise-first-bit-set -7))
     62        (test-assert 0 (bitwise-first-bit-set 7))
     63        (test-assert 3 (bitwise-first-bit-set -8))
     64        (test-assert 3 (bitwise-first-bit-set 8))
     65        (test-assert 0 (bitwise-first-bit-set -9))
     66        (test-assert 0 (bitwise-first-bit-set 9))
     67        (test-assert 1 (bitwise-first-bit-set -10))
     68        (test-assert 1 (bitwise-first-bit-set 10))
     69        (test-assert 0 (bitwise-first-bit-set -11))
     70        (test-assert 0 (bitwise-first-bit-set 11))
     71        (test-assert 2 (bitwise-first-bit-set -12))
     72        (test-assert 2 (bitwise-first-bit-set 12))
     73        (test-assert 0 (bitwise-first-bit-set -13))
     74        (test-assert 0 (bitwise-first-bit-set 13))
     75        (test-assert 1 (bitwise-first-bit-set -14))
     76        (test-assert 1 (bitwise-first-bit-set 14))
     77        (test-assert 0 (bitwise-first-bit-set -15))
     78        (test-assert 0 (bitwise-first-bit-set 15))
     79        (test-assert 4 (bitwise-first-bit-set -16))
     80        (test-assert 4 (bitwise-first-bit-set 16))
     81
     82        (test-assert #b1 (bitwise-copy-bit 0 0 1))
     83        (test-assert #b100 (bitwise-copy-bit 0 2 1))
     84        (test-assert #b1011 (bitwise-copy-bit #b1111 2 0))
     85
     86        (test-assert #b1 (bitwise-copy-bit 0 0 #t))
     87        (test-assert #b100 (bitwise-copy-bit 0 2 #t))
     88        (test-assert #b1011 (bitwise-copy-bit #b1111 2 #f))
     89
     90        (test-assert #b1010 (bitwise-bit-field #b1101101010 0 4))
     91        (test-assert #b10110 (bitwise-bit-field #b1101101010 4 9))
     92
     93        (test-assert #b1101100000 (bitwise-copy-bit-field #b1101101010 0 4 0))
     94        (test-assert #b1101101111 (bitwise-copy-bit-field #b1101101010 0 4 -1))
     95        (test-assert #b110100111110000 (bitwise-copy-bit-field #b110100100010000 5 9 -1))
     96
     97        (test-assert #b10 (bitwise-rotate-bit-field #b0100 0 4 3) )
     98        (test-assert #b10 (bitwise-rotate-bit-field #b0100 0 4 -1))
     99        (test-assert #b110100010010000 (bitwise-rotate-bit-field #b110100100010000 5 9 -1))
     100        (test-assert #b110100000110000 (bitwise-rotate-bit-field #b110100100010000 5 9 1) )
     101
     102        (test-assert #b11100101 (bitwise-reverse-bit-field #b10100111 0 8))
     103        (test-assert #b1011000 (bitwise-reverse-bit-field #b1010010 1 4))
     104
     105        (test-assert 0 (bitwise-list->integer '()))
     106        (test-assert #b101 (bitwise-list->integer '(#t #f #t)))
     107
     108        (test-assert '() (bitwise-integer->list #b0 0))
     109        (test-assert (make-list machine-word-bits #f) (bitwise-integer->list #b0))
     110        (test-assert '(#t #f #t) (bitwise-integer->list #b101))
     111        (test-assert '(#t #t #f #t) (bitwise-integer->list #b11101 4))
     112)
Note: See TracChangeset for help on using the changeset viewer.