diff --git a/libguile/ChangeLog b/libguile/ChangeLog index 2a9c264af..9a987700e 100644 --- a/libguile/ChangeLog +++ b/libguile/ChangeLog @@ -1,3 +1,25 @@ +2000-05-02 Dirk Herrmann + + * numbers.c (scm_logtest, scm_division): Reordered dispatch + sequence, thereby fixing some comparisons of SCM values with + integer constants. + + * numbers.h (scm_makdbl): Mark as deprecated at the point of + declaration. + + * eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_double2scm, + gh_doubles2scm), numbers.c (scm_istr2flo, scm_max, scm_min, + scm_sum, scm_difference, scm_product, scm_divide, scm_sys_expt, + scm_sys_atan2, scm_make_rectangular, scm_make_polar, + scm_real_part, scm_imag_part, scm_magnitude, scm_angle, + scm_long2num, scm_long_long2num, scm_ulong2num), ramap.c + (ramap_rp, scm_array_map_x), random.c (scm_random, + scm_random_uniform, scm_random_normal_vector_x, scm_random_exp), + struct.c (scm_struct_ref), unif.c (scm_array_to_list): Replace + call to scm_makdbl with a call to scm_make_real or + scm_make_complex, depending on whether the imaginary part is known + to be zero. + 2000-05-01 Gary Houston * scmsigs.c: fix the definition of orig_handlers for the case diff --git a/libguile/eval.c b/libguile/eval.c index d0ddf0f20..c55ba19ab 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -2751,18 +2751,17 @@ evapply: { if (SCM_INUMP (t.arg1)) { - RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)), - 0.0)); + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (t.arg1)))); } SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); if (SCM_REALP (t.arg1)) { - RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)), 0.0)); + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)))); } #ifdef SCM_BIGDIG if (SCM_BIGP (t.arg1)) { - RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)), 0.0)); + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (t.arg1)))); } #endif floerr: @@ -3348,16 +3347,16 @@ tail: { if (SCM_INUMP (arg1)) { - RETURN (scm_makdbl (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)), 0.0)); + RETURN (scm_make_real (SCM_DSUBRF (proc) ((double) SCM_INUM (arg1)))); } SCM_ASRTGO (SCM_NIMP (arg1), floerr); if (SCM_REALP (arg1)) { - RETURN (scm_makdbl (SCM_DSUBRF (proc) (SCM_REALPART (arg1)), 0.0)); + RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REALPART (arg1)))); } #ifdef SCM_BIGDIG if (SCM_BIGP (arg1)) - RETURN (scm_makdbl (SCM_DSUBRF (proc) (scm_big2dbl (arg1)), 0.0)) + RETURN (scm_make_real (SCM_DSUBRF (proc) (scm_big2dbl (arg1)))) #endif floerr: SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1, diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 8fddb8148..4d7a55af4 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -77,7 +77,7 @@ gh_long2scm (long x) SCM gh_double2scm (double x) { - return scm_makdbl (x, 0.0); + return scm_make_real (x); } SCM gh_char2scm (char c) @@ -151,7 +151,7 @@ gh_doubles2scm (double *d, int n) SCM *velts = SCM_VELTS(v); for(i = 0; i < n; i++) - velts[i] = scm_makdbl(d[i], 0.0); + velts[i] = scm_make_real (d[i]); return v; } diff --git a/libguile/numbers.c b/libguile/numbers.c index 7429f7a7f..d28588c4a 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -351,6 +351,7 @@ scm_gcd (SCM x, SCM y) return x; } } + tailrec: if (SCM_INUMP (x)) { if (SCM_INUMP (y)) { @@ -973,39 +974,48 @@ SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0, "@end example") #define FUNC_NAME s_scm_logtest { -#ifndef SCM_RECKLESS - if (!(SCM_NUMBERP(n1))) - badx: SCM_WTA(SCM_ARG1, n1); -#endif + if (SCM_INUMP (n1)) { + long nn1 = SCM_INUM (n1); + if (SCM_INUMP (n2)) { + long nn2 = SCM_INUM (n2); + return SCM_BOOL (nn1 & nn2); #ifdef SCM_BIGDIG - if SCM_NINUMP(n1) { - SCM t; - SCM_ASRTGO(SCM_BIGP (n1), badx); - if SCM_INUMP(n2) {t = n1; n1 = n2; n2 = t; goto intbig;} - SCM_ASRTGO(SCM_BIGP (n2), bady); - if (SCM_NUMDIGS(n1) > SCM_NUMDIGS(n2)) {t = n1; n1 = n2; n2 = t;} - return scm_big_test(SCM_BDIGITS(n1), SCM_NUMDIGS(n1), SCM_BIGSIGN(n1), n2); - } - if SCM_NINUMP(n2) { -# ifndef SCM_RECKLESS - if (!SCM_BIGP (n2)) - bady: SCM_WTA(SCM_ARG2, n2); -# endif - intbig: { + } else if (SCM_BIGP (n2)) { + intbig: + { # ifndef SCM_DIGSTOOBIG - long z = scm_pseudolong(SCM_INUM(n1)); - return scm_big_test((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (n1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + long z = scm_pseudolong (nn1); + return scm_big_test ((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, + (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); # else - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs(SCM_INUM(n1), zdigs); - return scm_big_test(zdigs, SCM_DIGSPERLONG, (n1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); + SCM_BIGDIG zdigs [SCM_DIGSPERLONG]; + scm_longdigs (nn1, zdigs); + return scm_big_test (zdigs, SCM_DIGSPERLONG, + (nn1 < 0) ? SCM_BIGSIGNFLAG : 0, n2); # endif - }} -#else - SCM_ASRTGO(SCM_INUMP(n1), badx); - SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, FUNC_NAME); + } #endif - return (SCM_INUM(n1) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F; + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + } +#ifdef SCM_BIGDIG + } else if (SCM_BIGP (n1)) { + if (SCM_INUMP (n2)) { + SCM_SWAP (n1, n2); + goto intbig; + } else if (SCM_BIGP (n2)) { + if (SCM_NUMDIGS (n1) > SCM_NUMDIGS (n2)) { + SCM_SWAP (n1, n2); + } + return scm_big_test (SCM_BDIGITS (n1), SCM_NUMDIGS (n1), + SCM_BIGSIGN (n1), n2); + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); + } +#endif + } else { + SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); + } } #undef FUNC_NAME @@ -2475,7 +2485,7 @@ scm_istr2flo (char *str, long len, long radix) return SCM_BOOL_F; /* must have leading sign */ if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl (0.0, lead_sgn); + return scm_make_complex (0.0, lead_sgn); } do { /* check initial digits */ @@ -2674,7 +2684,7 @@ scm_istr2flo (char *str, long len, long radix) if (lead_sgn == -1.0) res = -res; if (i == len) - return scm_makdbl (res, 0.0); + return scm_make_real (res); if (str[i] == 'i' || str[i] == 'I') { /* pure imaginary number */ @@ -2682,7 +2692,7 @@ scm_istr2flo (char *str, long len, long radix) return SCM_BOOL_F; /* must have leading sign */ if (++i < len) return SCM_BOOL_F; /* `i' not last character */ - return scm_makdbl (0.0, res); + return scm_make_complex (0.0, res); } switch (str[i++]) @@ -2702,7 +2712,7 @@ scm_istr2flo (char *str, long len, long radix) if (SCM_SLOPPY_COMPLEXP (second)) return SCM_BOOL_F; /* not `real' */ tmp = SCM_REALPART (second); - return scm_makdbl (res * cos (tmp), res * sin (tmp)); + return scm_make_complex (res * cos (tmp), res * sin (tmp)); } default: return SCM_BOOL_F; @@ -2713,7 +2723,7 @@ scm_istr2flo (char *str, long len, long radix) return SCM_BOOL_F; /* handles `x+i' and `x-i' */ if (i == (len - 1)) - return scm_makdbl (res, lead_sgn); + return scm_make_complex (res, lead_sgn); /* get a `ureal' for complex part */ second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix); if (!SCM_INEXACTP (second)) @@ -2723,7 +2733,7 @@ scm_istr2flo (char *str, long len, long radix) tmp = SCM_REALPART (second); if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */ - return scm_makdbl (res, (lead_sgn * tmp)); + return scm_make_complex (res, (lead_sgn * tmp)); } @@ -3254,7 +3264,7 @@ scm_max (SCM x, SCM y) return (1 == scm_bigcomp (x, y)) ? y : x; SCM_ASRTGO (SCM_SLOPPY_REALP (y), bady); z = scm_big2dbl (x); - return (z < SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0); + return (z < SCM_REALPART (y)) ? y : scm_make_real (z); } SCM_ASRTGO (SCM_SLOPPY_REALP (x), badx2); #else @@ -3263,13 +3273,13 @@ scm_max (SCM x, SCM y) #endif if (SCM_INUMP (y)) return ((SCM_REALPART (x) < (z = SCM_INUM (y))) - ? scm_makdbl (z, 0.0) + ? scm_make_real (z) : x); #ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (y), bady); if (SCM_BIGP (y)) return ((SCM_REALPART (x) < (z = scm_big2dbl (y))) - ? scm_makdbl (z, 0.0) + ? scm_make_real (z) : x); SCM_ASRTGO (SCM_SLOPPY_REALP (y), bady); #else @@ -3297,7 +3307,7 @@ scm_max (SCM x, SCM y) #endif return (((z = SCM_INUM (x)) < SCM_REALPART (y)) ? y - : scm_makdbl (z, 0.0)); + : scm_make_real (z)); } return ((long) x < (long) y) ? y : x; } @@ -3333,7 +3343,7 @@ scm_min (SCM x, SCM y) return (-1 == scm_bigcomp (x, y)) ? y : x; SCM_ASRTGO (SCM_SLOPPY_REALP (y), bady); z = scm_big2dbl (x); - return (z > SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0); + return (z > SCM_REALPART (y)) ? y : scm_make_real (z); } SCM_ASRTGO (SCM_SLOPPY_REALP (x), badx2); #else @@ -3342,13 +3352,13 @@ scm_min (SCM x, SCM y) #endif if (SCM_INUMP (y)) return ((SCM_REALPART (x) > (z = SCM_INUM (y))) - ? scm_makdbl (z, 0.0) + ? scm_make_real (z) : x); #ifdef SCM_BIGDIG SCM_ASRTGO (SCM_NIMP (y), bady); if (SCM_BIGP (y)) return ((SCM_REALPART (x) > (z = scm_big2dbl (y))) - ? scm_makdbl (z, 0.0) + ? scm_make_real (z) : x); SCM_ASRTGO (SCM_SLOPPY_REALP (y), bady); #else @@ -3376,7 +3386,7 @@ scm_min (SCM x, SCM y) #endif return (((z = SCM_INUM (x)) > SCM_REALPART (y)) ? y - : scm_makdbl (z, 0.0)); + : scm_make_real (z)); } return ((long) x > (long) y) ? y : x; } @@ -3467,7 +3477,7 @@ scm_sum (SCM x, SCM y) i = SCM_COMPLEX_IMAG (x); if (SCM_SLOPPY_COMPLEXP (y)) i += SCM_COMPLEX_IMAG (y); - return scm_makdbl (SCM_REALPART (x) + SCM_REALPART (y), i); + return scm_make_complex (SCM_REALPART (x) + SCM_REALPART (y), i); } } if (SCM_NINUMP (y)) @@ -3509,7 +3519,7 @@ scm_sum (SCM x, SCM y) #ifdef SCM_BIGDIG return scm_long2big (i); #else /* SCM_BIGDIG */ - return scm_makdbl ((double) i, 0.0); + return scm_make_real ((double) i); #endif /* SCM_BIGDIG */ } /* end scope */ } @@ -3658,8 +3668,12 @@ scm_difference (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); } #endif - return scm_makdbl (SCM_INUM (x) - SCM_REALPART (y), - SCM_SLOPPY_COMPLEXP (y) ? -SCM_IMAG (y) : 0.0); + if (SCM_SLOPPY_COMPLEXP (y)) { + return scm_make_complex (SCM_INUM (x) - SCM_COMPLEX_REAL (y), + -SCM_COMPLEX_IMAG (y)); + } else { + return scm_make_real (SCM_INUM (x) - SCM_REAL_VALUE (y)); + } } cx = SCM_INUM (x) - SCM_INUM (y); checkx: @@ -3668,7 +3682,7 @@ scm_difference (SCM x, SCM y) #ifdef SCM_BIGDIG return scm_long2big (cx); #else - return scm_makdbl ((double) cx, 0.0); + return scm_make_real ((double) cx); #endif } @@ -3714,8 +3728,12 @@ scm_product (SCM x, SCM y) bigreal: { double bg = scm_big2dbl (x); - return scm_makdbl (bg * SCM_REALPART (y), - SCM_SLOPPY_COMPLEXP (y) ? bg * SCM_IMAG (y) : 0.0); + if (SCM_SLOPPY_COMPLEXP (y)) { + return scm_make_complex (bg * SCM_COMPLEX_REAL (y), + bg * SCM_COMPLEX_IMAG (y)); + } else { + return scm_make_real (bg * SCM_REAL_VALUE (y)); + } } } SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x), badx2); @@ -3750,21 +3768,21 @@ scm_product (SCM x, SCM y) SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); } #endif - if (SCM_SLOPPY_COMPLEXP (x)) - { - if (SCM_SLOPPY_COMPLEXP (y)) - return scm_makdbl (SCM_REAL (x) * SCM_REAL (y) - - SCM_IMAG (x) * SCM_IMAG (y), - SCM_REAL (x) * SCM_IMAG (y) - + SCM_IMAG (x) * SCM_REAL (y)); - else - return scm_makdbl (SCM_REAL (x) * SCM_REALPART (y), - SCM_IMAG (x) * SCM_REALPART (y)); - } - return scm_makdbl (SCM_REALPART (x) * SCM_REALPART (y), - SCM_SLOPPY_COMPLEXP (y) - ? SCM_REALPART (x) * SCM_IMAG (y) - : 0.0); + if (SCM_SLOPPY_COMPLEXP (x)) { + if (SCM_SLOPPY_COMPLEXP (y)) + return scm_make_complex (SCM_REAL (x) * SCM_REAL (y) + - SCM_IMAG (x) * SCM_IMAG (y), + SCM_REAL (x) * SCM_IMAG (y) + + SCM_IMAG (x) * SCM_REAL (y)); + else + return scm_make_complex (SCM_REAL (x) * SCM_REALPART (y), + SCM_IMAG (x) * SCM_REALPART (y)); + } else if (SCM_SLOPPY_COMPLEXP (y)) { + return scm_make_complex (SCM_REALPART (x) * SCM_REALPART (y), + SCM_REALPART (x) * SCM_IMAG (y)); + } else { + return scm_make_real (SCM_REALPART (x) * SCM_REALPART (y)); + } } if (SCM_NINUMP (y)) { @@ -3797,8 +3815,12 @@ scm_product (SCM x, SCM y) SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y), bady); #endif intreal: - return scm_makdbl (SCM_INUM (x) * SCM_REALPART (y), - SCM_SLOPPY_COMPLEXP (y) ? SCM_INUM (x) * SCM_IMAG (y) : 0.0); + if (SCM_SLOPPY_COMPLEXP (y)) { + return scm_make_complex (SCM_INUM (x) * SCM_REALPART (y), + SCM_INUM (x) * SCM_IMAG (y)); + } else { + return scm_make_real (SCM_INUM (x) * SCM_REALPART (y)); + } } { long i, j, k; @@ -3828,7 +3850,7 @@ scm_product (SCM x, SCM y) #endif } #else - return scm_makdbl (((double) i) * ((double) j), 0.0); + return scm_make_real (((double) i) * ((double) j)); #endif return y; } @@ -3861,177 +3883,167 @@ SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide); SCM scm_divide (SCM x, SCM y) { - double d, r, i, a; - if (SCM_NINUMP (x)) - { - if (!(SCM_NIMP (x))) - { - if (SCM_UNBNDP (y)) - { - SCM_GASSERT0 (!SCM_UNBNDP (x), - g_divide, scm_makfrom0str (s_divide), SCM_WNA, 0); - badx: - SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); - } - else - { - badx2: - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); - } - } - if (SCM_UNBNDP (y)) - { -#ifdef SCM_BIGDIG - if (SCM_BIGP (x)) - return scm_makdbl (1.0 / scm_big2dbl (x), 0.0); -#endif - SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x), badx); - if (SCM_SLOPPY_REALP (x)) - return scm_makdbl (1.0 / SCM_REALPART (x), 0.0); - r = SCM_REAL (x); - i = SCM_IMAG (x); - d = r * r + i * i; - return scm_makdbl (r / d, -i / d); - } -#ifdef SCM_BIGDIG - if (SCM_BIGP (x)) - { - if (SCM_INUMP (y)) - { - long int z = SCM_INUM (y); -#ifndef SCM_RECKLESS - if (!z) - scm_num_overflow (s_divide); -#endif - if (1 == z) - return x; - if (z < 0) - z = -z; - if (z < SCM_BIGRAD) - { - SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0)); - return (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), - (SCM_BIGDIG) z) - ? scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0) - : scm_normbig (w)); - } -#ifndef SCM_DIGSTOOBIG - /*ugh! Does anyone know what this is supposed to do?*/ - z = scm_pseudolong (z); - z = SCM_INUM(scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - (SCM_BIGDIG *) & z, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3)); -#else - { - SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; - scm_longdigs (z, zdigs); - z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - zdigs, SCM_DIGSPERLONG, - SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3); - } -#endif - return z ? SCM_PACK (z) : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0); - } - SCM_ASRTGO (SCM_NIMP (y), bady); - if (SCM_BIGP (y)) - { - SCM z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), - SCM_BDIGITS (y), SCM_NUMDIGS (y), - SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); - return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y), - 0.0); - } - SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y), bady); - if (SCM_SLOPPY_REALP (y)) - return scm_makdbl (scm_big2dbl (x) / SCM_REALPART (y), 0.0); - a = scm_big2dbl (x); - goto complex_div; - } -#endif - SCM_ASRTGO (SCM_SLOPPY_INEXACTP (x), badx2); - if (SCM_INUMP (y)) - { - d = SCM_INUM (y); - goto basic_div; - } -#ifdef SCM_BIGDIG - SCM_ASRTGO (SCM_NIMP (y), bady); - if (SCM_BIGP (y)) - { - d = scm_big2dbl (y); - goto basic_div; - } - SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y), bady); -#else - SCM_ASRTGO (SCM_SLOPPY_INEXACTP (y), bady); -#endif - if (SCM_SLOPPY_REALP (y)) - { - d = SCM_REALPART (y); - basic_div: - return scm_makdbl (SCM_REALPART (x) / d, - SCM_SLOPPY_COMPLEXP (x) ? SCM_IMAG (x) / d : 0.0); - } - a = SCM_REALPART (x); - if (SCM_SLOPPY_REALP (x)) - goto complex_div; - r = SCM_REAL (y); - i = SCM_IMAG (y); - d = r * r + i * i; - return scm_makdbl ((a * r + SCM_IMAG (x) * i) / d, - (SCM_IMAG (x) * r - a * i) / d); - } - if (SCM_UNBNDP (y)) - { - if (SCM_EQ_P (x, SCM_MAKINUM (1L)) || SCM_EQ_P (x, SCM_MAKINUM (-1L))) + double a; + + if (SCM_UNBNDP (y)) { + if (SCM_UNBNDP (x)) { + SCM_WTA_DISPATCH_0 (g_divide, x, SCM_ARG1, s_divide); + } else if (SCM_INUMP (x)) { + if (SCM_EQ_P (x, SCM_MAKINUM (1L)) || SCM_EQ_P (x, SCM_MAKINUM (-1L))) { return x; - return scm_makdbl (1.0 / ((double) SCM_INUM (x)), 0.0); - } - if (SCM_NINUMP (y)) - { + } else { + return scm_make_real (1.0 / (double) SCM_INUM (x)); + } #ifdef SCM_BIGDIG - SCM_ASRTGO (SCM_NIMP (y), bady); - if (SCM_BIGP (y)) - return scm_makdbl (SCM_INUM (x) / scm_big2dbl (y), 0.0); - if (!(SCM_SLOPPY_INEXACTP (y))) - { - bady: - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); - } + } else if (SCM_BIGP (x)) { + return scm_make_real (1.0 / scm_big2dbl (x)); +#endif + } else if (SCM_REALP (x)) { + return scm_make_real (1.0 / SCM_REAL_VALUE (x)); + } else if (SCM_COMPLEXP (x)) { + double r = SCM_COMPLEX_REAL (x); + double i = SCM_COMPLEX_IMAG (x); + double d = r * r + i * i; + return scm_make_complex (r / d, -i / d); + } else { + SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); + } + } + + if (SCM_INUMP (x)) { + long xx = SCM_INUM (x); + if (SCM_INUMP (y)) { + long yy = SCM_INUM (y); + if (yy == 0) { + /* Dirk:FIXME:: Shouldn't we report an error here? */ + return scm_make_real ((double) xx / 0.0); + /* scm_num_overflow (s_divide); */ + } else if (xx % yy != 0) { + return scm_make_real ((double) xx / (double) yy); + } else { + long z = xx / yy; + if (SCM_FIXABLE (z)) { + return SCM_MAKINUM (z); + } else { +#ifdef SCM_BIGDIG + return scm_long2big (z); #else - if (!SCM_SLOPPY_INEXACTP (y)) - { - bady: - SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + return scm_make_real ((double) xx / (double) yy); +#endif } -#endif - if (SCM_SLOPPY_REALP (y)) - return scm_makdbl (SCM_INUM (x) / SCM_REALPART (y), 0.0); - a = SCM_INUM (x); - complex_div: - r = SCM_REAL (y); - i = SCM_IMAG (y); - d = r * r + i * i; - return scm_makdbl ((a * r) / d, (-a * i) / d); - } - { - long z = SCM_INUM (y); - if ((0 == z) || SCM_INUM (x) % z) - goto ov; - z = SCM_INUM (x) / z; - if (SCM_FIXABLE (z)) - return SCM_MAKINUM (z); + } #ifdef SCM_BIGDIG - return scm_long2big (z); + } else if (SCM_BIGP (y)) { + return scm_make_real ((double) xx / scm_big2dbl (y)); #endif - ov: - return scm_makdbl (((double) SCM_INUM (x)) / ((double) SCM_INUM (y)), 0.0); + } else if (SCM_REALP (y)) { + return scm_make_real ((double) xx / SCM_REAL_VALUE (y)); + } else if (SCM_COMPLEXP (y)) { + a = xx; + complex_div: /* y _must_ be a complex number */ + { + double r = SCM_COMPLEX_REAL (y); + double i = SCM_COMPLEX_IMAG (y); + double d = r * r + i * i; + return scm_make_complex ((a * r) / d, (-a * i) / d); + } + } else { + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } +#ifdef SCM_BIGDIG + } else if (SCM_BIGP (x)) { + if (SCM_INUMP (y)) { + long int yy = SCM_INUM (y); + if (yy == 0) { + scm_num_overflow (s_divide); + } else if (yy == 1) { + return x; + } else { + long z = yy < 0 ? -yy : yy; + if (z < SCM_BIGRAD) { + SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0)); + return scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), + (SCM_BIGDIG) z) + ? scm_make_real (scm_big2dbl (x) / (double) yy) + : scm_normbig (w); + } else { + SCM w; +#ifndef SCM_DIGSTOOBIG + z = scm_pseudolong (z); + w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), + (SCM_BIGDIG *) & z, SCM_DIGSPERLONG, + SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 3); +#else + SCM_BIGDIG zdigs[SCM_DIGSPERLONG]; + scm_longdigs (z, zdigs); + w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), + zdigs, SCM_DIGSPERLONG, + SCM_BIGSIGN (x) ? (yy > 0) : (yy < 0), 3); +#endif + /* Dirk:FIXME:: divbigbig shouldn't return '0' */ + return w ? w : scm_make_real (scm_big2dbl (x) / (double) yy); + } + } + } else if (SCM_BIGP (y)) { + SCM w = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), + SCM_BDIGITS (y), SCM_NUMDIGS (y), + SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3); + /* Dirk:FIXME:: divbigbig shouldn't return '0' */ + return w ? w : scm_make_real (scm_big2dbl (x) / scm_big2dbl (y)); + } else if (SCM_REALP (y)) { + return scm_make_real (scm_big2dbl (x) / SCM_REAL_VALUE (y)); + } else if (SCM_COMPLEXP (y)) { + a = scm_big2dbl (x); + goto complex_div; + } else { + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } +#endif + } else if (SCM_REALP (x)) { + double rx = SCM_REAL_VALUE (x); + if (SCM_INUMP (y)) { + return scm_make_real (rx / (double) SCM_INUM (y)); +#ifdef SCM_BIGDIG + } else if (SCM_BIGP (y)) { + return scm_make_real (rx / scm_big2dbl (y)); +#endif + } else if (SCM_REALP (y)) { + return scm_make_real (rx / SCM_REAL_VALUE (y)); + } else if (SCM_COMPLEXP (y)) { + a = rx; + goto complex_div; + } else { + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } + } else if (SCM_COMPLEXP (x)) { + double rx = SCM_COMPLEX_REAL (x); + double ix = SCM_COMPLEX_IMAG (x); + if (SCM_INUMP (y)) { + double d = SCM_INUM (y); + return scm_make_complex (rx / d, ix / d); +#ifdef SCM_BIGDIG + } else if (SCM_BIGP (y)) { + double d = scm_big2dbl (y); + return scm_make_complex (rx / d, ix / d); +#endif + } else if (SCM_REALP (y)) { + double d = SCM_REAL_VALUE (y); + return scm_make_complex (rx / d, ix / d); + } else if (SCM_COMPLEXP (y)) { + double ry = SCM_COMPLEX_REAL (y); + double iy = SCM_COMPLEX_IMAG (y); + double d = ry * ry + iy * iy; + return scm_make_complex ((rx * ry + ix * iy) / d, + (ix * ry - rx * iy) / d); + } else { + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); + } + } else { + SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); } } - - SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh); double @@ -4187,7 +4199,7 @@ SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0, { struct dpair xy; scm_two_doubles (z1, z2, FUNC_NAME, &xy); - return scm_makdbl (pow (xy.x, xy.y), 0.0); + return scm_make_real (pow (xy.x, xy.y)); } #undef FUNC_NAME @@ -4200,7 +4212,7 @@ SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0, { struct dpair xy; scm_two_doubles (z1, z2, FUNC_NAME, &xy); - return scm_makdbl (atan2 (xy.x, xy.y), 0.0); + return scm_make_real (atan2 (xy.x, xy.y)); } #undef FUNC_NAME @@ -4213,7 +4225,7 @@ SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0, { struct dpair xy; scm_two_doubles (z1, z2, FUNC_NAME, &xy); - return scm_makdbl (xy.x, xy.y); + return scm_make_complex (xy.x, xy.y); } #undef FUNC_NAME @@ -4226,7 +4238,7 @@ SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0, { struct dpair xy; scm_two_doubles (z1, z2, FUNC_NAME, &xy); - return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y)); + return scm_make_complex (xy.x * cos (xy.y), xy.x * sin (xy.y)); } #undef FUNC_NAME @@ -4254,7 +4266,7 @@ scm_real_part (SCM z) g_real_part, z, SCM_ARG1, s_real_part); #endif if (SCM_SLOPPY_COMPLEXP (z)) - return scm_makdbl (SCM_REAL (z), 0.0); + return scm_make_real (SCM_REAL (z)); } return z; } @@ -4282,7 +4294,7 @@ scm_imag_part (SCM z) g_imag_part, z, SCM_ARG1, s_imag_part); #endif if (SCM_SLOPPY_COMPLEXP (z)) - return scm_makdbl (SCM_IMAG (z), 0.0); + return scm_make_real (SCM_IMAG (z)); return scm_flo0; } @@ -4311,9 +4323,9 @@ scm_magnitude (SCM z) if (SCM_SLOPPY_COMPLEXP (z)) { double i = SCM_IMAG (z), r = SCM_REAL (z); - return scm_makdbl (sqrt (i * i + r * r), 0.0); + return scm_make_real (sqrt (i * i + r * r)); } - return scm_makdbl (fabs (SCM_REALPART (z)), 0.0); + return scm_make_real (fabs (SCM_REALPART (z))); } @@ -4353,7 +4365,7 @@ scm_angle (SCM z) x = SCM_REAL (z); y = SCM_IMAG (z); do_angle: - return scm_makdbl (atan2 (y, x), 0.0); + return scm_make_real (atan2 (y, x)); } @@ -4456,7 +4468,7 @@ scm_long2num (long sl) #ifdef SCM_BIGDIG return scm_long2big (sl); #else - return scm_makdbl ((double) sl, 0.0); + return scm_make_real ((double) sl); #endif } return SCM_MAKINUM (sl); @@ -4473,7 +4485,7 @@ scm_long_long2num (long_long sl) #ifdef SCM_BIGDIG return scm_long_long2big (sl); #else - return scm_makdbl ((double) sl, 0.0); + return scm_make_real ((double) sl); #endif } else @@ -4494,7 +4506,7 @@ scm_ulong2num (unsigned long sl) #ifdef SCM_BIGDIG return scm_ulong2big (sl); #else - return scm_makdbl ((double) sl, 0.0); + return scm_make_real ((double) sl); #endif } return SCM_MAKINUM (sl); diff --git a/libguile/numbers.h b/libguile/numbers.h index 6b781514a..f3f18de9d 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -337,7 +337,7 @@ extern SCM scm_istring2number (char *str, long len, long radix); extern SCM scm_string_to_number (SCM str, SCM radix); extern SCM scm_make_real (double x); extern SCM scm_make_complex (double x, double y); -extern SCM scm_makdbl (double x, double y); +extern SCM scm_makdbl (double x, double y); /* Deprecated */ extern SCM scm_bigequal (SCM x, SCM y); extern SCM scm_real_equalp (SCM x, SCM y); extern SCM scm_complex_equalp (SCM x, SCM y); diff --git a/libguile/ramap.c b/libguile/ramap.c index e80d11006..840661aad 100644 --- a/libguile/ramap.c +++ b/libguile/ramap.c @@ -1360,7 +1360,8 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) } case scm_tc7_dvect: { - SCM a1 = scm_makdbl (1.0 / 3.0, 0.0), a2 = scm_makdbl (1.0 / 3.0, 0.0); + SCM a1 = scm_make_real (1.0 / 3.0); + SCM a2 = scm_make_real (1.0 / 3.0); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if (SCM_BITVEC_REF (ra0, i0)) { @@ -1373,7 +1374,8 @@ ramap_rp (SCM ra0,SCM proc,SCM ras) } case scm_tc7_cvect: { - SCM a1 = scm_makdbl (1.0, 1.0), a2 = scm_makdbl (1.0, 1.0); + SCM a1 = scm_make_complex (1.0, 1.0); + SCM a2 = scm_make_complex (1.0, 1.0); for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) if (SCM_BITVEC_REF (ra0, i0)) { @@ -1549,7 +1551,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1, { prot = scm_array_prototype (ra0); if (SCM_INEXP (prot)) - fill = scm_makdbl ((double) SCM_INUM (fill), 0.0); + fill = scm_make_real ((double) SCM_INUM (fill)); } scm_array_fill_x (ra0, fill); diff --git a/libguile/random.c b/libguile/random.c index d69b023cb..a29469a1c 100644 --- a/libguile/random.c +++ b/libguile/random.c @@ -379,8 +379,8 @@ SCM_DEFINE (scm_random, "random", 1, 1, 0, } SCM_VALIDATE_NIM (1,n); if (SCM_REALP (n)) - return scm_makdbl (SCM_REALPART (n) * scm_c_uniform01 (SCM_RSTATE (state)), - 0.0); + return scm_make_real (SCM_REAL_VALUE (n) + * scm_c_uniform01 (SCM_RSTATE (state))); SCM_VALIDATE_SMOB (1, n, big); return scm_c_random_bignum (SCM_RSTATE (state), n); } @@ -419,7 +419,7 @@ SCM_DEFINE (scm_random_uniform, "random:uniform", 0, 1, 0, if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); - return scm_makdbl (scm_c_uniform01 (SCM_RSTATE (state)), 0.0); + return scm_make_real (scm_c_uniform01 (SCM_RSTATE (state))); } #undef FUNC_NAME @@ -435,7 +435,7 @@ SCM_DEFINE (scm_random_normal, "random:normal", 0, 1, 0, if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); - return scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0); + return scm_make_real (scm_c_normal01 (SCM_RSTATE (state))); } #undef FUNC_NAME @@ -540,7 +540,7 @@ SCM_DEFINE (scm_random_normal_vector_x, "random:normal-vector!", 1, 1, 0, n = SCM_LENGTH (v); if (SCM_VECTORP (v)) while (--n >= 0) - SCM_VELTS (v)[n] = scm_makdbl (scm_c_normal01 (SCM_RSTATE (state)), 0.0); + SCM_VELTS (v)[n] = scm_make_real (scm_c_normal01 (SCM_RSTATE (state))); else while (--n >= 0) ((double *) SCM_VELTS (v))[n] = scm_c_normal01 (SCM_RSTATE (state)); @@ -560,7 +560,7 @@ SCM_DEFINE (scm_random_exp, "random:exp", 0, 1, 0, if (SCM_UNBNDP (state)) state = SCM_CDR (scm_var_random_state); SCM_VALIDATE_RSTATE (1,state); - return scm_makdbl (scm_c_exp1 (SCM_RSTATE (state)), 0.0); + return scm_make_real (scm_c_exp1 (SCM_RSTATE (state))); } #undef FUNC_NAME diff --git a/libguile/struct.c b/libguile/struct.c index 67440808a..f89f2e7a9 100644 --- a/libguile/struct.c +++ b/libguile/struct.c @@ -561,7 +561,7 @@ SCM_DEFINE (scm_struct_ref, "struct-ref", 2, 0, 0, break; case 'd': - answer = scm_makdbl (*((double *)&(data[p])), 0.0); + answer = scm_make_real (*((double *)&(data[p]))); break; #endif diff --git a/libguile/unif.c b/libguile/unif.c index 46c62b833..5616dd155 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -2119,14 +2119,14 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, { double *data = (double *) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k], 0.0), res); + res = scm_cons (scm_make_real (data[k]), res); return res; } case scm_tc7_cvect: { double (*data)[2] = (double (*)[2]) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); + res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res); return res; } }