Changeset 13998 in project


Ignore:
Timestamp:
03/30/09 19:17:52 (11 years ago)
Author:
Kon Lovett
Message:

R6RS test suite.

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

Legend:

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

    r13794 r13998  
    11;;;; err5rs-arithmetic-bitwise.scm
    22;;;; Kon Lovett, Mar '09
     3
     4;; Issues
     5;;
     6;; - No support for the full-numeric-tower. All operations upon core numerics.
    37
    48;;; Prelude
     
    253257;;
    254258
    255 (define-inline (%check-fixnum loc obj)
    256   (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    257 
    258 (define-inline (%check-list loc obj)
    259   (unless (%list? obj) (error-type-list loc obj)) )
    260 
    261 (define-inline (%check-integer loc obj)
    262   (unless (%integer? obj) (error-type-integer loc obj)) )
    263 
    264 ;;
    265 
    266 (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
    267   (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
    268 
    269 (define-inline (%check-fixnum-range loc lfx fx hfx)
    270   (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    271 
    272 ;;
    273 
    274 (define-inline (%check-word-bits-range loc obj)
    275    (%check-fixnum loc obj)
    276    (%check-fixnum-range loc 0 obj machine-word-bits))
    277 
    278 (define-inline (%check-bits-range loc start end)
    279   (%check-fixnum loc start)
    280   (%check-fixnum loc end)
    281   (%check-fixnum-bounds-order loc start end)
    282   (%check-fixnum-range loc 0 start machine-word-precision)
    283   (%check-fixnum-range loc 0 end machine-word-bits) )
    284 
    285 (define-inline (%check-fixnum-bits-count loc count start end)
    286   (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) )
     259(cond-expand
     260  (unsafe
     261
     262    (define-inline (%check-fixnum loc obj) #t)
     263
     264    (define-inline (%check-list loc obj) #t)
     265
     266    (define-inline (%check-integer loc obj) #t)
     267
     268    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
     269
     270    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
     271
     272    (define-inline (%check-word-bits-range loc obj) #t)
     273
     274    (define-inline (%check-bits-range loc start end) #t)
     275
     276    (define-inline (%check-fixnum-bits-count loc count start end) #t) )
     277
     278  (else
     279
     280    (define-inline (%check-fixnum loc obj)
     281      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     282
     283    (define-inline (%check-list loc obj)
     284      (unless (%list? obj) (error-type-list loc obj)) )
     285
     286    (define-inline (%check-integer loc obj)
     287      (unless (%integer? obj) (error-type-integer loc obj)) )
     288
     289    (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
     290      (unless (%fx<= fx1 fx2) (error-bounds-order loc start end)) )
     291
     292    (define-inline (%check-fixnum-range loc lfx fx hfx)
     293      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
     294
     295    (define-inline (%check-word-bits-range loc obj)
     296       (%check-fixnum loc obj)
     297       (%check-fixnum-range loc 0 obj machine-word-bits) )
     298
     299    (define-inline (%check-bits-range loc start end)
     300      (%check-fixnum loc start)
     301      (%check-fixnum loc end)
     302      (%check-fixnum-bounds-order loc start end)
     303      (%check-fixnum-range loc 0 start machine-word-precision)
     304      (%check-fixnum-range loc 0 end machine-word-bits) )
     305
     306    (define-inline (%check-fixnum-bits-count loc count start end)
     307      (unless (%fx< (%fxabs count) (%fx- end start)) (error-bits-count loc count start end)) ) ) )
    287308
    288309;;
     
    295316
    296317;;;
    297 
    298 (require-library srfi-1 int-limits)
    299318
    300319(module err5rs-arithmetic-bitwise (;export
     
    340359(import scheme chicken foreign srfi-1 int-limits)
    341360
     361(require-library srfi-1 int-limits)
     362
    342363;;; Errors
    343364
    344 (define (error-type-fixnum loc obj)
    345   (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    346 
    347 (define (error-type-integer loc obj)
    348   (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
    349 
    350 (define (error-type-list loc obj)
    351   (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
    352 
    353 (define-inline (error-outside-range loc obj low high)
    354   (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
    355 
    356 (define (error-bounds-order loc start end)
    357   (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
    358 
    359 (define (error-bits-count loc count start end)
    360   (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
     365(cond-expand
     366  (unsafe)
     367  (else
     368
     369    (define (error-type-fixnum loc obj)
     370      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     371
     372    (define (error-type-integer loc obj)
     373      (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
     374
     375    (define (error-type-list loc obj)
     376      (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
     377
     378    (define-inline (error-outside-range loc obj low high)
     379      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     380
     381    (define (error-bounds-order loc start end)
     382      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     383
     384    (define (error-bits-count loc count start end)
     385      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) ) )
    361386
    362387;;; Unchecked Variants
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13807 r13998  
    2424;; Argument checking
    2525
    26 (define-inline (%check-fixnum loc obj)
    27   (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    28 
    29 (define-inline (%check-fixnum-shift-amount loc obj)
    30   (unless (and (%fixnum? obj)
    31                (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj)))
    32                  (%fxclosed? 0 amt fixnum-precision)))
    33     (error-type-shift-amount loc obj) ) )
    34 
    35 (define-inline (%check-fixnum-bounds-order loc start end)
    36   (unless (%fx<= start end) (error-bounds-order loc start end)) )
    37 
    38 (define-inline (%check-fixnum-range loc lfx fx hfx)
    39   (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
    40 
    41 (define-inline (%check-word-bits-range loc obj)
    42    (%check-fixnum loc obj)
    43    (%check-fixnum-range loc 0 obj fixnum-precision))
    44 
    45 (define-inline (%check-bits-range loc start end)
    46   (%check-fixnum loc start)
    47   (%check-fixnum loc end)
    48   (%check-fixnum-bounds-order loc start end)
    49   ; Inclusive start
    50   (%check-fixnum-range loc 0 start fixnum-precision)
    51   ; Exclusive end
    52   (%check-fixnum-range loc 0 end fixnum-width) )
    53 
    54 (define-inline (%check-fixnum-bits-count loc obj start end)
    55   (unless (and (%fixnum? obj) (%fxcardinal? obj)) (error-negative-count loc obj))
    56   (unless (%fx< obj (%fx- end start)) (error-bits-count loc obj start end)) )
    57 
    58 (define-inline (%check-zero-division loc fx1 fx2)
    59   (when (%fxzero? fx2) (error-zero-division loc fx1 fx2)) )
     26(cond-expand
     27  (unsafe
     28
     29    (define-inline (%check-fixnum loc obj) #t)
     30
     31    (define-inline (%check-fixnum-shift-amount loc obj) #t)
     32
     33    (define-inline (%check-fixnum-bounds-order loc start end) #t)
     34
     35    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
     36
     37    (define-inline (%check-word-bits-range loc obj) #t)
     38
     39    (define-inline (%check-bits-range loc start end) #t)
     40
     41    (define-inline (%check-fixnum-bits-count loc obj start end) #t)
     42
     43    (define-inline (%check-zero-division loc fx1 fx2) #t) )
     44
     45  (else
     46
     47    (define-inline (%check-fixnum loc obj)
     48      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     49
     50    (define-inline (%check-fixnum-shift-amount loc obj)
     51      (unless (and (%fixnum? obj)
     52                   (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj)))
     53                     (%fxclosed? 0 amt fixnum-precision)))
     54        (error-type-shift-amount loc obj) ) )
     55
     56    (define-inline (%check-fixnum-bounds-order loc start end)
     57      (unless (%fx<= start end) (error-bounds-order loc start end)) )
     58
     59    (define-inline (%check-fixnum-range loc lfx fx hfx)
     60      (unless (%fxclosed? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )
     61
     62    (define-inline (%check-word-bits-range loc obj)
     63      (%check-fixnum loc obj)
     64      (%check-fixnum-range loc 0 obj fixnum-precision))
     65
     66    (define-inline (%check-bits-range loc start end)
     67      (%check-fixnum loc start)
     68      (%check-fixnum loc end)
     69      (%check-fixnum-bounds-order loc start end)
     70      ; Inclusive start
     71      (%check-fixnum-range loc 0 start fixnum-precision)
     72      ; Exclusive end
     73      (%check-fixnum-range loc 0 end fixnum-width) )
     74
     75    (define-inline (%check-fixnum-bits-count loc obj start end)
     76      (unless (and (%fixnum? obj) (%fxcardinal? obj)) (error-negative-count loc obj))
     77      (unless (%fx< obj (%fx- end start)) (error-bits-count loc obj start end)) )
     78
     79    (define-inline (%check-zero-division loc fx1 fx2)
     80      (when (%fxzero? fx2) (error-zero-division loc fx1 fx2)) ) ) )
    6081
    6182;; Fold operations
     
    153174          (else
    154175           (error-fixnum-representation loc fx amt) ) ) ) )
    155  
     176
    156177(define-inline (%fxshr/check loc fx amt)
    157178  (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
     
    162183
    163184;;;
    164 
    165 (require-library data-structures err5rs-arithmetic-bitwise)
    166185
    167186(module err5rs-arithmetic-fixnums (;export
     
    227246        err5rs-arithmetic-bitwise)
    228247
     248(require-library data-structures err5rs-arithmetic-bitwise)
     249
    229250;;; Conditions
    230251
    231 (define (make-exn-condition loc msg args)
    232   (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    233 
    234 (define (make-arithmetic-condition loc msg args)
    235   (make-composite-condition
    236    (make-exn-condition loc msg args)
    237    (make-property-condition 'arithmetic)) )
    238 
    239 (define (make-shift-amount-condition loc amt)
    240   (make-arithmetic-condition loc "invalid shift amount" (list amt)) )
    241 
    242 (define (make-zero-division-condition loc fx1 fx2)
    243   (make-arithmetic-condition loc "division by zero" (list fx1 fx2)) )
    244 
    245 ; &implementation-restriction
    246 (define (make-fixnum-representation-condition loc args)
    247   (make-arithmetic-condition loc "result not representable as fixnum" args) )
     252(cond-expand
     253  (unsafe)
     254  (else
     255
     256    (define (make-exn-condition loc msg args)
     257      (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
     258
     259    (define (make-arithmetic-condition loc msg args)
     260      (make-composite-condition
     261       (make-exn-condition loc msg args)
     262       (make-property-condition 'arithmetic)) )
     263
     264    (define (make-shift-amount-condition loc amt)
     265      (make-arithmetic-condition loc "invalid shift amount" (list amt)) )
     266
     267    ; &assertion
     268    (define (make-zero-division-condition loc fx1 fx2)
     269      (make-arithmetic-condition loc "division by zero" (list fx1 fx2)) )
     270
     271    ; &implementation-restriction
     272    (define (make-fixnum-representation-condition loc args)
     273      (make-arithmetic-condition loc "result not representable as fixnum" args) ) ) )
    248274
    249275;;; Errors
    250276
    251 (define (error-type-fixnum loc obj)
    252   (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    253 
    254 (define (error-type-radix loc radix)
    255   (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
    256 
    257 (define (error-outside-range loc obj low high)
    258   (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
    259 
    260 (define (error-bounds-order loc start end)
    261   (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
    262 
    263 (define (error-negative-count loc count)
    264   (##sys#signal-hook #:bounds-error loc "cannot be negative" count) )
    265 
    266 (define (error-bits-count loc count start end)
    267   (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    268 
    269 (define (error-type-shift-amount loc obj)
    270   (abort (make-shift-amount-condition loc obj)) )
    271 
    272 (define (error-zero-division loc fx1 fx2)
    273   (abort (make-zero-division-condition loc fx1 fx2)) )
    274 
    275 (define (error-fixnum-representation loc . args)
    276   (abort (make-fixnum-representation-condition loc args)) )
     277(cond-expand
     278  (unsafe
     279
     280    (define (error-type-fixnum loc obj) #t)
     281
     282    (define (error-type-radix loc radix) #t)
     283
     284    (define (error-outside-range loc obj low high) #t)
     285
     286    (define (error-bounds-order loc start end) #t)
     287
     288    (define (error-negative-count loc count) #t)
     289
     290    (define (error-bits-count loc count start end) #t)
     291
     292    (define (error-type-shift-amount loc obj) #t)
     293
     294    (define (error-zero-division loc fx1 fx2) #t)
     295
     296    (define (error-fixnum-representation loc . args) #t) )
     297
     298  (else
     299
     300    (define (error-type-fixnum loc obj)
     301      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     302
     303    (define (error-type-radix loc radix)
     304      (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
     305
     306    (define (error-outside-range loc obj low high)
     307      (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     308
     309    (define (error-bounds-order loc start end)
     310      (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     311
     312    (define (error-negative-count loc count)
     313      (##sys#signal-hook #:bounds-error loc "cannot be negative" count) )
     314
     315    (define (error-bits-count loc count start end)
     316      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
     317
     318    (define (error-type-shift-amount loc obj)
     319      (abort (make-shift-amount-condition loc obj)) )
     320
     321    (define (error-zero-division loc fx1 fx2)
     322      (abort (make-zero-division-condition loc fx1 fx2)) )
     323
     324    (define (error-fixnum-representation loc . args)
     325      (abort (make-fixnum-representation-condition loc args)) ) ) )
    277326
    278327;;; Constants
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13824 r13998  
    2424(include "chicken-primitive-object-inlines")
    2525
    26 #>
    27 <#
    28 
    29 ;;
    30 
    31 (define-inline (%check-fixnum loc obj)
    32   (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    33 
    34 (define-inline (%check-flonum loc obj)
    35   (unless (%flonum? obj) (error-type-flonum loc obj)) )
    36 
    37 (define-inline (%check-cardinal loc obj)
    38   (unless (%cardinal? obj) (error-type-cardinal loc obj)) )
    39 
    40 (define-inline (%check-real loc obj)
    41   (unless (real? obj) (error-type-real loc obj)) )
     26;;
     27
     28(cond-expand
     29  (unsafe
     30
     31    (define-inline (%check-fixnum loc obj) #t)
     32
     33    (define-inline (%check-flonum loc obj) #t)
     34
     35    (define-inline (%check-cardinal loc obj) #t)
     36
     37    (define-inline (%check-real loc obj) #t) )
     38
     39  (else
     40
     41    (define-inline (%check-fixnum loc obj)
     42      (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
     43
     44    (define-inline (%check-flonum loc obj)
     45      (unless (%flonum? obj) (error-type-flonum loc obj)) )
     46
     47    (define-inline (%check-cardinal loc obj)
     48      (unless (%cardinal? obj) (error-type-cardinal loc obj)) )
     49
     50    (define-inline (%check-real loc obj)
     51      (unless (real? obj) (error-type-real loc obj)) ) ) )
    4252
    4353;;
     
    125135;;;
    126136
    127 (require-library srfi-1 mathh)
    128 
    129137(module err5rs-arithmetic-flonums (;export
    130138  ; ERR5RS
     139  #;no-infinities-violation? #;make-no-infinities-violation
     140  #;no-nans-violation? #;make-no-nans-violation
    131141  real->flonum fixnum->flonum
    132142  fl=? fl<? fl>? fl<=? fl>=?
     
    159169(import scheme chicken foreign srfi-1 mathh)
    160170
     171(require-library srfi-1 mathh)
     172
    161173;;; Errors
    162174
    163 (define (error-type-fixnum loc obj)
    164   (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    165 
    166 (define (error-type-flonum loc obj)
    167   (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) )
    168 
    169 (define (error-type-real loc obj)
    170   (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
    171 
    172 (define (error-type-cardinal loc obj)
    173   (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal" obj) )
     175(cond-expand
     176  (unsafe)
     177  (else
     178
     179    (define (error-type-fixnum loc obj)
     180      (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
     181
     182    (define (error-type-flonum loc obj)
     183      (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) )
     184
     185    (define (error-type-real loc obj)
     186      (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
     187
     188    (define (error-type-cardinal loc obj)
     189      (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal" obj) ) ) )
    174190
    175191;;; Procedures wrapping primitive-inlines for fold operations
     
    260276;;
    261277
     278#;(define (make-no-infinities-violation) )
     279
     280#;(define (no-infinities-violation? obj) )
     281
     282#;(define (make-no-nans-violation) )
     283
     284#;(define (no-nans-violation? obj) )
     285
     286;;
     287
    262288(define (real->flonum value)
    263   (if (%flonum? value) value
    264       (begin
    265         (%check-real 'real->flonum value)
    266         (%exact->inexact value) ) ) )
     289  (cond ((%flonum? value) value)
     290        (else
     291         (%check-real 'real->flonum value)
     292         (%exact->inexact value) ) ) )
    267293
    268294(define (fixnum->flonum fx)
     
    407433                     func ) ) ) ) ) )
    408434  (%check-flonum 'fllog fp)
    409   (if (not base) (%fplog fp)
    410       (begin
    411         (%check-cardinal 'fllog base)
    412         ((log/base base) fp) ) ) )
     435  (cond (base
     436         (%check-cardinal 'fllog base)
     437         ((log/base base) fp) )
     438        (else
     439         (%fplog fp) ) ) )
    413440
    414441(define (flsin fp)
     
    434461(define (flatan fp #!optional fpd)
    435462  (%check-flonum 'flatan fp)
    436   (if (not fpd) (%fpatan fp)
    437       (begin
    438         (%check-flonum 'flatan fpd)
    439         (%fpatan2 fp fpd) ) ) )
     463  (cond (fpd
     464         (%check-flonum 'flatan fpd)
     465         (%fpatan2 fp fpd) )
     466        (else
     467         (%fpatan fp) ) ) )
    440468
    441469(define (flsqrt fp)
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r13807 r13998  
    99
    1010  ;; Originally from Ikarus test suite:
     11
    1112  (define (fx*/carry-reference fx1 fx2 fx3)
    12     (let* ([s (+ (* fx1 fx2) fx3)]
    13            [s0 (mod0 s (expt 2 (fixnum-width)))]
    14            [s1 (div0 s (expt 2 (fixnum-width)))])
     13    (let* ((s (+ (* fx1 fx2) fx3))
     14           (s0 (mod0 s (expt 2 (fixnum-width))))
     15           (s1 (div0 s (expt 2 (fixnum-width)))))
    1516      (values s0 s1)))
     17
    1618  (define (fx+/carry-reference fx1 fx2 fx3)
    17     (let* ([s (+ (+ fx1 fx2) fx3)]
    18            [s0 (mod0 s (expt 2 (fixnum-width)))]
    19            [s1 (div0 s (expt 2 (fixnum-width)))])
     19    (let* ((s (+ (+ fx1 fx2) fx3))
     20           (s0 (mod0 s (expt 2 (fixnum-width))))
     21           (s1 (div0 s (expt 2 (fixnum-width)))))
    2022      (values s0 s1)))
     23
    2124  (define (fx-/carry-reference fx1 fx2 fx3)
    22     (let* ([s (- (- fx1 fx2) fx3)]
    23            [s0 (mod0 s (expt 2 (fixnum-width)))]
    24            [s1 (div0 s (expt 2 (fixnum-width)))])
     25    (let* ((s (- (- fx1 fx2) fx3))
     26           (s0 (mod0 s (expt 2 (fixnum-width))))
     27           (s1 (div0 s (expt 2 (fixnum-width)))))
    2528      (values s0 s1)))
    2629
     
    3033  (define-syntax carry-test
    3134    (syntax-rules ()
    32       [(_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
     35      ((_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
    3336       (test `(fxop/carry ,fx1 ,fx2 ,fx3)
    3437              (vals->list fxop/carry-reference fx1 fx2 fx3)
    35               (vals->list fxop/carry fx1 fx2 fx3))]))
     38              (vals->list fxop/carry fx1 fx2 fx3)))))
    3639
    3740  (define (carry-tests l)
     
    7578    (test (greatest-fixnum) (- (expt 2 (- (fixnum-width) 1)) 1))
    7679
    77     (test #f (fixnum? 1.0))
    78     (test #f (fixnum? 1+1i))
    79 
    80     (test #t (fixnum? 0))
    81     (test #t (fixnum? 1))
    82     (test #t (fixnum? -1))
    83     (test #t (fixnum? (- (expt 2 23))))
    84     (test #t (fixnum? (- (expt 2 23) 1)))
    85 
    86     (test #t (fixnum? (least-fixnum)))
    87     (test #f (fixnum? (- (least-fixnum) 1)))
    88     (test #t (fixnum? (greatest-fixnum)))
    89     (test #f (fixnum? (+ 1 (greatest-fixnum))))
    90 
    91     (let ([test-ordered
     80    (test-assert (not (fixnum? 1.0)))
     81    (test-assert (not (fixnum? 1+1i)))
     82
     83    (test-assert (fixnum? 0))
     84    (test-assert (fixnum? 1))
     85    (test-assert (fixnum? -1))
     86    (test-assert (fixnum? (- (expt 2 23))))
     87    (test-assert (fixnum? (- (expt 2 23) 1)))
     88
     89    (test-assert (fixnum? (least-fixnum)))
     90    (test-assert (not (fixnum? (- (least-fixnum) 1))))
     91    (test-assert (fixnum? (greatest-fixnum)))
     92    (test-assert (not (fixnum? (+ 1 (greatest-fixnum)))))
     93
     94    (let ((test-ordered
    9295           (lambda (a b c)
    93              (test #t (fx=? a a))
    94              (test #t (fx=? b b))
    95              (test #t (fx=? c c))
    96 
    97              (test #f (fx=? a b))
    98              (test #f (fx=? b a))
    99              (test #f (fx=? b c))
    100              (test #f (fx=? c b))
    101 
    102              (test #f (fx=? a c b))
    103              (test #f (fx=? a a b))
    104              (test #f (fx=? a b b))
    105 
    106              (let ([test-lt
     96             (test-assert (fx=? a a))
     97             (test-assert (fx=? b b))
     98             (test-assert (fx=? c c))
     99
     100             (test-assert (not (fx=? a b)))
     101             (test-assert (not (fx=? b a)))
     102             (test-assert (not (fx=? b c)))
     103             (test-assert (not (fx=? c b)))
     104
     105             (test-assert (not (fx=? a c b)))
     106             (test-assert (not (fx=? a a b)))
     107             (test-assert (not (fx=? a b b)))
     108
     109             (let ((test-lt
    107110                    (lambda (fx<? fx<=? a b c)
    108                       (test #t (fx<? a b))
    109                       (test #t (fx<? b c))
    110                       (test #t (fx<? a c))
    111                       (test #t (fx<? a b c))
    112 
    113                       (test #f (fx<? b a))
    114                       (test #f (fx<? c b))
    115                       (test #f (fx<? a c b))
    116 
    117                       (test #t (fx<=? a a))
    118                       (test #t (fx<=? a b))
    119                       (test #t (fx<=? a c))
    120                       (test #t (fx<=? b b))
    121                       (test #t (fx<=? b c))
    122                       (test #t (fx<=? c c))
    123                       (test #t (fx<=? a c c))
    124                       (test #t (fx<=? a b c))
    125                       (test #t (fx<=? b b c))
    126 
    127                       (test #f (fx<=? c a))
    128                       (test #f (fx<=? b a))
    129                       (test #f (fx<=? a c b))
    130                       (test (fx<=? b c a) #f))])
     111                      (test-assert (fx<? a b))
     112                      (test-assert (fx<? b c))
     113                      (test-assert (fx<? a c))
     114                      (test-assert (fx<? a b c))
     115
     116                      (test-assert (not (fx<? b a)))
     117                      (test-assert (not (fx<? c b)))
     118                      (test-assert (not (fx<? a c b)))
     119
     120                      (test-assert (fx<=? a a))
     121                      (test-assert (fx<=? a b))
     122                      (test-assert (fx<=? a c))
     123                      (test-assert (fx<=? b b))
     124                      (test-assert (fx<=? b c))
     125                      (test-assert (fx<=? c c))
     126                      (test-assert (fx<=? a c c))
     127                      (test-assert (fx<=? a b c))
     128                      (test-assert (fx<=? b b c))
     129
     130                      (test-assert (not (fx<=? c a)))
     131                      (test-assert (not (fx<=? b a)))
     132                      (test-assert (not (fx<=? a c b)))
     133                      (test-assert (not (fx<=? b c a))))))
    131134               (test-lt fx<? fx<=? a b c)
    132135               (test-lt fx>? fx>=? c b a))
    133136
    134137             ;; Since b is between a and c, we can add or subtract 1:
    135              (test #t (fx=? (+ b 1) (+ b 1)))
    136              (test #t (fx<? b (+ b 1)))
    137              (test #t (fx<=? b (+ b 1)))
    138              (test #f (fx>? b (+ b 1)))
    139              (test #f (fx>=? b (+ b 1)))
    140              (test #t (fx=? (- b 1) (- b 1)))
    141              (test #f (fx<? b (- b 1)))
    142              (test #f (fx<=? b (- b 1)))
    143              (test #t (fx>? b (- b 1)))
    144              (test #t (fx>=? b (- b 1)))
     138             (test-assert (fx=? (+ b 1) (+ b 1)))
     139             (test-assert (fx<? b (+ b 1)))
     140             (test-assert (fx<=? b (+ b 1)))
     141             (test-assert (not (fx>? b (+ b 1))))
     142             (test-assert (not (fx>=? b (+ b 1))))
     143             (test-assert (fx=? (- b 1) (- b 1)))
     144             (test-assert (not (fx<? b (- b 1))))
     145             (test-assert (not (fx<=? b (- b 1))))
     146             (test-assert (fx>? b (- b 1)))
     147             (test-assert (fx>=? b (- b 1)))
    145148
    146149             ;; Check min & max while we have ordered values:
     
    152155             (test c (fxmax b c))
    153156             (test c (fxmax a c))
    154              (test c (fxmax b c a)))])
     157             (test c (fxmax b c a)))))
    155158      (test-ordered 1 2 3)
    156159      (test-ordered -1 0 1)
    157160      (test-ordered (least-fixnum) 1 (greatest-fixnum)))
    158161
    159     (test #t (fxzero? 0))
    160     (test #f (fxzero? 1))
    161     (test #f (fxzero? (greatest-fixnum)))
    162     (test #f (fxzero? (least-fixnum)))
    163 
    164     (test #f (fxpositive? 0))
    165     (test #f (fxpositive? (least-fixnum)))
    166     (test #t (fxpositive? (greatest-fixnum)))
    167 
    168     (test #f (fxnegative? 0))
    169     (test #t (fxnegative? (least-fixnum)))
    170     (test #f (fxnegative? (greatest-fixnum)))
    171 
    172     (test #f (fxodd? 0))
    173     (test #f (fxodd? 2))
    174     (test #t (fxodd? 1))
    175     (test #t (fxodd? -1))
    176     (test #t (fxodd? (greatest-fixnum)))
    177     (test #f (fxodd? (least-fixnum)))
    178 
    179     (test #t (fxeven? 0))
    180     (test #t (fxeven? 2))
    181     (test #f (fxeven? 1))
    182     (test #f (fxeven? -1))
    183     (test #f (fxeven? (greatest-fixnum)))
    184     (test #t (fxeven? (least-fixnum)))
     162    (test-assert (fxzero? 0))
     163    (test-assert (not (fxzero? 1)))
     164    (test-assert (not (fxzero? (greatest-fixnum))))
     165    (test-assert (not (fxzero? (least-fixnum))))
     166
     167    (test-assert (not (fxpositive? 0)))
     168    (test-assert (not (fxpositive? (least-fixnum))))
     169    (test-assert (fxpositive? (greatest-fixnum)))
     170
     171    (test-assert (not (fxnegative? 0)))
     172    (test-assert (fxnegative? (least-fixnum)))
     173    (test-assert (not (fxnegative? (greatest-fixnum))))
     174
     175    (test-assert (not (fxodd? 0)))
     176    (test-assert (not (fxodd? 2)))
     177    (test-assert (fxodd? 1))
     178    (test-assert (fxodd? -1))
     179    (test-assert (fxodd? (greatest-fixnum)))
     180    (test-assert (not (fxodd? (least-fixnum))))
     181
     182    (test-assert (fxeven? 0))
     183    (test-assert (fxeven? 2))
     184    (test-assert (not (fxeven? 1)))
     185    (test-assert (not (fxeven? -1)))
     186    (test-assert (not (fxeven? (greatest-fixnum))))
     187    (test-assert (fxeven? (least-fixnum)))
    185188
    186189    (test 20 (fx+ 3 17))
     
    293296    (test 17 (fxfirst-bit-set (expt 2 17)))
    294297
    295     (test #t (fxbit-set? 15 0))
    296     (test #f (fxbit-set? 14 0))
    297     (test #t (fxbit-set? 14 3))
    298     (test #f (fxbit-set? 14 10))
    299     (test #t (fxbit-set? -1 10))
     298    (test-assert (fxbit-set? 15 0))
     299    (test-assert (not (fxbit-set? 14 0)))
     300    (test-assert (fxbit-set? 14 3))
     301    (test-assert (not (fxbit-set? 14 10)))
     302    (test-assert (fxbit-set? -1 10))
    300303
    301304    (test 1 (fxcopy-bit 0 0 1))
     
    354357;;
    355358
    356 (test-group "Flonum Functions"
    357 
    358   (test -4.0 (flround -4.3))
    359   (test 4.0 (flround 3.5))
    360   (test 4.0 (flround (fl/ 7.0 2.0)))
    361   (test 7.0 (flround 7.0))
    362   (test-assert (fl=? -0.0 (flround -0.5)))
    363   (test-assert (flzero? (flround -0.5)))
    364   (test-assert (flzero? (flround -0.3)))
    365   (test -1.0 (flround -0.6))
    366   (test-assert (flzero? (flround 0.5)))
    367   (test-assert (flzero? (flround 0.3)))
    368   (test 1.0 (flround 0.6))
    369 
    370   (current-test-epsilon 0.001)
    371 
    372   ;; basic cases, fixnum base
    373   (test 1.0 (flexpt 0.0 0.0))
    374   (test 1.0 (flexpt 2.0 0.0))
    375   (test 2.0 (flexpt 2.0 1.0))
    376   (test 4.0 (flexpt 2.0 2.0))
    377   (test 9.0 (flexpt 3.0 2.0))
    378   (test 9.0 (flexpt 3.0 2.0))
    379   (test 10.0451 (flexpt 3.0 2.1))
    380   (test 1.1161 (flexpt 3.0 0.1))
    381   (test (fl/ 1.0 3.0) (flexpt 3.0 -1.0))
    382   (test (fl/ 1.0 9.0) (flexpt 3.0 -2.0))
    383   (test 0.09955 (flexpt 3.0 -2.1))
    384 
    385   ;; basic cases, flonum base
    386   (test 1.0 (flexpt 0.0 0.0))
    387   (test 1.0 (flexpt 3.14 0.0))
    388   (test 3.14 (flexpt 3.14 1.0))
    389   (test 9.8596 (flexpt 3.14 2.0))
    390   (test 9.8596 (flexpt 3.14 2.0))
    391   (test 11.0548 (flexpt 3.14 2.1))
    392   (test 1.1212 (flexpt 3.14 0.1))
    393   (test 0.31847 (flexpt 3.14 -1.0))
    394   (test 0.10142 (flexpt 3.14 -2.0))
    395   (test 0.090458 (flexpt 3.14 -2.1))
    396 
    397   ;; check overflows into bignums
    398   (test (string->number "1073741824") (flexpt 2.0 30.0))
    399   (test (string->number "2147483648") (flexpt 2.0 31.0))
    400   (test (string->number "4294967296") (flexpt 2.0 32.0))
    401   (test (string->number "4611686018427387904") (flexpt 2.0 62.0))
    402   (test (string->number "9223372036854775808") (flexpt 2.0 63.0))
    403   (test (string->number "18446744073709551616") (flexpt 2.0 64.0))
    404 
    405   (define (one-followed-by-n-zeros n)
    406     (exact->inexact (string->number (string-append "1" (make-string n #\0)))))
    407 
    408   ;; bug reported on the chicken list
    409   (test (one-followed-by-n-zeros 100) (flexpt 10.0 100.0))
    410 
    411   ;; bignum base
    412   (test 1.0 (flexpt (one-followed-by-n-zeros 100) 0.0))
    413   (test (one-followed-by-n-zeros 100) (flexpt (one-followed-by-n-zeros 100) 1.0))
    414   (test (one-followed-by-n-zeros 200) (flexpt (one-followed-by-n-zeros 100) 2.0))
    415   (test 10000000000.0 (flexpt (one-followed-by-n-zeros 100) 0.1))
    416 
    417   ;; cannot compute e^(pi*i) = -1 in domain FL
    418   (test-assert (flnan? (flexpt (flexp 1.0) (* (flacos -1.0) (flsqrt -1.0)))))
    419 
    420   ;; rational rounding
    421   (test 1.0 (flround (fl/ 9.0 10.0)))
    422   (test 1.0 (flround (fl/ 6.0 10.0)))
    423   (test 0.0 (flround (fl/ 5.0 10.0)))
    424   (test 0.0 (flround (fl/ 1.0 10.0)))
    425   (test 0.0 (flround (fl/ 0.0 10.0)))
    426   (test 0.0 (flround (fl/ -1.0 10.0)))
    427   (test 0.0 (flround (fl/ -5.0 10.0)))
    428   (test -1.0 (flround (fl/ -6.0 10.0)))
    429   (test -1.0 (flround (fl/ -9.0 10.0)))
    430   (test-assert (flnan? (flround (fl/ (flexpt 10.0 10000.0) (fl+ (flexpt 10.0 10000.0) 1.0)))))
    431   (test 1.0 (flround (fl/ (flexpt 10.0 100.0) (fl+ (flexpt 10.0 100.0) 1.0))))
    432   (test (flexpt 10.0 9900.0) (flround (fl/ (fl+ 1.0 (flexpt 10.0 10000.0)) (flexpt 10.0 100.0))))
     359(define (run-arithmetic-flonums-tests)
     360
     361  (define (try-flonums proc)
     362    (proc 0.0)
     363    (proc 1.0)
     364    (proc -1.0)
     365    (proc +inf.0)
     366    (proc -inf.0)
     367    (proc +nan.0))
     368
     369  (define-syntax try-bad-divs
     370    (syntax-rules ()
     371      ((_ op)
     372       'nothing
     373       ;; The spec is unclear whether the following
     374       ;; are allowed to raise exceptions.
     375       #;
     376       (begin
     377         (test-error '&assertion (op 1.0 0.0))
     378         (test-error '&assertion (op +inf.0 1.0))
     379         (test-error '&assertion (op -inf.0 1.0))
     380         (test-error '&assertion (op +nan.0 1.0))))))
     381
     382  (test-group "Flonum Functions"
     383
     384    (test -4.0 (flround -4.3))
     385    (test 4.0 (flround 3.5))
     386    (test 4.0 (flround (fl/ 7.0 2.0)))
     387    (test 7.0 (flround 7.0))
     388    (test-assert (fl=? -0.0 (flround -0.5)))
     389    (test-assert (flzero? (flround -0.5)))
     390    (test-assert (flzero? (flround -0.3)))
     391    (test -1.0 (flround -0.6))
     392    (test-assert (flzero? (flround 0.5)))
     393    (test-assert (flzero? (flround 0.3)))
     394    (test 1.0 (flround 0.6))
     395
     396    (current-test-epsilon 0.001)
     397
     398    ;; basic cases, fixnum base
     399    (test 1.0 (flexpt 0.0 0.0))
     400    (test 1.0 (flexpt 2.0 0.0))
     401    (test 2.0 (flexpt 2.0 1.0))
     402    (test 4.0 (flexpt 2.0 2.0))
     403    (test 9.0 (flexpt 3.0 2.0))
     404    (test 9.0 (flexpt 3.0 2.0))
     405    (test 10.0451 (flexpt 3.0 2.1))
     406    (test 1.1161 (flexpt 3.0 0.1))
     407    (test (fl/ 1.0 3.0) (flexpt 3.0 -1.0))
     408    (test (fl/ 1.0 9.0) (flexpt 3.0 -2.0))
     409    (test 0.09955 (flexpt 3.0 -2.1))
     410
     411    ;; basic cases, flonum base
     412    (test 1.0 (flexpt 0.0 0.0))
     413    (test 1.0 (flexpt 3.14 0.0))
     414    (test 3.14 (flexpt 3.14 1.0))
     415    (test 9.8596 (flexpt 3.14 2.0))
     416    (test 9.8596 (flexpt 3.14 2.0))
     417    (test 11.0548 (flexpt 3.14 2.1))
     418    (test 1.1212 (flexpt 3.14 0.1))
     419    (test 0.31847 (flexpt 3.14 -1.0))
     420    (test 0.10142 (flexpt 3.14 -2.0))
     421    (test 0.090458 (flexpt 3.14 -2.1))
     422
     423    ;; check overflows into bignums
     424    (test (string->number "1073741824") (flexpt 2.0 30.0))
     425    (test (string->number "2147483648") (flexpt 2.0 31.0))
     426    (test (string->number "4294967296") (flexpt 2.0 32.0))
     427    (test (string->number "4611686018427387904") (flexpt 2.0 62.0))
     428    (test (string->number "9223372036854775808") (flexpt 2.0 63.0))
     429    (test (string->number "18446744073709551616") (flexpt 2.0 64.0))
     430
     431    (define (one-followed-by-n-zeros n)
     432      (exact->inexact (string->number (string-append "1" (make-string n #\0)))))
     433
     434    ;; bug reported on the chicken list
     435    (test (one-followed-by-n-zeros 100) (flexpt 10.0 100.0))
     436
     437    ;; bignum base
     438    (test 1.0 (flexpt (one-followed-by-n-zeros 100) 0.0))
     439    (test (one-followed-by-n-zeros 100) (flexpt (one-followed-by-n-zeros 100) 1.0))
     440    (test (one-followed-by-n-zeros 200) (flexpt (one-followed-by-n-zeros 100) 2.0))
     441    (test 10000000000.0 (flexpt (one-followed-by-n-zeros 100) 0.1))
     442
     443    ;; cannot compute e^(pi*i) = -1 in domain FL
     444    (test-assert (flnan? (flexpt (flexp 1.0) (* (flacos -1.0) (flsqrt -1.0)))))
     445
     446    ;; rational rounding
     447    (test 1.0 (flround (fl/ 9.0 10.0)))
     448    (test 1.0 (flround (fl/ 6.0 10.0)))
     449    (test 0.0 (flround (fl/ 5.0 10.0)))
     450    (test 0.0 (flround (fl/ 1.0 10.0)))
     451    (test 0.0 (flround (fl/ 0.0 10.0)))
     452    (test 0.0 (flround (fl/ -1.0 10.0)))
     453    (test 0.0 (flround (fl/ -5.0 10.0)))
     454    (test -1.0 (flround (fl/ -6.0 10.0)))
     455    (test -1.0 (flround (fl/ -9.0 10.0)))
     456    (test-assert (flnan? (flround (fl/ (flexpt 10.0 10000.0) (fl+ (flexpt 10.0 10000.0) 1.0)))))
     457    (test 1.0 (flround (fl/ (flexpt 10.0 100.0) (fl+ (flexpt 10.0 100.0) 1.0))))
     458    (test (flexpt 10.0 9900.0) (flround (fl/ (fl+ 1.0 (flexpt 10.0 10000.0)) (flexpt 10.0 100.0))))
     459  )
     460
     461  (test-group "R6RS Flonum Test Suite"
     462
     463    (current-test-epsilon 0.001)
     464
     465    (test-assert (fl=? +inf.0 +inf.0))
     466    (test-assert (not (fl=? -inf.0 +inf.0)))
     467    (test-assert (fl=? -inf.0 -inf.0))
     468    (test-assert (fl=? 0.0 -0.0))
     469    (test-assert (not (fl<? 0.0 -0.0)))
     470    (try-flonums
     471     (lambda (fl)
     472       (test-assert (not (fl=? +nan.0 fl)))
     473       (test-assert (not (fl<? +nan.0 fl)))))
     474
     475    (test-assert (not (flnegative? -0.0)))
     476    (test-assert (not (flfinite? +inf.0)))
     477    (test-assert (flfinite? 5.0))
     478    (test-assert (not (flinfinite? 5.0)))
     479    (test-assert (flinfinite? +inf.0))
     480    (test-assert (flinfinite? -inf.0))
     481    (test-assert (not (flinfinite? +nan.0)))
     482
     483    (test +nan.0 (fl+ +inf.0 -inf.0))
     484    (try-flonums
     485     (lambda (fl)
     486       (test +nan.0 (fl+ +nan.0 fl))
     487       (test +nan.0 (fl* +nan.0 fl))))
     488
     489    (test +nan.0 (fl- +inf.0 +inf.0))
     490
     491    (test +inf.0 (fl/ 1.0 0.0))
     492    (test -inf.0 (fl/ -1.0 0.0))
     493    (test +nan.0 (fl/ 0.0 0.0))
     494
     495    (test +inf.0 (flnumerator +inf.0))
     496    (test -inf.0 (flnumerator -inf.0))
     497    (test 1.0 (fldenominator +inf.0))
     498    (test 1.0 (fldenominator -inf.0))
     499
     500    (test 3.0 (flnumerator 0.75))
     501    (test 4.0 (fldenominator 0.75))
     502
     503    (test -0.0 (flnumerator -0.0))
     504
     505    (test +inf.0 (flfloor +inf.0))
     506    (test -inf.0 (flceiling -inf.0))
     507    (test +nan.0 (fltruncate +nan.0))
     508
     509    (test +inf.0 (flexp +inf.0))
     510    (test 0.0 (flexp -inf.0))
     511    (test +inf.0 (fllog +inf.0))
     512    (test -inf.0 (fllog 0.0))
     513    (test -0.0 (fllog -0.0))
     514    (test +nan.0 (fllog -inf.0))
     515    (test -1.5707963267948965 (flatan -inf.0))
     516    (test 1.5707963267948965 (flatan +inf.0))
     517
     518    (test +inf.0 (flsqrt +inf.0))
     519    (test -0.0 (flsqrt -0.0))
     520
     521    ;; ----------------------------------------
     522
     523    (let ((test-ordered
     524           (lambda (a b c)
     525             (test-assert (fl=? a a))
     526             (test-assert (fl=? b b))
     527             (test-assert (fl=? c c))
     528
     529             (test-assert (not (fl=? a b)))
     530             (test-assert (not (fl=? b a)))
     531             (test-assert (not (fl=? b c)))
     532             (test-assert (not (fl=? c b)))
     533
     534             (test-assert (not (fl=? a c b)))
     535             (test-assert (not (fl=? a a b)))
     536             (test-assert (not (fl=? a b b)))
     537
     538             (let ((test-lt
     539                    (lambda (fl<? fl<=? a b c)
     540                      (test-assert (fl<? a b))
     541                      (test-assert (fl<? b c))
     542                      (test-assert (fl<? a c))
     543                      (test-assert (fl<? a b c))
     544
     545                      (test-assert (not (fl<? b a)))
     546                      (test-assert (not (fl<? c b)))
     547                      (test-assert (not (fl<? a c b)))
     548
     549                      (test-assert (fl<=? a a))
     550                      (test-assert (fl<=? a b))
     551                      (test-assert (fl<=? a c))
     552                      (test-assert (fl<=? b b))
     553                      (test-assert (fl<=? b c))
     554                      (test-assert (fl<=? c c))
     555                      (test-assert (fl<=? a c c))
     556                      (test-assert (fl<=? a b c))
     557                      (test-assert (fl<=? b b c))
     558
     559                      (test-assert (not (fl<=? c a)))
     560                      (test-assert (not (fl<=? b a)))
     561                      (test-assert (not (fl<=? a c b)))
     562                      (test-assert (not (fl<=? b c a))))))
     563               (test-lt fl<? fl<=? a b c)
     564               (test-lt fl>? fl>=? c b a))
     565
     566             ;; Since b is between a and c, we can add or subtract 1:
     567             (test-assert (fl=? (+ b 1) (+ b 1)))
     568             (test-assert (fl<? b (+ b 1)))
     569             (test-assert (fl<=? b (+ b 1)))
     570             (test-assert (not (fl>? b (+ b 1))))
     571             (test-assert (not (fl>=? b (+ b 1))))
     572             (test-assert (fl=? (- b 1) (- b 1)))
     573             (test-assert (not (fl<? b (- b 1))))
     574             (test-assert (not (fl<=? b (- b 1))))
     575             (test-assert (fl>? b (- b 1)))
     576             (test-assert (fl>=? b (- b 1)))
     577
     578             ;; Check min & max while we have ordered values:
     579             (test a (flmin a b))
     580             (test b (flmin b c))
     581             (test a (flmin a c))
     582             (test a (flmin b a c))
     583             (test b (flmax a b))
     584             (test c (flmax b c))
     585             (test c (flmax a c))
     586             (test c (flmax b c a)))))
     587      (test-ordered 1.0 2.0 3.0)
     588      (test-ordered -1.0 0.0 1.0)
     589      (test-ordered -1.0e5 0.0 1.0e-5))
     590
     591    (test-assert (flinteger? 4.0))
     592    (test-assert (not (flinteger? 4.1)))
     593    (test-assert (not (flzero? 4.1)))
     594    (test-assert (flzero? 0.0))
     595    (test-assert (not (flzero? -4.1)))
     596    (test-assert (flpositive? 4.1))
     597    (test-assert (not (flpositive? 0.0)))
     598    (test-assert (not (flpositive? -4.1)))
     599    (test-assert (not (flnegative? 4.1)))
     600    (test-assert (not (flnegative? 0.0)))
     601    (test-assert (flnegative? -4.1))
     602
     603    (test-assert (fleven? 2.0))
     604    (test-assert (fleven? -2.0))
     605    (test-assert (fleven? 0.0))
     606    (test-assert (fleven? -0.0))
     607    (test-assert (not (fleven? 3.0)))
     608    (test-assert (not (fleven? -3.0)))
     609
     610    (test-assert (flodd? 3.0))
     611    (test-assert (flodd? -3.0))
     612    (test-assert (not (flodd? 0.0)))
     613    (test-assert (not (flodd? -0.0)))
     614    (test-assert (not (flodd? 2.0)))
     615    (test-assert (not (flodd? -2.0)))
     616
     617    (test-assert (not (flnan? +inf.0)))
     618    (test-assert (not (flnan? 0.0)))
     619    (test-assert (not (flnan? -0.0)))
     620    (test-assert (not (flnan? -inf.0)))
     621    (test-assert (flnan? +nan.0))
     622
     623    (test 2.3 (fl+ 2.3))
     624    (test 5.4 (fl+ 2.3 3.1))
     625    (test 4.3 (fl+ 2.3 3.1 -1.1))
     626    (test 261 (fl+ 2.3e2 3.1e1))
     627
     628    (test 2.3 (fl* 2.3))
     629    (test 4.83 (fl* 2.3 2.1))
     630    (test 5.313 (fl* 2.3 2.1 1.1))
     631    (test -5.313 (fl* 2.3 2.1 -1.1))
     632
     633    (test -2.3 (fl- 0.0 2.3))
     634    (test -1.2 (fl- 0.0 2.3 -1.1))
     635    (test -2.3 (fl- 2.3))
     636    (test -0.0 (fl- 0.0))
     637
     638    (test 2.5 (fl/ 5.0 2.0))
     639    (test 1.0 (fl/ 5.0 2.0 2.5))
     640    (test 0.5 (fl/ 2.0))
     641    (test -0.5 (fl/ -2.0))
     642
     643    (test 0.0 (flabs 0.0))
     644    (test 1.0 (flabs 1.0))
     645    (test 1.0 (flabs -1.0))
     646    (test 0.1 (flabs -0.1))
     647
     648    (test 12.0 (fldiv 123.0 10.0))
     649    (test 3.0 (flmod 123.0 10.0))
     650    (test -12.0 (fldiv 123.0 -10.0))
     651    (test 3.0 (flmod 123.0 -10.0))
     652    (test -13.0 (fldiv -123.0 10.0))
     653    (test 7.0 (flmod -123.0 10.0))
     654    (test 13.0 (fldiv -123.0 -10.0))
     655    (test 7.0 (flmod -123.0 -10.0))
     656
     657    (test (values -13.0 7.0) (fldiv-and-mod -123.0 10.0))
     658
     659    (try-bad-divs fldiv)
     660    (try-bad-divs flmod)
     661    (try-bad-divs fldiv-and-mod)
     662
     663    (test 12.0 (fldiv0 123.0 10.0))
     664    (test 3.0 (flmod0 123.0 10.0))
     665    (test -12.0 (fldiv0 123.0 -10.0))
     666    (test 3.0 (flmod0 123.0 -10.0))
     667    (test -12.0 (fldiv0 -123.0 10.0))
     668    (test -3.0 (flmod0 -123.0 10.0))
     669    (test 12.0 (fldiv0 -123.0 -10.0))
     670    (test -3.0 (flmod0 -123.0 -10.0))
     671
     672    (test (values -12.0 -3.0) (fldiv0-and-mod0 -123.0 10.0))
     673
     674    (try-bad-divs fldiv0)
     675    (try-bad-divs flmod0)
     676    (try-bad-divs fldiv0-and-mod0)
     677
     678    (test 3.0 (flfloor 3.1))
     679    (test -4.0 (flfloor -3.1))
     680    (test 4.0 (flceiling 3.1))
     681    (test -3.0 (flceiling -3.1))
     682    (test 3.0 (fltruncate 3.1))
     683    (test -3.0 (fltruncate -3.1))
     684    (test 3.0 (flround 3.1))
     685    (test -3.0 (flround -3.1))
     686    (test 4.0 (flround 3.8))
     687    (test -4.0 (flround -3.8))
     688    (test 4.0 (flround 3.5))
     689    (test -4.0 (flround -3.5))
     690    (test 2.0 (flround 2.5))
     691    (test -2.0 (flround -2.5))
     692
     693    (test 7.389 (flexp 2.0))
     694    (test 2.0 (fllog 7.389))
     695    (test 10.0 (fllog 1024.0 2.0))
     696
     697    (test 0.0 (flsin 0.0))
     698    (test 1.0 (flsin 1.570796))
     699    (test 0.0 (flcos 1.570796))
     700    (test 1.0 (flcos 0.0))
     701    (test 0.0 (flatan 0.0 1.0))
     702    (test (* 1.570796 2.0) (flatan 0.0 -1.0))
     703    (test 1.570796 (flatan 1.0 0.0))
     704    (test -1.570796 (flatan -1.0 0.0))
     705    (test (/ 1.570796 2.0) (flatan 1.0 1.0))
     706    (test (/ -1.570796 2.0) (flatan -1.0 1.0))
     707    (test 0.0 (flatan 0.0))
     708    (test (/ 1.570796 2.0) (flatan 1.0))
     709    (test 1.47113 (flatan 10.0))
     710    (test 0.0996687 (flatan 0.1))
     711
     712    (test 2.0 (flsqrt 4.0))
     713    (test 2.23607 (flsqrt 5.0))
     714
     715    (test 8.0 (flexpt 2.0 3.0))
     716    (test 1000.0 (flexpt 10.0 3.0))
     717
     718    #;(test (no-infinities-violation? (make-no-infinities-violation)) #t)
     719    #;(test ((record-predicate (record-type-descriptor &no-infinities)) (make-no-infinities-violation)) #t)
     720    #;(test (no-nans-violation? (make-no-nans-violation)) #t)
     721    #;(test ((record-predicate (record-type-descriptor &no-nans)) (make-no-nans-violation)) #t)
     722
     723    (test 2.0 (fixnum->flonum 2))
     724  )
    433725)
    434726
    435 (test-group "Bitwise Functions"
    436 
    437   (test #b011 (bitwise-if #b100 #b000 #b111))
    438   (test #b100 (bitwise-if #b011 #b000 #b100))
    439 
    440   (test #b100 (bitwise-if-not #b100 #b000 #b111))
    441   (test #b000 (bitwise-if-not #b011 #b000 #b100))
    442   (test #b110 (bitwise-if-not #b011 #b101 #b010))
    443 
    444   (test #t (bitwise-test? #b0010 #b0111))
    445   (test #f (bitwise-test? #b0001 #b0100))
    446         (test #f (bitwise-test? #b0100 #b1011))
    447         (test #t (bitwise-test? #b0100 #b0111))
    448 
    449         (test 4 (bitwise-bit-count #b10101010))
    450         (test 0 (bitwise-bit-count 0))
    451         (test 1 (bitwise-bit-count -2))
    452 
    453         (test 8 (bitwise-length #b10101010))
    454         (test 0 (bitwise-length 0))
    455         (test 4 (bitwise-length #b1111))
    456         (test 5 (bitwise-length -27))
    457 
    458         (test #t (bitwise-bit-set? #b1101 0))
    459         (test #f (bitwise-bit-set? #b1101 1))
    460         (test #t (bitwise-bit-set? #b1101 2))
    461         (test #t (bitwise-bit-set? #b1101 3))
    462         (test #f (bitwise-bit-set? #b1101 4))
    463 
    464   (test 0 (bitwise-last-bit-set 0))
    465   (test 8 (bitwise-last-bit-set #b10111100))
    466   (test machine-word-bits (bitwise-last-bit-set -1))
    467 
    468         (test -1 (bitwise-first-bit-set 0))
    469         (test 0 (bitwise-first-bit-set -1))
    470         (test 0 (bitwise-first-bit-set 1))
    471         (test 1 (bitwise-first-bit-set -2))
    472         (test 1 (bitwise-first-bit-set 2))
    473         (test 0 (bitwise-first-bit-set -3))
    474         (test 0 (bitwise-first-bit-set 3))
    475         (test 2 (bitwise-first-bit-set -4))
    476         (test 2 (bitwise-first-bit-set 4))
    477         (test 0 (bitwise-first-bit-set -5))
    478         (test 0 (bitwise-first-bit-set 5))
    479         (test 1 (bitwise-first-bit-set -6))
    480         (test 1 (bitwise-first-bit-set 6))
    481         (test 0 (bitwise-first-bit-set -7))
    482         (test 0 (bitwise-first-bit-set 7))
    483         (test 3 (bitwise-first-bit-set -8))
    484         (test 3 (bitwise-first-bit-set 8))
    485         (test 0 (bitwise-first-bit-set -9))
    486         (test 0 (bitwise-first-bit-set 9))
    487         (test 1 (bitwise-first-bit-set -10))
    488         (test 1 (bitwise-first-bit-set 10))
    489         (test 0 (bitwise-first-bit-set -11))
    490         (test 0 (bitwise-first-bit-set 11))
    491         (test 2 (bitwise-first-bit-set -12))
    492         (test 2 (bitwise-first-bit-set 12))
    493         (test 0 (bitwise-first-bit-set -13))
    494         (test 0 (bitwise-first-bit-set 13))
    495         (test 1 (bitwise-first-bit-set -14))
    496         (test 1 (bitwise-first-bit-set 14))
    497         (test 0 (bitwise-first-bit-set -15))
    498         (test 0 (bitwise-first-bit-set 15))
    499         (test 4 (bitwise-first-bit-set -16))
    500         (test 4 (bitwise-first-bit-set 16))
    501 
    502         (test #b1 (bitwise-copy-bit 0 0 1))
    503         (test #b100 (bitwise-copy-bit 0 2 1))
    504         (test #b1011 (bitwise-copy-bit #b1111 2 0))
    505 
    506         (test #b1 (bitwise-copy-bit 0 0 #t))
    507         (test #b100 (bitwise-copy-bit 0 2 #t))
    508         (test #b1011 (bitwise-copy-bit #b1111 2 #f))
    509 
    510         (test #b1010 (bitwise-bit-field #b1101101010 0 4))
    511         (test #b10110 (bitwise-bit-field #b1101101010 4 9))
    512 
    513         (test #b1101100000 (bitwise-copy-bit-field #b1101101010 0 4 0))
    514         (test #b1101101111 (bitwise-copy-bit-field #b1101101010 0 4 -1))
    515         (test #b110100111110000 (bitwise-copy-bit-field #b110100100010000 5 9 -1))
    516 
    517         (test #b10 (bitwise-rotate-bit-field #b0100 0 4 3) )
    518         (test #b10 (bitwise-rotate-bit-field #b0100 0 4 -1))
    519         ;                    9   5
    520         (test #b110100010010000 (bitwise-rotate-bit-field #b110100100010000 5 9 -1))
    521         (test #b110100000110000 (bitwise-rotate-bit-field #b110100100010000 5 9 1) )
    522 
    523         (test #b11100101 (bitwise-reverse-bit-field #b10100111 0 8))
    524         (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4))
    525 
    526         (test 0 (bitwise-list->integer '()))
    527         (test #b101 (bitwise-list->integer '(#t #f #t)))
    528 
    529         (test '() (bitwise-integer->list #b0 0))
    530         (test (make-list machine-word-bits #f) (bitwise-integer->list #b0))
    531         (test '(#t #f #t) (bitwise-integer->list #b101))
    532         (test '(#t #t #f #t) (bitwise-integer->list #b11101 4))
     727;;
     728
     729(define (run-arithmetic-bitwise-tests)
     730
     731  ;; Helpers originally from Ikarus test suite:
     732  (define (ref ei)
     733    (do ((result 0 (+ result 1))
     734         (bits (if (negative? ei) (bitwise-not ei) ei) (bitwise-arithmetic-shift bits -1)))
     735        ((zero? bits) result)))
     736
     737  (define-syntax len-test
     738    (syntax-rules ()
     739      ((_ n) (test (bitwise-length n) (ref n)))))
     740
     741  (define (pos-count-bits n)
     742    (if (zero? n)
     743        0
     744        (let ((c (count-bits (bitwise-arithmetic-shift-right n 1))))
     745          (if (even? n) c (+ c 1)))))
     746
     747  (define (count-bits n)
     748    (if (>= n 0) (pos-count-bits n)
     749        (bitwise-not (pos-count-bits (bitwise-not n)))))
     750
     751  (define-syntax count-test
     752    (syntax-rules ()
     753      ((_ n) (test (count-bits n) (bitwise-bit-count n)))))
     754
     755  (test-group "Bitwise Functions"
     756
     757    (test #b011 (bitwise-if #b100 #b000 #b111))
     758    (test #b100 (bitwise-if #b011 #b000 #b100))
     759
     760    (test #b100 (bitwise-if-not #b100 #b000 #b111))
     761    (test #b000 (bitwise-if-not #b011 #b000 #b100))
     762    (test #b110 (bitwise-if-not #b011 #b101 #b010))
     763
     764    (test-assert (bitwise-test? #b0010 #b0111))
     765    (test-assert (not (bitwise-test? #b0001 #b0100)))
     766    (test-assert (not (bitwise-test? #b0100 #b1011)))
     767    (test-assert (bitwise-test? #b0100 #b0111))
     768
     769    (test 4 (bitwise-bit-count #b10101010))
     770    (test 0 (bitwise-bit-count 0))
     771    (test 1 (bitwise-bit-count -2))
     772
     773    (test 8 (bitwise-length #b10101010))
     774    (test 0 (bitwise-length 0))
     775    (test 4 (bitwise-length #b1111))
     776    (test 5 (bitwise-length -27))
     777
     778    (test-assert (bitwise-bit-set? #b1101 0))
     779    (test-assert (not (bitwise-bit-set? #b1101 1)))
     780    (test-assert (bitwise-bit-set? #b1101 2))
     781    (test-assert (bitwise-bit-set? #b1101 3))
     782    (test-assert (not (bitwise-bit-set? #b1101 4)))
     783
     784    (test 0 (bitwise-last-bit-set 0))
     785    (test 8 (bitwise-last-bit-set #b10111100))
     786    (test machine-word-bits (bitwise-last-bit-set -1))
     787
     788    (test -1 (bitwise-first-bit-set 0))
     789    (test 0 (bitwise-first-bit-set -1))
     790    (test 0 (bitwise-first-bit-set 1))
     791    (test 1 (bitwise-first-bit-set -2))
     792    (test 1 (bitwise-first-bit-set 2))
     793    (test 0 (bitwise-first-bit-set -3))
     794    (test 0 (bitwise-first-bit-set 3))
     795    (test 2 (bitwise-first-bit-set -4))
     796    (test 2 (bitwise-first-bit-set 4))
     797    (test 0 (bitwise-first-bit-set -5))
     798    (test 0 (bitwise-first-bit-set 5))
     799    (test 1 (bitwise-first-bit-set -6))
     800    (test 1 (bitwise-first-bit-set 6))
     801    (test 0 (bitwise-first-bit-set -7))
     802    (test 0 (bitwise-first-bit-set 7))
     803    (test 3 (bitwise-first-bit-set -8))
     804    (test 3 (bitwise-first-bit-set 8))
     805    (test 0 (bitwise-first-bit-set -9))
     806    (test 0 (bitwise-first-bit-set 9))
     807    (test 1 (bitwise-first-bit-set -10))
     808    (test 1 (bitwise-first-bit-set 10))
     809    (test 0 (bitwise-first-bit-set -11))
     810    (test 0 (bitwise-first-bit-set 11))
     811    (test 2 (bitwise-first-bit-set -12))
     812    (test 2 (bitwise-first-bit-set 12))
     813    (test 0 (bitwise-first-bit-set -13))
     814    (test 0 (bitwise-first-bit-set 13))
     815    (test 1 (bitwise-first-bit-set -14))
     816    (test 1 (bitwise-first-bit-set 14))
     817    (test 0 (bitwise-first-bit-set -15))
     818    (test 0 (bitwise-first-bit-set 15))
     819    (test 4 (bitwise-first-bit-set -16))
     820    (test 4 (bitwise-first-bit-set 16))
     821
     822    (test #b1 (bitwise-copy-bit 0 0 1))
     823    (test #b100 (bitwise-copy-bit 0 2 1))
     824    (test #b1011 (bitwise-copy-bit #b1111 2 0))
     825
     826    (test #b1 (bitwise-copy-bit 0 0 #t))
     827    (test #b100 (bitwise-copy-bit 0 2 #t))
     828    (test #b1011 (bitwise-copy-bit #b1111 2 #f))
     829
     830    (test #b1010 (bitwise-bit-field #b1101101010 0 4))
     831    (test #b10110 (bitwise-bit-field #b1101101010 4 9))
     832
     833    (test #b1101100000 (bitwise-copy-bit-field #b1101101010 0 4 0))
     834    (test #b1101101111 (bitwise-copy-bit-field #b1101101010 0 4 -1))
     835    (test #b110100111110000 (bitwise-copy-bit-field #b110100100010000 5 9 -1))
     836
     837    (test #b10 (bitwise-rotate-bit-field #b0100 0 4 3) )
     838    (test #b10 (bitwise-rotate-bit-field #b0100 0 4 -1))
     839    ;                    9   5
     840    (test #b110100010010000 (bitwise-rotate-bit-field #b110100100010000 5 9 -1))
     841    (test #b110100000110000 (bitwise-rotate-bit-field #b110100100010000 5 9 1) )
     842
     843    (test #b11100101 (bitwise-reverse-bit-field #b10100111 0 8))
     844    (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4))
     845
     846    (test 0 (bitwise-list->integer '()))
     847    (test #b101 (bitwise-list->integer '(#t #f #t)))
     848
     849    (test '() (bitwise-integer->list #b0 0))
     850    (test (make-list machine-word-bits #f) (bitwise-integer->list #b0))
     851    (test '(#t #f #t) (bitwise-integer->list #b101))
     852    (test '(#t #t #f #t) (bitwise-integer->list #b11101 4))
     853  )
     854
     855  (test-group "R6RS Bitwise Test Suite"
     856
     857    (test -1 (bitwise-first-bit-set 0))
     858    (test 0 (bitwise-first-bit-set 1))
     859    (test 2 (bitwise-first-bit-set -4))
     860
     861    (test -3 (bitwise-arithmetic-shift -6 -1))
     862    (test -3 (bitwise-arithmetic-shift -5 -1))
     863    (test -2 (bitwise-arithmetic-shift -4 -1))
     864    (test -2 (bitwise-arithmetic-shift -3 -1))
     865    (test -1 (bitwise-arithmetic-shift -2 -1))
     866    (test -1 (bitwise-arithmetic-shift -1 -1))
     867
     868    (test 88 (bitwise-reverse-bit-field #b1010010 1 4)) ; #b1011000
     869
     870    ;; Originally from Ikarus test suite:
     871    (len-test #xF)
     872    (len-test #xFF)
     873    (len-test #xFFF)
     874    (len-test #xFFFF)
     875    (len-test #xFFFFF)
     876    (len-test #xFFFFFF)
     877    (len-test #xFFFFFFF)
     878    (len-test #xFFFFFFFF)
     879    (len-test #xFFFFFFFFF)
     880    (len-test #xFFFFFFFFFF)
     881    (len-test #xFFFFFFFFFFF)
     882    (len-test #xFFFFFFFFFFFF)
     883    (len-test #xFFFFFFFFFFFFF)
     884    (len-test #xFFFFFFFFFFFFFF)
     885    (len-test #xFFFFFFFFFFFFFFF)
     886    (len-test #xFFFFFFFFFFFFFFFF)
     887    (len-test #x-F)
     888    (len-test #x-FF)
     889    (len-test #x-FFF)
     890    (len-test #x-FFFF)
     891    (len-test #x-FFFFF)
     892    (len-test #x-FFFFFF)
     893    (len-test #x-FFFFFFF)
     894    (len-test #x-FFFFFFFF)
     895    (len-test #x-FFFFFFFFF)
     896    (len-test #x-FFFFFFFFFF)
     897    (len-test #x-FFFFFFFFFFF)
     898    (len-test #x-FFFFFFFFFFFF)
     899    (len-test #x-FFFFFFFFFFFFF)
     900    (len-test #x-FFFFFFFFFFFFFF)
     901    (len-test #x-FFFFFFFFFFFFFFF)
     902    (len-test #x-FFFFFFFFFFFFFFFF)
     903
     904    (len-test #xE)
     905    (len-test #xFE)
     906    (len-test #xFFE)
     907    (len-test #xFFFE)
     908    (len-test #xFFFFE)
     909    (len-test #xFFFFFE)
     910    (len-test #xFFFFFFE)
     911    (len-test #xFFFFFFFE)
     912    (len-test #xFFFFFFFFE)
     913    (len-test #xFFFFFFFFFE)
     914    (len-test #xFFFFFFFFFFE)
     915    (len-test #xFFFFFFFFFFFE)
     916    (len-test #xFFFFFFFFFFFFE)
     917    (len-test #xFFFFFFFFFFFFFE)
     918    (len-test #xFFFFFFFFFFFFFFE)
     919    (len-test #xFFFFFFFFFFFFFFFE)
     920    (len-test #x-E)
     921    (len-test #x-FE)
     922    (len-test #x-FFE)
     923    (len-test #x-FFFE)
     924    (len-test #x-FFFFE)
     925    (len-test #x-FFFFFE)
     926    (len-test #x-FFFFFFE)
     927    (len-test #x-FFFFFFFE)
     928    (len-test #x-FFFFFFFFE)
     929    (len-test #x-FFFFFFFFFE)
     930    (len-test #x-FFFFFFFFFFE)
     931    (len-test #x-FFFFFFFFFFFE)
     932    (len-test #x-FFFFFFFFFFFFE)
     933    (len-test #x-FFFFFFFFFFFFFE)
     934    (len-test #x-FFFFFFFFFFFFFFE)
     935    (len-test #x-FFFFFFFFFFFFFFFE)
     936
     937    (len-test #x1)
     938    (len-test #x1F)
     939    (len-test #x1FF)
     940    (len-test #x1FFF)
     941    (len-test #x1FFFF)
     942    (len-test #x1FFFFF)
     943    (len-test #x1FFFFFF)
     944    (len-test #x1FFFFFFF)
     945    (len-test #x1FFFFFFFF)
     946    (len-test #x1FFFFFFFFF)
     947    (len-test #x1FFFFFFFFFF)
     948    (len-test #x1FFFFFFFFFFF)
     949    (len-test #x1FFFFFFFFFFFF)
     950    (len-test #x1FFFFFFFFFFFFF)
     951    (len-test #x1FFFFFFFFFFFFFF)
     952    (len-test #x1FFFFFFFFFFFFFFF)
     953    (len-test #x-1)
     954    (len-test #x-1F)
     955    (len-test #x-1FF)
     956    (len-test #x-1FFF)
     957    (len-test #x-1FFFF)
     958    (len-test #x-1FFFFF)
     959    (len-test #x-1FFFFFF)
     960    (len-test #x-1FFFFFFF)
     961    (len-test #x-1FFFFFFFF)
     962    (len-test #x-1FFFFFFFFF)
     963    (len-test #x-1FFFFFFFFFF)
     964    (len-test #x-1FFFFFFFFFFF)
     965    (len-test #x-1FFFFFFFFFFFF)
     966    (len-test #x-1FFFFFFFFFFFFF)
     967    (len-test #x-1FFFFFFFFFFFFFF)
     968    (len-test #x-1FFFFFFFFFFFFFFF)
     969
     970    (len-test #x1)
     971    (len-test #x10)
     972    (len-test #x100)
     973    (len-test #x1000)
     974    (len-test #x10000)
     975    (len-test #x100000)
     976    (len-test #x1000000)
     977    (len-test #x10000000)
     978    (len-test #x100000000)
     979    (len-test #x1000000000)
     980    (len-test #x10000000000)
     981    (len-test #x100000000000)
     982    (len-test #x1000000000000)
     983    (len-test #x10000000000000)
     984    (len-test #x100000000000000)
     985    (len-test #x1000000000000000)
     986    (len-test #x-1)
     987    (len-test #x-10)
     988    (len-test #x-100)
     989    (len-test #x-1000)
     990    (len-test #x-10000)
     991    (len-test #x-100000)
     992    (len-test #x-1000000)
     993    (len-test #x-10000000)
     994    (len-test #x-100000000)
     995    (len-test #x-1000000000)
     996    (len-test #x-10000000000)
     997    (len-test #x-100000000000)
     998    (len-test #x-1000000000000)
     999    (len-test #x-10000000000000)
     1000    (len-test #x-100000000000000)
     1001    (len-test #x-1000000000000000)
     1002
     1003    (len-test #x1)
     1004    (len-test #x11)
     1005    (len-test #x101)
     1006    (len-test #x1001)
     1007    (len-test #x10001)
     1008    (len-test #x100001)
     1009    (len-test #x1000001)
     1010    (len-test #x10000001)
     1011    (len-test #x100000001)
     1012    (len-test #x1000000001)
     1013    (len-test #x10000000001)
     1014    (len-test #x100000000001)
     1015    (len-test #x1000000000001)
     1016    (len-test #x10000000000001)
     1017    (len-test #x100000000000001)
     1018    (len-test #x1000000000000001)
     1019    (len-test #x-1)
     1020    (len-test #x-11)
     1021    (len-test #x-101)
     1022    (len-test #x-1001)
     1023    (len-test #x-10001)
     1024    (len-test #x-100001)
     1025    (len-test #x-1000001)
     1026    (len-test #x-10000001)
     1027    (len-test #x-100000001)
     1028    (len-test #x-1000000001)
     1029    (len-test #x-10000000001)
     1030    (len-test #x-100000000001)
     1031    (len-test #x-1000000000001)
     1032    (len-test #x-10000000000001)
     1033    (len-test #x-100000000000001)
     1034    (len-test #x-1000000000000001)
     1035
     1036    (len-test (greatest-fixnum))
     1037    (len-test (least-fixnum))
     1038
     1039    (count-test 1)
     1040    (count-test 28472347823493290482390849023840928390482309480923840923840983)
     1041    (count-test -847234234903290482390849023840928390482309480923840923840983)
     1042    (count-test (greatest-fixnum))
     1043    (count-test (least-fixnum))
     1044
     1045    (test -13 (bitwise-not 12))
     1046    (test 11 (bitwise-not -12))
     1047    (test 0 (bitwise-not -1))
     1048    (test -1 (bitwise-not 0))
     1049    (test (least-fixnum) (bitwise-not (greatest-fixnum)))
     1050    (test (greatest-fixnum) (bitwise-not (least-fixnum)))
     1051
     1052    (test -38947389478348937489375 (bitwise-not 38947389478348937489374))
     1053    (test -22300745198530623141535718272648361505980416 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1054    (test 38947389478348937489374 (bitwise-not -38947389478348937489375))
     1055    (test 22300745198530623141535718272648361505980414 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1056    (test -340282366920938463463374607431768211456 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1057    (test 340282366920938463463374607431768211454 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1058    (test -79228162514264337593543950337 (bitwise-not #x1000000000000000000000000))
     1059    (test 79228162514264337593543950335 (bitwise-not #x-1000000000000000000000000))
     1060
     1061    ;; ----------------------------------------
     1062
     1063    (test 0 (bitwise-and (expt 2 100) 17))
     1064    (test 17 (bitwise-and (- (expt 2 100) 1) 17))
     1065    (test (expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
     1066
     1067    (test (bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
     1068    (test (- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
     1069    (test (- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
     1070
     1071    (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
     1072    (test 1 (bitwise-if (expt 2 100) 1 1) )
     1073    (test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
     1074
     1075    (test 1 (bitwise-bit-count (expt 2 300)))
     1076    (test 300 (bitwise-bit-count (- (expt 2 300) 1)))
     1077    (test -301 (bitwise-bit-count (- (expt 2 300))))
     1078
     1079    (test 301 (bitwise-length (expt 2 300)))
     1080    (test 300 (bitwise-length (- (expt 2 300) 1)))
     1081    (test 300 (bitwise-length (- (expt 2 300))))
     1082
     1083    (test 300 (bitwise-first-bit-set (expt 2 300)))
     1084    (test 0 (bitwise-first-bit-set (- (expt 2 300) 1)))
     1085
     1086    (test-assert (bitwise-bit-set? (expt 2 300) 300))
     1087    (test-assert (not (bitwise-bit-set? (expt 2 300) 0)))
     1088    (test-assert (not (bitwise-bit-set? (- (expt 2 300) 1) 300)))
     1089    (test-assert (bitwise-bit-set? (- (expt 2 300) 1) 299))
     1090    (test-assert (bitwise-bit-set? (- (expt 2 300) 1) 298))
     1091    (test-assert (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
     1092    (test-assert (bitwise-bit-set? -1 300))
     1093    (test-assert (bitwise-bit-set? -1 0))
     1094    (test-assert (not (bitwise-bit-set? -2 0)))
     1095
     1096    (test 0 (bitwise-copy-bit-field (expt 2 300) 300 302 0))
     1097    (test (expt 2 300) (bitwise-copy-bit-field (expt 2 300) 300 302 1))
     1098    (test (expt 2 301) (bitwise-copy-bit-field (expt 2 300) 300 302 2))
     1099    (test (bitwise-copy-bit-field (expt 2 300) 300 302 3) (+ (expt 2 300) (expt 2 301)))
     1100
     1101    (test (expt 2 301) (bitwise-arithmetic-shift (expt 2 300) 1))
     1102    (test (expt 2 299) (bitwise-arithmetic-shift (expt 2 300) -1))
     1103    (test (expt 2 600) (bitwise-arithmetic-shift (expt 2 300) 300))
     1104    (test 1 (bitwise-arithmetic-shift (expt 2 300) -300))
     1105
     1106    (test (expt 2 301) (bitwise-arithmetic-shift-left (expt 2 300) 1))
     1107    (test (expt 2 299) (bitwise-arithmetic-shift-right (expt 2 300) 1))
     1108    (test (expt 2 600) (bitwise-arithmetic-shift-left (expt 2 300) 300))
     1109    (test 1 (bitwise-arithmetic-shift-right (expt 2 300) 300))
     1110
     1111    (test (expt 2 302) (bitwise-rotate-bit-field (expt 2 300) 299 304 2))
     1112    (test (expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
     1113
     1114    (test (expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
     1115  )
    5331116)
     1117
     1118;;;
     1119
     1120(run-arithmetic-fixnums-tests)
     1121(run-arithmetic-flonums-tests)
     1122(run-arithmetic-bitwise-tests)
Note: See TracChangeset for help on using the changeset viewer.