Changeset 14008 in project


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

Save.

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

Legend:

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

    r13999 r14008  
    2222(include "chicken-primitive-object-inlines")
    2323
     24#>
     25static int
     26invalid_sum( C_word si1, C_word si2 )
     27{
     28#if 0
     29  signed int offs = si1 ^ si2;
     30  return ( (offs
     31            | (((si1 ^ (~offs
     32                        & (1 << (C_WORD_SIZE - (1 + 1))))) + si2) ^ si2)) >= 0 );
     33#else
     34  return ( (si1 > 0 && si2 > 0 && si1 > (C_MOST_POSITIVE_FIXNUM - si2))
     35           || (si1 < 0 && si2 < 0 && si1 < (C_MOST_NEGATIVE_FIXNUM - si2)) );
     36#endif
     37}
     38
     39static int
     40invalid_difference( C_word si1, C_word si2 )
     41{
     42#if 0
     43  signed int offs = si1 ^ si2;
     44  return ( (offs
     45            & (((si1 ^ (offs
     46                        & (1 << (C_WORD_SIZE - (1 + 1))))) - si2) ^ si2)) < 0 );
     47#else
     48  return invalid_sum( si1, -si2 );
     49#endif
     50}
     51
     52static int
     53invalid_product( C_word si1, C_word si2 )
     54{
     55  if (si1 > 0) {
     56    if (si2 > 0)
     57      return ( si1 > (C_MOST_POSITIVE_FIXNUM / si2) );
     58    else
     59      return ( si2 < (C_MOST_POSITIVE_FIXNUM / si1) );
     60  } else if (si2 > 0)
     61    return ( si1 < (C_MOST_POSITIVE_FIXNUM / si2) );
     62  else
     63    return ( (si1 != 0) && (si2 < (C_MOST_POSITIVE_FIXNUM / si1)) );
     64}
     65
     66static int
     67invalid_division( C_word si1, C_word si2 )
     68{
     69  return ( (si1 == C_MOST_NEGATIVE_FIXNUM) && (si2 == -1) );
     70}
     71<#
     72
    2473;; Argument checking
    2574
     
    85134
    86135(define-inline (%fxfold loc func init lyst)
    87   (%check-fixnum loc init)
    88136  (let loop ((ls lyst) (acc init))
    89137    (if (%null? ls) acc
    90         (let ((cur (%car ls)))
    91           (%check-fixnum loc cur)
    92           (loop (%cdr ls) (func acc cur)) ) ) ) )
     138        (loop (%cdr ls) (func acc (%car ls))) ) ) )
    93139
    94140(define-inline (%fxand-fold loc func init lyst)
    95   (%check-fixnum loc init)
    96141  (let loop ((ls lyst) (acc init))
    97142    (or (%null? ls)
    98143        (let ((cur (%car ls)))
    99           (%check-fixnum loc cur)
    100144          (and (func acc cur)
    101145               (loop (%cdr ls) cur) ) ) ) ) )
    102146
    103147;; Arithmetic
     148
     149(define-inline (%fx/-check loc fxn fxd)
     150  (%check-fixnum loc fxn)
     151  (%check-fixnum loc fxd)
     152  (%check-zero-division loc fxn fxd)
     153  (when (invalid-division fxn fxd) (error-fixnum-representation loc fxn fxd))
     154  (%fx/ fxn fxd) )
    104155
    105156(define-inline (%fxdiv0 fxn fxd)
     
    146197
    147198(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
    148 
    149 ;;
    150 
    151 (define-inline (%fxsamesign fx1 fx2)
    152   (cond ((%fxpositive? fx1) (%fxpositive? fx2))
    153         ((%fxnegative? fx1) (%fxnegative? fx2))
    154         ((%fxzero? fx1)     (%fxzero? fx2)) ) )
    155 
    156 (define-inline (%underflowed? resfx argfx)
    157   (if (%fxsamesign resfx argfx) (%fx> resfx argfx)
    158       (%fx< resfx argfx) ) )
    159 
    160 (define-inline (%overflowed? resfx argfx)
    161   (if (%fxsamesign resfx argfx) (%fx< resfx argfx)
    162       (%fx> resfx argfx) ) )
    163199
    164200;;
     
    229265  $fxmax $fxmin
    230266  $fxand $fxior $fxxor
    231   $fxneg
    232267  $fx+ $fx- $fx* $fx/)
    233268
     
    346381;;; Procedures wrapping primitive-inlines for fold operations
    347382
    348 (define ($fx= x y) (%fx= x y))
    349 (define ($fx< x y) (%fx< x y))
    350 (define ($fx> x y) (%fx> x y))
    351 (define ($fx>= x y) (%fx>= x y))
    352 (define ($fx<= x y) (%fx<= x y))
    353 (define ($fx<> x y) (not (%fx= x y)))
    354 (define ($fx+ x y) (%fx+ x y))
    355 (define ($fx- x y) (%fx- x y))
    356 (define ($fx* x y) (%fx* x y))
    357 (define ($fx/ x y) (%fx/ x y))
    358 (define ($fxneg x) (%fxneg x))
    359 (define ($fxmax x y) (%fxmax x y))
    360 (define ($fxmin x y) (%fxmin x y))
    361 (define ($fxand x y) (%fxand x y))
    362 (define ($fxior x y) (%fxior x y))
    363 (define ($fxxor x y) (%fxxor x y))
     383(define ($fx= x y)
     384  (%check-fixnum 'fx= x)
     385  (%check-fixnum 'fx= y)
     386  (%fx= x y) )
     387
     388(define ($fx< x y)
     389  (%check-fixnum 'fx< x)
     390  (%check-fixnum 'fx< y)
     391  (%fx< x y) )
     392
     393(define ($fx> x y)
     394  (%check-fixnum 'fx> x)
     395  (%check-fixnum 'fx> y)
     396  (%fx> x y) )
     397
     398(define ($fx>= x y)
     399  (%check-fixnum 'fx>= x)
     400  (%check-fixnum 'fx>= y)
     401  (%fx>= x y) )
     402
     403(define ($fx<= x y)
     404  (%check-fixnum 'fx<= x)
     405  (%check-fixnum 'fx<= y)
     406  (%fx<= x y) )
     407
     408(define ($fx<> x y)
     409  (%check-fixnum 'fx<> x)
     410  (%check-fixnum 'fx<> y)
     411  (not (%fx= x y)) )
     412
     413(define ($fxmax x y)
     414  (%check-fixnum 'fxmax x)
     415  (%check-fixnum 'fxmax y)
     416  (%fxmax x y) )
     417
     418(define ($fxmin x y)
     419  (%check-fixnum 'fxmin x)
     420  (%check-fixnum 'fxmin y)
     421  (%fxmin x y) )
     422
     423(define ($fxand x y)
     424  (%check-fixnum 'fxand x)
     425  (%check-fixnum 'fxand y)
     426  (%fxand x y) )
     427
     428(define ($fxior x y)
     429  (%check-fixnum 'fxior x)
     430  (%check-fixnum 'fxior y)
     431  (%fxior x y) )
     432
     433(define ($fxxor x y)
     434  (%check-fixnum 'fxxor x)
     435  (%check-fixnum 'fxxor y)
     436  (%fxxor x y) )
     437
     438;;
     439
     440(define invalid-sum (foreign-lambda bool "invalid_sum" int int))
     441(define invalid-difference (foreign-lambda bool "invalid_difference" int int))
     442(define invalid-product (foreign-lambda bool "invalid_product" int int))
     443(define invalid-division (foreign-lambda bool "invalid_division" int int))
     444
     445(define ($fx+ x y)
     446  (%check-fixnum 'fx+ x)
     447  (%check-fixnum 'fx+ y)
     448  (when (invalid-sum x y) (error-fixnum-representation 'fx+ x y))
     449  (%fx+ x y) )
     450
     451(define ($fx- x #!optional y)
     452  (%check-fixnum 'fx- x)
     453  (cond (y
     454         (%check-fixnum 'fx- y)
     455         (when (invalid-difference x y) (error-fixnum-representation 'fx- x y))
     456         (%fx- x y) )
     457        ((%fx= x most-negative-fixnum)
     458         (error-fixnum-representation 'fx- x) ) ;R6RS says raise &assertion but unsymmetrical
     459        (else
     460         (%fxneg x) ) ) )
     461
     462(define ($fx* x y)
     463  (%check-fixnum 'fx* x)
     464  (%check-fixnum 'fx* y)
     465  (when (invalid-product x y) (error-fixnum-representation 'fx* x y))
     466  (%fx* x y) )
     467
     468(define ($fx/ x y)
     469  (%fx/-check 'fx/ x y) )
    364470
    365471;;; ERR5RS
     
    424530;;
    425531
    426 (define (fx+ fx1 fx2)
    427   (%check-fixnum 'fx+ fx1)
    428   (%check-fixnum 'fx+ fx2)
    429   (let ((sum (%fx+ fx1 fx2)))
    430     (if (not (or (%underflowed? sum fx1) (%underflowed? sum fx2))) sum
    431         (error-fixnum-representation 'fx+ fx1 fx2) ) ) )
    432 
    433 (define (fx- fx1 #!optional fx2)
    434   (%check-fixnum 'fx- fx1)
    435   (cond (fx2
    436          (%check-fixnum 'fx- fx2)
    437          (let ((dif (%fx- fx1 fx2)))
    438            (if (not (or (%overflowed? dif fx1) (%overflowed? dif fx2))) dif
    439                (error-fixnum-representation 'fx- fx1 fx2) ) ) )
    440         ((%fx= fx1 most-negative-fixnum)
    441          (error-fixnum-representation 'fx- fx1) ) ;R6RS says raise &assertion but unsymmetrical
    442         (else
    443          (%fxneg fx1) ) ) )
    444 
    445 (define (fx* fx1  fx2)
    446   (%check-fixnum 'fx* fx1)
    447   (%check-fixnum 'fx* fx2)
    448   (let ((prd (%fx* fx1 fx2)))
    449     (if (not (or (%underflowed? prd fx1) (%underflowed? prd fx2))) prd
    450         (error-fixnum-representation 'fx* fx1 fx2) ) ) )
    451 
    452 (define (fxdiv fxn fxd)
    453   (%check-fixnum 'fxdiv fxn)
    454   (%check-fixnum 'fxdiv fxd)
    455   (%check-zero-division 'fxdiv fxn fxd)
    456   (let ((quo (%fx/ fxn fxd)))
    457     (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
    458         (error-fixnum-representation 'fxdiv fxn fxd) ) ) )
     532(define fx+ $fx+)
     533(define fx- $fx-)
     534(define fx* $fx*)
     535(define (fxdiv fxn fxd) (%fx/-check 'fxquotient fxn fxd))
    459536
    460537(define (fxmod fxn fxd)
     
    462539  (%check-fixnum 'fxmod fxd)
    463540  (%check-zero-division 'fxmod fxn fxd)
    464   (%fxmod fxn fxd) )
     541  (%fxmod fxn (or (and (%fxnegative? fxd) (not (%fx= most-positive-fixnum fxd))
     542                       (%fxneg fxd))
     543                  fxd)) )
    465544
    466545(define (fxdiv-and-mod fxn fxd)
     
    468547  (%check-fixnum 'fxdiv-and-mod fxd)
    469548  (%check-zero-division 'fxdiv fxn fxd)
    470   (let ((quo (%fx/ fxn fxd)))
    471     (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) (values quo (%fxmod fxn fxd))
    472         (error-fixnum-representation 'fx/ fxn fxd) ) ) )
     549  (when (invalid-division fxn fxd) (error-fixnum-representation 'fxdiv-and-mod fxn fxd))
     550  (values (%fx/ fxn fxd)
     551          (%fxmod fxn (or (and (%fxnegative? fxd) (not (%fx= most-positive-fixnum fxd))
     552                               (%fxneg fxd))
     553                          fxd))) )
    473554
    474555;;
     
    617698(define (fxadd1 fx)
    618699  (%check-fixnum 'fxadd1 fx)
    619   (let ((sum (%fxadd1 fx)))
    620     (if (not (or (%underflowed? sum fx) (%underflowed? sum 1))) sum
    621         (error-fixnum-representation 'fxadd1 fx) ) ) )
     700  (when (invalid-sum fx 1) (error-fixnum-representation 'fxadd1 fx))
     701  (%fxadd1 fx) )
    622702
    623703(define (fxsub1 fx)
    624704  (%check-fixnum 'fxsub1 fx)
    625   (let ((dif (%fxsub1 fx)))
    626     (if (not (or (%overflowed? dif fx) (%overflowed? dif 1))) dif
    627         (error-fixnum-representation 'fxsub1 fx) ) ) )
     705  (when (invalid-difference fx 1) (error-fixnum-representation 'fxsub1 fx))
     706  (%fxsub1 fx) )
    628707
    629708(define (fx/ fxn fxd)
    630   (%check-fixnum 'fx/ fxn)
    631   (%check-fixnum 'fx/ fxd)
    632   (%check-zero-division 'fx/ fxn fxd)
    633   (let ((quo (%fx/ fxn fxd)))
    634     (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
    635         (error-fixnum-representation 'fx/ fxn fxd) ) ) )
     709  (%fx/-check 'fx/ fxn fxd) )
    636710
    637711(define (fxquotient fxn fxd)
    638   (%check-fixnum 'fxquotient fxn)
    639   (%check-fixnum 'fxquotient fxd)
    640   (%check-zero-division 'fxquotient fxn fxd)
    641   (let ((quo (%fx/ fxn fxd)))
    642     (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) quo
    643         (error-fixnum-representation 'fxquotient fxn fxd) ) ) )
     712  (%fx/-check 'fxquotient fxn fxd) )
    644713
    645714(define (fxremainder fxn fxd)
    646   (%check-fixnum 'fxremainder fxn)
    647   (%check-fixnum 'fxremainder fxd)
    648   (%check-zero-division 'fxremainder fxn fxd)
    649   (let ((quo (%fx/ fxn fxd)))
    650     (if (not (or (%overflowed? quo fxn) (%overflowed? quo fxd))) (%fx- fxn (%fx* quo fxd))
    651         (error-fixnum-representation 'fxquotient fxn fxd) ) ) )
     715  (%fx- fxn (%fx* (%fx/-check 'fxremainder fxn fxd) fxd)) )
    652716
    653717;;
     
    813877  (syntax-rules ()
    814878    ((_ ?x)
    815       ($fxneg ?x) )
     879      ($fx- ?x) )
    816880    ((_ ?x ?y)
    817881      ($fx- ?x ?y) )
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-flonums.scm

    r13999 r14008  
    3333    (define-inline (%check-flonum loc obj) #t)
    3434
    35     (define-inline (%check-cardinal loc obj) #t)
     35    #;(define-inline (%check-positive-integer loc obj) #t)
     36
     37    (define-inline (%check-positive loc obj) #t)
    3638
    3739    (define-inline (%check-real loc obj) #t) )
     
    4547      (unless (%flonum? obj) (error-type-flonum loc obj)) )
    4648
    47     (define-inline (%check-cardinal loc obj)
    48       (unless (%cardinal? obj) (error-type-cardinal loc obj)) )
     49    #;(define-inline (%check-positive-integer loc obj)
     50      (unless (and (%integer? obj) (%positive? obj)) (error-type-positive-integer loc obj)) )
     51
     52    (define-inline (%check-positive loc obj)
     53      (unless (and (%number? obj) (%positive? obj)) (error-type-positive loc obj)) )
    4954
    5055    (define-inline (%check-real loc obj)
     
    7479;;
    7580
    76 (define-inline (%fpzero? fp) (or #;(%fp= -0.0 fp) (%fp= 0.0 fp)))
     81(define-inline (%fpnegzero? fp) (and (%fp=? -0.0 fp) (signbit fp)))
     82
     83(define-inline (%fpzero? fp) (or #;(%fpnegzero? fp) (%fp= 0.0 fp)))
    7784
    7885(define-inline (%fpdiv fpn fpd) (%fptruncate (%fp/ fpn fpd)))
     
    9198
    9299(define-inline (%fp<? x y)
    93   (and (not (and (%fp= 0.0 x) (%fp= -0.0 y)))
    94        (or (and (%fp= -0.0 x) (%fp= 0.0 y))
     100  (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
     101       (or (and (%fpnegzero? x) (%fp= 0.0 y))
    95102           (%fp< x y) ) ) )
    96103
    97104(define-inline (%fp<=? x y)
    98   (and (not (and (%fp= 0.0 x) (%fp= -0.0 y)))
    99        (or (and (%fp= -0.0 x) (%fp= 0.0 y))
     105  (and (not (and (%fp= 0.0 x) (%fpnegzero? y)))
     106       (or (and (%fpnegzero? x) (%fp= 0.0 y))
    100107           (%fp<= x y) ) ) )
    101108
    102109(define-inline (%fp>? x y)
    103   (and (not (and (%fp= -0.0 x) (%fp= 0.0 y)))
    104        (or (and (%fp= 0.0 x) (%fp= -0.0 y))
     110  (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
     111       (or (and (%fp= 0.0 x) (%fpnegzero? y))
    105112           (%fp> x y) ) ) )
    106113
    107114(define-inline (%fp>=? x y)
    108   (and (not (and (%fp= -0.0 x) (%fp= 0.0 y)))
    109        (or (and (%fp= 0.0 x) (%fp= -0.0 y))
     115  (and (not (and (%fpnegzero? x) (%fp= 0.0 y)))
     116       (or (and (%fp= 0.0 x) (%fpnegzero? y))
    110117           (%fp>= x y) ) ) )
    111118
     
    202209      (##sys#signal-hook #:type-error loc "bad argument type - not a real" obj) )
    203210
    204     (define (error-type-cardinal loc obj)
    205       (##sys#signal-hook #:type-error loc "bad argument type - not a cardinal" obj) ) ) )
     211    (define (error-type-positive loc obj)
     212      (##sys#signal-hook #:type-error loc "bad argument type - not a positive number" obj) ) ) )
    206213
    207214;;; Procedures wrapping primitive-inlines for fold operations
     
    342349(define (flpositive? fp)
    343350  (%check-flonum 'flpositive? fp)
    344   (and #;(not (%fpzero? fp))
    345        (%fp<? 0.0 fp) ) )
     351  (and (not (signbit fp))
     352       (not (%fpzero? fp)) ) )
    346353
    347354(define (flnegative? fp)
    348355  (%check-flonum 'flnegative? fp)
    349         (or #;(%fp=? -0.0 fp) (%fp<? fp 0.0) ) )
     356        (signbit fp) )
    350357
    351358(define (flodd? fp)
     
    441448    (let ((bases '()))
    442449      (lambda (base)
    443         (let ((logfun (assv base bases)))
    444                (if logfun (cdr logfun)
     450        (let* ((base (%exact->inexact base))
     451               (logfun (%assv base bases)))
     452               (if logfun (%cdr logfun)
    445453                   (let ((func (make-log/base base)))
    446454                     (set! bases (alist-cons base func bases))
    447455                     func ) ) ) ) ) )
    448456  (%check-flonum 'fllog fp)
    449   (cond ((%fp=? -0.0 fp) -0.0)
     457  (cond ((%fpnegzero? fp) -0.0)
    450458        (base
    451          (%check-cardinal 'fllog base)
     459         (%check-positive 'fllog base)
    452460         ((log/base base) fp) )
    453461        (else
     
    542550  (%check-flonum 'flcompare fl2)
    543551        (cond ((%fp=? fl1 fl2)
    544                (cond ((%fp=? -0.0 fl1)
    545                       (if (%fp=? -0.0 fl1) 0 1) )
    546                ((%fp=? -0.0 fl2)
     552               (cond ((%fpnegzero? fl1)
     553                      (if (%fpnegzero? fl1) 0 1) )
     554               ((%fpnegzero? fl2)
    547555                (if (%fp=? 0.0 fl1) -1 0) )
    548556                     (else
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.meta

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

    r13807 r14008  
    11;;;; "err5rs-arithmetic.setup  -*- Hen -*-
     2
     3(required-extension-version 'mathh "2.1.0")
    24
    35(include "setup-helper")
     
    68
    79(setup-shared-extension-module 'err5rs-arithmetic-bitwise (extension-version "1.0.0"))
    8 
    910(setup-shared-extension-module 'err5rs-arithmetic-fixnums (extension-version "1.0.0"))
    10 
    1111(setup-shared-extension-module 'err5rs-arithmetic-flonums (extension-version "1.0.0"))
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r13999 r14008  
    3434    (syntax-rules ()
    3535      ((_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
    36        (test `(fxop/carry ,fx1 ,fx2 ,fx3)
    37               (vals->list fxop/carry-reference fx1 fx2 fx3)
    38               (vals->list fxop/carry fx1 fx2 fx3)))))
     36       (test (vals->list fxop/carry-reference fx1 fx2 fx3)
     37             (vals->list fxop/carry fx1 fx2 fx3)))))
    3938
    4039  (define (carry-tests l)
     
    5453  (test-group "Fixnum Functions"
    5554
    56     (test 4 ($fx+ 2 2))
    57     (test -26 ($fx+ 74 -100))
    58     (test 1073741823 ($fx+ #x3ffffffe 1))
    59     (test -1073741824 ($fx+ #x3fffffff 1))
    60     (test 4 ($fx- 6 2))
    61     (test -4 ($fx- 1000 1004))
    62     (test 2004 ($fx- 1000 -1004))
    63     (test -1073741824 ($fx- (- #x3fffffff) 1))
    64     (test 1073741823 ($fx- (- #x3fffffff) 2))
     55    (test 4 (*fx+ 2 2))
     56    (test -26 (*fx+ 74 -100))
     57    (test 1073741823 (*fx+ #x3ffffffe 1))
     58    (test -1073741824 (*fx+ #x3fffffff 1))
     59    (test 4 (*fx- 6 2))
     60    (test -4 (*fx- 1000 1004))
     61    (test 2004 (*fx- 1000 -1004))
     62    (test -1073741824 (*fx- (- #x3fffffff) 1))
     63    (test 1073741823 (*fx- (- #x3fffffff) 2))
    6564  )
    6665
     
    624623    (test 5.4 (fl+ 2.3 3.1))
    625624    (test 4.3 (fl+ 2.3 3.1 -1.1))
    626     (test 261 (fl+ 2.3e2 3.1e1))
     625    (test 261.0 (fl+ 2.3e2 3.1e1))
    627626
    628627    (test 2.3 (fl* 2.3))
     
    737736  (define-syntax len-test
    738737    (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)))))
     738      ((_ n) (test (ref n) (bitwise-length n)))))
    746739
    747740  (define (count-bits n)
     741    (define (pos-count-bits n)
     742      (if (zero? n) 0
     743          (let ((c (count-bits (bitwise-arithmetic-shift-right n 1))))
     744            (if (even? n) c (+ c 1)))))
    748745    (if (>= n 0) (pos-count-bits n)
    749746        (bitwise-not (pos-count-bits (bitwise-not n)))))
     
    842839
    843840    (test #b11100101 (bitwise-reverse-bit-field #b10100111 0 8))
    844     (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4))
    845841
    846842    (test 0 (bitwise-list->integer '()))
     
    866862    (test -1 (bitwise-arithmetic-shift -1 -1))
    867863
    868     (test 88 (bitwise-reverse-bit-field #b1010010 1 4)) ; #b1011000
     864    (test #b1011000 (bitwise-reverse-bit-field #b1010010 1 4)) ; 88
    869865
    870866    ;; Originally from Ikarus test suite:
     
    10841080    (test 0 (bitwise-first-bit-set (- (expt 2 300) 1)))
    10851081
    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))
     1082    (test-error (bitwise-bit-set? (expt 2 300) 300))
     1083    (test-error (not (bitwise-bit-set? (expt 2 300) 0)))
     1084    (test-error (not (bitwise-bit-set? (- (expt 2 300) 1) 300)))
     1085    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 299))
     1086    (test-error (bitwise-bit-set? (- (expt 2 300) 1) 298))
    10911087    (test-assert (not (bitwise-bit-set? (- (expt 2 300) 2) 0)))
    1092     (test-assert (bitwise-bit-set? -1 300))
     1088    (test-error (bitwise-bit-set? -1 300))
    10931089    (test-assert (bitwise-bit-set? -1 0))
    10941090    (test-assert (not (bitwise-bit-set? -2 0)))
    10951091
    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))
     1092    (test-error #;0 (bitwise-copy-bit-field (expt 2 300) 300 302 0))
     1093    (test-error #;(expt 2 300) (bitwise-copy-bit-field (expt 2 300) 300 302 1))
     1094    (test-error #;(expt 2 301) (bitwise-copy-bit-field (expt 2 300) 300 302 2))
     1095    (test-error #;(+ (expt 2 300) (expt 2 301)) (bitwise-copy-bit-field (expt 2 300) 300 302 3))
     1096
     1097    (test-error #;(expt 2 301) (bitwise-arithmetic-shift (expt 2 300) 1))
     1098    (test-error #;(expt 2 299) (bitwise-arithmetic-shift (expt 2 300) -1))
     1099    (test-error #;(expt 2 600) (bitwise-arithmetic-shift (expt 2 300) 300))
     1100    (test-error #;1 (bitwise-arithmetic-shift (expt 2 300) -300))
     1101
     1102    (test-error #;(expt 2 301) (bitwise-arithmetic-shift-left (expt 2 300) 1))
     1103    (test-error #;(expt 2 299) (bitwise-arithmetic-shift-right (expt 2 300) 1))
     1104    (test-error #;(expt 2 600) (bitwise-arithmetic-shift-left (expt 2 300) 300))
     1105    (test-error #;1 (bitwise-arithmetic-shift-right (expt 2 300) 300))
     1106
     1107    (test-error #;(expt 2 302) (bitwise-rotate-bit-field (expt 2 300) 299 304 2))
     1108    (test-error #;(expt 2 299) (bitwise-rotate-bit-field (expt 2 300) 299 304 4))
     1109
     1110    ;;(test (expt 2 302) (bitwise-reverse-bit-field (expt 2 300) 299 304))
    11151111  )
    11161112)
Note: See TracChangeset for help on using the changeset viewer.