Changeset 13807 in project


Ignore:
Timestamp:
03/18/09 04:31:12 (11 years ago)
Author:
Kon Lovett
Message:

Updated prims, added R6RS fixnum test, added num & den impl via fp gcd, added shortcuts for shift..

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

Legend:

Unmodified
Added
Removed
  • release/4/err5rs-arithmetic/tags/1.0.0/chicken-primitive-object-inlines.scm

    r13775 r13807  
    742742(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
    743743(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
    744 (define-inline (%port-data-set! port port) (%wordblock-set!/mutate port 9 x))
     744(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))
    745745
    746746(define-inline (%make-port i/o class name type)
     
    903903(define-inline (%pointer->address ptr)
    904904  ; Pack pointer address value into Chicken words; '4' is platform dependent!
    905   (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
     905  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )
    906906
    907907;; Simple-pointer (wordblock)
     
    975975(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
    976976(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
    977 (define-inline (%cardinal? n) (and (%integer? x) (%<= 0 n)))
     977(define-inline (%cardinal? n) (and (%integer? n) (%<= 0 n)))
    978978(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
    979979(define-inline (%even? n) (##core#inline "C_i_evenp" n))
  • release/4/err5rs-arithmetic/trunk/chicken-primitive-object-inlines.scm

    r13775 r13807  
    742742(define-inline (%port-type-set! port s) (%wordblock-set!/mutate port 7 s))
    743743(define-inline (%port-closed-set! port f) (%wordblock-set!/immediate port 8 f))
    744 (define-inline (%port-data-set! port port) (%wordblock-set!/mutate port 9 x))
     744(define-inline (%port-data-set! port x) (%wordblock-set!/mutate port 9 x))
    745745
    746746(define-inline (%make-port i/o class name type)
     
    903903(define-inline (%pointer->address ptr)
    904904  ; Pack pointer address value into Chicken words; '4' is platform dependent!
    905   (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref x)) )
     905  (##core#inline_allocate ("C_block_address" 4) (%generic-pointer-ref ptr)) )
    906906
    907907;; Simple-pointer (wordblock)
     
    975975(define-inline (%positive? n) (##core#inline "C_i_positivep" n))
    976976(define-inline (%negative? n) (##core#inline "C_i_negativep" n))
    977 (define-inline (%cardinal? n) (and (%integer? x) (%<= 0 n)))
     977(define-inline (%cardinal? n) (and (%integer? n) (%<= 0 n)))
    978978(define-inline (%odd? n) (##core#inline "C_i_oddp" n))
    979979(define-inline (%even? n) (##core#inline "C_i_evenp" n))
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r13794 r13807  
    142142
    143143;invariant - (fixnum? (floor (* fx (expt 2 amt))))
    144 ; shl: msb + amt <= fixnum-precision
    145 ; shr: msb - amt >= 0
     144; shl: msb + amt < fixnum-precision
     145; shr: msb - amt > 0
     146;
     147; We know that amt is-a fixnum in [0 fixnum-precision] by now
    146148
    147149(define-inline (%fxshl/check loc fx amt)
    148   (if (<= (%fx+ (*bitwise-last-bit-set fx) amt) fixnum-precision) (%fxshl fx amt)
    149       (error-fixnum-representation loc fx amt) ) )
     150  (let ((bits (%fx+ (*bitwise-last-bit-set fx) amt)))
     151    (cond ((%fx= bits fixnum-precision) 0.0)
     152          ((%fx< bits fixnum-precision) (%fxshl fx amt))
     153          (else
     154           (error-fixnum-representation loc fx amt) ) ) ) )
    150155 
    151156(define-inline (%fxshr/check loc fx amt)
    152   (if (>= (%fx- (*bitwise-last-bit-set fx) amt) 0) (%fxshr fx amt)
    153       (error-fixnum-representation loc fx amt) ) )
     157  (let ((bits (%fx- (*bitwise-last-bit-set fx) amt)))
     158    (cond ((%fxzero? bits) fx)
     159          ((%fxpositive? bits) (%fxshr fx amt))
     160          (else
     161           (error-fixnum-representation loc fx amt) ) ) ) )
    154162
    155163;;;
     
    199207  $fxmax $fxmin
    200208  $fxand $fxior $fxxor
     209  $fxneg
    201210  $fx+ $fx- $fx* $fx/)
    202211
     
    229238
    230239(define (make-shift-amount-condition loc amt)
    231   (make-arithmetic-condition loc "invalid shift amount" amt) )
     240  (make-arithmetic-condition loc "invalid shift amount" (list amt)) )
    232241
    233242(define (make-zero-division-condition loc fx1 fx2)
     
    259268
    260269(define (error-type-shift-amount loc obj)
    261   (abort (make-shift-amount-condition loc args)) )
     270  (abort (make-shift-amount-condition loc obj)) )
    262271
    263272(define (error-zero-division loc fx1 fx2)
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13794 r13807  
    55;;
    66;; - No support for the full-numeric-tower. All operations upon core numerics.
    7 ;;
    8 ;; - `flnumerator' & `fldenominator` are unimplemented.
    97
    108;;; Prelude
     
    2624(include "chicken-primitive-object-inlines")
    2725
     26#>
     27<#
     28
    2829;;
    2930
     
    6263
    6364;;
     65
     66(define-inline (%fpzero? fp) (or #;(%fp= -0.0 fp) (%fp= 0.0 fp)))
    6467
    6568(define-inline (%fpdiv fpn fpd) (%fptruncate (%fp/ fpn fpd)))
     
    139142  flnumerator fldenominator
    140143  ; Extras
     144  flgcd
     145  flonum->fraction
    141146  fl<>?
    142147  flcompare
     
    148153  *fl- *fl+ *fl* *fl/
    149154  ; Macro helpers
    150   $fp= $fp< $fp> $fp>= $fp<= $fp<>?
     155  $fp=? $fp<? $fp>? $fp>=? $fp<=? $fp<>?
    151156  $fpmax $fpmin
    152157  $fp+ $fp- $fp* $fp/)
     
    183188(define ($fp/ x y) (%fp/ x y))
    184189
     190;;;
     191
     192(define maximum-integer-flonum (%fpfloor maximum-flonum) #;1.0e14)
     193(define small-epsilon flonum-epsilon                     #;5.0e-15)
     194(define large-epsilon (%fp* small-epsilon 10.0))
     195#;(define digits-limit 1.0e12)
     196
     197(define (*fpgcd fp1 fp2 #!optional (cnvrg-limit 50))
     198  (let ((fp1 (%fpabs fp1))
     199        (fp2 (%fpabs fp2)) )
     200    (let* ((dividend (%fpmax fp1 fp2))
     201           (divisor (%fpmin fp1 fp2))
     202           (dividend-epsilon (%fp* dividend large-epsilon))
     203           (divisor-epsilon (%fp* dividend-epsilon 100.0)) )
     204           ; Too small?
     205     (cond ((or (%fp<= divisor dividend-epsilon) (%fp<= maximum-integer-flonum dividend))
     206            0.0 )
     207           (else
     208            (let loop ((cnvrg 1) (dividend dividend) (divisor divisor))
     209              (let ((remainder (%fpabs (%fpmod dividend divisor))))
     210                      ; Not converging?
     211                (cond ((%fx= cnvrg cnvrg-limit)
     212                       0.0 )
     213                      ; Converged, maybe?
     214                      ((or (%fp<= remainder dividend-epsilon)
     215                           (%fp<= (%fpabs (%fp- divisor remainder)) dividend-epsilon))
     216                           ; No it hasn't
     217                       (if (and (not (%fpzero? remainder))
     218                                (%fp<= divisor divisor-epsilon)) 0.0
     219                           divisor ) )
     220                      ; Narrow
     221                      (else
     222                       (loop (%fxadd1 cnvrg) divisor remainder) ) ) ) ) ) ) ) ) )
     223
     224(define (*fp->fraction fp)
     225  (let ((numerator-epsilon (%fp* (%fpabs fp) small-epsilon))
     226        (numerator (%fpround fp)) )
     227        ; Close to an integer?
     228    (if (and (not (%fpzero? numerator))
     229             (%fp<= (%fpabs (%fp- numerator fp)) numerator-epsilon)) (values numerator 1.0)
     230        (let* ((divisor (*fpgcd fp 1.0))
     231               (numerator (%fpround (%fp/ fp divisor)))
     232               (denominator (%fpround (%fp/ 1.0 divisor))) )
     233                ; Too many digits?
     234          (cond #; ;No clipping
     235                ((or (%fp<= digits-limit (%fpabs numerator))
     236                     (%fp<= digits-limit (%fpabs denominator)))
     237                 (values +nan +nan) )
     238                ; Absurd denominator?
     239                #; ;Ignore
     240                ((%fp< denominator 2.0)
     241                 (values +nan +nan) )
     242                (else
     243                 (let ((divisor (*fpgcd numerator denominator)))
     244                       ; Fully reduced?
     245                   (if (%fp< 1.0 divisor)
     246                       ; Whaaat!
     247                       (values (%fp/ numerator divisor) (%fp/ denominator divisor))
     248                       ; Yes!
     249                       (values numerator denominator)
     250                       #; ;Ignore
     251                       (let* ((check (%fp/ numerator denominator))
     252                              (check-epsilon (%fp* (%fpabs check) small-epsilon)))
     253                             ; Inaccurate?
     254                         (if (%< check-epsilon (%fpabs (%fp- check fp))) (values +nan +nan)
     255                             ; Accurate!
     256                             (values numerator denominator) ) ) ) ) ) ) ) ) ) )
     257
    185258;;; ERR5RS
    186259
     
    226299(define (flzero? fp)
    227300  (%check-flonum 'flzero? fp)
    228         (or #;(%fp=? -0.0 fp) (%fp=? 0.0 fp)) )
     301        (%fpzero? fp) )
    229302
    230303(define (flpositive? fp)
     
    383456(define (flnumerator fp)
    384457  (%check-flonum 'flnumerator fp)
    385   (cond ((or (%integer? fp) #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)) (%fpnan? fp))
     458  (cond ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)) (%fpnan? fp))
    386459         fp )
    387        (else
    388           ) ) )
     460        (else
     461         (receive (n d) (*fp->fraction fp) n) ) ) )
    389462
    390463(define (fldenominator fp)
     
    392465  (cond ((%fpnan? fp)
    393466         +nan )
    394         ((or (%integer? fp) #;(%fp=? -0.0 fp) (%fp=? 0.0 fp) (not (%finite? fp)))
     467        ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)))
    395468         1.0 )
    396469        (else
    397           ) ) )
     470         (receive (n d) (*fp->fraction fp) d) ) ) )
    398471
    399472;;; Extras
     473
     474(define (flgcd fp1 fp2)
     475  (%check-flonum 'flgcd fp1)
     476  (%check-flonum 'flgcd fp2)
     477  (cond ((or (not (%finite? fp1)) (not (%finite? fp2)))
     478         0.0 )
     479        ((%fpzero? fp1)
     480         fp2 )
     481        ((%fpzero? fp2)
     482         fp1 )
     483        (else
     484         (*fpgcd fp1 fp2) ) ) )
     485
     486(define (flonum->fraction fp)
     487  (%check-flonum 'flonum->fraction fp)
     488  (cond ((%fpnan? fp)
     489         (values +nan +nan) )
     490        ((or (%integer? fp) (%fpzero? fp) (not (%finite? fp)))
     491         (values fp 1.0) )
     492        (else
     493         (*fp->fraction fp) ) ) )
    400494
    401495(define (fl<>? fp . fps) (%fpand-fold 'fl<>? $fp<>? fp fps))
     
    431525      #t )
    432526    ((_ ?x ?y)
    433       ($fp= ?x ?y) )
    434     ((_ ?x ?y ?rest ...)
    435       (and ($fp= ?x ?y) (*fl=? ?y ?rest ...)) ) ) )
     527      ($fp=? ?x ?y) )
     528    ((_ ?x ?y ?rest ...)
     529      (and ($fp=? ?x ?y) (*fl=? ?y ?rest ...)) ) ) )
    436530
    437531(define-syntax *fl<?
     
    440534      #t )
    441535    ((_ ?x ?y)
    442       ($fp< ?x ?y) )
    443     ((_ ?x ?y ?rest ...)
    444       (and ($fp< ?x ?y) (*fl<? ?y ?rest ...)) ) ) )
     536      ($fp<? ?x ?y) )
     537    ((_ ?x ?y ?rest ...)
     538      (and ($fp<? ?x ?y) (*fl<? ?y ?rest ...)) ) ) )
    445539
    446540(define-syntax *fl>?
     
    449543      #t )
    450544    ((_ ?x ?y)
    451       ($fp> ?x ?y) )
    452     ((_ ?x ?y ?rest ...)
    453       (and ($fp> ?x ?y) (*fl>? ?y ?rest ...)) ) ) )
     545      ($fp>? ?x ?y) )
     546    ((_ ?x ?y ?rest ...)
     547      (and ($fp>? ?x ?y) (*fl>? ?y ?rest ...)) ) ) )
    454548
    455549(define-syntax *fl<=?
     
    458552      #t )
    459553    ((_ ?x ?y)
    460       ($fp<= ?x ?y) )
    461     ((_ ?x ?y ?rest ...)
    462       (and ($fp<= ?x ?y) (*fl<=? ?y ?rest ...)) ) ) )
     554      ($fp<=? ?x ?y) )
     555    ((_ ?x ?y ?rest ...)
     556      (and ($fp<=? ?x ?y) (*fl<=? ?y ?rest ...)) ) ) )
    463557
    464558(define-syntax *fl>=?
     
    467561      #t )
    468562    ((_ ?x ?y)
    469       ($fp>= ?x ?y) )
    470     ((_ ?x ?y ?rest ...)
    471       (and ($fp>= ?x ?y) (*fl>=? ?y ?rest ...)) ) ) )
     563      ($fp>=? ?x ?y) )
     564    ((_ ?x ?y ?rest ...)
     565      (and ($fp>=? ?x ?y) (*fl>=? ?y ?rest ...)) ) ) )
    472566
    473567(define-syntax *fl<>?
     
    476570      #t )
    477571    ((_ ?x ?y)
    478       ($fp<> ?x ?y) )
    479     ((_ ?x ?y ?rest ...)
    480       (and ($fp<> ?x ?y) (*fl<>? ?y ?rest ...)) ) ) )
     572      ($fp<>? ?x ?y) )
     573    ((_ ?x ?y ?rest ...)
     574      (and ($fp<>? ?x ?y) (*fl<>? ?y ?rest ...)) ) ) )
    481575
    482576;;
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r13757 r13807  
    44(require-extension err5rs-arithmetic-fixnums err5rs-arithmetic-flonums err5rs-arithmetic-bitwise)
    55
    6 
    7 (test-group "Fixnum Functions"
    8 
    9   (test 4 (fx+# 2 2))
    10   (test -26 (fx+# 74 -100))
    11   (test 1073741823 (fx+# #x3ffffffe 1))
    12   (test -1073741824 (fx+# #x3fffffff 1))
    13   (test 4 (fx-# 6 2))
    14   (test -4 (fx-# 1000 1004))
    15   (test 2004 (fx-# 1000 -1004))
    16   (test -1073741824 (fx-# (- #x3fffffff) 1))
    17   (test 1073741823 (fx-# (- #x3fffffff) 2))
     6;;
     7
     8(define (run-arithmetic-fixnums-tests)
     9
     10  ;; Originally from Ikarus test suite:
     11  (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)))])
     15      (values s0 s1)))
     16  (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)))])
     20      (values s0 s1)))
     21  (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      (values s0 s1)))
     26
     27  (define (vals->list f a b c)
     28    (call-with-values (lambda () (f a b c)) list))
     29
     30  (define-syntax carry-test
     31    (syntax-rules ()
     32      [(_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
     33       (test `(fxop/carry ,fx1 ,fx2 ,fx3)
     34              (vals->list fxop/carry-reference fx1 fx2 fx3)
     35              (vals->list fxop/carry fx1 fx2 fx3))]))
     36
     37  (define (carry-tests l)
     38    (for-each
     39     (lambda (n)
     40       (for-each
     41        (lambda (m)
     42          (for-each
     43           (lambda (p)
     44             (carry-test fx*/carry fx*/carry-reference n m p)
     45             (carry-test fx+/carry fx+/carry-reference n m p)
     46             (carry-test fx-/carry fx-/carry-reference n m p))
     47           l))
     48        l))
     49     l))
     50
     51  (test-group "Fixnum Functions"
     52
     53    (test 4 (fx+# 2 2))
     54    (test -26 (fx+# 74 -100))
     55    (test 1073741823 (fx+# #x3ffffffe 1))
     56    (test -1073741824 (fx+# #x3fffffff 1))
     57    (test 4 (fx-# 6 2))
     58    (test -4 (fx-# 1000 1004))
     59    (test 2004 (fx-# 1000 -1004))
     60    (test -1073741824 (fx-# (- #x3fffffff) 1))
     61    (test 1073741823 (fx-# (- #x3fffffff) 2))
     62  )
     63
     64  (test-group "R6RS Fixnum Test Suite"
     65
     66    (test -1 (fxfirst-bit-set 0))
     67    (test 0 (fxfirst-bit-set 1))
     68    (test 2 (fxfirst-bit-set -4))
     69
     70    (test 88 (fxreverse-bit-field #b1010010 1 4)) ; #b1011000
     71
     72    ;; ----------------------------------------
     73
     74    (test (least-fixnum) (- (expt 2 (- (fixnum-width) 1))))
     75    (test (greatest-fixnum) (- (expt 2 (- (fixnum-width) 1)) 1))
     76
     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
     92           (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
     107                    (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))])
     131               (test-lt fx<? fx<=? a b c)
     132               (test-lt fx>? fx>=? c b a))
     133
     134             ;; 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)))
     145
     146             ;; Check min & max while we have ordered values:
     147             (test a (fxmin a b))
     148             (test b (fxmin b c))
     149             (test a (fxmin a c))
     150             (test a (fxmin b a c))
     151             (test b (fxmax a b))
     152             (test c (fxmax b c))
     153             (test c (fxmax a c))
     154             (test c (fxmax b c a)))])
     155      (test-ordered 1 2 3)
     156      (test-ordered -1 0 1)
     157      (test-ordered (least-fixnum) 1 (greatest-fixnum)))
     158
     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)))
     185
     186    (test 20 (fx+ 3 17))
     187    (test -1 (fx+ (greatest-fixnum) (least-fixnum)))
     188    (test (greatest-fixnum) (fx+ 0 (greatest-fixnum)))
     189    (test (least-fixnum) (fx+ 0 (least-fixnum)))
     190    (test-error '&implementation-restriction (fx+ (greatest-fixnum) 1))
     191    (test-error '&implementation-restriction (fx+ (least-fixnum) -1))
     192
     193    (test 51 (fx* 3 17))
     194    (test (least-fixnum) (fx* 1 (least-fixnum)))
     195    (test (greatest-fixnum) (fx* 1 (greatest-fixnum)))
     196    (test (+ (least-fixnum) 1) (fx* -1 (greatest-fixnum)))
     197    (test-error '&implementation-restriction (fx* (greatest-fixnum) 2))
     198    (test-error '&implementation-restriction (fx* (least-fixnum) -1))
     199
     200    (test -1 (fx- 1))
     201    (test 1 (fx- -1))
     202    (test 0 (fx- 0))
     203    (test (+ 1 (least-fixnum)) (fx- (greatest-fixnum)))
     204
     205    (test (fx- (greatest-fixnum) 1) (- (greatest-fixnum) 1))
     206    (test 0 (fx- (greatest-fixnum) (greatest-fixnum)))
     207    (test 0 (fx- (least-fixnum) (least-fixnum)))
     208
     209    (test-error '&implementation-restriction (fx- (least-fixnum)))
     210    (test-error '&implementation-restriction (fx- (least-fixnum) 1))
     211
     212    ;; If you put N numbers here, it runs to O(N^3) tests!
     213    (carry-tests (list 0 1 2 -1 -2 38734 -3843 2484598 -348732487 (greatest-fixnum) (least-fixnum)))
     214
     215    (test 12 (fxdiv 123 10))
     216    (test 3 (fxmod 123 10))
     217    (test -12 (fxdiv 123 -10))
     218    (test 3 (fxmod 123 -10))
     219    (test -13 (fxdiv -123 10))
     220    (test 7 (fxmod -123 10))
     221    (test 13 (fxdiv -123 -10))
     222    (test 7 (fxmod -123 -10))
     223
     224    (test (values -13 7) (fxdiv-and-mod -123 10))
     225
     226    (test 12 (fxdiv0 123 10))
     227    (test 3 (fxmod0 123 10))
     228    (test -12 (fxdiv0 123 -10))
     229    (test 3 (fxmod0 123 -10))
     230    (test -12 (fxdiv0 -123 10))
     231    (test -3 (fxmod0 -123 10))
     232    (test 12 (fxdiv0 -123 -10))
     233    (test -3 (fxmod0 -123 -10))
     234
     235    (test (values -12 -3) (fxdiv0-and-mod0 -123 10))
     236
     237    (test-error '&assertion (fxdiv 1 0))
     238    (test-error '&assertion (fxmod 1 0))
     239    (test-error '&assertion (fxdiv-and-mod 1 0))
     240    (test-error '&assertion (fxdiv0 1 0))
     241    (test-error '&assertion (fxmod0 1 0))
     242    (test-error '&assertion (fxdiv0-and-mod0 1 0))
     243
     244    (test-error '&implementation-restriction (fxdiv (least-fixnum) -1))
     245    (test-error '&implementation-restriction (fxdiv-and-mod (least-fixnum) -1))
     246    (test-error '&implementation-restriction (fxdiv0 (least-fixnum) -1))
     247    (test-error '&implementation-restriction (fxdiv0-and-mod0 (least-fixnum) -1))
     248
     249    (test -1 (fxnot 0))
     250    (test 1 (fxnot -2))
     251    (test -2 (fxnot 1))
     252
     253    (test 7 (fxand 7))
     254    (test 0 (fxand 7 0))
     255    (test 1 (fxand 7 1))
     256    (test 5 (fxand 7 5))
     257    (test 4 (fxand 7 4 5))
     258    (test 4 (fxand 7 5 4))
     259
     260    (test 7 (fxior 7))
     261    (test 7 (fxior 7 0))
     262    (test 5 (fxior 5 4))
     263    (test 7 (fxior 5 3))
     264    (test 39 (fxior 5 3 32))
     265
     266    (test 7 (fxxor 7))
     267    (test 7 (fxxor 7 0))
     268    (test 1 (fxxor 5 4))
     269    (test 6 (fxxor 5 3))
     270    (test 36 (fxxor 5 1 32))
     271
     272    (test 5 (fxif 5 15 0))
     273    (test 10 (fxif 5 0 15))
     274    (test 0 (fxif 5 0 1))
     275    (test 2 (fxif 5 0 3))
     276    (test 1 (fxif 5 3 0))
     277
     278    (test 2 (fxbit-count 5))
     279    (test 2 (fxbit-count 6))
     280    (test 3 (fxbit-count 7))
     281    (test -3 (fxbit-count -7))
     282
     283    (test 1 (fxlength 1))
     284    (test 8 (fxlength 255))
     285    (test 0 (fxlength 0))
     286    (test 1 (fxlength -2))
     287    (test 8 (fxlength -255))
     288
     289    (test -1 (fxfirst-bit-set 0))
     290    (test 0 (fxfirst-bit-set 1))
     291    (test 4 (fxfirst-bit-set 16))
     292    (test 1 (fxfirst-bit-set -2))
     293    (test 17 (fxfirst-bit-set (expt 2 17)))
     294
     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))
     300
     301    (test 1 (fxcopy-bit 0 0 1))
     302    (test 2 (fxcopy-bit 0 1 1))
     303    (test 16 (fxcopy-bit 0 4 1))
     304    (test 0 (fxcopy-bit 0 4 0))
     305    (test 15 (fxcopy-bit 31 4 0))
     306
     307    (test 3 (fxbit-field 30 1 3))
     308    (test 7 (fxbit-field 30 1 4))
     309    (test 15 (fxbit-field 30 1 5))
     310    (test 15 (fxbit-field 30 1 6))
     311    (test 6 (fxbit-field 30 0 3))
     312
     313    (test 6 (fxcopy-bit-field 0 0 3 30))
     314    (test 6 (fxcopy-bit-field 7 0 3 30))
     315    (test 14 (fxcopy-bit-field 15 0 3 30))
     316    (test 24 (fxcopy-bit-field 0 2 5 30))
     317    (test 25 (fxcopy-bit-field 1 2 5 30))
     318    (test 27 (fxcopy-bit-field 7 2 5 30))
     319    (test 27 (fxcopy-bit-field 15 2 5 30))
     320    (test 0 (fxcopy-bit-field 0 2 5 120))
     321    (test 1 (fxcopy-bit-field 1 2 5 120))
     322
     323    (test 2 (fxarithmetic-shift 1 1))
     324    (test 0 (fxarithmetic-shift 1 -1))
     325    (test 40 (fxarithmetic-shift 10 2))
     326    (test 10 (fxarithmetic-shift 40 -2))
     327    (test -2 (fxarithmetic-shift -1 1))
     328    (test -1 (fxarithmetic-shift -1 -1))
     329    (test -40 (fxarithmetic-shift -10 2))
     330    (test -10 (fxarithmetic-shift -40 -2))
     331    (test-error '&implementation-restriction (fxarithmetic-shift (greatest-fixnum) 1))
     332
     333    (test 2 (fxarithmetic-shift-left 1 1))
     334    (test 0 (fxarithmetic-shift-right 1 1))
     335    (test 40 (fxarithmetic-shift-left 10 2))
     336    (test 10 (fxarithmetic-shift-right 40 2))
     337    (test -2 (fxarithmetic-shift-left -1 1))
     338    (test -1 (fxarithmetic-shift-right -1 1))
     339    (test -40 (fxarithmetic-shift-left -10 2))
     340    (test -10 (fxarithmetic-shift-right -40 2))
     341    (test-error '&implementation-restriction (fxarithmetic-shift-left (greatest-fixnum) 1))
     342
     343    (test 10 (fxrotate-bit-field 10 0 2 0))
     344    (test 9 (fxrotate-bit-field 10 0 2 1))
     345
     346    (test 10 (fxrotate-bit-field 10 2 4 0))
     347    (test 6 (fxrotate-bit-field 10 2 4 1))
     348    (test 12 (fxrotate-bit-field 10 1 4 2))
     349    (test 6 (fxrotate-bit-field 10 1 4 1))
     350    (test 6 (fxrotate-bit-field 10 2 4 1))
     351  )
    18352)
     353
     354;;
    19355
    20356(test-group "Flonum Functions"
Note: See TracChangeset for help on using the changeset viewer.