Changeset 14321 in project


Ignore:
Timestamp:
04/21/09 04:31:46 (11 years ago)
Author:
Kon Lovett
Message:

Fix for fx*/carry - wasn't using wide '*' for carry calc. check-* & error-* unsafe are (begin).

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

Legend:

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

    r14231 r14321  
    177177  (unsafe
    178178
    179     (define-inline (%check-fixnum-bounds-order loc fx1 fx2) #t)
    180     (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
    181     (define-inline (%check-word-bits-range loc obj) #t)
    182     (define-inline (%check-bits-range loc start end) #t)
    183     (define-inline (%check-fixnum-bits-count loc count start end) #t) )
     179    (define-inline (%check-fixnum-bounds-order loc fx1 fx2) (begin))
     180    (define-inline (%check-fixnum-range loc lfx fx hfx) (begin))
     181    (define-inline (%check-word-bits-range loc obj) (begin))
     182    (define-inline (%check-bits-range loc start end) (begin))
     183    (define-inline (%check-fixnum-bits-count loc count start end) (begin)) )
    184184
    185185  (else
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic-fixnums.scm

    r14231 r14321  
    2424
    2525#>
    26 static int
    27 C_invalid_sump( C_word si1, C_word si2 )
    28 {
     26#define C_WORD_WIDT (C_WORD_SIZE - 1)
     27#define C_WORD_PREC (C_WORD_SIZE - (1 + 1))
     28
    2929#if 0
    30   signed int offs = si1 ^ si2;
    31   return ( (offs
    32             | (((si1 ^ (~offs
    33                         & (1 << (C_WORD_SIZE - (1 + 1))))) + si2) ^ si2)) >= 0 );
     30#define C_WORD_ADD_INVP( si1, si2 ) \
     31  (((si1 ^ si2) | (((si1 ^ (~(si1 ^ si2) & (1 << C_WORD_PREC))) + si2) ^ si2)) >= 0)
    3432#else
    35   return ( (si1 > 0 && si2 > 0 && si1 > (C_MOST_POSITIVE_FIXNUM - si2))
    36            || (si1 < 0 && si2 < 0 && si1 < (C_MOST_NEGATIVE_FIXNUM - si2)) );
     33#define C_WORD_ADD_INVP( si1, si2 ) \
     34  ((si1 > 0 && si2 > 0 && si1 > (C_MOST_POSITIVE_FIXNUM - si2)) \
     35  || (si1 < 0 && si2 < 0 && si1 < (C_MOST_NEGATIVE_FIXNUM - si2)))
    3736#endif
    38 }
    39 
    40 static int
    41 C_invalid_differencep( C_word si1, C_word si2 )
    42 {
     37
    4338#if 0
    44   signed int offs = si1 ^ si2;
    45   return ( (offs
    46             & (((si1 ^ (offs
    47                         & (1 << (C_WORD_SIZE - (1 + 1))))) - si2) ^ si2)) < 0 );
     39#define C_WORD_SUB_INVP( si1, si2 ) \
     40  (((si1 ^ si2) & (((si1 ^ ((si1 ^ si2) & (1 << C_WORD_PREC))) - si2) ^ si2)) < 0)
    4841#else
    49   return C_invalid_sump( si1, -si2 );
     42#define C_WORD_SUB_INVP( si1, si2 ) \
     43  C_WORD_ADD_INVP( si1, (-si2) )
    5044#endif
    51 }
    52 
    53 static int
    54 C_invalid_productp( C_word si1, C_word si2 )
    55 {
    56   if (si1 > 0) {
    57     if (si2 > 0)
    58       return ( si1 > (C_MOST_POSITIVE_FIXNUM / si2) );
    59     else
    60       return ( si2 < (C_MOST_NEGATIVE_FIXNUM / si1) );
    61   } else if (si2 > 0)
    62     return ( si1 < (C_MOST_NEGATIVE_FIXNUM / si2) );
    63   else
    64     return ( (si1 != 0) && (si2 < (C_MOST_POSITIVE_FIXNUM / si1)) );
    65 }
    66 
    67 static int
    68 C_invalid_divisionp( C_word si1, C_word si2 )
    69 {
    70   return ( (si1 == C_MOST_NEGATIVE_FIXNUM) && (si2 == -1) );
    71 }
     45
     46#define C_WORD_MUL_INVP( si1, si2 ) \
     47  ((si1 > 0) \
     48     ? ((si2 > 0) \
     49         ? (si1 > (C_MOST_POSITIVE_FIXNUM / si2)) \
     50         : (si2 < (C_MOST_NEGATIVE_FIXNUM / si1))) \
     51     : ((si2 > 0) \
     52         ? (si1 < (C_MOST_NEGATIVE_FIXNUM / si2)) \
     53         : ((si1 != 0) && (si2 < (C_MOST_POSITIVE_FIXNUM / si1)))))
     54
     55#define C_WORD_DIV_INVP( si1, si2 ) \
     56  ((si1 == C_MOST_NEGATIVE_FIXNUM) && (si2 == -1))
    7257<#
    7358
     
    7762  (unsafe
    7863
    79     (define-inline (%check-fixnum-shift-amount loc obj) #t)
    80     (define-inline (%check-fixnum-bounds-order loc start end) #t)
    81     (define-inline (%check-fixnum-range loc lfx fx hfx) #t)
    82     (define-inline (%check-word-bits-range loc obj) #t)
    83     (define-inline (%check-bits-range loc start end) #t)
    84     (define-inline (%check-fixnum-bits-count loc obj start end) #t)
    85     (define-inline (%check-zero-division loc fx1 fx2) #t) )
     64    (define-inline (%check-fixnum-shift-amount loc obj) (begin))
     65    (define-inline (%check-fixnum-bounds-order loc start end) (begin))
     66    (define-inline (%check-fixnum-range loc lfx fx hfx) (begin))
     67    (define-inline (%check-word-bits-range loc obj) (begin))
     68    (define-inline (%check-bits-range loc start end) (begin))
     69    (define-inline (%check-fixnum-bits-count loc obj start end) (begin))
     70    (define-inline (%check-zero-division loc fx1 fx2) (begin)) )
    8671
    8772  (else
     
    137122;; Arithmetic
    138123
    139 (define-inline (%fx/int fxn fxd)
    140   (let ((div (%fx/ fxn fxd)))
     124;;
     125
     126(define-inline (%fxdiv/int fxn fxd)
     127  (let ((quo (%fx/ fxn fxd)))
     128    (cond ((%fx<= (%fx* quo fxd) fxn) quo)
     129          ((%fxnegative? fxd)         (%fxadd1 quo))
     130          (else                       (%fxsub1 quo)) )
     131    #;
    141132    (cond ((%fxnegative? fxn)
    142            (if (%fxnegative? fxd) (%fxadd1 div)
    143                (%fxsub1 div) ) )
     133           (if (%fxnegative? fxd) (%fxadd1 quo)
     134               (%fxsub1 quo) ) )
    144135          ((%fxnegative? fxd)
    145            (if (%fxnegative? fxn) (%fxadd1 div)
    146                div ) )
    147           (else div ) ) ) )
    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/int fxn fxd) )
    155 
    156 (define-inline (%fxmod-divisor fxd)
    157   (or (and (%fxnegative? fxd) (not (%fx= most-positive-fixnum fxd))
    158            (%fxneg fxd))
    159       fxd) )
    160 
    161 ;FIXME
     136           (if (%fxnegative? fxn) (%fxadd1 quo)
     137               quo ) )
     138          (else
     139           quo ) ) ) )
     140
    162141(define-inline (%fxmod/int fxn fxd)
    163   (%fxmod fxn (%fxmod-divisor fxd)) )
     142  #;
     143  (let* ((quo (%fx/ fxn fxd))
     144         (rem (%fx- fxn (%fx* quo fxd))) )
     145    (cond ((%fxcardinal? rem) rem)
     146          ((%fxnegative? fxd) (%fx+ rem fxd))
     147          (else               (%fx- rem fxd)) ) )
     148  (%fxmod fxn (or (and (%fxnegative? fxd) (not (%fx= most-positive-fixnum fxd))
     149                       (%fxneg fxd))
     150              fxd)) )
     151
     152(define-inline (%fxdiv-and-mod/int fxn fxd)
     153  (let* ((quo (%fx/ fxn fxd))
     154         (rem (%fx- fxn (%fx* quo fxd))) )
     155    (cond ((%fxcardinal? rem) (values quo rem))
     156          ((%fxnegative? fxd) (values (%fxadd1 quo) (%fx+ rem fxd)))
     157          (else               (values (%fxsub1 quo) (%fx- rem fxd))) ) ) )
     158
     159;;
    164160
    165161(define-inline (%fxdiv0 fxn fxd)
     
    202198           (values (%sub1 quo) (%+ rem fxd)) ) ) ) )
    203199
    204 (define-inline (%fxcarry-bit fx) (%arithmetic-shift fx *fixnum-negated-precision*))
    205 
    206200;;
    207201
     
    229223              (else
    230224               (error-fixnum-representation loc fx amt) ) ) ) ) )
     225
     226;;
     227
     228(define-inline (%fxdiv/check loc fxn fxd)
     229  (%check-fixnum loc fxn)
     230  (%check-fixnum loc fxd)
     231  (%check-zero-division loc fxn fxd)
     232  (when (invalid-division? fxn fxd) (error-fixnum-representation loc fxn fxd))
     233  (%fxdiv/int fxn fxd) )
    231234
    232235;;;
     
    329332  (unsafe
    330333
    331     (define (error-radix loc radix) #t)
    332 
    333     (define (error-fixnum-representation loc . args) #t) )
     334    (define (error-radix loc radix) (begin))
     335    (define (error-fixnum-representation loc . args) (begin)) )
    334336
    335337  (else
     
    358360    (define (error-fixnum-representation loc . args)
    359361      (abort (make-fixnum-representation-condition loc args)) ) ) )
    360 
    361 ;;; Constants
    362 
    363 (define *fixnum-negated-precision* (%fxneg fixnum-precision))
    364362
    365363;;; Procedures wrapping primitive-inlines for fold operations
     
    422420;;
    423421
    424 (define invalid-sum? (foreign-lambda bool "C_invalid_sump" int int))
    425 (define invalid-difference? (foreign-lambda bool "C_invalid_differencep" int int))
    426 (define invalid-product? (foreign-lambda bool "C_invalid_productp" int int))
    427 (define invalid-division? (foreign-lambda bool "C_invalid_divisionp" int int))
     422(define fxcarry-bit (foreign-lambda* int ((integer64 x)) "return( x >> C_WORD_WIDT );"))
     423
     424(define fx+/carry-result
     425  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 + si2 + si3 );"))
     426(define fx-/carry-result
     427  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 - si2 - si3 );"))
     428(define fx*/carry-result
     429  (foreign-lambda* int ((int si1) (int si2) (int si3)) "return( si1 * si2 + si3 );"))
     430
     431;;
     432
     433(define invalid-sum?
     434  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_ADD_INVP( si1, si2 ) );"))
     435(define invalid-difference?
     436  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_SUB_INVP( si1, si2 ) );"))
     437(define invalid-product?
     438  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_MUL_INVP( si1, si2 ) );"))
     439(define invalid-division?
     440  (foreign-lambda* bool ((int si1) (int si2)) "return( C_WORD_DIV_INVP( si1, si2 ) );"))
     441
     442;;
    428443
    429444(define (-fx+ x y)
     
    450465  (%fx* x y) )
    451466
    452 (define (-fx/ x y) (%fx/check 'fx/ x y))
     467(define (-fx/ x y) (%fxdiv/check 'fx/ x y))
    453468
    454469;;; ERR5RS
     
    516531(define fx- -fx-)
    517532(define fx* -fx*)
    518 (define (fxdiv fxn fxd) (%fx/check 'fxdiv fxn fxd))
     533(define (fxdiv fxn fxd) (%fxdiv/check 'fxdiv fxn fxd))
    519534
    520535(define (fxmod fxn fxd)
     
    529544  (%check-zero-division 'fxdiv fxn fxd)
    530545  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv-and-mod fxn fxd))
    531   (values (%fx/int fxn fxd) (%fxmod/int fxn fxd)) )
     546  (%fxdiv-and-mod/int fxn fxd) )
    532547
    533548;;
     
    537552  (%check-fixnum 'fxdiv0 fxd)
    538553  (%check-zero-division 'fxdiv0 fxn fxd)
     554  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv0 fxn fxd))
    539555  (let ((d (%fxdiv0 fxn fxd)))
    540556    (if (%fixnum? d) d
     
    545561  (%check-fixnum 'fxmod0 fxd)
    546562  (%check-zero-division 'fxmod0 fxn fxd)
     563  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxmod0 fxn fxd))
    547564  (let ((m (%fxmod0 fxn fxd)))
    548565    (if (%fixnum? m) m
     
    553570  (%check-fixnum 'fxdiv0-and-mod0 fxd)
    554571  (%check-zero-division 'fxdiv0-and-mod0 fxn fxd)
     572  (when (invalid-division? fxn fxd) (error-fixnum-representation 'fxdiv0-and-mod0 fxn fxd))
    555573  (let-values (((d m) (%fxdiv0-and-mod0 fxn fxd)))
    556574    (if (and (%fixnum? d) (%fixnum? m)) (values d m)
     
    558576
    559577;;
     578
     579(define (fx+/carry fx1 fx2 fx3)
     580  (%check-fixnum 'fx+/carry fx1)
     581  (%check-fixnum 'fx+/carry fx2)
     582  (%check-fixnum 'fx+/carry fx3)
     583  (let ((res (fx+/carry-result fx1 fx2 fx3)))
     584    #;(unless (%fixnum? res) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
     585    (values res (fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) )
     586
     587(define (fx-/carry fx1 fx2 fx3)
     588  (%check-fixnum 'fx-/carry fx1)
     589  (%check-fixnum 'fx-/carry fx2)
     590  (%check-fixnum 'fx-/carry fx3)
     591  (let ((res (fx-/carry-result fx1 fx2 fx3)))
     592    #;(unless (%fixnum? res) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
     593    (values res (fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) )
    560594
    561595(define (fx*/carry fx1 fx2 fx3)
     
    563597  (%check-fixnum 'fx*/carry fx2)
    564598  (%check-fixnum 'fx*/carry fx3)
    565   (when (invalid-product? fx1 fx2) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
    566   (let ((prod (%fx* fx1 fx2)))
    567     (when (invalid-sum? prod fx3) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
    568     (let ((res (%fx+ prod fx3)))
    569       (values res (%fxcarry-bit (%+ prod (%- fx3 res)))) ) ) )
    570 
    571 (define (fx+/carry fx1 fx2 fx3)
    572   (%check-fixnum 'fx+/carry fx1)
    573   (%check-fixnum 'fx+/carry fx2)
    574   (%check-fixnum 'fx+/carry fx3)
    575   (when (invalid-sum? fx1 fx2) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
    576   (let ((sum (%fx+ fx1 fx2)))
    577     (when (invalid-sum? sum fx3) (error-fixnum-representation 'fx+/carry fx1 fx2 fx3))
    578     (let ((res (%fx+ sum fx3)))
    579       (values res (%fxcarry-bit (%+ (%+ fx1 fx2) (%- fx3 res)))) ) ) )
    580 
    581 (define (fx-/carry fx1 fx2 fx3)
    582   (%check-fixnum 'fx-/carry fx1)
    583   (%check-fixnum 'fx-/carry fx2)
    584   (%check-fixnum 'fx-/carry fx3)
    585   (when (invalid-difference? fx1 fx2) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
    586   (let ((diff (%fx- fx1 fx2)))
    587     (when (invalid-difference? diff fx3) (error-fixnum-representation 'fx-/carry fx1 fx2 fx3))
    588     (let ((res (%fx- diff fx3)))
    589       (values res (%fxcarry-bit (%- (%- fx1 fx2) (%+ res fx3)))) ) ) )
     599  (let ((res (fx*/carry-result fx1 fx2 fx3)))
     600    #;(unless (%fixnum? res) (error-fixnum-representation 'fx*/carry fx1 fx2 fx3))
     601    (values res (fxcarry-bit (%+ (%* fx1 fx2) (%- fx3 res)))) ) )
    590602
    591603;;
     
    693705  (%fxsub1 fx) )
    694706
    695 (define (fx/ fxn fxd) (%fx/check 'fx/ fxn fxd))
    696 
    697 (define (fxquotient fxn fxd) (%fx/check 'fxquotient fxn fxd))
    698 
    699 (define (fxremainder fxn fxd) (%fx- fxn (%fx* (%fx/check 'fxremainder fxn fxd) fxd)))
     707(define (fx/ fxn fxd) (%fxdiv/check 'fx/ fxn fxd))
     708(define (fxquotient fxn fxd) (%fxdiv/check 'fxquotient fxn fxd))
     709(define (fxremainder fxn fxd) (%fx- fxn (%fx* (%fxdiv/check 'fxremainder fxn fxd) fxd)))
    700710
    701711;;
  • release/4/err5rs-arithmetic/trunk/err5rs-arithmetic.setup

    r14008 r14321  
    77(verify-extension-name "err5rs-arithmetic")
    88
    9 (setup-shared-extension-module 'err5rs-arithmetic-bitwise (extension-version "1.0.0"))
     9#;(setup-shared-extension-module 'err5rs-arithmetic-bitwise (extension-version "1.0.0"))
    1010(setup-shared-extension-module 'err5rs-arithmetic-fixnums (extension-version "1.0.0"))
    11 (setup-shared-extension-module 'err5rs-arithmetic-flonums (extension-version "1.0.0"))
     11#;(setup-shared-extension-module 'err5rs-arithmetic-flonums (extension-version "1.0.0"))
  • release/4/err5rs-arithmetic/trunk/tests/run.scm

    r14231 r14321  
    3737
    3838  ;; Originally from Ikarus test suite:
     39 
     40  (define 2^fxwid (expt 2 (fixnum-width)))
    3941
    4042  (define (fx*/carry-reference fx1 fx2 fx3)
    41     (let* ((s (+ (* fx1 fx2) fx3))
    42            (s0 (mod0 s (expt 2 (fixnum-width))))
    43            (s1 (div0 s (expt 2 (fixnum-width)))))
    44       (values (inexact->exact s0) (inexact->exact s1))))
     43    (let ((s (+ (* fx1 fx2) fx3)))
     44      (values (inexact->exact (mod0 s 2^fxwid)) (inexact->exact (div0 s 2^fxwid)))))
    4545
    4646  (define (fx+/carry-reference fx1 fx2 fx3)
    47     (let* ((s (+ (+ fx1 fx2) fx3))
    48            (s0 (mod0 s (expt 2 (fixnum-width))))
    49            (s1 (div0 s (expt 2 (fixnum-width)))))
    50       (values (inexact->exact s0) (inexact->exact s1))))
     47    (let ((s (+ (+ fx1 fx2) fx3)))
     48      (values (inexact->exact (mod0 s 2^fxwid)) (inexact->exact (div0 s 2^fxwid)))))
    5149
    5250  (define (fx-/carry-reference fx1 fx2 fx3)
    53     (let* ((s (- (- fx1 fx2) fx3))
    54            (s0 (mod0 s (expt 2 (fixnum-width))))
    55            (s1 (div0 s (expt 2 (fixnum-width)))))
    56       (values (inexact->exact s0) (inexact->exact s1))))
     51    (let ((s (- (- fx1 fx2) fx3)))
     52      (values (inexact->exact (mod0 s 2^fxwid)) (inexact->exact (div0 s 2^fxwid)))))
    5753
    5854  (define (vals->list f a b c)
     
    11741170;;;
    11751171
     1172;(run-arithmetic-bitwise-tests)
    11761173(run-arithmetic-fixnums-tests)
    1177 (run-arithmetic-flonums-tests)
    1178 (run-arithmetic-bitwise-tests)
     1174;(run-arithmetic-flonums-tests)
Note: See TracChangeset for help on using the changeset viewer.