Changeset 14010 in project


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

Added fx rep chk to /carry routines. Fixed product rep chk. Use of add1/sub1. Made deliberate attempt at over/underflow in test an error.

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

Legend:

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

    r14008 r14010  
    5757      return ( si1 > (C_MOST_POSITIVE_FIXNUM / si2) );
    5858    else
    59       return ( si2 < (C_MOST_POSITIVE_FIXNUM / si1) );
     59      return ( si2 < (C_MOST_NEGATIVE_FIXNUM / si1) );
    6060  } else if (si2 > 0)
    61     return ( si1 < (C_MOST_POSITIVE_FIXNUM / si2) );
     61    return ( si1 < (C_MOST_NEGATIVE_FIXNUM / si2) );
    6262  else
    6363    return ( (si1 != 0) && (si2 < (C_MOST_POSITIVE_FIXNUM / si1)) );
     
    158158         (rem (%- fxn (%* quo fxd))))
    159159    (cond ((%<= 0 fxd)
    160            (if (%< (%* rem 2) fxd)
     160           (if (%<= fxd (%* rem 2)) (%add1 quo)
    161161               (if (%<= (%* rem -2) fxd) quo
    162                    (%- quo 1) )
    163                (%+ quo 1) ) )
     162                   (%sub1 quo) ) ) )
    164163          ((%< fxd (%* rem -2))
    165164           (if (%<= fxd (%* rem 2)) quo
    166                (%+ quo 1) ) )
     165               (%add1 quo) ) )
    167166          (else
    168            (%- quo 1) ) ) ) )
     167           (%sub1 quo) ) ) ) )
    169168
    170169(define-inline (%fxmod0 fxn fxd)
     
    172171         (rem (%- fxn (%* quo fxd))))
    173172    (cond ((%<= 0 fxd)
    174            (if (%< (%* rem 2) fxd)
     173           (if (%<= fxd (%* rem 2)) (%- rem fxd)
    175174               (if (%<= (%* rem -2) fxd) rem
    176                    (%+ rem fxd) )
    177                (%- rem fxd) ) )
     175                   (%+ rem fxd) ) ) )
    178176          ((%< fxd (%* rem -2))
    179177           (if (%<= fxd (%* rem 2)) rem
     
    186184         (rem (%- fxn (%* quo fxd))))
    187185    (cond ((%<= 0 fxd)
    188            (if (%< (%* rem 2) fxd)
     186           (if (%<= fxd (%* rem 2)) (values (%add1 quo) (%- rem fxd))
    189187               (if (%<= (%* rem -2) fxd) (values quo rem)
    190                    (values (%- quo 1) (%+ rem fxd)) )
    191                (values (%+ quo 1) (%- rem fxd)) ) )
     188                   (values (%sub1 quo) (%+ rem fxd)) ) ) )
    192189          ((%< fxd (%* rem -2))
    193190           (if (%<= fxd (%* rem 2)) (values quo rem)
    194                (values (%+ quo 1) (%- rem fxd)) ) )
     191               (values (%add1 quo) (%- rem fxd)) ) )
    195192          (else
    196            (values (%- quo 1) (%+ rem fxd)) ) ) ) )
     193           (values (%sub1 quo) (%+ rem fxd)) ) ) ) )
    197194
    198195(define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
     
    585582  (%check-fixnum 'fx*/carry fx2)
    586583  (%check-fixnum 'fx*/carry fx3)
    587   (let ((res (%fx+ (%fx* fx1 fx2) fx3)))
    588     (values res (%fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
     584  (when (invalid-product fx1 fx2) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
     585  (let ((prod (%fx* fx1 fx2)))
     586    (when (invalid-sum prod fx3) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
     587    (let ((res (%fx+ prod fx3)))
     588      (values res (%fxcarry-bit (%+ prod (%- fx3 res)))) ) ) )
    589589
    590590(define (fx+/carry fx1 fx2 fx3)
     
    592592  (%check-fixnum 'fx+/carry fx2)
    593593  (%check-fixnum 'fx+/carry fx3)
    594   (let ((res (%fx+ (%fx+ fx1 fx2) fx3)))
    595     (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
     594  (when (invalid-sum fx1 fx2) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
     595  (let ((sum (%fx+ fx1 fx2)))
     596    (when (invalid-sum sum fx3) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
     597    (let ((res (%fx+ sum fx3)))
     598      (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) ) )
    596599
    597600(define (fx-/carry fx1 fx2 fx3)
     
    599602  (%check-fixnum 'fx-/carry fx2)
    600603  (%check-fixnum 'fx-/carry fx3)
    601   (let ((res (%fx- (%fx- fx1 fx2) fx3)))
    602     (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
     604  (when (invalid-difference fx1 fx2) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
     605  (let ((diff (%fx- fx1 fx2)))
     606    (when (invalid-difference diff fx3) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
     607    (let ((res (%fx- diff fx3)))
     608      (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) ) )
    603609
    604610;;
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r14009 r14010  
    4242           (s0 (mod0 s (expt 2 (fixnum-width))))
    4343           (s1 (div0 s (expt 2 (fixnum-width)))))
    44       (values s0 s1)))
     44      (values (inexact->exact s0) (inexact->exact s1))))
    4545
    4646  (define (fx+/carry-reference fx1 fx2 fx3)
     
    4848           (s0 (mod0 s (expt 2 (fixnum-width))))
    4949           (s1 (div0 s (expt 2 (fixnum-width)))))
    50       (values s0 s1)))
     50      (values (inexact->exact s0) (inexact->exact s1))))
    5151
    5252  (define (fx-/carry-reference fx1 fx2 fx3)
     
    5454           (s0 (mod0 s (expt 2 (fixnum-width))))
    5555           (s1 (div0 s (expt 2 (fixnum-width)))))
    56       (values s0 s1)))
     56      (values (inexact->exact s0) (inexact->exact s1))))
    5757
    5858  (define (vals->list f a b c)
     
    6262    (syntax-rules ()
    6363      ((_ fxop/carry fxop/carry-reference fx1 fx2 fx3)
    64        (test #;`(fxop/carry ,fx1 ,fx2 ,fx3)
    65               (vals->list fxop/carry-reference fx1 fx2 fx3)
    66               (vals->list fxop/carry fx1 fx2 fx3)))))
     64       (test (conc 'fxop/carry #\space fx1 #\space fx2 #\space fx3)
     65             (vals->list fxop/carry-reference fx1 fx2 fx3)
     66             (vals->list fxop/carry fx1 fx2 fx3)))))
    6767
    6868  (define (carry-tests l)
     
    8484    (test 4 (*fx+ 2 2))
    8585    (test -26 (*fx+ 74 -100))
    86     (test 1073741823 (*fx+ #x3ffffffe 1))
    87     (test -1073741824 (*fx+ #x3fffffff 1))
     86    (test (greatest-fixnum) (*fx+ #x3ffffffe 1))
     87    (test-error (*fx+ #x3fffffff 1))
    8888    (test 4 (*fx- 6 2))
    8989    (test -4 (*fx- 1000 1004))
    9090    (test 2004 (*fx- 1000 -1004))
    91     (test -1073741824 (*fx- (- #x3fffffff) 1))
    92     (test 1073741823 (*fx- (- #x3fffffff) 2))
     91    (test (least-fixnum) (*fx- (- #x3fffffff) 1))
     92    (test-error (*fx- (- #x3fffffff) 2))
    9393  )
    9494
Note: See TracChangeset for help on using the changeset viewer.