Back to index

plt-scheme  4.2.1
numarith.c
Go to the documentation of this file.
00001 /*
00002   MzScheme
00003   Copyright (c) 2004-2009 PLT Scheme Inc.
00004   Copyright (c) 2000-2001 Matthew Flatt
00005 
00006     This library is free software; you can redistribute it and/or
00007     modify it under the terms of the GNU Library General Public
00008     License as published by the Free Software Foundation; either
00009     version 2 of the License, or (at your option) any later version.
00010 
00011     This library is distributed in the hope that it will be useful,
00012     but WITHOUT ANY WARRANTY; without even the implied warranty of
00013     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
00014     Library General Public License for more details.
00015 
00016     You should have received a copy of the GNU Library General Public
00017     License along with this library; if not, write to the Free
00018     Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
00019     Boston, MA 02110-1301 USA.
00020 
00021   libscheme
00022   Copyright (c) 1994 Brent Benson
00023   All rights reserved.
00024 */
00025 
00026 #include "schpriv.h"
00027 #include "nummacs.h"
00028 #include <math.h>
00029 
00030 static Scheme_Object *plus (int argc, Scheme_Object *argv[]);
00031 static Scheme_Object *minus (int argc, Scheme_Object *argv[]);
00032 static Scheme_Object *mult (int argc, Scheme_Object *argv[]);
00033 static Scheme_Object *div_prim (int argc, Scheme_Object *argv[]);
00034 static Scheme_Object *quotient (int argc, Scheme_Object *argv[]);
00035 static Scheme_Object *rem_prim (int argc, Scheme_Object *argv[]);
00036 static Scheme_Object *quotient_remainder (int argc, Scheme_Object *argv[]);
00037 
00038 #define zeroi scheme_exact_zero
00039 
00040 void scheme_init_numarith(Scheme_Env *env)
00041 {
00042   Scheme_Object *p;
00043 
00044   p = scheme_make_folding_prim(scheme_add1, "add1", 1, 1, 1);
00045   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00046   scheme_add_global_constant("add1", p, env);
00047 
00048   p = scheme_make_folding_prim(scheme_sub1, "sub1", 1, 1, 1);
00049   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00050   scheme_add_global_constant("sub1", p, env);
00051 
00052   p = scheme_make_folding_prim(plus, "+", 0, -1, 1);
00053   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00054   scheme_add_global_constant("+", p, env);
00055 
00056   p = scheme_make_folding_prim(minus, "-", 1, -1, 1);
00057   SCHEME_PRIM_PROC_FLAGS(p) |= (SCHEME_PRIM_IS_BINARY_INLINED
00058                                 | SCHEME_PRIM_IS_UNARY_INLINED);
00059   scheme_add_global_constant("-", p, env);
00060 
00061   p = scheme_make_folding_prim(mult, "*", 0, -1, 1);
00062   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00063   scheme_add_global_constant("*", p, env);
00064 
00065   p = scheme_make_folding_prim(div_prim, "/", 1, -1, 1);
00066   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_BINARY_INLINED;
00067   scheme_add_global_constant("/", p, env);
00068 
00069   p = scheme_make_folding_prim(scheme_abs, "abs", 1, 1, 1);
00070   SCHEME_PRIM_PROC_FLAGS(p) |= SCHEME_PRIM_IS_UNARY_INLINED;
00071   scheme_add_global_constant("abs", p, env);
00072 
00073   scheme_add_global_constant("quotient", 
00074                           scheme_make_folding_prim(quotient,
00075                                                 "quotient", 
00076                                                 2, 2, 1),
00077                           env);
00078   scheme_add_global_constant("remainder", 
00079                           scheme_make_folding_prim(rem_prim,
00080                                                 "remainder", 
00081                                                 2, 2, 1),
00082                           env);
00083   scheme_add_global_constant("quotient/remainder", 
00084                           scheme_make_prim_w_arity2(quotient_remainder,
00085                                                  "quotient/remainder", 
00086                                                  2, 2,
00087                                                  2, 2),
00088                           env);
00089   scheme_add_global_constant("modulo", 
00090                           scheme_make_folding_prim(scheme_modulo,
00091                                                 "modulo", 
00092                                                 2, 2, 1),
00093                           env);
00094 }
00095 
00096 Scheme_Object *
00097 scheme_add1 (int argc, Scheme_Object *argv[])
00098 {
00099   Scheme_Type t;
00100   Scheme_Object *o = argv[0];
00101 
00102   if (SCHEME_INTP(o)) {
00103     long v;
00104     v = SCHEME_INT_VAL(o);
00105     if (v < 0x3FFFFFFF)
00106       return scheme_make_integer(v + 1);
00107     else {
00108       Small_Bignum b;
00109       return scheme_bignum_add1(scheme_make_small_bignum(v, &b));
00110     }
00111   }
00112   t = _SCHEME_TYPE(o);
00113 #ifdef MZ_USE_SINGLE_FLOATS
00114   if (t == scheme_float_type)
00115     return scheme_make_float(SCHEME_FLT_VAL(o) + 1.0f);
00116 #endif
00117   if (t == scheme_double_type)
00118     return scheme_make_double(SCHEME_DBL_VAL(o) + 1.0);
00119   if (t == scheme_bignum_type)
00120     return scheme_bignum_add1(o);
00121   if (t == scheme_rational_type)
00122     return scheme_rational_add1(o);
00123   if (t == scheme_complex_type)
00124     return scheme_complex_add1(o);
00125 
00126   NEED_NUMBER(add1);
00127 
00128   ESCAPED_BEFORE_HERE;
00129 }
00130 
00131 Scheme_Object *
00132 scheme_sub1 (int argc, Scheme_Object *argv[])
00133 {
00134   Scheme_Type t;
00135   Scheme_Object *o = argv[0];
00136 
00137   if (SCHEME_INTP(o)) {
00138     long v;
00139     v = SCHEME_INT_VAL(o);
00140     if (v > -(0x3FFFFFFF))
00141       return scheme_make_integer(SCHEME_INT_VAL(o) - 1);
00142     else {
00143       Small_Bignum b;
00144       return scheme_bignum_sub1(scheme_make_small_bignum(v, &b));
00145     }
00146   }
00147   t = _SCHEME_TYPE(o);
00148 #ifdef MZ_USE_SINGLE_FLOATS
00149   if (t == scheme_float_type)
00150     return scheme_make_float(SCHEME_FLT_VAL(o) - 1.0f);
00151 #endif
00152   if (t == scheme_double_type)
00153     return scheme_make_double(SCHEME_DBL_VAL(o) - 1.0);
00154   if (t == scheme_bignum_type)
00155     return scheme_bignum_sub1(o);
00156   if (t == scheme_rational_type)
00157     return scheme_rational_sub1(o);
00158   if (t == scheme_complex_type)
00159     return scheme_complex_sub1(o);
00160   
00161   NEED_NUMBER(sub1);
00162 
00163   ESCAPED_BEFORE_HERE;
00164 }
00165 
00166 #define F_ADD(x,y) scheme_make_double(x + y)
00167 #define F_SUBTRACT(x,y) scheme_make_double(x - y)
00168 #define F_MULTIPLY(x,y) scheme_make_double(x * y)
00169 #define DIVIDE(x,y) scheme_make_fixnum_rational(x, y)
00170 #define F_DIVIDE(x,y) scheme_make_double((double)x / (double)y)
00171 
00172 #define FS_ADD(x,y) scheme_make_float(x + y)
00173 #define FS_SUBTRACT(x,y) scheme_make_float(x - y)
00174 #define FS_MULTIPLY(x,y) scheme_make_float(x * y)
00175 #define FS_DIVIDE(x,y) scheme_make_float((float)x / (float)y)
00176 
00177 static Scheme_Object *ADD_slow(long a, long b)
00178 {
00179   Small_Bignum sa, sb;
00180   return scheme_bignum_add(scheme_make_small_bignum(a, &sa),
00181                            scheme_make_small_bignum(b, &sb));
00182 }
00183 
00184 static Scheme_Object *ADD(long a, long b)
00185 {
00186   long r;
00187   Scheme_Object *o;
00188 
00189   r = a + b;
00190 
00191   o = scheme_make_integer(r);
00192   r = SCHEME_INT_VAL(o);
00193 
00194   if (b == r - a)
00195     return o;
00196   else
00197     return ADD_slow(a, b);
00198 }
00199 
00200 static Scheme_Object *SUBTRACT_slow(long a, long b)
00201 {
00202   Small_Bignum sa, sb;
00203   return scheme_bignum_subtract(scheme_make_small_bignum(a, &sa),
00204                                 scheme_make_small_bignum(b, &sb));  
00205 }
00206 
00207 static Scheme_Object *SUBTRACT(long a, long b)
00208 {
00209   long r;
00210   Scheme_Object *o;
00211 
00212   r = a - b;
00213 
00214   o = scheme_make_integer(r);
00215   r = SCHEME_INT_VAL(o);
00216 
00217   if (a == r + b)
00218     return o;
00219   else
00220     return SUBTRACT_slow(a, b);
00221 }
00222 
00223 static Scheme_Object *MULTIPLY(long a, long b)
00224 {
00225   long r;
00226   Scheme_Object *o;
00227 
00228   if (!b)
00229     return zeroi;
00230 
00231   r = a * b;
00232 
00233   o = scheme_make_integer(r);
00234   r = SCHEME_INT_VAL(o);
00235 
00236   if (a == r / b)
00237     return o;
00238   else {
00239     Small_Bignum sa, sb;
00240     return scheme_bignum_multiply(scheme_make_small_bignum(a, &sa),
00241                               scheme_make_small_bignum(b, &sb));
00242   }
00243 }
00244 
00245 static Scheme_Object *unary_minus(const Scheme_Object *n)
00246 {
00247   Scheme_Object *a[1];
00248   a[0] = (Scheme_Object *)n;
00249   return minus(1, a);
00250 }
00251 
00252 #define ret_other(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(0))) return (Scheme_Object *)n2
00253 #define ret_1other(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(1))) return (Scheme_Object *)n2
00254 #define ret_zero(n1, n2) if (SAME_OBJ(n1, scheme_make_integer(0))) return scheme_make_integer(0)
00255 
00256 GEN_BIN_OP(scheme_bin_plus, "+", ADD, F_ADD, FS_ADD, scheme_bignum_add, scheme_rational_add, scheme_complex_add, GEN_RETURN_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK, ret_other, cx_NO_CHECK, ret_other, cx_NO_CHECK)
00257 GEN_BIN_OP(scheme_bin_minus, "-", SUBTRACT, F_SUBTRACT, FS_SUBTRACT, scheme_bignum_subtract, scheme_rational_subtract, scheme_complex_subtract, GEN_SINGLE_SUBTRACT_N2, GEN_RETURN_N1, NO_NAN_CHECK, NO_NAN_CHECK, cx_NO_CHECK, cx_NO_CHECK, ret_other, cx_NO_CHECK)
00258 GEN_BIN_OP(scheme_bin_mult, "*", MULTIPLY, F_MULTIPLY, FS_MULTIPLY, scheme_bignum_multiply, scheme_rational_multiply, scheme_complex_multiply, GEN_RETURN_0, GEN_RETURN_0, NO_NAN_CHECK, NO_NAN_CHECK, ret_zero, ret_1other, ret_zero, ret_1other)
00259 GEN_BIN_DIV_OP(scheme_bin_div, "/", DIVIDE, F_DIVIDE, FS_DIVIDE, scheme_make_rational, scheme_rational_divide, scheme_complex_divide, ret_zero, cx_NO_CHECK, cx_NO_CHECK, ret_1other)
00260 
00261 GEN_NARY_OP(static, plus, "+", scheme_bin_plus, 0, SCHEME_NUMBERP, "number", GEN_IDENT)
00262 GEN_NARY_OP(static, mult, "*", scheme_bin_mult, 1, SCHEME_NUMBERP, "number", GEN_IDENT)
00263 
00264 static MZ_INLINE Scheme_Object *
00265 minus_slow (Scheme_Object *ret, int argc, Scheme_Object *argv[])
00266 {
00267   int i;
00268   for (i = 1; i < argc; i++) {
00269     Scheme_Object *o = argv[i];
00270     if (!SCHEME_NUMBERP(o)) {
00271       scheme_wrong_type("-", "number", i, argc, argv);
00272       ESCAPED_BEFORE_HERE;
00273     }
00274     ret = scheme_bin_minus(ret, o);
00275   }
00276   return ret;
00277 }
00278 
00279 static Scheme_Object *
00280 minus (int argc, Scheme_Object *argv[])
00281 {
00282   Scheme_Object *ret, *v;
00283 
00284   ret = argv[0];
00285   if (!SCHEME_NUMBERP(ret)) {
00286     scheme_wrong_type("-", "number", 0, argc, argv);
00287     ESCAPED_BEFORE_HERE;
00288   }
00289   if (argc == 1) {
00290     if (SCHEME_FLOATP(ret)) {
00291 #ifdef MZ_USE_SINGLE_FLOATS
00292       if (SCHEME_FLTP(ret))
00293        return scheme_make_float(-SCHEME_FLT_VAL(ret));
00294 #endif
00295       return scheme_make_double(-SCHEME_DBL_VAL(ret));
00296     }
00297     return scheme_bin_minus(zeroi, ret);
00298   }
00299   if (argc == 2) {
00300     v = argv[1];
00301     if (!SCHEME_NUMBERP(v)) {
00302       scheme_wrong_type("-", "number", 1, argc, argv);
00303       ESCAPED_BEFORE_HERE;
00304     } 
00305     return scheme_bin_minus(ret, v);
00306   }
00307   return minus_slow(ret, argc, argv);
00308 }
00309 
00310 static Scheme_Object *
00311 div_prim (int argc, Scheme_Object *argv[])
00312 {
00313   Scheme_Object *ret;
00314   int i;
00315 
00316   ret = argv[0];
00317   if (!SCHEME_NUMBERP(ret)) {
00318     scheme_wrong_type("/", "number", 0, argc, argv);
00319     ESCAPED_BEFORE_HERE;
00320   }
00321   if (argc == 1) {
00322     if (ret != zeroi)
00323       return scheme_bin_div(scheme_make_integer(1), ret);
00324     else {
00325       scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00326                      "/: division by zero");
00327       ESCAPED_BEFORE_HERE;
00328     }
00329   }
00330   for (i = 1; i < argc; i++) {
00331     Scheme_Object *o = argv[i];
00332 
00333     if (!SCHEME_NUMBERP(o)) {
00334       scheme_wrong_type("/", "number", i, argc, argv);
00335       ESCAPED_BEFORE_HERE;
00336     }
00337 
00338     if (o != zeroi)
00339       ret = scheme_bin_div(ret, o);
00340     else {
00341       scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00342                      "/: division by zero");
00343       ESCAPED_BEFORE_HERE;
00344     }
00345   }
00346   return ret;
00347 }
00348 
00349 #define ABS(n)  ((n>0) ? n : -n)
00350 
00351 Scheme_Object *
00352 scheme_abs(int argc, Scheme_Object *argv[])
00353 {
00354   Scheme_Type t;
00355   Scheme_Object *o;
00356 
00357   o = argv[0];
00358 
00359   if (SCHEME_INTP(o)) {
00360     long n = SCHEME_INT_VAL(o);
00361     return scheme_make_integer_value(ABS(n));
00362   } 
00363   t = _SCHEME_TYPE(o);
00364 #ifdef MZ_USE_SINGLE_FLOATS
00365   if (t == scheme_float_type)
00366     return scheme_make_float(fabs(SCHEME_FLT_VAL(o)));
00367 #endif
00368   if (t == scheme_double_type)
00369     return scheme_make_double(fabs(SCHEME_DBL_VAL(o)));
00370   if (t == scheme_bignum_type) {
00371     if (SCHEME_BIGPOS(o))
00372       return o;
00373     return scheme_bignum_negate(o);
00374   }
00375   if (t == scheme_rational_type) {
00376     if (scheme_is_rational_positive(o))
00377       return o;
00378     else
00379       return scheme_rational_negate(o);
00380   }
00381 
00382   NEED_REAL(abs);
00383 
00384   ESCAPED_BEFORE_HERE;
00385 }
00386 
00387 Scheme_Object *
00388 do_bin_quotient(const char *name, const Scheme_Object *n1, const Scheme_Object *n2, Scheme_Object **bn_rem)
00389 {
00390   Scheme_Object *q;
00391 
00392   if (!scheme_is_integer(n1)) {
00393     Scheme_Object *a[2];
00394     a[0] = (Scheme_Object *)n1;
00395     a[1] = (Scheme_Object *)n2;
00396     scheme_wrong_type(name, "integer", 0, 2, a);
00397   }
00398   if (!scheme_is_integer(n2)) {
00399     Scheme_Object *a[2];
00400     a[0] = (Scheme_Object *)n1;
00401     a[1] = (Scheme_Object *)n2;
00402     scheme_wrong_type(name, "integer", 1, 2, a);
00403   }
00404 
00405   if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
00406     scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00407                    "%s: undefined for 0", name);
00408   if (
00409 #ifdef MZ_USE_SINGLE_FLOATS
00410       (SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
00411 #endif
00412       (SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0)))
00413     scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00414                    "%s: undefined for 0.0", name);
00415 
00416   if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
00417     return (scheme_make_integer (SCHEME_INT_VAL(n1) / SCHEME_INT_VAL(n2)));
00418   }
00419   if (SCHEME_DBLP(n1) || SCHEME_DBLP(n2)) {
00420     Scheme_Object *r;
00421     double d, d2;
00422 
00423     r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
00424     if (SCHEME_DBLP(r)) {
00425       d = SCHEME_DBL_VAL(r);
00426       
00427       if (d > 0)
00428        d2 = floor(d);
00429       else
00430        d2 = ceil(d);
00431       
00432       if (d2 == d)
00433        return r;
00434       else
00435        return scheme_make_double(d2);
00436     } else
00437       return r;
00438   }
00439 #ifdef MZ_USE_SINGLE_FLOATS
00440   if (SCHEME_FLTP(n1) || SCHEME_FLTP(n2)) {
00441     Scheme_Object *r;
00442     float d, d2;
00443 
00444     r = scheme_bin_div(n1, n2); /* could be exact 0 ... */
00445     if (SCHEME_FLTP(r)) {
00446       d = SCHEME_FLT_VAL(r);
00447       
00448       if (d > 0)
00449        d2 = floor(d);
00450       else
00451        d2 = ceil(d);
00452       
00453       if (d2 == d)
00454        return r;
00455       else
00456        return scheme_make_float(d2);
00457     } else
00458       return r;
00459   }
00460 #endif
00461 
00462 #if 0
00463   /* I'm pretty sure this isn't needed, but I'm keeping the code just
00464      in case... 03/19/2000 */
00465   if (SCHEME_RATIONALP(n1))
00466     WRONG_TYPE(name, "integer", n1);
00467   if (SCHEME_RATIONALP(n2))
00468     WRONG_TYPE(name, "integer", n2);
00469 #endif
00470   
00471   n1 = scheme_to_bignum(n1);
00472   n2 = scheme_to_bignum(n2);
00473 
00474   scheme_bignum_divide(n1, n2, &q, bn_rem, 1);
00475   return q;
00476 }
00477 
00478 Scheme_Object *
00479 scheme_bin_quotient (const Scheme_Object *n1, const Scheme_Object *n2)
00480 {
00481   return do_bin_quotient("quotient", n1, n2, NULL);
00482 }
00483 
00484 static Scheme_Object *
00485 quotient (int argc, Scheme_Object *argv[])
00486 {
00487   return do_bin_quotient("quotient", argv[0], argv[1], NULL);
00488 }
00489 
00490 /* Declaration is for FARPROC: */
00491 static Scheme_Object *
00492 rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign);
00493 
00494 static Scheme_Object *
00495 rem_mod (int argc, Scheme_Object *argv[], char *name, int first_sign)
00496 {
00497   Scheme_Object *n1, *n2, *r;
00498   int negate;
00499 
00500   n1 = argv[0];
00501   n2 = argv[1];
00502 
00503   if (!scheme_is_integer(n1))
00504     scheme_wrong_type(name, "integer", 0, argc, argv);
00505   if (!scheme_is_integer(n2))
00506     scheme_wrong_type(name, "integer", 1, argc, argv);
00507 
00508   if (SCHEME_INTP(n2) && !SCHEME_INT_VAL(n2))
00509     scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00510                    "%s: undefined for 0", name);
00511   if (
00512 #ifdef MZ_USE_SINGLE_FLOATS
00513       (SCHEME_FLTP(n2) && (SCHEME_FLT_VAL(n2) == 0.0f)) ||
00514 #endif
00515       (SCHEME_DBLP(n2) && (SCHEME_DBL_VAL(n2) == 0.0))) {
00516     int neg;
00517     neg = scheme_minus_zero_p(SCHEME_FLOAT_VAL(n2));
00518     scheme_raise_exn(MZEXN_FAIL_CONTRACT_DIVIDE_BY_ZERO,
00519                    "%s: undefined for %s0.0",
00520                    name,
00521                    neg ? "-" : "");
00522   }
00523 
00524   if (SCHEME_INTP(n1) && !SCHEME_INT_VAL(n1))
00525     return zeroi;
00526 
00527   if (SCHEME_INTP(n1) && SCHEME_INTP(n2)) {
00528     long a, b, na, nb, v;
00529     int neg1, neg2;
00530 
00531     a = SCHEME_INT_VAL(n1);
00532     b = SCHEME_INT_VAL(n2);
00533     na =  (a < 0) ? -a : a;
00534     nb =  (b < 0) ? -b : b;
00535 
00536     v = na % nb;
00537 
00538     if (v) {
00539       if (first_sign) {
00540        if (a < 0)
00541          v = -v;
00542       } else {
00543        neg1 = (a < 0);
00544        neg2 = (b < 0);
00545        
00546        if (neg1 != neg2)
00547          v = nb - v;
00548        
00549        if (neg2)
00550          v = -v;
00551       }
00552     }
00553 
00554     return scheme_make_integer(v);
00555   }
00556 
00557   if (SCHEME_FLOATP(n1) || SCHEME_FLOATP(n2)) {
00558     double a, b, na, nb, v;
00559 #ifdef MZ_USE_SINGLE_FLOATS
00560     int was_single = !(SCHEME_DBLP(n1) || SCHEME_DBLP(n2));
00561 #endif
00562 
00563     if (SCHEME_INTP(n1))
00564       a = SCHEME_INT_VAL(n1);
00565 #ifdef MZ_USE_SINGLE_FLOATS
00566     else if (SCHEME_FLTP(n1))
00567       a = SCHEME_FLT_VAL(n1);
00568 #endif
00569     else if (SCHEME_DBLP(n1))
00570       a = SCHEME_DBL_VAL(n1);
00571     else
00572       a = scheme_bignum_to_double(n1);
00573 
00574     if (SCHEME_INTP(n2))
00575       b = SCHEME_INT_VAL(n2);
00576 #ifdef MZ_USE_SINGLE_FLOATS
00577     else if (SCHEME_FLTP(n2))
00578       b = SCHEME_FLT_VAL(n2);
00579 #endif
00580     else if (SCHEME_DBLP(n2))
00581       b = SCHEME_DBL_VAL(n2);
00582     else
00583       b = scheme_bignum_to_double(n2);
00584 
00585     if (a == 0.0) {
00586       /* Avoid sign problems. */
00587 #ifdef MZ_USE_SINGLE_FLOATS
00588       if (was_single)
00589        return scheme_zerof;
00590 #endif
00591       return scheme_zerod;
00592     }
00593 
00594     na =  (a < 0) ? -a : a;
00595     nb =  (b < 0) ? -b : b;
00596 
00597     if (MZ_IS_POS_INFINITY(nb))
00598       v = na;
00599     else if (MZ_IS_POS_INFINITY(na)) {
00600 #ifdef MZ_USE_SINGLE_FLOATS
00601       if (was_single)
00602        return scheme_zerof;
00603 #endif
00604       return scheme_zerod;
00605     } else {
00606       v = fmod(na, nb);
00607 
00608 #ifdef FMOD_CAN_RETURN_NEG_ZERO
00609       if (v == 0.0)
00610        v = 0.0;
00611 #endif
00612     }
00613 
00614     if (v) {
00615       if (first_sign) {
00616        if (a < 0)
00617          v = -v;
00618       } else {
00619        int neg1, neg2;
00620        
00621        neg1 = (a < 0);
00622        neg2 = (b < 0);
00623        
00624        if (neg1 != neg2)
00625          v = nb - v;
00626        
00627        if (neg2)
00628          v = -v;
00629       }
00630     }
00631 
00632 #ifdef MZ_USE_SINGLE_FLOATS
00633     if (was_single)
00634       return scheme_make_float((float)v);
00635 #endif
00636 
00637     return scheme_make_double(v);
00638   }
00639 
00640   n1 = scheme_to_bignum(n1);
00641   n2 = scheme_to_bignum(n2);
00642 
00643   scheme_bignum_divide(n1, n2, NULL, &r, 1);
00644 
00645   negate = 0;
00646 
00647   if (!SCHEME_INTP(r) || SCHEME_INT_VAL(r)) {
00648     /* Easier if we can assume 'r' is positive: */
00649     if (SCHEME_INTP(r)) {
00650       if (SCHEME_INT_VAL(r) < 0)
00651        r = scheme_make_integer(-SCHEME_INT_VAL(r));
00652     } else if (!SCHEME_BIGPOS(r))
00653       r = scheme_bignum_negate(r);
00654 
00655     if (first_sign) {
00656       if (!SCHEME_BIGPOS(n1))
00657        negate = 1;
00658     } else {
00659       int neg1, neg2;
00660       
00661       neg1 = !SCHEME_BIGPOS(n1);
00662       neg2 = !SCHEME_BIGPOS(n2);
00663       
00664       if (neg1 != neg2) {
00665        if (neg2)
00666          r = scheme_bin_plus(n2, r);
00667        else
00668          r = scheme_bin_minus(n2, r);
00669       } else if (neg2)
00670        negate = 1;
00671     }
00672     
00673     if (negate) {
00674       if (SCHEME_INTP(r))
00675        r = scheme_make_integer(-SCHEME_INT_VAL(r));
00676       else
00677        r = scheme_bignum_negate(r);
00678     }
00679   }
00680 
00681   return r;
00682 }
00683 
00684 static Scheme_Object *
00685 rem_prim (int argc, Scheme_Object *argv[])
00686 {
00687   return rem_mod(argc, argv, "remainder", 1);
00688 }
00689 
00690 Scheme_Object *
00691 scheme_modulo(int argc, Scheme_Object *argv[])
00692 {
00693   return rem_mod(argc, argv, "modulo", 0);
00694 }
00695 
00696 
00697 Scheme_Object *
00698 quotient_remainder(int argc, Scheme_Object *argv[])
00699 {
00700   Scheme_Object *rem = NULL, *quot, *a[2];
00701 
00702   quot = do_bin_quotient("quotient/remainder", argv[0], argv[1], &rem);
00703   if (!rem) {
00704     rem = rem_mod(argc, argv, "remainder", 1);
00705   }
00706   a[0] = quot;
00707   a[1] = rem;
00708   return scheme_values(2, a);
00709 }