Changeset 31424 in project


Ignore:
Timestamp:
09/14/14 21:39:59 (7 years ago)
Author:
sjamaan
Message:

numbers: Begin of large simplification by using a simple, but nice naming "system". Hopefully this will make it more acceptable to build into core, and less clumsy too.

Location:
release/4/numbers/trunk
Files:
5 edited

Legend:

Unmodified
Added
Removed
  • release/4/numbers/trunk/numbers-c.c

    r31421 r31424  
    4141#include <math.h> /* frexp() */
    4242
     43# define nmax(x, y)     ((x) > (y) ? (x) : (y)) /* From runtime.c */
     44
    4345static void *tags;
    4446
     
    8991static C_word bignum_normalize_shifted(C_word bignum, C_word shift_right);
    9092
     93/* This should be replaced by C_header_bits(x) == C_BIGNUM_TYPE in core */
     94#define C_IS_BIGNUM_TYPE(x) (C_header_bits(x) == C_STRUCTURE_TYPE && C_block_item(CHICKEN_gc_root_ref(tags), BIG_TAG) == C_block_item(x, 0))
     95
    9196static C_word
    9297init_tags(___scheme_value tagvec)
     
    134139}
    135140
    136 /* Eventually this will probably need to be integrated into C_2_plus. */
    137 void C_ccall
    138 C_u_2_fixnum_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
    139 {
    140   C_word z, ab[C_SIZEOF_BIGNUM(2)], *a = ab;
    141 
     141void C_ccall
     142C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
     143{
     144  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM*2)], *a = ab;
     145
     146  if (x & C_FIXNUM_BIT) {
     147    if (y & C_FIXNUM_BIT) {
     148       C_kontinue(k, C_a_u_i_2_fixnum_plus(&a, 2, x, y));
     149    } else if (C_immediatep(y)) {
     150       C_kontinue(k, C_SCHEME_FALSE);
     151    } else if (C_block_header(y) == C_FLONUM_TAG) {
     152       C_kontinue(k, C_flonum(&a, (double)C_unfix(x) + C_flonum_magnitude(y)));
     153    } else if (C_IS_BIGNUM_TYPE(y)) {
     154       C_u_2_bignum_plus(2, (C_word)NULL, k, C_a_u_i_fix_to_big(&a, x), y);
     155    } else {
     156       C_kontinue(k, C_SCHEME_FALSE);
     157    }
     158  } else if (C_immediatep(x)) {
     159    C_kontinue(k, C_SCHEME_FALSE);
     160  } else if (C_block_header(x) == C_FLONUM_TAG) {
     161    if (y & C_FIXNUM_BIT) {
     162       C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) + (double)C_unfix(y)));
     163    } else if (C_immediatep(y)) {
     164       C_kontinue(k, C_SCHEME_FALSE);
     165    } else if (C_block_header(y) == C_FLONUM_TAG) {
     166       C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, y));
     167    } else if (C_IS_BIGNUM_TYPE(y)) {
     168       C_kontinue(k, C_a_i_flonum_plus(&a, 2, x, C_a_u_i_big_to_flo(&a, 2, y)));
     169    } else {
     170       C_kontinue(k, C_SCHEME_FALSE);
     171    }
     172  } else if (C_IS_BIGNUM_TYPE(x)) {
     173    if (y & C_FIXNUM_BIT) {
     174       C_u_2_bignum_plus(2, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
     175    } else if (C_immediatep(y)) {
     176       C_kontinue(k, C_SCHEME_FALSE);
     177    } else if (C_block_header(y) == C_FLONUM_TAG) {
     178       C_kontinue(k, C_a_i_flonum_plus(&a, 2, C_a_u_i_big_to_flo(&a, 2, x), y));
     179    } else if (C_IS_BIGNUM_TYPE(y)) {
     180       C_u_2_bignum_plus(2, (C_word)NULL, k, x, y);
     181    } else {
     182       C_kontinue(k, C_SCHEME_FALSE);
     183    }
     184  } else {
     185     C_kontinue(k, C_SCHEME_FALSE);
     186  }
     187}
     188
     189void C_ccall
     190C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y)
     191{
     192  C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
     193
     194  if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT)
     195    C_kontinue(k, C_a_u_i_2_fixnum_plus(&a, 2, x, y));
     196
     197  if (x & C_FIXNUM_BIT)
     198    x = C_a_u_i_fix_to_big(&a, x);
     199  if (y & C_FIXNUM_BIT)
     200    y = C_a_u_i_fix_to_big(&a, y);
     201
     202  C_u_2_bignum_plus(2, (C_word)NULL, k, x, y);
     203}
     204
     205C_regparm C_word C_fcall
     206C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y)
     207{
    142208  /* Exceptional situation: this will cause a real overflow */
    143209  if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) && y == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
    144     C_kontinue(k, C_bignum2(&a, 1, 0, 2));
    145   } else {
    146     z = C_unfix(x) + C_unfix(y);
    147 
    148     /* This code "knows" that both fixnums and bignums have 2 reserved bits */
     210    return C_bignum2(ptr, 1, 0, 2);
     211  } else {
     212    C_word z = C_unfix(x) + C_unfix(y);
     213
    149214    if(!C_fitsinfixnump(z)) {
    150       /* TODO: function returning either a fixnum or a bignum from a C int */
     215      /* TODO: function/macro returning either fixnum or bignum from a C int */
    151216      /* This should help with the C API/FFI too. */
    152       C_kontinue(k, C_bignum2(&a, (z < 0), labs(z) & (C_uword)C_BIGNUM_DIGIT_MASK, 1));
    153     } else {
    154       C_kontinue(k, C_fix(z));
    155     }
    156   }
    157 }
    158 
    159 void C_ccall
    160 C_u_fixnum_plus_bignum(C_word c, C_word self, C_word k, C_word x, C_word y)
    161 {
    162   C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, bigx;
    163   bigx = C_a_u_i_fix_to_big(&a, x);
    164   C_u_2_bignum_plus(2, (C_word)NULL, k, bigx, y);
     217      return C_bignum2(ptr, (z < 0), labs(z) & (C_uword)C_BIGNUM_DIGIT_MASK, 1);
     218    } else {
     219      return C_fix(z);
     220    }
     221  }
    165222}
    166223
     
    184241
    185242void C_ccall
    186 C_u_fixnum_minus_bignum(C_word c, C_word self, C_word k, C_word x, C_word y)
    187 {
    188   C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, bigx;
    189   bigx = C_a_u_i_fix_to_big(&a, x);
    190   C_u_2_bignum_minus(2, (C_word)NULL, k, bigx, y);
    191 }
    192 
    193 void C_ccall
    194 C_u_bignum_minus_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y)
    195 {
    196   C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, bigy;
    197   bigy = C_a_u_i_fix_to_big(&a, y);
    198   C_u_2_bignum_minus(2, (C_word)NULL, k, x, bigy);
     243C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
     244{
     245  C_word ab[nmax(C_SIZEOF_FIX_BIGNUM, C_SIZEOF_FLONUM*2)], *a = ab;
     246
     247  /* TODO */
     248  if (x & C_FIXNUM_BIT) {
     249    if (y & C_FIXNUM_BIT) {
     250       C_kontinue(k, C_a_u_i_2_fixnum_minus(&a, 2, x, y));
     251    } else if (C_immediatep(y)) {
     252       C_kontinue(k, C_SCHEME_FALSE);
     253    } else if (C_block_header(y) == C_FLONUM_TAG) {
     254       C_kontinue(k, C_flonum(&a, (double)C_unfix(x) - C_flonum_magnitude(y)));
     255    } else if (C_IS_BIGNUM_TYPE(y)) {
     256       C_u_2_bignum_minus(2, (C_word)NULL, k, C_a_u_i_fix_to_big(&a, x), y);
     257    } else {
     258       C_kontinue(k, C_SCHEME_FALSE);
     259    }
     260  } else if (C_immediatep(x)) {
     261    C_kontinue(k, C_SCHEME_FALSE);
     262  } else if (C_block_header(x) == C_FLONUM_TAG) {
     263    if (y & C_FIXNUM_BIT) {
     264       C_kontinue(k, C_flonum(&a, C_flonum_magnitude(x) - (double)C_unfix(y)));
     265    } else if (C_immediatep(y)) {
     266       C_kontinue(k, C_SCHEME_FALSE);
     267    } else if (C_block_header(y) == C_FLONUM_TAG) {
     268       C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, y)); /* XXX NAMING! */
     269    } else if (C_IS_BIGNUM_TYPE(y)) {
     270       C_kontinue(k, C_a_i_flonum_difference(&a, 2, x, C_a_u_i_big_to_flo(&a, 2, y)));
     271    } else {
     272       C_kontinue(k, C_SCHEME_FALSE);
     273    }
     274  } else if (C_IS_BIGNUM_TYPE(x)) {
     275    if (y & C_FIXNUM_BIT) {
     276       C_u_2_bignum_minus(2, (C_word)NULL, k, x, C_a_u_i_fix_to_big(&a, y));
     277    } else if (C_immediatep(y)) {
     278       C_kontinue(k, C_SCHEME_FALSE);
     279    } else if (C_block_header(y) == C_FLONUM_TAG) {
     280       C_kontinue(k, C_a_i_flonum_difference(&a, 2, C_a_u_i_big_to_flo(&a, 2, x), y));
     281    } else if (C_IS_BIGNUM_TYPE(y)) {
     282       C_u_2_bignum_minus(2, (C_word)NULL, k, x, y);
     283    } else {
     284       C_kontinue(k, C_SCHEME_FALSE);
     285    }
     286  } else {
     287     C_kontinue(k, C_SCHEME_FALSE);
     288  }
     289}
     290
     291void C_ccall
     292C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y)
     293{
     294  C_word ab[C_SIZEOF_FIX_BIGNUM * 2], *a = ab;
     295
     296  if (x & C_FIXNUM_BIT && y & C_FIXNUM_BIT)
     297    C_kontinue(k, C_a_u_i_2_fixnum_minus(&a, 2, x, y));
     298
     299  if (x & C_FIXNUM_BIT)
     300    x = C_a_u_i_fix_to_big(&a, x);
     301  if (y & C_FIXNUM_BIT)
     302    y = C_a_u_i_fix_to_big(&a, y);
     303
     304  C_u_2_bignum_minus(2, (C_word)NULL, k, x, y);
     305}
     306
     307C_regparm C_word C_fcall
     308C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y)
     309{
     310  C_word z = C_unfix(x) - C_unfix(y);
     311
     312  if(!C_fitsinfixnump(z)) {
     313    /* TODO: function/macro returning either fixnum or bignum from a C int */
     314    /* This should help with the C API/FFI too. */
     315    return C_bignum2(ptr, (z < 0), labs(z) & (C_uword)C_BIGNUM_DIGIT_MASK, 1);
     316  } else {
     317    return C_fix(z);
     318  }
    199319}
    200320
     
    388508}
    389509
    390 /* TODO: This should probably be renamed C_fixnum_negate to replace
    391  * what's in core.  Unfortunately, that one is allocating inline.
    392  * That one may be renamed to C_u_i_fixnum_negate() or some such.
    393  * TODO: Convert this to be an inline function and move to header?
    394  */
    395 void C_ccall
    396 C_u_fixnum_neg(C_word c, C_word self, C_word k, C_word x)
     510C_regparm C_word C_fcall
     511C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x)
    397512{
    398513  /* Exceptional situation: this will cause an overflow to itself */
    399514  if (x == C_fix(C_MOST_NEGATIVE_FIXNUM)) { /* C_fitsinfixnump(x) */
    400     C_word ab[C_SIZEOF_BIGNUM(2)], *a = ab;
    401     C_kontinue(k, C_bignum2(&a, 0, 0, 1));
    402   } else {
    403     C_kontinue(k, C_fix(-C_unfix(x)));
     515    return C_bignum2(ptr, 0, 0, 1);
     516  } else {
     517    return C_fix(-C_unfix(x));
    404518  }
    405519}
     
    10431157C_u_int_shift_fix(C_word c, C_word self, C_word k, C_word x, C_word y)
    10441158{
    1045   C_word kab[C_SIZEOF_FIX_BIGNUM + C_SIZEOF_CLOSURE(3) + C_SIZEOF_CLOSURE(2)],
    1046          *ka = kab, k2, k3, size;
     1159  C_word kab[C_SIZEOF_FIX_BIGNUM * 2 + C_SIZEOF_CLOSURE(3) + C_SIZEOF_CLOSURE(2)],
     1160         *ka = kab, k2, k3, size, minus1;
    10471161
    10481162  if (y == C_fix(0) || x == C_fix(0)) { /* Done (no shift) */
     
    10601174    k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k3, y);
    10611175    /* Actually invert by subtracting: -1 - x */
    1062     C_u_fixnum_minus_bignum(2, (C_word)NULL, k2, C_fix(-1), x);
     1176    minus1 = C_a_u_i_fix_to_big(&ka, C_fix(-1));
     1177    C_u_2_bignum_minus(2, (C_word)NULL, k2, minus1, x);
    10631178  } else {
    10641179    k2 = C_closure(&ka, 3, (C_word)bignum_allocate_for_shift, k, y);
     
    11071222bignum_negate_after_shift(C_word c, C_word self, C_word result)
    11081223{
    1109   C_word k = C_block_item(self, 1),
    1110          ab[C_SIZEOF_FIX_BIGNUM], *a = ab;
    1111   if (result & C_FIXNUM_BIT) /* Normalisation may happen after shift */
     1224  C_word k = C_block_item(self, 1);
     1225  if (result & C_FIXNUM_BIT) { /* Normalisation may happen after shift */
    11121226    C_kontinue(k, C_fix(-1 - C_unfix(result)));
    1113   else
    1114     C_u_fixnum_minus_bignum(2, (C_word)NULL, k, C_fix(-1), result);
     1227  } else {
     1228    C_word ab[C_SIZEOF_FIX_BIGNUM], *a = ab, minus1;
     1229    minus1 = C_a_u_i_fix_to_big(&a, C_fix(-1));
     1230    C_u_2_bignum_minus(2, (C_word)NULL, k, minus1, result);
     1231  }
    11151232}
    11161233
     
    12561373  if (y & C_FIXNUM_BIT)
    12571374    y = C_a_u_i_fix_to_big(&ka, y);
    1258 
    1259 # define nmax(x, y)     ((x) > (y) ? (x) : (y)) /* From runtime.c */
    12601375
    12611376  if (C_bignum_negativep(x)) {
  • release/4/numbers/trunk/numbers-c.h

    r31418 r31424  
    7272C_word C_ccall C_u_i_2_fixnum_gcd(C_word x, C_word y);
    7373C_word C_ccall C_a_u_i_2_flonum_gcd(C_word **p, C_word n, C_word x, C_word y);
    74 void C_ccall C_u_fixnum_neg(C_word c, C_word self, C_word k, C_word x);
     74
     75void C_ccall C_2_basic_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
     76C_regparm C_word C_fcall C_a_u_i_2_fixnum_plus(C_word **ptr, C_word n, C_word x, C_word y);
     77void C_ccall C_u_2_integer_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
     78void C_ccall C_u_2_bignum_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
    7579void C_ccall C_u_bignum_negate(C_word c, C_word self, C_word k, C_word x);
    76 
    77 void C_ccall C_u_2_fixnum_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
    78 void C_ccall C_u_fixnum_plus_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
    79 void C_ccall C_u_2_bignum_plus(C_word c, C_word self, C_word k, C_word x, C_word y);
     80C_regparm C_word C_fcall C_a_u_i_fixnum_negate(C_word **ptr, C_word n, C_word x);
     81void C_ccall C_2_basic_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
     82C_regparm C_word C_fcall C_a_u_i_2_fixnum_minus(C_word **ptr, C_word n, C_word x, C_word y);
     83void C_ccall C_u_2_integer_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
     84void C_ccall C_u_2_bignum_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
    8085
    8186void C_ccall C_u_2_fixnum_times(C_word c, C_word self, C_word k, C_word x, C_word y);
     
    9095void C_ccall C_u_bignum_quotient_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
    9196
    92 
    93 void C_ccall C_u_fixnum_minus_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
    94 void C_ccall C_u_bignum_minus_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
    95 void C_ccall C_u_2_bignum_minus(C_word c, C_word self, C_word k, C_word x, C_word y);
    9697C_word C_u_i_bignum_cmp(C_word x, C_word y);
    9798void C_ccall C_u_bignum_abs(C_word c, C_word self, C_word k, C_word big);
  • release/4/numbers/trunk/numbers.scm

    r31420 r31424  
    5353       make-rectangular make-polar real-part imag-part magnitude angle
    5454       bignum? ratnum? cflonum? rectnum? compnum? cintnum? cplxnum?
    55        nan? finite? infinite?)
     55       nan? finite? infinite?
     56
     57       ;; Specialization hooks
     58       @fixnum-2-plus @integer-2-plus @basic-2-plus @fixnum-negate
     59       @fixnum-2-minus @integer-2-minus)
    5660
    5761  (import (except scheme
     
    7579(foreign-declare "#include \"numbers-c.c\"")
    7680
     81;;; THESE SERVE AS SPECIALIZATION ENTRIES.
     82;;; Once this is integrated into core, they can be killed and the
     83;;; C functions inlined directly.  Remember to fix the allocations!
     84(define @basic-2-plus (##core#primitive "C_2_basic_plus"))
     85(define (@fixnum-2-plus a b) (##core#inline_allocate ("C_a_u_i_2_fixnum_plus" 8) a b))
     86(define @integer-2-plus (##core#primitive "C_u_2_integer_plus"))
     87(define (@fixnum-negate x) (##core#inline_allocate ("C_a_u_i_fixnum_negate" 8) x))
     88(define (@fixnum-2-minus a b) (##core#inline_allocate ("C_a_u_i_2_fixnum_minus" 8) a b))
     89(define @integer-2-minus (##core#primitive "C_u_2_integer_minus"))
     90
    7791(define-foreign-variable FIX integer)
    7892(define-foreign-variable FLO integer)
     
    134148(define-inline (%big->flo n) (##core#inline_allocate ("C_a_u_i_big_to_flo" 4) n))
    135149
    136 (define %fix+fix (##core#primitive "C_u_2_fixnum_plus"))
    137 (define %fix+big (##core#primitive "C_u_fixnum_plus_bignum"))
    138 (define %big+big (##core#primitive "C_u_2_bignum_plus"))
    139 
    140 (define %big-neg (##core#primitive "C_u_bignum_negate"))
    141 ;; Can't use fxneg because that breaks in the edge case of negating
    142 ;; the most negative fixnum.  Yes, 2's complement is fun!
    143 (define %fix-neg (##core#primitive "C_u_fixnum_neg"))
    144 
    145 (define %fix-big (##core#primitive "C_u_fixnum_minus_bignum"))
    146 (define %big-fix (##core#primitive "C_u_bignum_minus_fixnum"))
    147 (define %big-big (##core#primitive "C_u_2_bignum_minus"))
    148 
    149150(define %fix*fix (##core#primitive "C_u_2_fixnum_times"))
    150151(define %fix*big (##core#primitive "C_u_fixnum_times_bignum"))
     
    243244
    244245(define (%+ x y)
    245   (switchq (%check-number x)
    246     [FIX
    247      (switchq (%check-number y)
    248        [FIX (%fix+fix x y)]
    249        [FLO (fp+ (%fix->flo x) y)]
    250        [BIG (%fix+big x y)]
    251        ;; a/b + c/d = (a*d + b*c)/(b*d)  [with b = 1]
    252        [RAT (let ((d (rat-denominator y)))
    253               (%/ (%+ (%* x d) (rat-numerator y)) d))]
    254        [COMP (%comp+comp (%make-complex x 0) y)]
    255        [else (bad-number '+ y)] ) ]
    256     [FLO
    257      (switchq (%check-number y)
    258        [FIX (fp+ x (%fix->flo y))]
    259        [FLO (fp+ x y)]
    260        [BIG (fp+ x (%big->flo y))]
    261        ;; a/b + c/d = (a*d + b*c)/(b*d)  [with b = 1]
    262        [RAT (let ((d (rat-denominator y)))
    263               (%/ (%+ (%* x d) (rat-numerator y)) d))]
    264        [COMP (%comp+comp (%make-complex x 0) y)]
    265        [else (bad-number '+ y)] ) ]
    266     [BIG
    267      (switchq (%check-number y)
    268        [FIX (%fix+big y x)]
    269        [FLO (fp+ (%big->flo x) y)]
    270        [BIG (%big+big x y)]
    271        ;; a/b + c/d = (a*d + b*c)/(b*d)  [with b = 1]
    272        [RAT (let ((d (rat-denominator y)))
    273               (%/ (%+ (%* x d) (rat-numerator y)) d))]
    274        [COMP (%comp+comp (%make-complex x 0) y)]
    275        [else (bad-number '+ y)] ) ]
    276     [RAT
    277      (switchq (%check-number y)
    278        [RAT (rat+/- '+ %+ x y)]
    279        [COMP (%comp+comp (%make-complex x 0) y)]
    280        [NONE (bad-number '+ y)]
    281        ;; a/b + c/d = (a*d + b*c)/(b*d)  [with d = 1]
    282        [else (let ((b (rat-denominator x)))
    283               (%/ (%+ (rat-numerator x) (%* b y)) b))] ) ]
    284     [COMP
    285      (switchq (%check-number y)
    286        [COMP (%comp+comp x y)]
    287        [NONE (bad-number '+ y)]
    288        [else (%comp+comp x (%make-complex y 0))] ) ]
    289     [else (bad-number '+ x)] ) )
    290 
    291 (define (%comp+comp x y)
    292   (let ([r (%+ (complex-real x) (complex-real y))]
    293         [i (%+ (complex-imag x) (complex-imag y))] )
    294     (make-complex r i) ) )
     246
     247  (define (%comp+comp x y)
     248    (let ((r (%+ (complex-real x) (complex-real y)))
     249          (i (%+ (complex-imag x) (complex-imag y))) )
     250      (make-complex r i) ) )
     251
     252  (or ((##core#primitive "C_2_basic_plus") x y)
     253      (switchq (%check-number x)
     254        (RAT (switchq (%check-number y)
     255               (RAT (rat+/- '+ %+ x y))
     256               (COMP (%comp+comp (%make-complex x 0) y))
     257               (NONE (bad-number '+ y))
     258               ;; a/b + c/d = (a*d + b*c)/(b*d)  [with d = 1]
     259               (else (let ((b (rat-denominator x)))
     260                       (%/ (%+ (rat-numerator x) (%* b y)) b))) ))
     261        (COMP (switchq (%check-number y)
     262                (COMP (%comp+comp x y))
     263                (NONE (bad-number '+ y))
     264                (else (%comp+comp x (%make-complex y 0))) ))
     265        (NONE (bad-number '+ x))
     266        (else (switchq (%check-number y) ; x is a basic number, y isn't
     267                ;; a/b + c/d = (a*d + b*c)/(b*d)  [with b = 1]
     268                (RAT (let ((d (rat-denominator y)))
     269                       (%/ (%+ (%* x d) (rat-numerator y)) d)))
     270                (COMP (%comp+comp (%make-complex x 0) y))
     271                (else (bad-number '+ y)) ) ) ) ) )
    295272
    296273(define (- arg1 . args)
    297274  (if (null? args)
    298275      (switchq (%check-number arg1)
    299         [FIX (%fix-neg arg1)]
    300         [FLO (fpneg arg1)]
    301         [BIG (%big-neg arg1)]
    302         [RAT (%make-rat (- (rat-numerator arg1)) (rat-denominator arg1))]
    303         [COMP (%make-complex (%- 0 (complex-real arg1)) (%- 0 (complex-imag arg1)))]
    304         [else (bad-number '- arg1)] )
     276        ;; Can't use fxneg because that breaks in the edge case of negating
     277        ;; the most negative fixnum.  Yes, 2's complement is fun!
     278        ;; TODO: change allocation.
     279        (FIX (##core#inline_allocate ("C_a_u_i_fixnum_negate" 8) arg1))
     280        (FLO (fpneg arg1))
     281        (BIG ((##core#primitive "C_u_bignum_negate") arg1))
     282        (RAT (%make-rat (- (rat-numerator arg1))
     283                        (rat-denominator arg1)))
     284        (COMP (%make-complex (%- 0 (complex-real arg1))
     285                             (%- 0 (complex-imag arg1))))
     286        (else (bad-number '- arg1)) )
    305287      (let loop ([args (##sys#slot args 1)] [x (%- arg1 (##sys#slot args 0))])
    306288        (if (null? args)
     
    309291
    310292(define (%- x y)
    311   (switchq (%check-number x)
    312     [FIX
    313      (switchq (%check-number y)
    314        [FIX (let ((n (%fix-neg y)))
    315               (if (= (%check-number n) BIG) ;; fix-neg(most negative) => bignum
    316                   (%fix+big x n)
    317                   (%fix+fix x n)))]
    318        [FLO (fp- (%fix->flo x) y)]
    319        [BIG (%fix-big x y)]
    320        ;; a/b - c/d = (a*d - b*c)/(b*d)  [with b = 1]
    321        [RAT (let ((d (rat-denominator y)))
    322               (%/ (%- (%* x d) (rat-numerator y)) d))]
    323        [COMP (%comp-comp (%make-complex x 0) y)]
    324        [else (bad-number '- y)] ) ]
    325     [FLO
    326      (switchq (%check-number y)
    327        [FIX (fp- x (%fix->flo y))]
    328        [FLO (fp- x y)]
    329        [BIG (fp- x (%big->flo y))]
    330        ;; a/b - c/d = (a*d - b*c)/(b*d)  [with b = 1]
    331        [RAT (let ((d (rat-denominator y)))
    332               (%/ (%- (%* x d) (rat-numerator y)) d))]
    333        [COMP (%comp-comp (%make-complex x 0) y)]
    334        [else (bad-number '- y)] ) ]
    335     [BIG
    336      (switchq (%check-number y)
    337        [FIX (%big-fix x y)]
    338        [FLO (fp- (%big->flo x) y)]
    339        [BIG (%big-big x y)]             
    340        ;; a/b - c/d = (a*d - b*c)/(b*d)  [with b = 1]
    341        [RAT (let ((d (rat-denominator y)))
    342               (%/ (%- (%* x d) (rat-numerator y)) d))]
    343        [COMP (%comp-comp (%make-complex x 0) y)]
    344        [else (bad-number '- y)] ) ]
    345     [RAT
    346      (switchq (%check-number y)
    347        [RAT (rat+/- '- %- x y)]
    348        [COMP (%comp-comp (%make-complex x 0) y)]
    349        [NONE (bad-number '- y)]
    350        ;; a/b - c/d = (a*d - b*c)/(b*d)  [with d = 1]
    351        [else (let ((b (rat-denominator x)))
    352                (%/ (%- (rat-numerator x) (%* b y)) b))] ) ]
    353     [COMP
    354      (switchq (%check-number y)
    355        [COMP (%comp-comp x y)]
    356        [NONE (bad-number '- y)]
    357        [else (%comp-comp x (%make-complex y 0))] ) ]
    358     [else (bad-number '- x)] ) )
    359 
    360 (define (%comp-comp x y)
    361   (let ([r (%- (complex-real x) (complex-real y))]
    362         [i (%- (complex-imag x) (complex-imag y))] )
    363     (make-complex r i) ) )
     293  (define (%comp-comp x y)
     294    (let ((r (%- (complex-real x) (complex-real y)))
     295          (i (%- (complex-imag x) (complex-imag y))) )
     296      (make-complex r i) ) )
     297
     298  (or ((##core#primitive "C_2_basic_minus") x y)
     299      (switchq (%check-number x)
     300        (RAT (switchq (%check-number y)
     301               (RAT (rat+/- '- %- x y))
     302               (COMP (%comp-comp (%make-complex x 0) y))
     303               (NONE (bad-number '- y))
     304               ;; a/b - c/d = (a*d - b*c)/(b*d)  [with d = 1]
     305               (else (let ((b (rat-denominator x)))
     306                       (%/ (%- (rat-numerator x) (%* b y)) b))) ) )
     307        (COMP (switchq (%check-number y)
     308                (COMP (%comp-comp x y))
     309                (NONE (bad-number '- y))
     310                (else (%comp-comp x (%make-complex y 0))) ) )
     311        (NONE (bad-number '- x))
     312        (else (switchq (%check-number y)
     313                ;; a/b - c/d = (a*d - b*c)/(b*d)  [with b = 1]
     314                (RAT (let ((d (rat-denominator y)))
     315                       (%/ (%- (%* x d) (rat-numerator y)) d)))
     316                (COMP (%comp-comp (%make-complex x 0) y))
     317                (else (bad-number '- y)) ) ) )) )
    364318
    365319(define (* . args)
     
    913867(define (%abs x)
    914868  (switchq (%check-number x)
    915     (FIX (if (fx< x 0) (%fix-neg x) x))
     869    ;; TODO: change allocation.
     870    (FIX (if (fx< x 0) (##core#inline_allocate ("C_a_u_i_fixnum_negate" 8) x) x))
    916871    (FLO (##core#inline_allocate ("C_a_i_abs" 4) x))
    917872    (BIG (%big-abs x))
  • release/4/numbers/trunk/numbers.types

    r31422 r31424  
    117117
    118118(numbers#+ (#(procedure #:clean #:enforce) numbers#+ (#!rest (or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
     119           (() (fixnum) '0)
     120           ((fixnum) (fixnum) #(1))
     121           ((float) (float) #(1))
     122           ((number) (number) #(1))
     123           (((struct bignum)) ((struct bignum)) #(1))
     124           (((struct ratnum)) ((struct ratnum)) #(1))
     125           (((struct compnum)) ((struct compnum)) #(1))
    119126           ((float fixnum) (float)
    120127            (##core#inline_allocate
     
    122129             #(1)
    123130             (##core#inline_allocate ("C_a_i_fix_to_flo" 4) #(2))))
    124            ((fixnum float)
    125             (float)
     131           ((fixnum float) (float)
    126132            (##core#inline_allocate
    127133             ("C_a_i_flonum_plus" 4)
     
    129135             #(2)))
    130136           ((float float) (float)
    131             (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2))))
     137            (##core#inline_allocate ("C_a_i_flonum_plus" 4) #(1) #(2)))
     138           ((fixnum fixnum) ((or fixnum (struct bignum)))
     139            (numbers#@fixnum-2-plus #(1) #(2)))
     140           (((or fixnum (struct bignum)) (or fixnum (struct bignum))) ((or fixnum (struct bignum)))
     141            (numbers#@integer-2-plus #(1) #(2)))
     142           (((or fixnum (struct bignum) float) (or fixnum (struct bignum) float)) ((or fixnum (struct bignum) float))
     143            (numbers#@basic-2-plus #(1) #(2))))
    132144
    133145(numbers#add1 (#(procedure #:clean #:enforce) numbers#add1 ((or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
     
    136148
    137149(numbers#- (#(procedure #:clean #:enforce) numbers#- ((or fixnum float (struct bignum) (struct compnum) (struct ratnum)) #!rest (or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
    138            ;; This breaks when negating the smallest possible fixnum
    139            ;; (which negates to itself in 2s complement)
    140            #;((fixnum) (fixnum)
    141               (##core#inline "C_u_fixnum_negate" #(1)))
     150           ((fixnum) ((or fixnum (struct bignum)))
     151            (numbers#@fixnum-negate #(1)))
     152           ((float) (float)
     153            (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1)))
    142154           ((float fixnum) (float)
    143155            (##core#inline_allocate
     
    152164           ((float float) (float)
    153165            (##core#inline_allocate ("C_a_i_flonum_difference" 4) #(1) #(2)))
    154            ((float) (float)
    155             (##core#inline_allocate ("C_a_i_flonum_negate" 4) #(1))))
     166           ((fixnum fixnum) ((or fixnum (struct bignum)))
     167            (numbers#@fixnum-2-minus #(1) #(2)))
     168           (((or fixnum (struct bignum)) (or fixnum (struct bignum))) ((or fixnum (struct bignum)))
     169            (numbers#@integer-2-minus #(1) #(2)))
     170           (((or fixnum (struct bignum) float) (or fixnum (struct bignum) float)) ((or fixnum (struct bignum) float))
     171            (numbers#@basic-2-minus #(1) #(2))))
    156172
    157173(numbers#sub1 (#(procedure #:clean #:enforce) numbers#sub1 ((or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
  • release/4/numbers/trunk/tests/numbers-test.scm

    r31291 r31424  
    8989 (test "-: negate fix" -33 (- 33))
    9090 (test "-: negate most negative fix" min-big (- min-fix))
     91 (test "abs: most negative fix" min-big (abs most-negative-fixnum))
    9192 (test "-: negate flo" -33.2 (- 33.2))
    9293 (test-assert "-: negate rat" (show (- r1)))
Note: See TracChangeset for help on using the changeset viewer.