Changeset 14231 in project


Ignore:
Timestamp:
04/10/09 21:59:25 (11 years ago)
Author:
Kon Lovett
Message:

Use check-errors. Rmvd tests outside of core number range. Use of integer64 to accept integers outside of integer range. Many fixes.

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

Legend:

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

    r14031 r14231  
    2121
    2222(include "chicken-primitive-object-inlines")
     23(include "inline-type-checks")
    2324
    2425;;
     
    176177  (unsafe
    177178
    178     (define-inline (%check-fixnum loc obj) #t)
    179 
    180     (define-inline (%check-list loc obj) #t)
    181 
    182     (define-inline (%check-integer loc obj) #t)
    183 
    184179    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
    185 
    186180    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
    187 
    188181    (define-inline (%check-word-bits-range loc obj) #t)
    189 
    190182    (define-inline (%check-bits-range loc start end) #t)
    191 
    192183    (define-inline (%check-fixnum-bits-count loc count start end) #t) )
    193184
    194185  (else
    195 
    196     (define-inline (%check-fixnum loc obj)
    197       (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    198 
    199     (define-inline (%check-list loc obj)
    200       (unless (%list? obj) (error-type-list loc obj)) )
    201 
    202     (define-inline (%check-integer loc obj)
    203       (unless (%integer? obj) (error-type-integer loc obj)) )
    204186
    205187    (define-inline (%check-fixnum-bounds-order loc fx1 fx2)
     
    243225          (%check-integer loc cur)
    244226          (loop (%cdr ls) (func acc cur)) ) ) ) )
     227
     228(define-inline (%bw-logic loc func ls ident)
     229  (if (%null? ls) ident
     230      (let ((1st (%car ls))
     231            (rst (%cdr ls)) )
     232        (if (%null? rst) 1st
     233            (%bwfold loc func 1st rst) ) ) ) )
    245234
    246235;;;
     
    287276  *bitwise-arithmetic-shift *bitwise-arithmetic-shift-left *bitwise-arithmetic-shift-right
    288277  *bitwise-if-not
    289   *pow2log2)
     278  *pow2log2
     279  *bitwise-log2)
    290280
    291281(import scheme
     
    296286          (bitwise-not chicken:bitwise-not))
    297287        foreign
     288        (only type-errors error-fixnum error-integer error-list)
    298289        (only int-limits machine-word-bits machine-word-precision))
    299290
    300 (require-library int-limits)
     291(require-library type-errors int-limits)
    301292
    302293;;; Errors
    303294
    304 (cond-expand
    305   (unsafe)
    306   (else
    307 
    308     (define (error-type-fixnum loc obj)
    309       (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    310 
    311     (define (error-type-integer loc obj)
    312       (##sys#signal-hook #:type-error loc "bad argument type - not an integer" obj) )
    313 
    314     (define (error-type-list loc obj)
    315       (##sys#signal-hook #:type-error loc "bad argument type - not a list" obj) )
    316 
    317     (define-inline (error-outside-range loc obj low high)
    318       (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
    319 
    320     (define (error-bounds-order loc start end)
    321       (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
    322 
    323     (define (error-bits-count loc count start end)
    324       (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) ) ) )
     295(define (error-outside-range loc obj low high)
     296  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
     297
     298(define (error-bounds-order loc start end)
     299  (##sys#signal-hook #:bounds-error loc "bounds reversed" start end) )
     300
     301(define (error-bits-count loc count start end)
     302  (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    325303
    326304;;; Unchecked Variants
     
    329307
    330308(define *bitwise-not
    331   (foreign-lambda* integer ((unsigned-integer n))
    332    "return( ~n );"))
     309  (foreign-lambda* integer ((integer64 n))
     310   "return( ~((C_word) n) );"))
    333311
    334312(define *bitwise-and
    335   (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
    336    "return( n & m );"))
     313  (foreign-lambda* integer ((integer64 n) (integer64 m))
     314   "return( ((C_word) n) & ((C_word) m) );"))
    337315
    338316(define *bitwise-ior
    339   (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
    340    "return( n | m );"))
     317  (foreign-lambda* integer ((integer64 n) (integer64 m))
     318   "return( ((C_word) n) | ((C_word) m) );"))
    341319
    342320(define *bitwise-xor
    343   (foreign-lambda* integer ((unsigned-integer n) (unsigned-integer m))
    344    "return( n ^ m );"))
     321  (foreign-lambda* integer ((integer64 n) (integer64 m))
     322   "return( ((C_word) n) ^ ((C_word) m) );"))
    345323
    346324(define *bitwise-if
    347   (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
    348    "return( BITS_MERGE( m, t, f ) );"))
     325  (foreign-lambda* integer ((integer64 m) (integer64 t) (integer64 f))
     326   "return( BITS_MERGE( (C_uword) m, (C_uword) t, (C_uword) f ) );"))
    349327
    350328(define *bitwise-test?
    351   (foreign-lambda* bool ((unsigned-integer a) (unsigned-integer b))
    352    "return( BITS_TEST( a, b ) );"))
     329  (foreign-lambda* bool ((integer64 a) (integer64 b))
     330   "return( BITS_TEST( (C_uword) a, (C_uword) b ) );"))
    353331
    354332(define *bitwise-bit-count
    355   (foreign-lambda* unsigned-int ((unsigned-integer n))
    356    "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : C_uword_bits( ~((C_word) n) ) );"))
    357 
    358 #;
    359 (define *bitwise-bit-count
    360   (foreign-lambda* unsigned-int ((unsigned-integer n))
    361    "return( 0 <= ((C_word) n) ? C_uword_bits( n ) : ~((C_word) C_uword_bits( ~((C_word) n) )) );"))
    362 
    363 #;
    364 (define *bitwise-bit-count
    365   (foreign-lambda unsigned-int "C_uword_bits" unsigned-integer))
     333  (foreign-lambda* int ((integer64 n))
     334   "return( 0 <= n "
     335              "? C_uword_bits( (C_uword) n ) "
     336              ": ~((C_word) C_uword_bits( (C_uword) ~n )) );"))
    366337
    367338(define *bitwise-length
    368   (foreign-lambda* unsigned-int ((unsigned-integer n))
    369    "return( 0 <= ((C_word) n) ? C_uword_log2( n ) : C_uword_log2( ~((C_word) n) ) );"))
    370 
    371 #;
    372 (define *bitwise-length
    373   (foreign-lambda unsigned-int "C_uword_log2" unsigned-integer))
    374 
     339  (foreign-lambda* unsigned-int ((integer64 n))
     340   "return( 0 <= n "
     341              "? C_uword_log2( (C_uword) n ) "
     342              ": C_uword_log2( (C_uword) ~n ) );"))
    375343
    376344(define *bitwise-first-bit-set
    377   (foreign-lambda* int ((unsigned-integer n))
    378    "return( C_UWORD_LOG2_FACTORS( n ) );"))
     345  (foreign-lambda* int ((integer64 n))
     346   "return( C_UWORD_LOG2_FACTORS( (C_uword) n ) );"))
    379347
    380348(define *bitwise-bit-set?
    381   (foreign-lambda* bool ((unsigned-integer n) (unsigned-int i))
    382    "return( BIT_TEST( n, i ) );"))
     349  (foreign-lambda* bool ((integer64 n) (unsigned-int i))
     350   "return( BIT_TEST( (C_uword) n, i ) );"))
    383351
    384352(define *bitwise-copy-bit
    385   (foreign-lambda* integer ((unsigned-integer to) (unsigned-int i) (unsigned-int b))
    386    "return( BIT_COPY( to, i, b ) );"))
     353  (foreign-lambda* integer ((integer64 to) (unsigned-int i) (unsigned-int b))
     354   "return( BIT_COPY( (C_uword) to, i, b ) );"))
    387355
    388356(define *bitwise-bit-field
    389   (foreign-lambda* integer ((unsigned-integer n) (unsigned-int s) (unsigned-int e))
    390    "return( BITS( n, s, e ) );"))
     357  (foreign-lambda* integer ((integer64 n) (unsigned-int s) (unsigned-int e))
     358   "return( BITS( (C_uword) n, s, e ) );"))
    391359
    392360(define *bitwise-copy-bit-field
    393   (foreign-lambda* integer ((unsigned-integer t) (unsigned-int s) (unsigned-int e) (unsigned-integer f))
    394    "return( BITS_COPY( t, s, e, f ) );"))
     361  (foreign-lambda* integer ((integer64 t) (unsigned-int s) (unsigned-int e) (integer64 f))
     362   "return( BITS_COPY( (C_uword) t, s, e, (C_uword) f ) );"))
    395363
    396364(define *bitwise-rotate-bit-field
    397   (foreign-lambda integer "C_uword_rotate_bit_field" unsigned-integer unsigned-int unsigned-int unsigned-int))
     365  (foreign-lambda* integer ((integer64 n) (unsigned-int s) (unsigned-int e) (unsigned-int c))
     366   "return( C_uword_rotate_bit_field( (C_uword) n, s, e, c ) );"))
    398367
    399368(define *bitwise-reverse
    400   (foreign-lambda integer "C_uword_reverse" unsigned-integer unsigned-int))
    401 
    402 #;
    403 (define (*bitwise-reverse n c)
    404   (let ((negval? (%negative? n)))
    405     (do ((mask (if negval? (%bitwise-not n) n) (%arithmetic-shift mask -1))
    406          (count (%fxsub1 c) (%fxsub1 count))
    407          (revval 0 (%bitwise-ior (%arithmetic-shift revval 1) (%bitwise-and 1 mask))) )
    408         ((%fxnegative? count) (if negval? (%bitwise-not revval) revval)) ) ) )
     369  (foreign-lambda* integer ((integer64 n) (unsigned-int c))
     370   "return( C_uword_reverse( (C_uword) n, c ) );"))
    409371
    410372(define *bitwise-reverse-bit-field
    411   (foreign-lambda integer "C_uword_reverse_bit_field" unsigned-integer unsigned-int unsigned-int))
    412 
    413 #;
    414 (define (*bitwise-reverse-bit-field n s e)
    415   (let* ((width (%fx- e s))
    416          (mask (%bitwise-not (%arithmetic-shift -1 width)))
    417          (field (%bitwise-and mask (%arithmetic-shift n (%fxneg s)))) )
    418     (%bitwise-ior
    419      (%arithmetic-shift (*bitwise-reverse field width) s)
    420      (%bitwise-and (%bitwise-not (%arithmetic-shift mask s)) n)) ) )
     373  (foreign-lambda* integer ((integer64 n) (unsigned-int s) (unsigned-int e))
     374   "return( C_uword_reverse_bit_field( (C_uword) n, s, e ) );"))
    421375
    422376; returns (list lsb .. msb)
     
    445399
    446400(define *bitwise-if-not
    447   (foreign-lambda* integer ((unsigned-integer m) (unsigned-integer t) (unsigned-integer f))
    448    "return( BITS_MERGE_NOT( m, t, f ) );"))
     401  (foreign-lambda* integer ((integer64 m) (integer64 t) (integer64 f))
     402   "return( BITS_MERGE_NOT( (C_uword) m, (C_uword) t, (C_uword) f ) );"))
    449403
    450404(define *bitwise-last-bit-set
    451   (foreign-lambda* unsigned-int ((unsigned-integer n))
    452    "return( 0 == n ? 0 : (C_uword_log2( n ) - 1) );"))
     405  (foreign-lambda* unsigned-int ((integer64 n))
     406   "return( 0 == ((C_word) n) ? 0 : (C_uword_log2( (C_uword) n ) - 1) );"))
    453407
    454408(define *pow2log2
    455   (foreign-lambda* unsigned-int ((unsigned-integer n))
    456    "return( 2 << C_uword_log2( n ) );"))
     409  (foreign-lambda* unsigned-int ((integer64 n))
     410   "return( 2 << C_uword_log2( (C_uword) n ) );"))
     411
     412(define *bitwise-log2
     413  (foreign-lambda* unsigned-int ((integer64 n))
     414  "return( C_uword_log2( (C_uword) n ) );"))
    457415
    458416;;; ERR5RS
     
    462420  (*bitwise-not value) )
    463421
    464 (define (bitwise-and value . values)
    465   (%bwfold 'bitwise-and *bitwise-and value values) )
    466 
    467 (define (bitwise-ior value . values)
    468   (%bwfold 'bitwise-ior *bitwise-ior value values) )
    469 
    470 (define (bitwise-xor value . values)
    471   (%bwfold 'bitwise-xor *bitwise-xor value values) )
     422(define (bitwise-and . values) (%bw-logic 'bitwise-and *bitwise-and values 0))
     423(define (bitwise-ior . values) (%bw-logic 'bitwise-ior *bitwise-ior values 1))
     424(define (bitwise-xor . values) (%bw-logic 'bitwise-xor *bitwise-xor values 0))
    472425
    473426(define (bitwise-if mask true false)
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r14190 r14231  
    2121
    2222(include "chicken-primitive-object-inlines")
     23(include "inline-type-checks")
    2324
    2425#>
     
    7677  (unsafe
    7778
    78     (define-inline (%check-fixnum loc obj) #t)
    79 
    8079    (define-inline (%check-fixnum-shift-amount loc obj) #t)
    81 
    8280    (define-inline (%check-fixnum-bounds-order loc start end) #t)
    83 
    8481    (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
    85 
    8682    (define-inline (%check-word-bits-range loc obj) #t)
    87 
    8883    (define-inline (%check-bits-range loc start end) #t)
    89 
    9084    (define-inline (%check-fixnum-bits-count loc obj start end) #t)
    91 
    9285    (define-inline (%check-zero-division loc fx1 fx2) #t) )
    9386
    9487  (else
    95 
    96     (define-inline (%check-fixnum loc obj)
    97       (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    9888
    9989    (define-inline (%check-fixnum-shift-amount loc obj)
     
    10191      (unless (let ((amt (if (%fxnegative? obj) (%fxneg obj) obj)))
    10292                (%fxclosed? 0 amt fixnum-precision))
    103         (error-type-shift-amount loc obj) ) )
     93        (error-shift-amount loc obj) ) )
    10494
    10595    (define-inline (%check-fixnum-bounds-order loc start end)
     
    281271  fxlast-bit-set
    282272  fixnum->string
    283   ; Macros
    284   $fx=? $fx<? $fx>? $fx<=? $fx>=? $fx<>?
    285   $fxmax $fxmin
    286   $fx- $fx+ $fx* $fx/
    287   $fxand $fxior $fxxor
    288   ; Macro helpers
    289   -fx= -fx< -fx> -fx>= -fx<= -fx<>
    290   -fxmax -fxmin
    291   -fxand -fxior -fxxor
    292   -fx+ -fx- -fx* -fx/)
     273  ;; Macros
     274  ($fx=? -fx=) ($fx<? -fx<) ($fx>? -fx>) ($fx<=? -fx<=) ($fx>=? -fx>=) ($fx<>? -fx<>)
     275  ($fxmax -fxmax) ($fxmin -fxmin)
     276  ($fx- -fx-) ($fx+ -fx+) ($fx* -fx*) ($fx/ -fx/)
     277  ($fxand -fxand) ($fxior -fxior) ($fxxor -fxxor))
    293278
    294279(import scheme
     
    307292        foreign
    308293        data-structures
     294        conditions
     295        (only type-errors error-fixnum)
    309296        (only err5rs-arithmetic-bitwise
    310297          *bitwise-if *bitwise-if-not
     
    316303          *pow2log2))
    317304
    318 (require-library data-structures err5rs-arithmetic-bitwise)
     305(require-library data-structures conditions type-errors err5rs-arithmetic-bitwise)
    319306
    320307;;; Conditions
    321308
    322 (cond-expand
    323   (unsafe)
    324   (else
    325 
    326     (define (make-exn-condition loc msg args)
    327       (make-property-condition 'exn 'location loc 'message msg 'arguments args) )
    328 
    329     (define (make-arithmetic-condition loc msg args . conds)
    330       (apply make-composite-condition
    331        (make-exn-condition loc msg args)
    332        (make-property-condition 'arithmetic)
    333        conds) )
    334 
    335     ; &assertion
    336     (define (make-zero-division-condition loc fx1 fx2)
    337       (make-arithmetic-condition loc "division by zero" (list fx1 fx2)
    338                                  (make-property-condition 'division)) )
    339 
    340     ; &implementation-restriction
    341     (define (make-fixnum-representation-condition loc args)
    342       (make-arithmetic-condition loc "result not representable as fixnum" args
    343                                  (make-property-condition 'representation)) ) ) )
     309(define (make-arithmetic-condition loc msg args . cnds)
     310  (apply make-exn-condition+ loc msg args 'arithmetic cnds) )
    344311
    345312; &assertion
    346 (define (zero-division-violation? obj)
    347   (and (condition? obj)
    348        ((condition-predicate 'arithmetic) obj)
    349        ((condition-predicate 'division) obj) ) )
     313(define (make-zero-division-condition loc fx1 fx2)
     314  (make-arithmetic-condition loc "division by zero" (list fx1 fx2) 'division) )
    350315
    351316; &implementation-restriction
    352 (define (representation-violation? obj)
    353   (and (condition? obj)
    354        ((condition-predicate 'arithmetic) obj)
    355        ((condition-predicate 'representation) obj) ) )
     317(define (make-fixnum-representation-condition loc args)
     318  (make-arithmetic-condition loc "result not representable as fixnum" args 'representation) )
     319
     320; &assertion
     321(define zero-division-violation? (make-condition-predicate arithmetic division))
     322
     323; &implementation-restriction
     324(define representation-violation? (make-condition-predicate arithmetic representation))
    356325
    357326;;; Errors
     
    360329  (unsafe
    361330
    362     (define (error-type-fixnum loc obj) #t)
    363 
    364     (define (error-type-radix loc radix) #t)
    365 
    366     (define (error-outside-range loc obj low high) #t)
    367 
    368     (define (error-bounds-order loc start end) #t)
    369 
    370     (define (error-negative-count loc count) #t)
    371 
    372     (define (error-bits-count loc count start end) #t)
    373 
    374     (define (error-type-shift-amount loc obj) #t)
    375 
    376     (define (error-zero-division loc fx1 fx2) #t)
     331    (define (error-radix loc radix) #t)
    377332
    378333    (define (error-fixnum-representation loc . args) #t) )
     
    380335  (else
    381336
    382     (define (error-type-fixnum loc obj)
    383       (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    384 
    385     (define (error-type-radix loc radix)
     337    (define (error-radix loc radix)
    386338      (##sys#signal-hook #:type-error loc "bad argument type - invalid radix" radix) )
    387339
     
    398350      (##sys#signal-hook #:bounds-error loc "too many bits for interval" count start end) )
    399351
    400     (define (error-type-shift-amount loc amt)
     352    (define (error-shift-amount loc amt)
    401353      (##sys#signal-hook #:bounds-error loc "invalid shift amount" amt) )
    402354
     
    752704  (let ((digits "0123456789ABCDEF"))
    753705    (lambda (fx #!optional (radix 10))
     706
    754707      (define (fx-digits fx from to)
    755708        (if (%fxzero? fx) (values (%make-string from #\#) to)
     
    759712                (%string-set! str to digit)
    760713                (values str (%fx+ to 1)) ) ) ) )
     714
    761715      (define (fx->str fx)
    762716        (cond ((%fxzero? fx)
     
    774728                 (%string-set! str 0 #\-)
    775729                 str ) ) ) )
     730
    776731      (%check-fixnum 'fixnum->string fx)
    777732      (case radix
    778         ((2 8 10 16)
    779           (fx->str fx))
    780         (else
    781           (error-type-radix 'fixnum->string radix) ) ) ) ) )
     733        ((2 8 10 16) (fx->str fx))
     734        (else (error-radix 'fixnum->string radix) ) ) ) ) )
    782735
    783736;;
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r14031 r14231  
    2323
    2424(include "chicken-primitive-object-inlines")
    25 
     25(include "inline-type-checks")
    2626#;(include "mathh-constants")
    2727
    2828;;
    2929
    30 (cond-expand
    31   (unsafe
    32 
    33     (define-inline (%check-fixnum loc obj) #t)
    34 
    35     (define-inline (%check-flonum loc obj) #t)
    36 
    37     #;(define-inline (%check-positive-integer loc obj) #t)
    38 
    39     (define-inline (%check-positive loc obj) #t)
    40 
    41     (define-inline (%check-real loc obj) #t) )
    42 
    43   (else
    44 
    45     (define-inline (%check-fixnum loc obj)
    46       (unless (%fixnum? obj) (error-type-fixnum loc obj)) )
    47 
    48     (define-inline (%check-flonum loc obj)
    49       (unless (%flonum? obj) (error-type-flonum loc obj)) )
    50 
    51     #;(define-inline (%check-positive-integer loc obj)
    52       (unless (and (%integer? obj) (%positive? obj)) (error-type-positive-integer loc obj)) )
    53 
    54     (define-inline (%check-positive loc obj)
    55       (unless (and (%number? obj) (%positive? obj)) (error-type-positive loc obj)) )
    56 
    57     (define-inline (%check-real loc obj)
    58       (unless (real? obj) (error-type-real loc obj)) ) ) )
     30(define-inline (%real? obj) (real? obj))
     31(define-inline-check-type real)
    5932
    6033;;
     
    10578
    10679(define-inline (%fp=? x y)
    107   (cond ((%fpnegzero? x) (%fpnegzero? y))
    108         ((%fpzero? x) (%fpposzero? y))
    109         (else (%fp= x y) ) ) )
     80  (%fp= x y)
     81  #; ;0.0 = -0.0
     82  (if (%fpzero? x) (and (%fpzero? y) (%eq? (signbit x) (signbit y)))
     83      (%fp= x y) ) )
    11084
    11185(define-inline (%fp<? x y)
     
    165139           (values (%fpsub1 quo) (%fp+ rem fpd)) ) ) ) )
    166140
     141(define-inline (%fpgcd fp1 fp2)
     142  (cond ((or (not (%finite? fp1)) (not (%finite? fp2))) 0.0 )
     143        ((%fpzero? fp1) fp2 )
     144        ((%fpzero? fp2) fp1 )
     145        (else ($fpgcd fp1 fp2) ) ) )
    167146;;;
    168147
    169148(module err5rs-arithmetic-flonums (;export
    170   ; ERR5RS
    171   #;no-infinities-violation? #;make-no-infinities-violation
    172   #;no-nans-violation? #;make-no-nans-violation
     149  ;; ERR5RS
    173150  real->flonum fixnum->flonum
    174151  fl=? fl<? fl>? fl<=? fl>=?
     
    183160  flexp fllog flsin flcos fltan flasin flacos flatan flsqrt flexpt
    184161  flnumerator fldenominator
    185   ; Extras
    186   flgcd
     162  ;; Extras
     163  flgcd fllcm
    187164  flonum->fraction
    188165  fl<>?
     
    190167  flfraction
    191168  flnegate
    192   ; Macros
    193   $fl=? $fl<? $fl>? $fl<=? $fl>=? $fl<>?
    194   $flmax $flmin
    195   $fl- $fl+ $fl* $fl/
    196   ; Macro helpers
    197   -fp=? -fp<? -fp>? -fp>=? -fp<=? -fp<>?
    198   -fpmax -fpmin
    199   -fp+ -fp- -fp* -fp/)
    200 
    201 (import scheme chicken foreign srfi-1 mathh)
    202 
    203 (require-library srfi-1 mathh)
     169  ;; Macros
     170  ($fl=? -fl=?) ($fl<? -fl<?) ($fl>? -fl>?) ($fl<=? -fl>=?) ($fl>=? -fl<=?) ($fl<>? -fl<>?)
     171  ($flmax -flmax) ($flmin -flmin)
     172  ($fl- -flnegate -fl-) ($fl+ -fl+) ($fl* -fl*) ($fl/ -fl/))
     173
     174(import scheme chicken foreign srfi-1
     175  (only type-errors define-error-type error-fixnum error-flonum error-positive-number)
     176  mathh)
     177
     178(require-library srfi-1 type-errors mathh)
    204179
    205180;;; Errors
    206181
    207 (cond-expand
    208   (unsafe)
    209   (else
    210 
    211     (define (error-type-fixnum loc obj)
    212       (##sys#signal-hook #:type-error loc "bad argument type - not a fixnum" obj) )
    213 
    214     (define (error-type-flonum loc obj)
    215       (##sys#signal-hook #:type-error loc "bad argument type - not a flonum" obj) )
    216 
    217     (define (error-type-real loc obj)
    218       (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
    219 
    220     (define (error-type-positive loc obj)
    221       (##sys#signal-hook #:type-error loc "bad argument type - not a positive number" obj) ) ) )
     182(define-error-type real)
    222183
    223184;;; Procedures wrapping primitive-inlines for fold operations
    224185
    225 (define (-fp=? x y)
    226         (%check-flonum 'fp=? x)
    227         (%check-flonum 'fp=? y)
     186(define (-fl=? x y)
     187        (%check-flonum 'fl=? x)
     188        (%check-flonum 'fl=? y)
    228189        (%fp=? x y) )
    229190
    230 (define (-fp<? x y)
    231         (%check-flonum 'fp<? x)
    232         (%check-flonum 'fp<? y)
     191(define (-fl<? x y)
     192        (%check-flonum 'fl<? x)
     193        (%check-flonum 'fl<? y)
    233194        (%fp<? x y) )
    234195
    235 (define (-fp>? x y)
    236         (%check-flonum 'fp>? x)
    237         (%check-flonum 'fp>? y)
     196(define (-fl>? x y)
     197        (%check-flonum 'fl>? x)
     198        (%check-flonum 'fl>? y)
    238199        (%fp>? x y) )
    239200
    240 (define (-fp<=? x y)
    241         (%check-flonum 'fp<=? x)
    242         (%check-flonum 'fp<=? y)
     201(define (-fl<=? x y)
     202        (%check-flonum 'fl<=? x)
     203        (%check-flonum 'fl<=? y)
    243204        (%fp<=? x y) )
    244205
    245 (define (-fp>=? x y)
    246         (%check-flonum 'fp>=? x)
    247         (%check-flonum 'fp>=? y)
     206(define (-fl>=? x y)
     207        (%check-flonum 'fl>=? x)
     208        (%check-flonum 'fl>=? y)
    248209        (%fp>=? x y) )
    249210
    250 (define (-fp<>? x y)
    251         (%check-flonum 'fp<>? x)
    252         (%check-flonum 'fp<>? y)
     211(define (-fl<>? x y)
     212        (%check-flonum 'fl<>? x)
     213        (%check-flonum 'fl<>? y)
    253214  (not (%fp=? x y)) )
    254215
    255 (define (-fpmax x y)
    256         (%check-flonum 'fpmax x)
    257         (%check-flonum 'fpmax y)
     216(define (-flmax x y)
     217        (%check-flonum 'flmax x)
     218        (%check-flonum 'flmax y)
    258219        (%fpmax x y) )
    259220
    260 (define (-fpmin x y)
    261         (%check-flonum 'fpmin x)
    262         (%check-flonum 'fpmin y)
     221(define (-flmin x y)
     222        (%check-flonum 'flmin x)
     223        (%check-flonum 'flmin y)
    263224        (%fpmin x y) )
    264225
    265 (define (-fp- x y)
    266         (%check-flonum 'fp- x)
    267         (%check-flonum 'fp- y)
     226(define (-flnegate x)
     227        (%check-flonum 'flnegate x)
     228        (%fpnegate x) )
     229
     230(define (-fl- x y)
     231        (%check-flonum 'fl- x)
     232        (%check-flonum 'fl- y)
    268233        (%fp- x y) )
    269234
    270 (define (-fp+ x y)
    271         (%check-flonum 'fp+ x)
    272         (%check-flonum 'fp+ y)
     235(define (-fl+ x y)
     236        (%check-flonum 'fl+ x)
     237        (%check-flonum 'fl+ y)
    273238        (%fp+ x y) )
    274239
    275 (define (-fp* x y)
    276         (%check-flonum 'fp* x)
    277         (%check-flonum 'fp* y)
     240(define (-fl* x y)
     241        (%check-flonum 'fl* x)
     242        (%check-flonum 'fl* y)
    278243        (%fp* x y) )
    279244
    280 (define (-fp/ x y)
    281         (%check-flonum 'fp/ x)
    282         (%check-flonum 'fp/ y)
     245(define (-fl/ x y)
     246        (%check-flonum 'fl/ x)
     247        (%check-flonum 'fl/ y)
    283248        (%fp/ x y) )
    284249
     
    353318;;; ERR5RS
    354319
    355 ;; We can represent NaN & Inf
    356 
    357 ;;(define (make-no-infinities-violation) )
    358 ;;(define (no-infinities-violation? obj) )
    359 ;;(define (make-no-nans-violation) )
    360 ;;(define (no-nans-violation? obj) )
    361 
    362320;;
    363321
     
    374332;;
    375333
    376 (define (fl=? fp . fps) (%fpand-fold 'fl=? -fp=? fp fps))
    377 (define (fl<? fp . fps) (%fpand-fold 'fl<? -fp<? fp fps))
    378 (define (fl>? fp . fps) (%fpand-fold 'fl>? -fp>? fp fps))
    379 (define (fl<=? fp . fps) (%fpand-fold 'fl<=? -fp<=? fp fps))
    380 (define (fl>=? fp . fps) (%fpand-fold 'fl>=? -fp>=? fp fps))
    381 
    382 ;;
    383 
    384 (define (flmax fp . fps) (%fpfold 'flmax -fpmax fp fps))
    385 (define (flmin fp . fps) (%fpfold 'flmin -fpmin fp fps))
     334(define (fl=? fp . fps) (%fpand-fold 'fl=? -fl=? fp fps))
     335(define (fl<? fp . fps) (%fpand-fold 'fl<? -fl<? fp fps))
     336(define (fl>? fp . fps) (%fpand-fold 'fl>? -fl>? fp fps))
     337(define (fl<=? fp . fps) (%fpand-fold 'fl<=? -fl<=? fp fps))
     338(define (fl>=? fp . fps) (%fpand-fold 'fl>=? -fl>=? fp fps))
     339
     340;;
     341
     342(define (flmax fp . fps) (%fpfold 'flmax -flmax fp fps))
     343(define (flmin fp . fps) (%fpfold 'flmin -flmin fp fps))
    386344
    387345(define (flmax-and-min fp . fps)
     
    434392;;
    435393
    436 (define (fl+ fp . fps) (%fpfold 'fl+ -fp+ fp fps))
     394(define (fl+ fp . fps) (%fpfold 'fl+ -fl+ fp fps))
    437395
    438396(define (fl- fp . fps)
    439397  (if (%null? fps) (%fpnegate fp)
    440       (%fpfold 'fl- -fp- fp fps) ) )
    441 
    442 (define (fl* fp . fps) (%fpfold 'fl* -fp* fp fps))
     398      (%fpfold 'fl- -fl- fp fps) ) )
     399
     400(define (fl* fp . fps) (%fpfold 'fl* -fl* fp fps))
    443401
    444402(define (fl/ fp . fps)
    445403  (if (%null? fps) (%fp/ 1.0 fp)
    446         (%fpfold 'fl/ -fp/ fp fps) ) )
     404        (%fpfold 'fl/ -fl/ fp fps) ) )
    447405
    448406(define (flabs fp)
     
    513471  (cond ((%fpnegzero? fp) -0.0)
    514472        (base
    515          (%check-positive 'fllog base)
     473         (%check-positive-number 'fllog base)
    516474         ((log/base base) fp) )
    517475        (else
     
    596554  (%check-flonum 'flgcd fp1)
    597555  (%check-flonum 'flgcd fp2)
    598   (cond ((or (not (%finite? fp1)) (not (%finite? fp2)))
    599          0.0 )
    600         ((%fpzero? fp1)
    601          fp2 )
    602         ((%fpzero? fp2)
    603          fp1 )
    604         (else
    605          ($fpgcd fp1 fp2) ) ) )
     556  (%fpgcd fp1 fp2) )
     557
     558(define (fllcm fp1 fp2)
     559  (%check-flonum 'fllcm fp1)
     560  (%check-flonum 'fllcm fp2)
     561  (if (or (%fpzero? fp1) (%fpzero? fp2)) 1.0
     562    (let ((gcd (%fpgcd fp1 fp2)))
     563      (if (%fpzero? gcd) 1.0
     564          (%quotient (%fp* fp1 fp2) gcd) ) ) ) )
    606565
    607566(define (flonum->fraction fp)
     
    614573         ($fp->fraction fp) ) ) )
    615574
    616 (define (fl<>? fp . fps) (%fpand-fold 'fl<>? -fp<>? fp fps))
     575(define (fl<>? fp . fps) (%fpand-fold 'fl<>? -fl<>? fp fps))
    617576
    618577(define (flcompare fl1 fl2)
    619578  (%check-flonum 'flcompare fl1)
    620579  (%check-flonum 'flcompare fl2)
    621         (cond ((%fp=? fl1 fl2)  0)
    622               ((%fp<? fl1 fl2)  -1)
     580        (cond ((%fp<? fl1 fl2)  -1)
     581              ((%fp=? fl1 fl2)  0)
    623582              (else             1) ) )
    624583
     
    627586  (%fpfraction fp) )
    628587
    629 (define (flnegate fp)
    630   (%check-flonum 'flnegate fp)
    631   (%fpnegate fp) )
     588(define flnegate -flnegate)
    632589
    633590;;
     
    636593  (syntax-rules ()
    637594    ((_ ?x)               #t )
    638     ((_ ?x ?y)            (-fp=? ?x ?y) )
    639     ((_ ?x ?y ?rest ...)  (and (-fp=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )
     595    ((_ ?x ?y)            (-fl=? ?x ?y) )
     596    ((_ ?x ?y ?rest ...)  (and (-fl=? ?x ?y) ($fl=? ?y ?rest ...)) ) ) )
    640597
    641598(define-syntax $fl<?
    642599  (syntax-rules ()
    643600    ((_ ?x)               #t )
    644     ((_ ?x ?y)            (-fp<? ?x ?y) )
    645     ((_ ?x ?y ?rest ...)  (and (-fp<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )
     601    ((_ ?x ?y)            (-fl<? ?x ?y) )
     602    ((_ ?x ?y ?rest ...)  (and (-fl<? ?x ?y) ($fl<? ?y ?rest ...)) ) ) )
    646603
    647604(define-syntax $fl>?
    648605  (syntax-rules ()
    649606    ((_ ?x)               #t )
    650     ((_ ?x ?y)            (-fp>? ?x ?y) )
    651     ((_ ?x ?y ?rest ...)  (and (-fp>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )
     607    ((_ ?x ?y)            (-fl>? ?x ?y) )
     608    ((_ ?x ?y ?rest ...)  (and (-fl>? ?x ?y) ($fl>? ?y ?rest ...)) ) ) )
    652609
    653610(define-syntax $fl<=?
    654611  (syntax-rules ()
    655612    ((_ ?x)               #t )
    656     ((_ ?x ?y)            (-fp<=? ?x ?y) )
    657     ((_ ?x ?y ?rest ...)  (and (-fp<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )
     613    ((_ ?x ?y)            (-fl<=? ?x ?y) )
     614    ((_ ?x ?y ?rest ...)  (and (-fl<=? ?x ?y) ($fl<=? ?y ?rest ...)) ) ) )
    658615
    659616(define-syntax $fl>=?
    660617  (syntax-rules ()
    661618    ((_ ?x)               #t )
    662     ((_ ?x ?y)            (-fp>=? ?x ?y) )
    663     ((_ ?x ?y ?rest ...)  (and (-fp>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )
     619    ((_ ?x ?y)            (-fl>=? ?x ?y) )
     620    ((_ ?x ?y ?rest ...)  (and (-fl>=? ?x ?y) ($fl>=? ?y ?rest ...)) ) ) )
    664621
    665622(define-syntax $fl<>?
    666623  (syntax-rules ()
    667624    ((_ ?x)               #f )
    668     ((_ ?x ?y)            (-fp<>? ?x ?y) )
    669     ((_ ?x ?y ?rest ...)  (and (-fp<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) )
     625    ((_ ?x ?y)            (-fl<>? ?x ?y) )
     626    ((_ ?x ?y ?rest ...)  (and (-fl<>? ?x ?y) ($fl<>? ?y ?rest ...)) ) ) )
    670627
    671628;;
     
    674631  (syntax-rules ()
    675632    ((_ ?x)               ?x )
    676     ((_ ?x ?y)            (-fpmax ?x ?y) )
    677     ((_ ?x ?y ?rest ...)  (-fpmax ?x ($flmax ?y ?rest ...)) ) ) )
     633    ((_ ?x ?y)            (-flmax ?x ?y) )
     634    ((_ ?x ?y ?rest ...)  (-flmax ?x ($flmax ?y ?rest ...)) ) ) )
    678635
    679636(define-syntax $flmin
    680637  (syntax-rules ()
    681638    ((_ ?x)               ?x )
    682     ((_ ?x ?y)            (-fpmin ?x ?y) )
    683     ((_ ?x ?y ?rest ...)  (-fpmin ?x ($flmin ?y ?rest ...)) ) ) )
     639    ((_ ?x ?y)            (-flmin ?x ?y) )
     640    ((_ ?x ?y ?rest ...)  (-flmin ?x ($flmin ?y ?rest ...)) ) ) )
    684641
    685642;;
     
    687644(define-syntax $fl-
    688645  (syntax-rules ()
    689     ((_ ?x)               (-fpneg ?x) )
    690     ((_ ?x ?y)            (-fp- ?x ?y) )
    691     ((_ ?x ?y ?rest ...)  (-fp- ?x ($fl- ?y ?rest ...) ) ) ) )
     646    ((_ ?x)               (-flnegate ?x) )
     647    ((_ ?x ?y)            (-fl- ?x ?y) )
     648    ((_ ?x ?y ?rest ...)  (-fl- ?x ($fl- ?y ?rest ...) ) ) ) )
    692649
    693650(define-syntax $fl+
    694651  (syntax-rules ()
    695652    ((_ ?x)               ?x )
    696     ((_ ?x ?y)            (-fp+ ?x ?y) )
    697     ((_ ?x ?y ?rest ...)  (-fp+ ?x ($fl+ ?y ?rest ...) ) ) ) )
     653    ((_ ?x ?y)            (-fl+ ?x ?y) )
     654    ((_ ?x ?y ?rest ...)  (-fl+ ?x ($fl+ ?y ?rest ...) ) ) ) )
    698655
    699656(define-syntax $fl*
    700657  (syntax-rules ()
    701658    ((_ ?x)               ?x )
    702     ((_ ?x ?y)            (-fp* ?x ?y) )
    703     ((_ ?x ?y ?rest ...)  (-fp* ?x ($fl* ?y ?rest ...) ) ) ) )
     659    ((_ ?x ?y)            (-fl* ?x ?y) )
     660    ((_ ?x ?y ?rest ...)  (-fl* ?x ($fl* ?y ?rest ...) ) ) ) )
    704661
    705662(define-syntax $fl/
    706663  (syntax-rules ()
    707664    ((_ ?x)               ?x )
    708     ((_ ?x ?y)            (-fp/ ?x ?y) )
    709     ((_ ?x ?y ?rest ...)  (-fp/ ?x ($fl/ ?y ?rest ...) ) ) ) )
     665    ((_ ?x ?y)            (-fl/ ?x ?y) )
     666    ((_ ?x ?y ?rest ...)  (-fl/ ?x ($fl/ ?y ?rest ...) ) ) ) )
    710667
    711668) ;module err5rs-arithmetic-flonums
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.meta

    r14008 r14231  
    77 (doc-from-wiki)
    88 (synopsis "ERR5RS Arithmetic")
    9  (needs setup-helper number-limits mathh)
     9 (needs setup-helper number-limits mathh check-errors)
    1010 (files
    1111  "tests"
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r14031 r14231  
    1010         (rem (- n (* quo d))))
    1111    (cond ((<= 0 d)
    12            (if (>= (* rem 2) d) (+ quo 1)
     12           (if (>= (* rem 2) d) (add1 quo)
    1313               (if (<= (* rem -2) d) quo
    14                    (- quo 1) ) ) )
     14                   (sub1 quo) ) ) )
    1515          ((< d (* rem -2))
    1616           (if (<= d (* rem 2)) quo
    17                (+ quo 1) ) )
     17               (add1 quo) ) )
    1818          (else
    19            (- quo 1) ) ) ) )
     19           (sub1 quo) ) ) ) )
    2020
    2121(define (mod0 n d)
     
    3131          (else
    3232           (+ rem d) ) ) ) )
     33
     34;;
    3335
    3436(define (run-arithmetic-fixnums-tests)
     
    105107
    106108    (test-assert (not (fixnum? 1.0)))
    107     ;;(test-assert (not (fixnum? 1+1i)))
     109    #;(test-assert (not (fixnum? 1+1i)))
     110    (test-assert (not (fixnum? 1.0)))
    108111
    109112    (test-assert (fixnum? 0))
     
    225228    (test (+ (least-fixnum) 1) (fx* -1 (greatest-fixnum)))
    226229    (test-error "&implementation-restriction" (fx* (greatest-fixnum) 2))
    227     (test-error "implementation-restriction" (fx* (least-fixnum) -1))
     230    (test-error "&implementation-restriction" (fx* (least-fixnum) -1))
    228231
    229232    (test -1 (fx- 1))
     
    487490  (test-group "R6RS Flonum Test Suite"
    488491
    489     (current-test-epsilon 0.001)
     492    (current-test-epsilon 0.00000000000001)
    490493
    491494    (test-assert (fl=? +inf +inf))
     
    717720    (test -2.0 (flround -2.5))
    718721
     722    (current-test-epsilon 0.001)
     723
    719724    (test 7.389 (flexp 2.0))
    720725    (test 2.0 (fllog 7.389))
    721726    (test 10.0 (fllog 1024.0 2.0))
     727
     728    (current-test-epsilon 0.0001)
    722729
    723730    (test 0.0 (flsin 0.0))
     
    742749    (test 1000.0 (flexpt 10.0 3.0))
    743750
     751    ;; We have infinities & nans
    744752    #;(test (no-infinities-violation? (make-no-infinities-violation)) #t)
    745753    #;(test ((record-predicate (record-type-descriptor &no-infinities)) (make-no-infinities-violation)) #t)
     
    756764
    757765  ;; Helpers originally from Ikarus test suite:
     766
    758767  (define (ref ei)
    759     (do ((result 0 (+ result 1))
     768    (do ((result 0 (add1 result))
    760769         (bits (if (negative? ei) (bitwise-not ei) ei) (bitwise-arithmetic-shift bits -1)))
     770        ((zero? bits) result)))
     771
     772  (define (chicken:ref ei)
     773    (do ((result 0 (add1 result))
     774         (bits (if (negative? ei) (chicken:bitwise-not ei) ei) (arithmetic-shift bits -1)))
    761775        ((zero? bits) result)))
    762776
     
    768782    (define (pos-count-bits n)
    769783      (if (zero? n) 0
    770           (let ((c (count-bits (bitwise-arithmetic-shift-right n 1))))
    771             (if (even? n) c (+ c 1)))))
     784          (let ((c (count-bits (bitwise-arithmetic-shift n -1))))
     785            (if (even? n) c (add1 c)))))
    772786    (if (>= n 0) (pos-count-bits n)
    773787        (bitwise-not (pos-count-bits (bitwise-not n)))))
     788
     789  (define (chicken:count-bits n)
     790    (define (chicken:pos-count-bits n)
     791      (if (zero? n) 0
     792          (let ((c (chicken:count-bits (arithmetic-shift n -1))))
     793            (if (even? n) c (add1 c)))))
     794    (if (>= n 0) (chicken:pos-count-bits n)
     795        (chicken:bitwise-not (chicken:pos-count-bits (chicken:bitwise-not n)))))
    774796
    775797  (define-syntax count-test
     
    793815    (test 4 (bitwise-bit-count #b10101010))
    794816    (test 0 (bitwise-bit-count 0))
    795     (test 1 (bitwise-bit-count -2))
     817    (test -2 (bitwise-bit-count -2))
     818    (test 31 (bitwise-bit-count #b11111111111111111111111111111110))
    796819
    797820    (test 8 (bitwise-length #b10101010))
     
    889912    (test -1 (bitwise-arithmetic-shift -1 -1))
    890913
     914    (test-error #;(expt 2 301) (bitwise-arithmetic-shift (expt 2 300) 1))
     915    (test-error #;(expt 2 299) (bitwise-arithmetic-shift (expt 2 300) -1))
     916    (test-error #;(expt 2 600) (bitwise-arithmetic-shift (expt 2 300) 300))
     917    (test-error #;1 (bitwise-arithmetic-shift (expt 2 300) -300))
     918
     919    (test-error #;(expt 2 301) (bitwise-arithmetic-shift-left (expt 2 300) 1))
     920    (test-error #;(expt 2 299) (bitwise-arithmetic-shift-right (expt 2 300) 1))
     921    (test-error #;(expt 2 600) (bitwise-arithmetic-shift-left (expt 2 300) 300))
     922    (test-error #;1 (bitwise-arithmetic-shift-right (expt 2 300) 300))
     923
     924    (test -13 (bitwise-not 12))
     925    (test 11 (bitwise-not -12))
     926    (test 0 (bitwise-not -1))
     927    (test -1 (bitwise-not 0))
     928    (test (least-fixnum) (bitwise-not (greatest-fixnum)))
     929    (test (greatest-fixnum) (bitwise-not (least-fixnum)))
     930
    891931    (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4)) ; 88
    892932
     
    10611101
    10621102    (count-test 1)
    1063     ;;(count-test 28472347823493290482390849023840928390482309480923840923840983)
    1064     ;;(count-test -847234234903290482390849023840928390482309480923840923840983)
     1103    #;(count-test 28472347823493290482390849023840928390482309480923840923840983)
     1104    #;(count-test -847234234903290482390849023840928390482309480923840923840983)
    10651105    (count-test (greatest-fixnum))
    10661106    (count-test (least-fixnum))
    1067 
    1068     (test -13 (bitwise-not 12))
    1069     (test 11 (bitwise-not -12))
    1070     (test 0 (bitwise-not -1))
    1071     (test -1 (bitwise-not 0))
    1072     (test (least-fixnum) (bitwise-not (greatest-fixnum)))
    1073     (test (greatest-fixnum) (bitwise-not (least-fixnum)))
    1074 
    1075     ;;(test -38947389478348937489375 (bitwise-not 38947389478348937489374))
    1076     ;;(test -22300745198530623141535718272648361505980416 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
    1077     ;;(test 38947389478348937489374 (bitwise-not -38947389478348937489375))
    1078     ;;(test 22300745198530623141535718272648361505980414 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
    1079     ;;(test -340282366920938463463374607431768211456 (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
    1080     ;;(test 340282366920938463463374607431768211454 (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
    1081     ;;(test -79228162514264337593543950337 (bitwise-not #x1000000000000000000000000))
    1082     ;;(test 79228162514264337593543950335 (bitwise-not #x-1000000000000000000000000))
     1107    (count-test 4294967295)
     1108    (count-test 4294967294)
     1109
     1110    ;;(test -38947389478348937489375
     1111    ;;      (bitwise-not 38947389478348937489374))
     1112    ;;(test -22300745198530623141535718272648361505980416
     1113    ;;      (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1114    ;;(test 38947389478348937489374
     1115    ;;      (bitwise-not -38947389478348937489375))
     1116    ;;(test 22300745198530623141535718272648361505980414
     1117    ;;      (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1118    ;;(test -340282366920938463463374607431768211456
     1119    ;;      (bitwise-not #xFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1120    ;;(test 340282366920938463463374607431768211454
     1121    ;;      (bitwise-not #x-FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF))
     1122    ;;(test -79228162514264337593543950337
     1123    ;;      (bitwise-not #x1000000000000000000000000))
     1124    ;;(test 79228162514264337593543950335
     1125    ;;      (bitwise-not #x-1000000000000000000000000))
    10831126
    10841127    ;; ----------------------------------------
    10851128
    1086     (test-error #;0 (bitwise-and (expt 2 100) 17))
    1087     (test-error #;17 (bitwise-and (- (expt 2 100) 1) 17))
    1088     (test-error #;(expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
    1089 
    1090     (test-error #;(bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
    1091     (test-error #;(- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
    1092     (test-error #;(- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
    1093 
    1094     (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
    1095     (test-error #;1 (bitwise-if (expt 2 100) 1 1) )
    1096     (test-error #;(+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
    1097 
    1098     (test-error #;1 (bitwise-bit-count (expt 2 300)))
    1099     (test-error #;300 (bitwise-bit-count (- (expt 2 300) 1)))
    1100     (test-error #;-301 (bitwise-bit-count (- (expt 2 300))))
    1101 
    1102     (test-error #;301 (bitwise-length (expt 2 300)))
    1103     (test-error #;300 (bitwise-length (- (expt 2 300) 1)))
    1104     (test-error #;300 (bitwise-length (- (expt 2 300))))
    1105 
    1106     (test-error #;300 (bitwise-first-bit-set (expt 2 300)))
    1107     (test-error #;0 (bitwise-first-bit-set (- (expt 2 300) 1)))
    1108 
    1109     (test-error (bitwise-bit-set? (expt 2 300) 300))
    1110     (test-error (not (bitwise-bit-set? (expt 2 300) 0)))
    1111     (test-error (not (bitwise-bit-set? (- (expt 2 300) 1) 300)))
    1112     (test-error (bitwise-bit-set? (- (expt 2 300) 1) 299))
    1113     (test-error (bitwise-bit-set? (- (expt 2 300) 1) 298))
    1114     (test-error (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
    1115     (test-error (bitwise-bit-set? -1 300))
    1116     (test-assert (bitwise-bit-set? -1 0))
    1117     (test-assert (not (bitwise-bit-set? -2 0)))
    1118 
    1119     (test-error #;0 (bitwise-copy-bit-field (expt 2 300) 300 302 0))
    1120     (test-error #;(expt 2 300) (bitwise-copy-bit-field (expt 2 300) 300 302 1))
    1121     (test-error #;(expt 2 301) (bitwise-copy-bit-field (expt 2 300) 300 302 2))
    1122     (test-error #;(+ (expt 2 300) (expt 2 301)) (bitwise-copy-bit-field (expt 2 300) 300 302 3))
    1123 
    1124     (test-error #;(expt 2 301) (bitwise-arithmetic-shift (expt 2 300) 1))
    1125     (test-error #;(expt 2 299) (bitwise-arithmetic-shift (expt 2 300) -1))
    1126     (test-error #;(expt 2 600) (bitwise-arithmetic-shift (expt 2 300) 300))
    1127     (test-error #;1 (bitwise-arithmetic-shift (expt 2 300) -300))
    1128 
    1129     (test-error #;(expt 2 301) (bitwise-arithmetic-shift-left (expt 2 300) 1))
    1130     (test-error #;(expt 2 299) (bitwise-arithmetic-shift-right (expt 2 300) 1))
    1131     (test-error #;(expt 2 600) (bitwise-arithmetic-shift-left (expt 2 300) 300))
    1132     (test-error #;1 (bitwise-arithmetic-shift-right (expt 2 300) 300))
    1133 
    1134     (test-error #;(expt 2 302) (bitwise-rotate-bit-field (expt 2 300) 299 304 2))
    1135     (test-error #;(expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
    1136 
    1137     (test-error #;(expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
     1129    ;;(test 0 (bitwise-and (expt 2 100) 17))
     1130    ;;(test 17 (bitwise-and (- (expt 2 100) 1) 17))
     1131    ;;(test (expt 2 90) (bitwise-and (- (expt 2 100) 1) (expt 2 90)))
     1132
     1133    ;;(test (bitwise-ior (expt 2 100) 17) (bitwise-xor (expt 2 100) 17))
     1134    ;;(test (- (expt 2 100) 18) (bitwise-xor (- (expt 2 100) 1) 17))
     1135    ;;(test (- (expt 2 100) (expt 2 90) 1) (bitwise-xor (- (expt 2 100) 1) (expt 2 90)))
     1136
     1137    ;;(test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) -1 1))
     1138    ;;(test 1 (bitwise-if (expt 2 100) 1 1) )
     1139    ;;(test (+ (expt 2 100) 1) (bitwise-if (expt 2 100) (- (expt 2 200) 1) 1))
     1140
     1141    ;;(test 1 (bitwise-bit-count (expt 2 300)))
     1142    ;;(test 300 (bitwise-bit-count (- (expt 2 300) 1)))
     1143    ;;(test -301 (bitwise-bit-count (- (expt 2 300))))
     1144
     1145    ;;(test 301 (bitwise-length (expt 2 300)))
     1146    ;;(test 300 (bitwise-length (- (expt 2 300) 1)))
     1147    ;;(test 300 (bitwise-length (- (expt 2 300))))
     1148
     1149    ;;(test 300 (bitwise-first-bit-set (expt 2 300)))
     1150    ;;(test 0 (bitwise-first-bit-set (- (expt 2 300) 1)))
     1151
     1152    ;;(test-assert (bitwise-bit-set? (expt 2 300) 300))
     1153    ;;(test-assert (not (bitwise-bit-set? (expt 2 300) 0)))
     1154    ;;(test-assert (not (bitwise-bit-set? (- (expt 2 300) 1) 300)))
     1155    ;;(test-assert (bitwise-bit-set? (- (expt 2 300) 1) 299))
     1156    ;;(test-assert (bitwise-bit-set? (- (expt 2 300) 1) 298))
     1157    ;;(test-assert (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
     1158    ;;(test-assert (bitwise-bit-set? -1 300))
     1159    ;;(test-assert (bitwise-bit-set? -1 0))
     1160    ;;(test-assert (not (bitwise-bit-set? -2 0)))
     1161
     1162    ;;(test 0 (bitwise-copy-bit-field (expt 2 300) 300 302 0))
     1163    ;;(test (expt 2 300) (bitwise-copy-bit-field (expt 2 300) 300 302 1))
     1164    ;;(test (expt 2 301) (bitwise-copy-bit-field (expt 2 300) 300 302 2))
     1165    ;;(test (+ (expt 2 300) (expt 2 301)) (bitwise-copy-bit-field (expt 2 300) 300 302 3))
     1166
     1167    ;;(test (expt 2 302) (bitwise-rotate-bit-field (expt 2 300) 299 304 2))
     1168    ;;(test (expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
     1169
     1170    ;;(test (expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
    11381171  )
    11391172)
Note: See TracChangeset for help on using the changeset viewer.