Changeset 31467 in project


Ignore:
Timestamp:
09/20/14 19:36:48 (5 years ago)
Author:
sjamaan
Message:

numbers: Convert "remainder" to new style

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

Legend:

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

    r31466 r31467  
    7878static void bignum_posneg_bitwise_op(C_word c, C_word self, C_word result);
    7979static void bignum_pospos_bitwise_op(C_word c, C_word self, C_word result);
    80 static void C_ccall quotient_intflo_2(C_word c, C_word self, C_word intnum);
    81 static void C_ccall quotient_intflo_3(C_word c, C_word self, C_word intnum);
     80static void quotient_intflo(C_word c, C_word self, C_word intnum);
     81static void quotient_intflo_2(C_word c, C_word self, C_word intnum);
     82static void remainder_intflo(C_word c, C_word self, C_word intnum);
     83static void remainder_intflo_2(C_word c, C_word self, C_word intnum);
    8284static void bignum_destructive_normalize(C_word target, C_word source, C_word shift_left);
    8385static void bignum_destructive_remainder_unsigned_halfdigit(C_word k, C_word n, C_word d, C_word negp);
     
    17191721
    17201722void C_ccall
    1721 C_u_bignum_remainder_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y)
    1722 {
    1723   C_word negp = C_mk_bool(C_bignum_negativep(x));
    1724    
    1725   y = C_unfix(y);
    1726 
    1727   if (y == 1 || y == -1) {
    1728     C_kontinue(k, C_fix(0));
    1729   } else if (y == C_MOST_NEGATIVE_FIXNUM) {
    1730     /* This is the only case we need to go allocate a bignum for */
    1731     C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *a = ab, k2, size;
    1732 
    1733     y = C_a_u_i_fix_to_big(&a, C_fix(C_MOST_NEGATIVE_FIXNUM));
    1734 
    1735     /* We can skip bignum_divide_2_unsigned because we need no quotient */
    1736     k2 = C_closure(&a, 9, (C_word)bignum_divide_2_unsigned_2, k, x, y,
    1737                    /* Do not return quotient, do return remainder */
    1738                    C_SCHEME_FALSE, C_SCHEME_TRUE, negp,
    1739                    C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
    1740     size = C_fix(C_bignum_size(x) + 1);
    1741     C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
    1742   } else {
    1743     C_word absy = (y < 0) ? -y : y;
    1744      
    1745     if (C_fitsinbignumhalfdigitp(absy)) {
    1746       bignum_destructive_remainder_unsigned_halfdigit(k, x, absy, negp);
    1747     } else {
    1748       C_word kab[C_SIZEOF_CLOSURE(7)], *ka = kab, k2,
    1749              size = C_fix(C_bignum_size(x)) + 1; /* Due to normalization */
     1723C_basic_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
     1724{
     1725  C_word ab[nmax(C_SIZEOF_FLONUM * 2, C_SIZEOF_CLOSURE(5))], *a = ab, k2;
     1726
     1727  if (x & C_FIXNUM_BIT) {
     1728    if (y & C_FIXNUM_BIT) {
     1729      C_kontinue(k, C_u_i_fixnum_remainder_checked_loc(loc, x, y));
     1730    } else if (C_immediatep(y)) {
     1731      C_kontinue(k, C_SCHEME_FALSE);
     1732    } else if (C_block_header(y) == C_FLONUM_TAG) {
     1733      if (C_isnan(C_flonum_magnitude(y)) ||
     1734          C_isinf(C_flonum_magnitude(y)) ||
     1735          !C_truep(C_u_i_fpintegerp(y))) {
     1736        C_kontinue(k, C_SCHEME_FALSE);
     1737      } else {
     1738        x = C_a_i_fix_to_flo(&a, 1, x);
     1739        C_kontinue(k, C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y));
     1740      }
     1741    } else if (C_IS_BIGNUM_TYPE(y)) {
     1742      C_u_integer_remainder(3, (C_word)NULL, k, loc, x, y);
     1743    } else {
     1744      C_kontinue(k, C_SCHEME_FALSE);
     1745    }
     1746  } else if (C_immediatep(x)) {
     1747    C_kontinue(k, C_SCHEME_FALSE);
     1748  } else if (C_block_header(x) == C_FLONUM_TAG) {
     1749    if (C_isnan(C_flonum_magnitude(x)) ||
     1750        C_isinf(C_flonum_magnitude(x)) ||
     1751        !C_truep(C_u_i_fpintegerp(x))) {
     1752        C_kontinue(k, C_SCHEME_FALSE);
     1753    } else if (y & C_FIXNUM_BIT) {
     1754      y = C_a_i_fix_to_flo(&a, 1, y);
     1755      C_kontinue(k, C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y));
     1756    } else if (C_immediatep(y)) {
     1757      C_kontinue(k, C_SCHEME_FALSE);
     1758    } else if (C_block_header(y) == C_FLONUM_TAG) {
     1759      if (C_isnan(C_flonum_magnitude(y)) ||
     1760          C_isinf(C_flonum_magnitude(y)) ||
     1761          !C_truep(C_u_i_fpintegerp(y))) {
     1762        C_kontinue(k, C_SCHEME_FALSE);
     1763      } else {
     1764        C_kontinue(k, C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y));
     1765      }
     1766    } else if (C_IS_BIGNUM_TYPE(y)) {
     1767      if (C_truep(C_u_i_fpintegerp(x))) {
     1768        k2 = C_closure(&a, 5, (C_word)remainder_intflo,
     1769                       k, loc, C_SCHEME_TRUE, y);
     1770        C_u_flo_to_int(1, (C_word)NULL, k2, x);
     1771      } else { /* May overflow... */
     1772        y = C_a_u_i_big_to_flo(&a, 1, y);
     1773        C_kontinue(k, C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y));
     1774      }
     1775    } else {
     1776      C_kontinue(k, C_SCHEME_FALSE);
     1777    }
     1778  } else if (C_IS_BIGNUM_TYPE(x)) {
     1779    if (y & C_FIXNUM_BIT) {
     1780      C_u_integer_remainder(3, (C_word)NULL, k, loc, x, y);
     1781    } else if (C_immediatep(y)) {
     1782      C_kontinue(k, C_SCHEME_FALSE);
     1783    } else if (C_block_header(y) == C_FLONUM_TAG) {
     1784      if (C_truep(C_u_i_fpintegerp(y))) {
     1785        k2 = C_closure(&a, 5, (C_word)remainder_intflo,
     1786                       k, loc, C_SCHEME_FALSE, x);
     1787        C_u_flo_to_int(1, (C_word)NULL, k2, y);
     1788      } else if (C_isnan(C_flonum_magnitude(y)) ||
     1789                 C_isinf(C_flonum_magnitude(y))) {
     1790        C_kontinue(k, C_SCHEME_FALSE);
     1791      } else { /* May overflow... */
     1792        x = C_a_u_i_big_to_flo(&a, 1, x);
     1793        C_kontinue(k, C_a_i_flonum_remainder_checked_loc(&a, 3, loc, x, y));
     1794      }
     1795    } else if (C_IS_BIGNUM_TYPE(y)) {
     1796      C_u_bignum_remainder(2, (C_word)NULL, k, x, y);
     1797    } else {
     1798      C_kontinue(k, C_SCHEME_FALSE);
     1799    }
     1800  } else {
     1801    C_kontinue(k, C_SCHEME_FALSE);
     1802  }
     1803}
     1804
     1805void C_ccall
     1806C_u_integer_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y)
     1807{
     1808  if (!(y & C_FIXNUM_BIT)) { /* y is bignum. */
     1809    if (x & C_FIXNUM_BIT) {
     1810      /* abs(x) < abs(y), so it will always be x except for this case: */
     1811      if (x == C_fix(C_MOST_NEGATIVE_FIXNUM) &&
     1812          C_bignum_negated_fitsinfixnump(y)) {
     1813        C_kontinue(k, C_fix(0));
     1814      } else {
     1815        C_kontinue(k, x);
     1816      }
     1817    } else {
     1818      C_u_bignum_remainder(2, (C_word)NULL, k, x, y);
     1819    }
     1820  } else if (x & C_FIXNUM_BIT) { /* both x and y are fixnum. */
     1821    C_kontinue(k, C_u_i_fixnum_remainder_checked_loc(loc, x, y));
     1822  } else { /* x is bignum, y is fixnum. */
     1823    if (y == C_fix(1) || y == C_fix(-1)) {
     1824      C_kontinue(k, C_fix(0));
     1825    } else if (y == C_fix(0)) {
     1826      char *a;
     1827      C_div_by_zero_error(C_strloc(a, loc));
     1828    } else if (y == C_fix(C_MOST_NEGATIVE_FIXNUM)) {
     1829      /* This is the only case we need to go allocate a bignum for */
     1830      C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *a = ab, k2,
     1831             size, negp = C_mk_bool(C_bignum_negativep(x));
     1832
     1833      y = C_a_u_i_fix_to_big(&a, C_fix(C_MOST_NEGATIVE_FIXNUM));
     1834
     1835      /* We can skip bignum_divide_2_unsigned because we need no quotient */
     1836      k2 = C_closure(&a, 9, (C_word)bignum_divide_2_unsigned_2, k, x, y,
     1837                     /* Do not return quotient, do return remainder */
     1838                     C_SCHEME_FALSE, C_SCHEME_TRUE, negp,
     1839                     C_SCHEME_UNDEFINED, C_SCHEME_UNDEFINED);
     1840      size = C_fix(C_bignum_size(x) + 1);
     1841      C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
     1842    } else {
     1843      C_word absy = (y < 0) ? -C_unfix(y) : C_unfix(y),
     1844             negp = C_mk_bool(C_bignum_negativep(x));
     1845
     1846      if (C_fitsinbignumhalfdigitp(absy)) {
     1847        bignum_destructive_remainder_unsigned_halfdigit(k, x, absy, negp);
     1848      } else {
     1849        C_word kab[C_SIZEOF_CLOSURE(7)], *ka = kab, k2,
     1850               size = C_fix(C_bignum_size(x)) + 1; /* Due to normalization */
    17501851     
    1751       k2 = C_closure(&ka, 7, (C_word)bignum_destructive_divide_unsigned_digit,
    1752                      k, x, C_fix(absy),
    1753                      /* Do not return quotient, do return remainder */
    1754                      C_SCHEME_FALSE, C_SCHEME_TRUE, negp);
    1755       C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
    1756     }
    1757   }
    1758 }
    1759 
    1760 void C_ccall
    1761 C_u_bignum_remainder_bignum(C_word c, C_word self, C_word k, C_word x, C_word y)
     1852        k2 = C_closure(&ka, 7, (C_word)bignum_destructive_divide_unsigned_digit,
     1853                       k, x, C_fix(absy),
     1854                       /* Do not return quotient, do return remainder */
     1855                       C_SCHEME_FALSE, C_SCHEME_TRUE, negp);
     1856        C_allocate_bignum(3, (C_word)NULL, k2, size, negp, C_SCHEME_FALSE);
     1857      }
     1858    }
     1859  }
     1860}
     1861
     1862static void remainder_intflo(C_word c, C_word self, C_word intnum)
     1863{
     1864  C_word k = C_block_item(self, 1),
     1865         loc = C_block_item(self, 2),
     1866         intnum_is_x =  C_block_item(self, 3),
     1867         other_arg = C_block_item(self, 4),
     1868         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
     1869 
     1870  k2 = C_closure(&ka, 2, (C_word)remainder_intflo_2, k);
     1871  if (C_truep(intnum_is_x))
     1872    C_u_integer_remainder(3, (C_word)NULL, k2, loc, intnum, other_arg);
     1873  else
     1874    C_u_integer_remainder(3, (C_word)NULL, k2, loc, other_arg, intnum);
     1875}
     1876
     1877static void remainder_intflo_2(C_word c, C_word self, C_word x)
     1878{
     1879   C_word k = C_block_item(self, 1),
     1880          ab[C_SIZEOF_FLONUM], *a = ab;
     1881   if (x & C_FIXNUM_BIT) C_kontinue(k, C_a_i_fix_to_flo(&a, 1, x));
     1882   else C_kontinue(k, C_a_u_i_big_to_flo(&a, 1, x));
     1883}
     1884
     1885void C_ccall
     1886C_u_bignum_remainder(C_word c, C_word self, C_word k, C_word x, C_word y)
    17621887{
    17631888  C_word ab[C_SIZEOF_FIX_BIGNUM+C_SIZEOF_CLOSURE(9)], *a = ab, k2, size, negp;
     
    18441969    } else if (C_IS_BIGNUM_TYPE(y)) {
    18451970      if (C_truep(C_u_i_fpintegerp(x))) {
    1846         k2 = C_closure(&a, 5, (C_word)quotient_intflo_2,
     1971        k2 = C_closure(&a, 5, (C_word)quotient_intflo,
    18471972                       k, loc, C_SCHEME_TRUE, y);
    18481973        C_u_flo_to_int(1, (C_word)NULL, k2, x);
     
    18611986    } else if (C_block_header(y) == C_FLONUM_TAG) {
    18621987      if (C_truep(C_u_i_fpintegerp(y))) {
    1863         k2 = C_closure(&a, 5, (C_word)quotient_intflo_2,
     1988        k2 = C_closure(&a, 5, (C_word)quotient_intflo,
    18641989                       k, loc, C_SCHEME_FALSE, x);
    18651990        C_u_flo_to_int(1, (C_word)NULL, k2, y);
     
    18812006}
    18822007
    1883 static void C_ccall quotient_intflo_2(C_word c, C_word self, C_word intnum)
     2008static void quotient_intflo(C_word c, C_word self, C_word intnum)
    18842009{
    18852010  C_word k = C_block_item(self, 1),
     
    18892014         kab[C_SIZEOF_CLOSURE(2)], *ka = kab, k2;
    18902015 
    1891   k2 = C_closure(&ka, 2, (C_word)quotient_intflo_3, k);
     2016  k2 = C_closure(&ka, 2, (C_word)quotient_intflo_2, k);
    18922017  if (C_truep(intnum_is_x))
    18932018    C_u_integer_quotient(3, (C_word)NULL, k2, loc, intnum, other_arg);
     
    18962021}
    18972022
    1898 static void C_ccall quotient_intflo_3(C_word c, C_word self, C_word x)
     2023static void quotient_intflo_2(C_word c, C_word self, C_word x)
    18992024{
    19002025   C_word k = C_block_item(self, 1),
  • release/4/numbers/trunk/numbers-c.h

    r31466 r31467  
    109109void C_ccall C_u_bignum_quotient(C_word c, C_word self, C_word k, C_word x, C_word y);
    110110
     111void C_ccall C_basic_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
     112void C_ccall C_u_integer_remainder(C_word c, C_word self, C_word k, C_word loc, C_word x, C_word y);
     113void C_ccall C_u_bignum_remainder(C_word c, C_word self, C_word k, C_word x, C_word y);
     114
    111115void C_ccall C_u_bignum_divrem_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
    112116void C_ccall C_u_bignum_divrem_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
    113 void C_ccall C_u_bignum_remainder_fixnum(C_word c, C_word self, C_word k, C_word x, C_word y);
    114 void C_ccall C_u_bignum_remainder_bignum(C_word c, C_word self, C_word k, C_word x, C_word y);
    115117
    116118C_word C_u_i_bignum_cmp(C_word x, C_word y);
     
    158160
    159161  /* TODO: Maybe add C_a_i_structureN, like C_a_i_vectorN? */
     162  /* TODO: Those exist and are called C_a_i_recordN */
    160163  return C_structure(ptr, 2, C_block_item(tagvec, BIG_TAG), p0);
    161164}
     
    239242}
    240243
     244C_inline C_word C_u_i_fixnum_remainder_checked_loc(C_word loc, C_word x, C_word y)
     245{
     246  char *a;
     247  if (y == C_fix(0)) {
     248    C_div_by_zero_error(C_strloc(a, loc));
     249  } else {
     250    x = C_unfix(x);
     251    y = C_unfix(y);
     252    return C_fix(x - ((x / y) * y));
     253  }
     254}
     255
    241256/* More weirdness: the other flonum_quotient macros and inline functions
    242257 * do not compute the quotient but the "plain" division!
     
    255270  }
    256271}
     272
     273C_inline C_word
     274C_a_i_flonum_remainder_checked_loc(C_word **ptr, int c, C_word loc, C_word x, C_word y)
     275{
     276  char *a; /* Can't use ptr, it may not be big enough */
     277  double dx = C_flonum_magnitude(x),
     278         dy = C_flonum_magnitude(y), r;
     279
     280  if(dy == 0.0) {
     281    C_div_by_zero_error(C_strloc(a, loc));
     282  } else {
     283    modf(dx / dy, &r);
     284    return C_flonum(ptr, dx - r * dy);
     285  }
     286}
  • release/4/numbers/trunk/numbers.scm

    r31466 r31467  
    6161       @fixnum-2-minus @integer-2-minus @basic-2-minus @bignum-2-minus
    6262       @fixnum-2-times @integer-2-times @basic-2-times @bignum-2-times
    63        @fixnum-quotient @flonum-quotient @integer-quotient @basic-quotient @bignum-quotient)
     63       @fixnum-quotient @flonum-quotient @integer-quotient @basic-quotient @bignum-quotient
     64       @fixnum-remainder @flonum-remainder @integer-remainder @basic-remainder @bignum-remainder)
    6465
    6566  (import (except scheme
     
    117118(define @bignum-quotient (##core#primitive "C_u_bignum_quotient"))
    118119
     120(define @basic-remainder (##core#primitive "C_basic_remainder"))
     121(define (@fixnum-remainder loc a b) (##core#inline "C_u_i_fixnum_remainder_checked_loc" loc a b))
     122(define (@flonum-remainder loc a b) (##core#inline_allocate ("C_a_i_flonum_remainder_checked_loc" 4) loc a b))
     123(define @integer-remainder (##core#primitive "C_u_integer_remainder"))
     124(define @bignum-remainder (##core#primitive "C_u_bignum_remainder"))
     125
    119126(define-foreign-variable FIX integer)
    120127(define-foreign-variable FLO integer)
     
    175182(define-inline (%fix->flo n) (##core#inline_allocate ("C_a_i_fix_to_flo" 4) n))
    176183(define-inline (%big->flo n) (##core#inline_allocate ("C_a_u_i_big_to_flo" 4) n))
    177 
    178 (define %big-remainder-fix (##core#primitive "C_u_bignum_remainder_fixnum"))
    179 (define %big-remainder-big (##core#primitive "C_u_bignum_remainder_bignum"))
    180184
    181185(define %big-divrem-fix (##core#primitive "C_u_bignum_divrem_fixnum"))
     
    812816
    813817;; Knuth, 4.5.1
     818;; TODO: Use integer-quotient here
    814819(define (rat+/- loc op x y)
    815820  (let ((a (ratnum-numerator x)) (b (ratnum-denominator x))
     
    986991
    987992(define (%remainder loc x y)
    988   (switchq (%check-number x)
    989     [FIX (switchq (%check-number y)
    990            [FIX (fx- x (fx* (fx/ x y) y))]
    991            [FLO (let ((flx (%fix->flo x)))
    992                   (if (%flo-integer? y)
    993                       (fp- flx (fp* (##sys#truncate (fp/ flx y)) y))
    994                       (bad-integer loc y)))]
    995            ;; If abs(x) < abs(y), then remainder is always just x
    996            ;; except when y happens to be -most-negative-fixnum
    997            [BIG (if (and (eq? most-negative-fixnum x) (= (negate x) y)) 0 x)]
    998            [else (bad-integer loc y)])]
    999     [FLO (unless (%flo-integer? x)
    1000            (bad-integer loc x))
    1001          (switchq (%check-number y)
    1002            [FLO (if (%flo-integer? y)
    1003                     (fp- x (fp* (##sys#truncate (fp/ x y)) y))
    1004                     (bad-integer loc y))]
    1005            [FIX (let ((fly (%fix->flo (fix-div/0 x y loc))))
    1006                   (fp- x (fp* (##sys#truncate (fp/ x fly)) fly)))]
    1007            [BIG (%exact->inexact (%remainder loc (%flo->integer x) y))]
    1008            [else (bad-integer loc y)])]
    1009     [BIG (switchq (%check-number y)
    1010            [FIX (%big-remainder-fix x (fix-div/0 x y loc))]
    1011            [FLO (if (%flo-integer? y)
    1012                     (%exact->inexact (%remainder loc x (%flo->integer y)))
    1013                     (bad-integer loc y))]
    1014            [BIG (%big-remainder-big x y)]
    1015            [else (bad-integer loc y)])]
    1016     [else (bad-integer loc x)]) )
     993  (or ((##core#primitive "C_basic_remainder") loc x y)
     994      (cond ((number? x)        ; XXX What about non-integral flonums?
     995             (if (extended-number? y)
     996                 (bad-integer loc y)
     997                 (bad-number loc y)))
     998            ((number? y)
     999             (if (extended-number? x)
     1000                 (bad-integer loc x)
     1001                 (bad-number loc x)))
     1002            (else (bad-number loc y)))))
    10171003
    10181004(define (remainder x y) (%remainder 'remainder x y))
     
    10211007;; Modulo's sign follows y  (whereas remainder's sign follows x)
    10221008(define (%modulo loc x y)
    1023    (let ((r (%remainder loc x y)))
    1024       (if (%> y 0 loc)
    1025           (if (%< r 0 loc)
    1026               (%+ r y)
    1027               r)
    1028           (if (%> r 0 loc)
    1029               (%+ r y)
    1030               r))))
     1009  (let ((r (%remainder loc x y)))
     1010    (if (%> y 0 loc)
     1011        (if (%< r 0 loc)
     1012            (%+ r y)
     1013            r)
     1014        (if (%> r 0 loc)
     1015            (%+ r y)
     1016            r))))
    10311017
    10321018(define (modulo x y) (%modulo 'modulo x y))
     
    10511037           [BIG (if (%flo-integer? x)
    10521038                    (receive (div rem)
    1053                       (%quotient&remainder loc (%flo->integer x) y)
     1039                        (%quotient&remainder loc (%flo->integer x) y)
    10541040                      (values (%exact->inexact div) (%exact->inexact rem)))
    10551041                    (bad-integer loc x))]
     
    10591045           [FLO (if (%flo-integer? y)
    10601046                    (receive (div rem)
    1061                       (%quotient&remainder loc x (%flo->integer y))
     1047                        (%quotient&remainder loc x (%flo->integer y))
    10621048                      (values (%exact->inexact div) (%exact->inexact rem)))
    10631049                    (bad-integer loc y))]
     
    11151101                           q)
    11161102                       d)))
    1117              (if (%exact? e)
     1103            (if (%exact? e)
    11181104                e
    11191105                (bad-inexact loc x)))
     
    12211207           [FIX (if (eq? y 0) x (fxgcd y (%remainder loc x y)))]
    12221208           [FLO (if (fp= y 0.0) x (fpgcd y (%remainder loc x y)))]
    1223            [BIG (%gcd-0 loc y (%big-remainder-big x y))]
     1209           [BIG (%gcd-0 loc y ((##core#primitive "C_u_bignum_remainder") x y))]
    12241210           [else (bad-integer loc y)])]
    12251211    [else (bad-integer loc x)]) )
     
    13321318    (NONE (bad-number 'exp n))
    13331319    (COMP (%* (##core#inline_allocate ("C_a_i_exp" 4) (compnum-real n))
    1334               (let ((p (compnum-imag n)))
    1335                 (make-complex
    1336                 (##core#inline_allocate ("C_a_i_cos" 4) p)
    1337                 (##core#inline_allocate ("C_a_i_sin" 4) p) ) ) ) )
     1320              (let ((p (compnum-imag n)))
     1321                (make-complex
     1322                (##core#inline_allocate ("C_a_i_cos" 4) p)
     1323                (##core#inline_allocate ("C_a_i_sin" 4) p) ) ) ) )
    13381324    (else (##core#inline_allocate ("C_a_i_exp" 4) (%exact->inexact n)) ) ))
    13391325
     
    13641350    (NONE (bad-number 'sin n))
    13651351    (COMP (let ((in (%* %i n)))
    1366             (%/ (%- (%exp in) (%exp (%- 0 in))) %i2)))
     1352            (%/ (%- (%exp in) (%exp (%- 0 in))) %i2)))
    13671353    (else (##core#inline_allocate ("C_a_i_sin" 4) (%exact->inexact n)) ) ))
    13681354
     
    13731359    (NONE (bad-number 'cos n))
    13741360    (COMP (let ((in (%* %i n)))
    1375             (%/ (%+ (%exp in) (%exp (%- 0 in))) 2) ) )
     1361            (%/ (%+ (%exp in) (%exp (%- 0 in))) 2) ) )
    13761362    (else (##core#inline_allocate ("C_a_i_cos" 4) (%exact->inexact n)) ) ) )
    13771363
     
    14171403    (NONE (bad-number 'atan n))
    14181404    (COMP (if b
    1419               (bad-real 'atan n)
    1420               (let ((in (%* %i n)))
    1421                 (%/ (%- (%log (%+ 1 in)) (%log (%- 1 in))) %i2) ) ) )
     1405              (bad-real 'atan n)
     1406              (let ((in (%* %i n)))
     1407                (%/ (%- (%log (%+ 1 in)) (%log (%- 1 in))) %i2) ) ) )
    14221408    (else (if b
    14231409              (##core#inline_allocate ("C_a_i_atan2" 4) (%exact->inexact n) (%exact->inexact b))
     
    14551441    (NONE (bad-number 'sqrt n))
    14561442    (COMP (let ((p (%/ (%angle n) 2))
    1457                 (m (##core#inline_allocate ("C_a_i_sqrt" 4) (%magnitude n))) )
    1458             (make-complex (%* m (%cos p)) (%* m (%sin p)) ) ) )
     1443                (m (##core#inline_allocate ("C_a_i_sqrt" 4) (%magnitude n))) )
     1444            (make-complex (%* m (%cos p)) (%* m (%sin p)) ) ) )
    14591445    (RAT (let ((num (ratnum-numerator n))
    14601446               (den (ratnum-denominator n)))
    14611447           (if (and (>= num 0) (>= den 0))
    14621448               (receive (ns^2 nr)
    1463                  (%exact-integer-sqrt loc num)
     1449                   (%exact-integer-sqrt loc num)
    14641450                 (if (eq? nr 0)
    14651451                     (receive (ds^2 dr)
    1466                        (%exact-integer-sqrt loc den)
     1452                         (%exact-integer-sqrt loc den)
    14671453                       (if (eq? dr 0)
    14681454                           (%/ ns^2 ds^2)
     
    14781464      ((integer? n)
    14791465       (receive (s^2 r)
    1480          (%exact-integer-sqrt loc (%->integer loc n))
     1466           (%exact-integer-sqrt loc (%->integer loc n))
    14811467         (if (eq? 0 r)
    14821468             (if (exact? n) s^2 (%exact->inexact s^2))
     
    15281514      (let lp ((res 1) (e2 e))
    15291515        (cond
    1530           ((eq? e2 0) res)
    1531           ((even? e2) ; recursion is faster than iteration here
    1532            (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
    1533           (else
    1534            (lp (%* res base) (%- e2 1)))))))
     1516         ((eq? e2 0) res)
     1517         ((even? e2) ; recursion is faster than iteration here
     1518          (%* res (square (lp 1 (arithmetic-shift e2 -1)))))
     1519         (else
     1520          (lp (%* res base) (%- e2 1)))))))
    15351521
    15361522(define (expt a b)
     
    15541540                      (%expt-0 (%fix->flo a) (%rat->flo b))
    15551541                      (receive (ds^n r)
    1556                         (%exact-integer-nth-root 'expt a (ratnum-denominator b))
     1542                          (%exact-integer-nth-root 'expt a (ratnum-denominator b))
    15571543                        (if (eq? r 0)
    15581544                            (expt ds^n (ratnum-numerator b))
     
    15611547                      (%expt-0 (%big->flo a) (%rat->flo b))
    15621548                      (receive (ds^n r)
    1563                         (%exact-integer-nth-root 'expt a (ratnum-denominator b))
     1549                          (%exact-integer-nth-root 'expt a (ratnum-denominator b))
    15641550                        (if (eq? r 0)
    15651551                            (expt ds^n (ratnum-numerator b))
     
    15891575  (switchq (%check-number n)
    15901576    (FIX (cond ((eq? 0 n) 0)
    1591                ((fx< n 0) -1)
    1592                (else 1) ) )
     1577               ((fx< n 0) -1)
     1578               (else 1) ) )
    15931579    (FLO (cond ((fp= n 0.0) 0.0)
    1594                ((fp< n 0.0) -1.0)
    1595                (else 1.0) ) )
     1580               ((fp< n 0.0) -1.0)
     1581               (else 1.0) ) )
    15961582    (BIG (if (%big-negative? n) -1 1)) ; Can't be 0; it would be a fixnum then
    15971583    (RAT (signum (ratnum-numerator n)))
     
    16041590    (FLO (if (%integer? n)
    16051591             (%flo->integer n)
    1606              (bad-integer loc n)))
     1592             (bad-integer loc n)))
    16071593    (BIG n)
    16081594    (else (bad-integer loc n)) ) )
     
    16571643        (switchq (%check-number n)
    16581644          (FIX (number->string-0 n base))
    1659           (FLO (cond
     1645          (FLO (cond
    16601646                ((fp= n -inf.0) "-inf.0") ; Core does not handle these right
    16611647                ((fp= n +inf.0) "+inf.0")
    16621648                ((not (fp= n n)) "+nan.0")
    16631649                (else (number->string-0 n base))))
    1664           (BIG (%big->string n base))
    1665           (RAT (string-append (numstr (ratnum-numerator n))
     1650          (BIG (%big->string n base))
     1651          (RAT (string-append (numstr (ratnum-numerator n))
    16661652                              "/"
    16671653                              (numstr (ratnum-denominator n))))
    1668           (COMP (let ((r (compnum-real n))
    1669                       (i (compnum-imag n)) )
    1670                   (string-append
     1654          (COMP (let ((r (compnum-real n))
     1655                      (i (compnum-imag n)) )
     1656                  (string-append
    16711657                   (numstr r)
    16721658                   ;; The infinities and NaN always print their sign
    16731659                   (if (and (finite? i) (%> i 0 'number->string)) "+" "")
    16741660                   (numstr i) "i") ) )
    1675           (else (bad-number 'number->string n)) ) ) ) ) )
     1661          (else (bad-number 'number->string n)) ) ) ) ) )
    16761662
    16771663(define number->string %number->string)
     
    16911677               0
    16921678               (cond
    1693                 ((> e +maximum-allowed-exponent+)
    1694                   (and (eq? exactness 'i)
    1695                        (cond ((zero? value) 0.0)
    1696                              ((> value 0.0) +inf.0)
    1697                              (else -inf.0))))
    1698                 ((< e (negate +maximum-allowed-exponent+))
    1699                   (and (eq? exactness 'i) +0.0))
    1700                  (else (%* value (expt 10 e)))))))
     1679                ((> e +maximum-allowed-exponent+)
     1680                 (and (eq? exactness 'i)
     1681                      (cond ((zero? value) 0.0)
     1682                            ((> value 0.0) +inf.0)
     1683                            (else -inf.0))))
     1684                ((< e (negate +maximum-allowed-exponent+))
     1685                 (and (eq? exactness 'i) +0.0))
     1686                (else (%* value (expt 10 e)))))))
    17011687  (let* ((len (##sys#size str))
    17021688         (r..9 (integer->char (fx+ (char->integer #\0) radix)))
     
    18151801                           ;; *really* need exact values, then fail at the end.
    18161802                           (and (not (eq? exactness 'e))
    1817                             (case (signum num)
    1818                               ((-1) (cons -inf.0 (cdr d)))
    1819                               ((0)  (cons +nan.0 (cdr d)))
    1820                               ((+1) (cons +inf.0 (cdr d))))))))
     1803                                (case (signum num)
     1804                                  ((-1) (cons -inf.0 (cdr d)))
     1805                                  ((0)  (cons +nan.0 (cdr d)))
     1806                                  ((+1) (cons +inf.0 (cdr d))))))))
    18211807                    (else end))))))
    18221808         (scan-real
  • release/4/numbers/trunk/numbers.types

    r31466 r31467  
    343343
    344344(numbers#remainder (#(procedure #:clean #:enforce) numbers#remainder ((or fixnum float (struct bignum) (struct compnum) (struct ratnum)) (or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
    345                    ;;XXX flonum/mixed case
    346                    ;;XXX is this correct?
    347                    ((fixnum fixnum) (fixnum)
    348                     (##core#inline "C_fixnum_modulo" #(1) #(2))))
     345                  ;; XXX Disabled: it may return #f for non-integral flonums
     346                  #;((float float) (float)
     347                   (numbers#@flonum-remainder 'remainder #(1) #(2)))
     348                  ;; TODO: mixed fix/flo cases?
     349                  ((fixnum fixnum) (fixnum)
     350                   (numbers#@fixnum-remainder 'remainder #(1) #(2)))
     351                  (((struct bignum) (struct bignum)) ((struct bignum))
     352                   (numbers#@bignum-remainder 'remainder #(1) #(2)))
     353                  (((or fixnum (struct bignum)) (or fixnum (struct bignum))) ((or fixnum (struct bignum)))
     354                   (numbers#@integer-remainder 'remainder #(1) #(2)))
     355                  ;; XXX Disabled: it may return #f for non-integral flonums
     356                  #;(((or fixnum (struct bignum) float) (or fixnum (struct bignum) float)) ((or fixnum (struct bignum) float))
     357                   (numbers#@basic-remainder 'remainder #(1) #(2))))
    349358
    350359;; Identical to the above
    351360(numbers#truncate-remainder (#(procedure #:clean #:enforce) numbers#truncate-remainder ((or fixnum float (struct bignum) (struct compnum) (struct ratnum)) (or fixnum float (struct bignum) (struct compnum) (struct ratnum))) (or fixnum float (struct bignum) (struct compnum) (struct ratnum)))
    352                    ;;XXX flonum/mixed case
    353                    ;;XXX is this correct?
    354                    ((fixnum fixnum) (fixnum)
    355                     (##core#inline "C_fixnum_modulo" #(1) #(2))))
     361                  ;; XXX Disabled: it may return #f for non-integral flonums
     362                  #;((float float) (float)
     363                   (numbers#@flonum-remainder 'truncate-remainder #(1) #(2)))
     364                  ;; TODO: mixed fix/flo cases?
     365                  ((fixnum fixnum) (fixnum)
     366                   (numbers#@fixnum-remainder 'truncate-remainder #(1) #(2)))
     367                  (((struct bignum) (struct bignum)) ((struct bignum))
     368                   (numbers#@bignum-remainder 'truncate-remainder #(1) #(2)))
     369                  (((or fixnum (struct bignum)) (or fixnum (struct bignum))) ((or fixnum (struct bignum)))
     370                   (numbers#@integer-remainder 'truncate-remainder #(1) #(2)))
     371                  ;; XXX Disabled: it may return #f for non-integral flonums
     372                  #;(((or fixnum (struct bignum) float) (or fixnum (struct bignum) float)) ((or fixnum (struct bignum) float))
     373                   (numbers#@basic-remainder 'truncate-remainder #(1) #(2))))
    356374
    357375(numbers#modulo
Note: See TracChangeset for help on using the changeset viewer.