1 /* Copyright (C) 1995-2016, 2018, 2019, 2020 Free Software Foundation, Inc.
2 *
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
5 *
6 *
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
11 *
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
16 *
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
20 * 02110-1301 USA
21 */
22
23
24 /* General assumptions:
25 * All objects satisfying SCM_BIGP() are too large to fit in a fixnum.
26 * If an object satisfies integer?, it's either an inum, a bignum, or a real.
27 * If floor (r) == r, r is an int, and mpz_set_d will DTRT.
28 * XXX What about infinities? They are equal to their own floor! -mhw
29 * All objects satisfying SCM_FRACTIONP are never an integer.
30 */
31
32 /* TODO:
33
34 - see if special casing bignums and reals in integer-exponent when
35 possible (to use mpz_pow and mpf_pow_ui) is faster.
36
37 - look in to better short-circuiting of common cases in
38 integer-expt and elsewhere.
39
40 - see if direct mpz operations can help in ash and elsewhere.
41
42 */
43
44 #ifdef HAVE_CONFIG_H
45 # include <config.h>
46 #endif
47
48 /* With old GCC, do not override _Static_assert: it conflicts with
49 #include <complex.h> below. */
50 #if defined(__clang__) || (__GNUC__ * 10 + __GNUC_MINOR__ >= 46)
51 #include <verify.h>
52 #endif
53 #include <assert.h>
54
55 #include <math.h>
56 #include <string.h>
57 #include <unicase.h>
58 #include <unictype.h>
59
60 #if HAVE_COMPLEX_H
61 #include <complex.h>
62 #endif
63
64 #include <stdarg.h>
65
66 #include "libguile/_scm.h"
67 #include "libguile/feature.h"
68 #include "libguile/ports.h"
69 #include "libguile/smob.h"
70 #include "libguile/strings.h"
71 #include "libguile/bdw-gc.h"
72
73 #include "libguile/validate.h"
74 #include "libguile/numbers.h"
75 #include "libguile/deprecation.h"
76
77 #include "libguile/eq.h"
78
79 /* values per glibc, if not already defined */
80 #ifndef M_LOG10E
81 #define M_LOG10E 0.43429448190325182765
82 #endif
83 #ifndef M_LN2
84 #define M_LN2 0.69314718055994530942
85 #endif
86 #ifndef M_PI
87 #define M_PI 3.14159265358979323846
88 #endif
89
90 /* FIXME: We assume that FLT_RADIX is 2 */
91 verify (FLT_RADIX == 2);
92
93 /* Make sure that scm_t_inum fits within a SCM value. */
94 verify (sizeof (scm_t_inum) <= sizeof (scm_t_bits));
95
96 /* Several functions below assume that fixnums fit within a long, and
97 furthermore that there is some headroom to spare for other operations
98 without overflowing. */
99 verify (SCM_I_FIXNUM_BIT <= SCM_LONG_BIT - 2);
100
101 /* Some functions that use GMP's mpn functions assume that a
102 non-negative fixnum will always fit in a 'mp_limb_t'. */
103 verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1);
104
105 #define scm_from_inum(x) (scm_from_signed_integer (x))
106
107 /* Test an inum to see if it can be converted to a double without loss
108 of precision. Note that this will sometimes return 0 even when 1
109 could have been returned, e.g. for large powers of 2. It is designed
110 to be a fast check to optimize common cases. */
111 #define INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE(n) \
112 (SCM_I_FIXNUM_BIT-1 <= DBL_MANT_DIG \
113 || ((n) ^ ((n) >> (SCM_I_FIXNUM_BIT-1))) < (1L << DBL_MANT_DIG))
114
115 #if ! HAVE_DECL_MPZ_INITS
116
117 /* GMP < 5.0.0 lacks `mpz_inits' and `mpz_clears'. Provide them. */
118
119 #define VARARG_MPZ_ITERATOR(func) \
120 static void \
121 func ## s (mpz_t x, ...) \
122 { \
123 va_list ap; \
124 \
125 va_start (ap, x); \
126 while (x != NULL) \
127 { \
128 func (x); \
129 x = va_arg (ap, mpz_ptr); \
130 } \
131 va_end (ap); \
132 }
133
134 VARARG_MPZ_ITERATOR (mpz_init)
135 VARARG_MPZ_ITERATOR (mpz_clear)
136
137 #endif
138
139
140
141 /*
142 Wonder if this might be faster for some of our code? A switch on
143 the numtag would jump directly to the right case, and the
144 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
145
146 #define SCM_I_NUMTAG_NOTNUM 0
147 #define SCM_I_NUMTAG_INUM 1
148 #define SCM_I_NUMTAG_BIG scm_tc16_big
149 #define SCM_I_NUMTAG_REAL scm_tc16_real
150 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
151 #define SCM_I_NUMTAG(x) \
152 (SCM_I_INUMP(x) ? SCM_I_NUMTAG_INUM \
153 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
154 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
155 : SCM_I_NUMTAG_NOTNUM)))
156 */
157 /* the macro above will not work as is with fractions */
158
159
160 /* Default to 1, because as we used to hard-code `free' as the
161 deallocator, we know that overriding these functions with
162 instrumented `malloc' / `free' is OK. */
163 int scm_install_gmp_memory_functions = 1;
164 static SCM flo0;
165 static SCM exactly_one_half;
166 static SCM flo_log10e;
167
168 #define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
169
170 /* FLOBUFLEN is the maximum number of characters necessary for the
171 * printed or scm_string representation of an inexact number.
172 */
173 #define FLOBUFLEN (40+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
174
175
176 #if !defined (HAVE_ASINH)
asinh(double x)177 static double asinh (double x) { return log (x + sqrt (x * x + 1)); }
178 #endif
179 #if !defined (HAVE_ACOSH)
acosh(double x)180 static double acosh (double x) { return log (x + sqrt (x * x - 1)); }
181 #endif
182 #if !defined (HAVE_ATANH)
atanh(double x)183 static double atanh (double x) { return 0.5 * log ((1 + x) / (1 - x)); }
184 #endif
185
186 /* mpz_cmp_d in GMP before 4.2 didn't recognise infinities, so
187 xmpz_cmp_d uses an explicit check. Starting with GMP 4.2 (released
188 in March 2006), mpz_cmp_d now handles infinities properly. */
189 #if 1
190 #define xmpz_cmp_d(z, d) \
191 (isinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
192 #else
193 #define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
194 #endif
195
196
197 #if defined (GUILE_I)
198 #if defined HAVE_COMPLEX_DOUBLE && (HAVE_CLOG || HAVE_CLOG10 || HAVE_CEXP || HAVE_USABLE_CSQRT) && defined (SCM_COMPLEX_VALUE)
199
200 /* For an SCM object Z which is a complex number (ie. satisfies
201 SCM_COMPLEXP), return its value as a C level "complex double". */
202 #define SCM_COMPLEX_VALUE(z) \
203 (SCM_COMPLEX_REAL (z) + GUILE_I * SCM_COMPLEX_IMAG (z))
204
205 static inline SCM scm_from_complex_double (complex double z) SCM_UNUSED;
206
207 /* Convert a C "complex double" to an SCM value. */
208 static inline SCM
scm_from_complex_double(complex double z)209 scm_from_complex_double (complex double z)
210 {
211 return scm_c_make_rectangular (creal (z), cimag (z));
212 }
213
214 #endif /* HAVE_COMPLEX_DOUBLE */
215 #endif /* GUILE_I */
216
217
218
219 static mpz_t z_negative_one;
220
221
222
223 /* Clear the `mpz_t' embedded in bignum PTR. */
224 static void
finalize_bignum(void * ptr,void * data)225 finalize_bignum (void *ptr, void *data)
226 {
227 SCM bignum;
228
229 bignum = SCM_PACK_POINTER (ptr);
230 mpz_clear (SCM_I_BIG_MPZ (bignum));
231 }
232
233 /* The next three functions (custom_libgmp_*) are passed to
234 mp_set_memory_functions (in GMP) so that memory used by the digits
235 themselves is known to the garbage collector. This is needed so
236 that GC will be run at appropriate times. Otherwise, a program which
237 creates many large bignums would malloc a huge amount of memory
238 before the GC runs. */
239 static void *
custom_gmp_malloc(size_t alloc_size)240 custom_gmp_malloc (size_t alloc_size)
241 {
242 return scm_gc_malloc_pointerless (alloc_size, "GMP");
243 }
244
245 static void *
custom_gmp_realloc(void * old_ptr,size_t old_size,size_t new_size)246 custom_gmp_realloc (void *old_ptr, size_t old_size, size_t new_size)
247 {
248 return scm_gc_realloc (old_ptr, old_size, new_size, "GMP");
249 }
250
251 static void
custom_gmp_free(void * ptr,size_t size)252 custom_gmp_free (void *ptr, size_t size)
253 {
254 /* Do nothing: all memory allocated by GMP is under GC control and
255 will be freed when needed. */
256 }
257
258
259 /* Return a new uninitialized bignum. */
260 static inline SCM
make_bignum(void)261 make_bignum (void)
262 {
263 scm_t_bits *p;
264
265 /* Allocate one word for the type tag and enough room for an `mpz_t'. */
266 p = scm_gc_malloc (sizeof (scm_t_bits) + sizeof (mpz_t),
267 "bignum");
268 p[0] = scm_tc16_big;
269
270 /* When the 'custom_gmp_*' functions are in use, no need to set a
271 finalizer since allocated memory is under GC control. In other
272 cases, set a finalizer to call 'mpz_clear', which is expensive. */
273 if (!scm_install_gmp_memory_functions)
274 scm_i_set_finalizer (p, finalize_bignum, NULL);
275
276 return SCM_PACK (p);
277 }
278
279
280 SCM
scm_i_mkbig()281 scm_i_mkbig ()
282 {
283 /* Return a newly created bignum. */
284 SCM z = make_bignum ();
285 mpz_init (SCM_I_BIG_MPZ (z));
286 return z;
287 }
288
289 static SCM
scm_i_inum2big(scm_t_inum x)290 scm_i_inum2big (scm_t_inum x)
291 {
292 /* Return a newly created bignum initialized to X. */
293 SCM z = make_bignum ();
294 mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
295 return z;
296 }
297
298 SCM
scm_i_long2big(long x)299 scm_i_long2big (long x)
300 {
301 /* Return a newly created bignum initialized to X. */
302 SCM z = make_bignum ();
303 mpz_init_set_si (SCM_I_BIG_MPZ (z), x);
304 return z;
305 }
306
307 SCM
scm_i_ulong2big(unsigned long x)308 scm_i_ulong2big (unsigned long x)
309 {
310 /* Return a newly created bignum initialized to X. */
311 SCM z = make_bignum ();
312 mpz_init_set_ui (SCM_I_BIG_MPZ (z), x);
313 return z;
314 }
315
316 SCM
scm_i_clonebig(SCM src_big,int same_sign_p)317 scm_i_clonebig (SCM src_big, int same_sign_p)
318 {
319 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
320 SCM z = make_bignum ();
321 mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
322 if (!same_sign_p)
323 mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
324 return z;
325 }
326
327 int
scm_i_bigcmp(SCM x,SCM y)328 scm_i_bigcmp (SCM x, SCM y)
329 {
330 /* Return neg if x < y, pos if x > y, and 0 if x == y */
331 /* presume we already know x and y are bignums */
332 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
333 scm_remember_upto_here_2 (x, y);
334 return result;
335 }
336
337 SCM
scm_i_dbl2big(double d)338 scm_i_dbl2big (double d)
339 {
340 /* results are only defined if d is an integer */
341 SCM z = make_bignum ();
342 mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
343 return z;
344 }
345
346 /* Convert a integer in double representation to a SCM number. */
347
348 SCM
scm_i_dbl2num(double u)349 scm_i_dbl2num (double u)
350 {
351 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
352 powers of 2, so there's no rounding when making "double" values
353 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
354 get rounded on a 64-bit machine, hence the "+1".
355
356 The use of floor() to force to an integer value ensures we get a
357 "numerically closest" value without depending on how a
358 double->long cast or how mpz_set_d will round. For reference,
359 double->long probably follows the hardware rounding mode,
360 mpz_set_d truncates towards zero. */
361
362 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
363 representable as a double? */
364
365 if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
366 && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
367 return SCM_I_MAKINUM ((scm_t_inum) u);
368 else
369 return scm_i_dbl2big (u);
370 }
371
372 static SCM round_right_shift_exact_integer (SCM n, long count);
373
374 /* scm_i_big2dbl_2exp() is like frexp for bignums: it converts the
375 bignum b into a normalized significand and exponent such that
376 b = significand * 2^exponent and 1/2 <= abs(significand) < 1.
377 The return value is the significand rounded to the closest
378 representable double, and the exponent is placed into *expon_p.
379 If b is zero, then the returned exponent and significand are both
380 zero. */
381
382 static double
scm_i_big2dbl_2exp(SCM b,long * expon_p)383 scm_i_big2dbl_2exp (SCM b, long *expon_p)
384 {
385 size_t bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
386 size_t shift = 0;
387
388 if (bits > DBL_MANT_DIG)
389 {
390 shift = bits - DBL_MANT_DIG;
391 b = round_right_shift_exact_integer (b, shift);
392 if (SCM_I_INUMP (b))
393 {
394 int expon;
395 double signif = frexp (SCM_I_INUM (b), &expon);
396 *expon_p = expon + shift;
397 return signif;
398 }
399 }
400
401 {
402 long expon;
403 double signif = mpz_get_d_2exp (&expon, SCM_I_BIG_MPZ (b));
404 scm_remember_upto_here_1 (b);
405 *expon_p = expon + shift;
406 return signif;
407 }
408 }
409
410 /* scm_i_big2dbl() rounds to the closest representable double,
411 in accordance with R5RS exact->inexact. */
412 double
scm_i_big2dbl(SCM b)413 scm_i_big2dbl (SCM b)
414 {
415 long expon;
416 double signif = scm_i_big2dbl_2exp (b, &expon);
417 return ldexp (signif, expon);
418 }
419
420 SCM
scm_i_normbig(SCM b)421 scm_i_normbig (SCM b)
422 {
423 /* convert a big back to a fixnum if it'll fit */
424 /* presume b is a bignum */
425 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
426 {
427 scm_t_inum val = mpz_get_si (SCM_I_BIG_MPZ (b));
428 if (SCM_FIXABLE (val))
429 b = SCM_I_MAKINUM (val);
430 }
431 return b;
432 }
433
434 static SCM_C_INLINE_KEYWORD SCM
scm_i_mpz2num(mpz_t b)435 scm_i_mpz2num (mpz_t b)
436 {
437 /* convert a mpz number to a SCM number. */
438 if (mpz_fits_slong_p (b))
439 {
440 scm_t_inum val = mpz_get_si (b);
441 if (SCM_FIXABLE (val))
442 return SCM_I_MAKINUM (val);
443 }
444
445 {
446 SCM z = make_bignum ();
447 mpz_init_set (SCM_I_BIG_MPZ (z), b);
448 return z;
449 }
450 }
451
452 /* Make the ratio NUMERATOR/DENOMINATOR, where:
453 1. NUMERATOR and DENOMINATOR are exact integers
454 2. NUMERATOR and DENOMINATOR are reduced to lowest terms: gcd(n,d) == 1 */
455 static SCM
scm_i_make_ratio_already_reduced(SCM numerator,SCM denominator)456 scm_i_make_ratio_already_reduced (SCM numerator, SCM denominator)
457 {
458 /* Flip signs so that the denominator is positive. */
459 if (scm_is_false (scm_positive_p (denominator)))
460 {
461 if (SCM_UNLIKELY (scm_is_eq (denominator, SCM_INUM0)))
462 scm_num_overflow ("make-ratio");
463 else
464 {
465 numerator = scm_difference (numerator, SCM_UNDEFINED);
466 denominator = scm_difference (denominator, SCM_UNDEFINED);
467 }
468 }
469
470 /* Check for the integer case */
471 if (scm_is_eq (denominator, SCM_INUM1))
472 return numerator;
473
474 return scm_double_cell (scm_tc16_fraction,
475 SCM_UNPACK (numerator),
476 SCM_UNPACK (denominator), 0);
477 }
478
479 static SCM scm_exact_integer_quotient (SCM x, SCM y);
480
481 /* Make the ratio NUMERATOR/DENOMINATOR */
482 static SCM
scm_i_make_ratio(SCM numerator,SCM denominator)483 scm_i_make_ratio (SCM numerator, SCM denominator)
484 #define FUNC_NAME "make-ratio"
485 {
486 /* Make sure the arguments are proper */
487 if (!SCM_LIKELY (SCM_I_INUMP (numerator) || SCM_BIGP (numerator)))
488 SCM_WRONG_TYPE_ARG (1, numerator);
489 else if (!SCM_LIKELY (SCM_I_INUMP (denominator) || SCM_BIGP (denominator)))
490 SCM_WRONG_TYPE_ARG (2, denominator);
491 else
492 {
493 SCM the_gcd = scm_gcd (numerator, denominator);
494 if (!(scm_is_eq (the_gcd, SCM_INUM1)))
495 {
496 /* Reduce to lowest terms */
497 numerator = scm_exact_integer_quotient (numerator, the_gcd);
498 denominator = scm_exact_integer_quotient (denominator, the_gcd);
499 }
500 return scm_i_make_ratio_already_reduced (numerator, denominator);
501 }
502 }
503 #undef FUNC_NAME
504
505 static mpz_t scm_i_divide2double_lo2b;
506
507 /* Return the double that is closest to the exact rational N/D, with
508 ties rounded toward even mantissas. N and D must be exact
509 integers. */
510 static double
scm_i_divide2double(SCM n,SCM d)511 scm_i_divide2double (SCM n, SCM d)
512 {
513 int neg;
514 mpz_t nn, dd, lo, hi, x;
515 ssize_t e;
516
517 if (SCM_LIKELY (SCM_I_INUMP (d)))
518 {
519 if (SCM_LIKELY
520 (SCM_I_INUMP (n)
521 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (n))
522 && INUM_LOSSLESSLY_CONVERTIBLE_TO_DOUBLE (SCM_I_INUM (d))))
523 /* If both N and D can be losslessly converted to doubles, then
524 we can rely on IEEE floating point to do proper rounding much
525 faster than we can. */
526 return ((double) SCM_I_INUM (n)) / ((double) SCM_I_INUM (d));
527
528 if (SCM_UNLIKELY (scm_is_eq (d, SCM_INUM0)))
529 {
530 if (scm_is_true (scm_positive_p (n)))
531 return 1.0 / 0.0;
532 else if (scm_is_true (scm_negative_p (n)))
533 return -1.0 / 0.0;
534 else
535 return 0.0 / 0.0;
536 }
537
538 mpz_init_set_si (dd, SCM_I_INUM (d));
539 }
540 else
541 mpz_init_set (dd, SCM_I_BIG_MPZ (d));
542
543 if (SCM_I_INUMP (n))
544 mpz_init_set_si (nn, SCM_I_INUM (n));
545 else
546 mpz_init_set (nn, SCM_I_BIG_MPZ (n));
547
548 neg = (mpz_sgn (nn) < 0) ^ (mpz_sgn (dd) < 0);
549 mpz_abs (nn, nn);
550 mpz_abs (dd, dd);
551
552 /* Now we need to find the value of e such that:
553
554 For e <= 0:
555 b^{p-1} - 1/2b <= b^-e n / d < b^p - 1/2 [1A]
556 (2 b^p - 1) <= 2 b b^-e n / d < (2 b^p - 1) b [2A]
557 (2 b^p - 1) d <= 2 b b^-e n < (2 b^p - 1) d b [3A]
558
559 For e >= 0:
560 b^{p-1} - 1/2b <= n / b^e d < b^p - 1/2 [1B]
561 (2 b^p - 1) <= 2 b n / b^e d < (2 b^p - 1) b [2B]
562 (2 b^p - 1) d b^e <= 2 b n < (2 b^p - 1) d b b^e [3B]
563
564 where: p = DBL_MANT_DIG
565 b = FLT_RADIX (here assumed to be 2)
566
567 After rounding, the mantissa must be an integer between b^{p-1} and
568 (b^p - 1), except for subnormal numbers. In the inequations [1A]
569 and [1B], the middle expression represents the mantissa *before*
570 rounding, and therefore is bounded by the range of values that will
571 round to a floating-point number with the exponent e. The upper
572 bound is (b^p - 1 + 1/2) = (b^p - 1/2), and is exclusive because
573 ties will round up to the next power of b. The lower bound is
574 (b^{p-1} - 1/2b), and is inclusive because ties will round toward
575 this power of b. Here we subtract 1/2b instead of 1/2 because it
576 is in the range of the next smaller exponent, where the
577 representable numbers are closer together by a factor of b.
578
579 Inequations [2A] and [2B] are derived from [1A] and [1B] by
580 multiplying by 2b, and in [3A] and [3B] we multiply by the
581 denominator of the middle value to obtain integer expressions.
582
583 In the code below, we refer to the three expressions in [3A] or
584 [3B] as lo, x, and hi. If the number is normalizable, we will
585 achieve the goal: lo <= x < hi */
586
587 /* Make an initial guess for e */
588 e = mpz_sizeinbase (nn, 2) - mpz_sizeinbase (dd, 2) - (DBL_MANT_DIG-1);
589 if (e < DBL_MIN_EXP - DBL_MANT_DIG)
590 e = DBL_MIN_EXP - DBL_MANT_DIG;
591
592 /* Compute the initial values of lo, x, and hi
593 based on the initial guess of e */
594 mpz_inits (lo, hi, x, NULL);
595 mpz_mul_2exp (x, nn, 2 + ((e < 0) ? -e : 0));
596 mpz_mul (lo, dd, scm_i_divide2double_lo2b);
597 if (e > 0)
598 mpz_mul_2exp (lo, lo, e);
599 mpz_mul_2exp (hi, lo, 1);
600
601 /* Adjust e as needed to satisfy the inequality lo <= x < hi,
602 (but without making e less than the minimum exponent) */
603 while (mpz_cmp (x, lo) < 0 && e > DBL_MIN_EXP - DBL_MANT_DIG)
604 {
605 mpz_mul_2exp (x, x, 1);
606 e--;
607 }
608 while (mpz_cmp (x, hi) >= 0)
609 {
610 /* If we ever used lo's value again,
611 we would need to double lo here. */
612 mpz_mul_2exp (hi, hi, 1);
613 e++;
614 }
615
616 /* Now compute the rounded mantissa:
617 n / b^e d (if e >= 0)
618 n b^-e / d (if e <= 0) */
619 {
620 int cmp;
621 double result;
622
623 if (e < 0)
624 mpz_mul_2exp (nn, nn, -e);
625 else
626 mpz_mul_2exp (dd, dd, e);
627
628 /* mpz does not directly support rounded right
629 shifts, so we have to do it the hard way.
630 For efficiency, we reuse lo and hi.
631 hi == quotient, lo == remainder */
632 mpz_fdiv_qr (hi, lo, nn, dd);
633
634 /* The fractional part of the unrounded mantissa would be
635 remainder/dividend, i.e. lo/dd. So we have a tie if
636 lo/dd = 1/2. Multiplying both sides by 2*dd yields the
637 integer expression 2*lo = dd. Here we do that comparison
638 to decide whether to round up or down. */
639 mpz_mul_2exp (lo, lo, 1);
640 cmp = mpz_cmp (lo, dd);
641 if (cmp > 0 || (cmp == 0 && mpz_odd_p (hi)))
642 mpz_add_ui (hi, hi, 1);
643
644 result = ldexp (mpz_get_d (hi), e);
645 if (neg)
646 result = -result;
647
648 mpz_clears (nn, dd, lo, hi, x, NULL);
649 return result;
650 }
651 }
652
653 double
scm_i_fraction2double(SCM z)654 scm_i_fraction2double (SCM z)
655 {
656 return scm_i_divide2double (SCM_FRACTION_NUMERATOR (z),
657 SCM_FRACTION_DENOMINATOR (z));
658 }
659
660 static SCM
scm_i_from_double(double val)661 scm_i_from_double (double val)
662 {
663 SCM z;
664
665 z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_double), "real"));
666
667 SCM_SET_CELL_TYPE (z, scm_tc16_real);
668 SCM_REAL_VALUE (z) = val;
669
670 return z;
671 }
672
673 SCM_PRIMITIVE_GENERIC (scm_exact_p, "exact?", 1, 0, 0,
674 (SCM x),
675 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
676 "otherwise.")
677 #define FUNC_NAME s_scm_exact_p
678 {
679 if (SCM_INEXACTP (x))
680 return SCM_BOOL_F;
681 else if (SCM_NUMBERP (x))
682 return SCM_BOOL_T;
683 else
684 return scm_wta_dispatch_1 (g_scm_exact_p, x, 1, s_scm_exact_p);
685 }
686 #undef FUNC_NAME
687
688 int
scm_is_exact(SCM val)689 scm_is_exact (SCM val)
690 {
691 return scm_is_true (scm_exact_p (val));
692 }
693
694 SCM_PRIMITIVE_GENERIC (scm_inexact_p, "inexact?", 1, 0, 0,
695 (SCM x),
696 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
697 "else.")
698 #define FUNC_NAME s_scm_inexact_p
699 {
700 if (SCM_INEXACTP (x))
701 return SCM_BOOL_T;
702 else if (SCM_NUMBERP (x))
703 return SCM_BOOL_F;
704 else
705 return scm_wta_dispatch_1 (g_scm_inexact_p, x, 1, s_scm_inexact_p);
706 }
707 #undef FUNC_NAME
708
709 int
scm_is_inexact(SCM val)710 scm_is_inexact (SCM val)
711 {
712 return scm_is_true (scm_inexact_p (val));
713 }
714
715 SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0,
716 (SCM n),
717 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
718 "otherwise.")
719 #define FUNC_NAME s_scm_odd_p
720 {
721 if (SCM_I_INUMP (n))
722 {
723 scm_t_inum val = SCM_I_INUM (n);
724 return scm_from_bool ((val & 1L) != 0);
725 }
726 else if (SCM_BIGP (n))
727 {
728 int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
729 scm_remember_upto_here_1 (n);
730 return scm_from_bool (odd_p);
731 }
732 else if (SCM_REALP (n))
733 {
734 double val = SCM_REAL_VALUE (n);
735 if (isfinite (val))
736 {
737 double rem = fabs (fmod (val, 2.0));
738 if (rem == 1.0)
739 return SCM_BOOL_T;
740 else if (rem == 0.0)
741 return SCM_BOOL_F;
742 }
743 }
744 return scm_wta_dispatch_1 (g_scm_odd_p, n, 1, s_scm_odd_p);
745 }
746 #undef FUNC_NAME
747
748
749 SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0,
750 (SCM n),
751 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
752 "otherwise.")
753 #define FUNC_NAME s_scm_even_p
754 {
755 if (SCM_I_INUMP (n))
756 {
757 scm_t_inum val = SCM_I_INUM (n);
758 return scm_from_bool ((val & 1L) == 0);
759 }
760 else if (SCM_BIGP (n))
761 {
762 int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
763 scm_remember_upto_here_1 (n);
764 return scm_from_bool (even_p);
765 }
766 else if (SCM_REALP (n))
767 {
768 double val = SCM_REAL_VALUE (n);
769 if (isfinite (val))
770 {
771 double rem = fabs (fmod (val, 2.0));
772 if (rem == 1.0)
773 return SCM_BOOL_F;
774 else if (rem == 0.0)
775 return SCM_BOOL_T;
776 }
777 }
778 return scm_wta_dispatch_1 (g_scm_even_p, n, 1, s_scm_even_p);
779 }
780 #undef FUNC_NAME
781
782 SCM_PRIMITIVE_GENERIC (scm_finite_p, "finite?", 1, 0, 0,
783 (SCM x),
784 "Return @code{#t} if the real number @var{x} is neither\n"
785 "infinite nor a NaN, @code{#f} otherwise.")
786 #define FUNC_NAME s_scm_finite_p
787 {
788 if (SCM_REALP (x))
789 return scm_from_bool (isfinite (SCM_REAL_VALUE (x)));
790 else if (scm_is_real (x))
791 return SCM_BOOL_T;
792 else
793 return scm_wta_dispatch_1 (g_scm_finite_p, x, 1, s_scm_finite_p);
794 }
795 #undef FUNC_NAME
796
797 SCM_PRIMITIVE_GENERIC (scm_inf_p, "inf?", 1, 0, 0,
798 (SCM x),
799 "Return @code{#t} if the real number @var{x} is @samp{+inf.0} or\n"
800 "@samp{-inf.0}. Otherwise return @code{#f}.")
801 #define FUNC_NAME s_scm_inf_p
802 {
803 if (SCM_REALP (x))
804 return scm_from_bool (isinf (SCM_REAL_VALUE (x)));
805 else if (scm_is_real (x))
806 return SCM_BOOL_F;
807 else
808 return scm_wta_dispatch_1 (g_scm_inf_p, x, 1, s_scm_inf_p);
809 }
810 #undef FUNC_NAME
811
812 SCM_PRIMITIVE_GENERIC (scm_nan_p, "nan?", 1, 0, 0,
813 (SCM x),
814 "Return @code{#t} if the real number @var{x} is a NaN,\n"
815 "or @code{#f} otherwise.")
816 #define FUNC_NAME s_scm_nan_p
817 {
818 if (SCM_REALP (x))
819 return scm_from_bool (isnan (SCM_REAL_VALUE (x)));
820 else if (scm_is_real (x))
821 return SCM_BOOL_F;
822 else
823 return scm_wta_dispatch_1 (g_scm_nan_p, x, 1, s_scm_nan_p);
824 }
825 #undef FUNC_NAME
826
827 /* Guile's idea of infinity. */
828 static double guile_Inf;
829
830 /* Guile's idea of not a number. */
831 static double guile_NaN;
832
833 static void
guile_ieee_init(void)834 guile_ieee_init (void)
835 {
836 /* Some version of gcc on some old version of Linux used to crash when
837 trying to make Inf and NaN. */
838
839 #ifdef INFINITY
840 /* C99 INFINITY, when available.
841 FIXME: The standard allows for INFINITY to be something that overflows
842 at compile time. We ought to have a configure test to check for that
843 before trying to use it. (But in practice we believe this is not a
844 problem on any system guile is likely to target.) */
845 guile_Inf = INFINITY;
846 #elif defined HAVE_DINFINITY
847 /* OSF */
848 extern unsigned int DINFINITY[2];
849 guile_Inf = (*((double *) (DINFINITY)));
850 #else
851 double tmp = 1e+10;
852 guile_Inf = tmp;
853 for (;;)
854 {
855 guile_Inf *= 1e+10;
856 if (guile_Inf == tmp)
857 break;
858 tmp = guile_Inf;
859 }
860 #endif
861
862 #ifdef NAN
863 /* C99 NAN, when available */
864 guile_NaN = NAN;
865 #elif defined HAVE_DQNAN
866 {
867 /* OSF */
868 extern unsigned int DQNAN[2];
869 guile_NaN = (*((double *)(DQNAN)));
870 }
871 #else
872 guile_NaN = guile_Inf / guile_Inf;
873 #endif
874 }
875
876 SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
877 (void),
878 "Return Inf.")
879 #define FUNC_NAME s_scm_inf
880 {
881 static int initialized = 0;
882 if (! initialized)
883 {
884 guile_ieee_init ();
885 initialized = 1;
886 }
887 return scm_i_from_double (guile_Inf);
888 }
889 #undef FUNC_NAME
890
891 SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
892 (void),
893 "Return NaN.")
894 #define FUNC_NAME s_scm_nan
895 {
896 static int initialized = 0;
897 if (!initialized)
898 {
899 guile_ieee_init ();
900 initialized = 1;
901 }
902 return scm_i_from_double (guile_NaN);
903 }
904 #undef FUNC_NAME
905
906
907 SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
908 (SCM x),
909 "Return the absolute value of @var{x}.")
910 #define FUNC_NAME s_scm_abs
911 {
912 if (SCM_I_INUMP (x))
913 {
914 scm_t_inum xx = SCM_I_INUM (x);
915 if (xx >= 0)
916 return x;
917 else if (SCM_POSFIXABLE (-xx))
918 return SCM_I_MAKINUM (-xx);
919 else
920 return scm_i_inum2big (-xx);
921 }
922 else if (SCM_LIKELY (SCM_REALP (x)))
923 {
924 double xx = SCM_REAL_VALUE (x);
925 /* If x is a NaN then xx<0 is false so we return x unchanged */
926 if (xx < 0.0)
927 return scm_i_from_double (-xx);
928 /* Handle signed zeroes properly */
929 else if (SCM_UNLIKELY (xx == 0.0))
930 return flo0;
931 else
932 return x;
933 }
934 else if (SCM_BIGP (x))
935 {
936 const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
937 if (sgn < 0)
938 return scm_i_clonebig (x, 0);
939 else
940 return x;
941 }
942 else if (SCM_FRACTIONP (x))
943 {
944 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
945 return x;
946 return scm_i_make_ratio_already_reduced
947 (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
948 SCM_FRACTION_DENOMINATOR (x));
949 }
950 else
951 return scm_wta_dispatch_1 (g_scm_abs, x, 1, s_scm_abs);
952 }
953 #undef FUNC_NAME
954
955
956 SCM_PRIMITIVE_GENERIC (scm_quotient, "quotient", 2, 0, 0,
957 (SCM x, SCM y),
958 "Return the quotient of the numbers @var{x} and @var{y}.")
959 #define FUNC_NAME s_scm_quotient
960 {
961 if (SCM_LIKELY (scm_is_integer (x)))
962 {
963 if (SCM_LIKELY (scm_is_integer (y)))
964 return scm_truncate_quotient (x, y);
965 else
966 return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG2, s_scm_quotient);
967 }
968 else
969 return scm_wta_dispatch_2 (g_scm_quotient, x, y, SCM_ARG1, s_scm_quotient);
970 }
971 #undef FUNC_NAME
972
973 SCM_PRIMITIVE_GENERIC (scm_remainder, "remainder", 2, 0, 0,
974 (SCM x, SCM y),
975 "Return the remainder of the numbers @var{x} and @var{y}.\n"
976 "@lisp\n"
977 "(remainder 13 4) @result{} 1\n"
978 "(remainder -13 4) @result{} -1\n"
979 "@end lisp")
980 #define FUNC_NAME s_scm_remainder
981 {
982 if (SCM_LIKELY (scm_is_integer (x)))
983 {
984 if (SCM_LIKELY (scm_is_integer (y)))
985 return scm_truncate_remainder (x, y);
986 else
987 return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG2, s_scm_remainder);
988 }
989 else
990 return scm_wta_dispatch_2 (g_scm_remainder, x, y, SCM_ARG1, s_scm_remainder);
991 }
992 #undef FUNC_NAME
993
994
995 SCM_PRIMITIVE_GENERIC (scm_modulo, "modulo", 2, 0, 0,
996 (SCM x, SCM y),
997 "Return the modulo of the numbers @var{x} and @var{y}.\n"
998 "@lisp\n"
999 "(modulo 13 4) @result{} 1\n"
1000 "(modulo -13 4) @result{} 3\n"
1001 "@end lisp")
1002 #define FUNC_NAME s_scm_modulo
1003 {
1004 if (SCM_LIKELY (scm_is_integer (x)))
1005 {
1006 if (SCM_LIKELY (scm_is_integer (y)))
1007 return scm_floor_remainder (x, y);
1008 else
1009 return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG2, s_scm_modulo);
1010 }
1011 else
1012 return scm_wta_dispatch_2 (g_scm_modulo, x, y, SCM_ARG1, s_scm_modulo);
1013 }
1014 #undef FUNC_NAME
1015
1016 /* Return the exact integer q such that n = q*d, for exact integers n
1017 and d, where d is known in advance to divide n evenly (with zero
1018 remainder). For large integers, this can be computed more
1019 efficiently than when the remainder is unknown. */
1020 static SCM
scm_exact_integer_quotient(SCM n,SCM d)1021 scm_exact_integer_quotient (SCM n, SCM d)
1022 #define FUNC_NAME "exact-integer-quotient"
1023 {
1024 if (SCM_LIKELY (SCM_I_INUMP (n)))
1025 {
1026 scm_t_inum nn = SCM_I_INUM (n);
1027 if (SCM_LIKELY (SCM_I_INUMP (d)))
1028 {
1029 scm_t_inum dd = SCM_I_INUM (d);
1030 if (SCM_UNLIKELY (dd == 0))
1031 scm_num_overflow ("exact-integer-quotient");
1032 else
1033 {
1034 scm_t_inum qq = nn / dd;
1035 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1036 return SCM_I_MAKINUM (qq);
1037 else
1038 return scm_i_inum2big (qq);
1039 }
1040 }
1041 else if (SCM_LIKELY (SCM_BIGP (d)))
1042 {
1043 /* n is an inum and d is a bignum. Given that d is known to
1044 divide n evenly, there are only two possibilities: n is 0,
1045 or else n is fixnum-min and d is abs(fixnum-min). */
1046 if (nn == 0)
1047 return SCM_INUM0;
1048 else
1049 return SCM_I_MAKINUM (-1);
1050 }
1051 else
1052 SCM_WRONG_TYPE_ARG (2, d);
1053 }
1054 else if (SCM_LIKELY (SCM_BIGP (n)))
1055 {
1056 if (SCM_LIKELY (SCM_I_INUMP (d)))
1057 {
1058 scm_t_inum dd = SCM_I_INUM (d);
1059 if (SCM_UNLIKELY (dd == 0))
1060 scm_num_overflow ("exact-integer-quotient");
1061 else if (SCM_UNLIKELY (dd == 1))
1062 return n;
1063 else
1064 {
1065 SCM q = scm_i_mkbig ();
1066 if (dd > 0)
1067 mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), dd);
1068 else
1069 {
1070 mpz_divexact_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), -dd);
1071 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1072 }
1073 scm_remember_upto_here_1 (n);
1074 return scm_i_normbig (q);
1075 }
1076 }
1077 else if (SCM_LIKELY (SCM_BIGP (d)))
1078 {
1079 SCM q = scm_i_mkbig ();
1080 mpz_divexact (SCM_I_BIG_MPZ (q),
1081 SCM_I_BIG_MPZ (n),
1082 SCM_I_BIG_MPZ (d));
1083 scm_remember_upto_here_2 (n, d);
1084 return scm_i_normbig (q);
1085 }
1086 else
1087 SCM_WRONG_TYPE_ARG (2, d);
1088 }
1089 else
1090 SCM_WRONG_TYPE_ARG (1, n);
1091 }
1092 #undef FUNC_NAME
1093
1094 /* two_valued_wta_dispatch_2 is a version of SCM_WTA_DISPATCH_2 for
1095 two-valued functions. It is called from primitive generics that take
1096 two arguments and return two values, when the core procedure is
1097 unable to handle the given argument types. If there are GOOPS
1098 methods for this primitive generic, it dispatches to GOOPS and, if
1099 successful, expects two values to be returned, which are placed in
1100 *rp1 and *rp2. If there are no GOOPS methods, it throws a
1101 wrong-type-arg exception.
1102
1103 FIXME: This obviously belongs somewhere else, but until we decide on
1104 the right API, it is here as a static function, because it is needed
1105 by the *_divide functions below.
1106 */
1107 static void
two_valued_wta_dispatch_2(SCM gf,SCM a1,SCM a2,int pos,const char * subr,SCM * rp1,SCM * rp2)1108 two_valued_wta_dispatch_2 (SCM gf, SCM a1, SCM a2, int pos,
1109 const char *subr, SCM *rp1, SCM *rp2)
1110 {
1111 SCM vals = scm_wta_dispatch_2 (gf, a1, a2, pos, subr);
1112
1113 scm_i_extract_values_2 (vals, rp1, rp2);
1114 }
1115
1116 SCM_DEFINE (scm_euclidean_quotient, "euclidean-quotient", 2, 0, 0,
1117 (SCM x, SCM y),
1118 "Return the integer @var{q} such that\n"
1119 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1120 "where @math{0 <= @var{r} < abs(@var{y})}.\n"
1121 "@lisp\n"
1122 "(euclidean-quotient 123 10) @result{} 12\n"
1123 "(euclidean-quotient 123 -10) @result{} -12\n"
1124 "(euclidean-quotient -123 10) @result{} -13\n"
1125 "(euclidean-quotient -123 -10) @result{} 13\n"
1126 "(euclidean-quotient -123.2 -63.5) @result{} 2.0\n"
1127 "(euclidean-quotient 16/3 -10/7) @result{} -3\n"
1128 "@end lisp")
1129 #define FUNC_NAME s_scm_euclidean_quotient
1130 {
1131 if (scm_is_false (scm_negative_p (y)))
1132 return scm_floor_quotient (x, y);
1133 else
1134 return scm_ceiling_quotient (x, y);
1135 }
1136 #undef FUNC_NAME
1137
1138 SCM_DEFINE (scm_euclidean_remainder, "euclidean-remainder", 2, 0, 0,
1139 (SCM x, SCM y),
1140 "Return the real number @var{r} such that\n"
1141 "@math{0 <= @var{r} < abs(@var{y})} and\n"
1142 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1143 "for some integer @var{q}.\n"
1144 "@lisp\n"
1145 "(euclidean-remainder 123 10) @result{} 3\n"
1146 "(euclidean-remainder 123 -10) @result{} 3\n"
1147 "(euclidean-remainder -123 10) @result{} 7\n"
1148 "(euclidean-remainder -123 -10) @result{} 7\n"
1149 "(euclidean-remainder -123.2 -63.5) @result{} 3.8\n"
1150 "(euclidean-remainder 16/3 -10/7) @result{} 22/21\n"
1151 "@end lisp")
1152 #define FUNC_NAME s_scm_euclidean_remainder
1153 {
1154 if (scm_is_false (scm_negative_p (y)))
1155 return scm_floor_remainder (x, y);
1156 else
1157 return scm_ceiling_remainder (x, y);
1158 }
1159 #undef FUNC_NAME
1160
1161 SCM_DEFINE (scm_i_euclidean_divide, "euclidean/", 2, 0, 0,
1162 (SCM x, SCM y),
1163 "Return the integer @var{q} and the real number @var{r}\n"
1164 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1165 "and @math{0 <= @var{r} < abs(@var{y})}.\n"
1166 "@lisp\n"
1167 "(euclidean/ 123 10) @result{} 12 and 3\n"
1168 "(euclidean/ 123 -10) @result{} -12 and 3\n"
1169 "(euclidean/ -123 10) @result{} -13 and 7\n"
1170 "(euclidean/ -123 -10) @result{} 13 and 7\n"
1171 "(euclidean/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
1172 "(euclidean/ 16/3 -10/7) @result{} -3 and 22/21\n"
1173 "@end lisp")
1174 #define FUNC_NAME s_scm_i_euclidean_divide
1175 {
1176 if (scm_is_false (scm_negative_p (y)))
1177 return scm_i_floor_divide (x, y);
1178 else
1179 return scm_i_ceiling_divide (x, y);
1180 }
1181 #undef FUNC_NAME
1182
1183 void
scm_euclidean_divide(SCM x,SCM y,SCM * qp,SCM * rp)1184 scm_euclidean_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1185 {
1186 if (scm_is_false (scm_negative_p (y)))
1187 scm_floor_divide (x, y, qp, rp);
1188 else
1189 scm_ceiling_divide (x, y, qp, rp);
1190 }
1191
1192 static SCM scm_i_inexact_floor_quotient (double x, double y);
1193 static SCM scm_i_exact_rational_floor_quotient (SCM x, SCM y);
1194
1195 SCM_PRIMITIVE_GENERIC (scm_floor_quotient, "floor-quotient", 2, 0, 0,
1196 (SCM x, SCM y),
1197 "Return the floor of @math{@var{x} / @var{y}}.\n"
1198 "@lisp\n"
1199 "(floor-quotient 123 10) @result{} 12\n"
1200 "(floor-quotient 123 -10) @result{} -13\n"
1201 "(floor-quotient -123 10) @result{} -13\n"
1202 "(floor-quotient -123 -10) @result{} 12\n"
1203 "(floor-quotient -123.2 -63.5) @result{} 1.0\n"
1204 "(floor-quotient 16/3 -10/7) @result{} -4\n"
1205 "@end lisp")
1206 #define FUNC_NAME s_scm_floor_quotient
1207 {
1208 if (SCM_LIKELY (SCM_I_INUMP (x)))
1209 {
1210 scm_t_inum xx = SCM_I_INUM (x);
1211 if (SCM_LIKELY (SCM_I_INUMP (y)))
1212 {
1213 scm_t_inum yy = SCM_I_INUM (y);
1214 scm_t_inum xx1 = xx;
1215 scm_t_inum qq;
1216 if (SCM_LIKELY (yy > 0))
1217 {
1218 if (SCM_UNLIKELY (xx < 0))
1219 xx1 = xx - yy + 1;
1220 }
1221 else if (SCM_UNLIKELY (yy == 0))
1222 scm_num_overflow (s_scm_floor_quotient);
1223 else if (xx > 0)
1224 xx1 = xx - yy - 1;
1225 qq = xx1 / yy;
1226 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1227 return SCM_I_MAKINUM (qq);
1228 else
1229 return scm_i_inum2big (qq);
1230 }
1231 else if (SCM_BIGP (y))
1232 {
1233 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1234 scm_remember_upto_here_1 (y);
1235 if (sign > 0)
1236 return SCM_I_MAKINUM ((xx < 0) ? -1 : 0);
1237 else
1238 return SCM_I_MAKINUM ((xx > 0) ? -1 : 0);
1239 }
1240 else if (SCM_REALP (y))
1241 return scm_i_inexact_floor_quotient (xx, SCM_REAL_VALUE (y));
1242 else if (SCM_FRACTIONP (y))
1243 return scm_i_exact_rational_floor_quotient (x, y);
1244 else
1245 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1246 s_scm_floor_quotient);
1247 }
1248 else if (SCM_BIGP (x))
1249 {
1250 if (SCM_LIKELY (SCM_I_INUMP (y)))
1251 {
1252 scm_t_inum yy = SCM_I_INUM (y);
1253 if (SCM_UNLIKELY (yy == 0))
1254 scm_num_overflow (s_scm_floor_quotient);
1255 else if (SCM_UNLIKELY (yy == 1))
1256 return x;
1257 else
1258 {
1259 SCM q = scm_i_mkbig ();
1260 if (yy > 0)
1261 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
1262 else
1263 {
1264 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
1265 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1266 }
1267 scm_remember_upto_here_1 (x);
1268 return scm_i_normbig (q);
1269 }
1270 }
1271 else if (SCM_BIGP (y))
1272 {
1273 SCM q = scm_i_mkbig ();
1274 mpz_fdiv_q (SCM_I_BIG_MPZ (q),
1275 SCM_I_BIG_MPZ (x),
1276 SCM_I_BIG_MPZ (y));
1277 scm_remember_upto_here_2 (x, y);
1278 return scm_i_normbig (q);
1279 }
1280 else if (SCM_REALP (y))
1281 return scm_i_inexact_floor_quotient
1282 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1283 else if (SCM_FRACTIONP (y))
1284 return scm_i_exact_rational_floor_quotient (x, y);
1285 else
1286 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1287 s_scm_floor_quotient);
1288 }
1289 else if (SCM_REALP (x))
1290 {
1291 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1292 SCM_BIGP (y) || SCM_FRACTIONP (y))
1293 return scm_i_inexact_floor_quotient
1294 (SCM_REAL_VALUE (x), scm_to_double (y));
1295 else
1296 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1297 s_scm_floor_quotient);
1298 }
1299 else if (SCM_FRACTIONP (x))
1300 {
1301 if (SCM_REALP (y))
1302 return scm_i_inexact_floor_quotient
1303 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1304 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1305 return scm_i_exact_rational_floor_quotient (x, y);
1306 else
1307 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG2,
1308 s_scm_floor_quotient);
1309 }
1310 else
1311 return scm_wta_dispatch_2 (g_scm_floor_quotient, x, y, SCM_ARG1,
1312 s_scm_floor_quotient);
1313 }
1314 #undef FUNC_NAME
1315
1316 static SCM
scm_i_inexact_floor_quotient(double x,double y)1317 scm_i_inexact_floor_quotient (double x, double y)
1318 {
1319 if (SCM_UNLIKELY (y == 0))
1320 scm_num_overflow (s_scm_floor_quotient); /* or return a NaN? */
1321 else
1322 return scm_i_from_double (floor (x / y));
1323 }
1324
1325 static SCM
scm_i_exact_rational_floor_quotient(SCM x,SCM y)1326 scm_i_exact_rational_floor_quotient (SCM x, SCM y)
1327 {
1328 return scm_floor_quotient
1329 (scm_product (scm_numerator (x), scm_denominator (y)),
1330 scm_product (scm_numerator (y), scm_denominator (x)));
1331 }
1332
1333 static SCM scm_i_inexact_floor_remainder (double x, double y);
1334 static SCM scm_i_exact_rational_floor_remainder (SCM x, SCM y);
1335
1336 SCM_PRIMITIVE_GENERIC (scm_floor_remainder, "floor-remainder", 2, 0, 0,
1337 (SCM x, SCM y),
1338 "Return the real number @var{r} such that\n"
1339 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1340 "where @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1341 "@lisp\n"
1342 "(floor-remainder 123 10) @result{} 3\n"
1343 "(floor-remainder 123 -10) @result{} -7\n"
1344 "(floor-remainder -123 10) @result{} 7\n"
1345 "(floor-remainder -123 -10) @result{} -3\n"
1346 "(floor-remainder -123.2 -63.5) @result{} -59.7\n"
1347 "(floor-remainder 16/3 -10/7) @result{} -8/21\n"
1348 "@end lisp")
1349 #define FUNC_NAME s_scm_floor_remainder
1350 {
1351 if (SCM_LIKELY (SCM_I_INUMP (x)))
1352 {
1353 scm_t_inum xx = SCM_I_INUM (x);
1354 if (SCM_LIKELY (SCM_I_INUMP (y)))
1355 {
1356 scm_t_inum yy = SCM_I_INUM (y);
1357 if (SCM_UNLIKELY (yy == 0))
1358 scm_num_overflow (s_scm_floor_remainder);
1359 else
1360 {
1361 scm_t_inum rr = xx % yy;
1362 int needs_adjustment;
1363
1364 if (SCM_LIKELY (yy > 0))
1365 needs_adjustment = (rr < 0);
1366 else
1367 needs_adjustment = (rr > 0);
1368
1369 if (needs_adjustment)
1370 rr += yy;
1371 return SCM_I_MAKINUM (rr);
1372 }
1373 }
1374 else if (SCM_BIGP (y))
1375 {
1376 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1377 scm_remember_upto_here_1 (y);
1378 if (sign > 0)
1379 {
1380 if (xx < 0)
1381 {
1382 SCM r = scm_i_mkbig ();
1383 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1384 scm_remember_upto_here_1 (y);
1385 return scm_i_normbig (r);
1386 }
1387 else
1388 return x;
1389 }
1390 else if (xx <= 0)
1391 return x;
1392 else
1393 {
1394 SCM r = scm_i_mkbig ();
1395 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1396 scm_remember_upto_here_1 (y);
1397 return scm_i_normbig (r);
1398 }
1399 }
1400 else if (SCM_REALP (y))
1401 return scm_i_inexact_floor_remainder (xx, SCM_REAL_VALUE (y));
1402 else if (SCM_FRACTIONP (y))
1403 return scm_i_exact_rational_floor_remainder (x, y);
1404 else
1405 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1406 s_scm_floor_remainder);
1407 }
1408 else if (SCM_BIGP (x))
1409 {
1410 if (SCM_LIKELY (SCM_I_INUMP (y)))
1411 {
1412 scm_t_inum yy = SCM_I_INUM (y);
1413 if (SCM_UNLIKELY (yy == 0))
1414 scm_num_overflow (s_scm_floor_remainder);
1415 else
1416 {
1417 scm_t_inum rr;
1418 if (yy > 0)
1419 rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), yy);
1420 else
1421 rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
1422 scm_remember_upto_here_1 (x);
1423 return SCM_I_MAKINUM (rr);
1424 }
1425 }
1426 else if (SCM_BIGP (y))
1427 {
1428 SCM r = scm_i_mkbig ();
1429 mpz_fdiv_r (SCM_I_BIG_MPZ (r),
1430 SCM_I_BIG_MPZ (x),
1431 SCM_I_BIG_MPZ (y));
1432 scm_remember_upto_here_2 (x, y);
1433 return scm_i_normbig (r);
1434 }
1435 else if (SCM_REALP (y))
1436 return scm_i_inexact_floor_remainder
1437 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1438 else if (SCM_FRACTIONP (y))
1439 return scm_i_exact_rational_floor_remainder (x, y);
1440 else
1441 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1442 s_scm_floor_remainder);
1443 }
1444 else if (SCM_REALP (x))
1445 {
1446 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1447 SCM_BIGP (y) || SCM_FRACTIONP (y))
1448 return scm_i_inexact_floor_remainder
1449 (SCM_REAL_VALUE (x), scm_to_double (y));
1450 else
1451 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1452 s_scm_floor_remainder);
1453 }
1454 else if (SCM_FRACTIONP (x))
1455 {
1456 if (SCM_REALP (y))
1457 return scm_i_inexact_floor_remainder
1458 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1459 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1460 return scm_i_exact_rational_floor_remainder (x, y);
1461 else
1462 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG2,
1463 s_scm_floor_remainder);
1464 }
1465 else
1466 return scm_wta_dispatch_2 (g_scm_floor_remainder, x, y, SCM_ARG1,
1467 s_scm_floor_remainder);
1468 }
1469 #undef FUNC_NAME
1470
1471 static SCM
scm_i_inexact_floor_remainder(double x,double y)1472 scm_i_inexact_floor_remainder (double x, double y)
1473 {
1474 /* Although it would be more efficient to use fmod here, we can't
1475 because it would in some cases produce results inconsistent with
1476 scm_i_inexact_floor_quotient, such that x != q * y + r (not even
1477 close). In particular, when x is very close to a multiple of y,
1478 then r might be either 0.0 or y, but those two cases must
1479 correspond to different choices of q. If r = 0.0 then q must be
1480 x/y, and if r = y then q must be x/y-1. If quotient chooses one
1481 and remainder chooses the other, it would be bad. */
1482 if (SCM_UNLIKELY (y == 0))
1483 scm_num_overflow (s_scm_floor_remainder); /* or return a NaN? */
1484 else
1485 return scm_i_from_double (x - y * floor (x / y));
1486 }
1487
1488 static SCM
scm_i_exact_rational_floor_remainder(SCM x,SCM y)1489 scm_i_exact_rational_floor_remainder (SCM x, SCM y)
1490 {
1491 SCM xd = scm_denominator (x);
1492 SCM yd = scm_denominator (y);
1493 SCM r1 = scm_floor_remainder (scm_product (scm_numerator (x), yd),
1494 scm_product (scm_numerator (y), xd));
1495 return scm_divide (r1, scm_product (xd, yd));
1496 }
1497
1498
1499 static void scm_i_inexact_floor_divide (double x, double y,
1500 SCM *qp, SCM *rp);
1501 static void scm_i_exact_rational_floor_divide (SCM x, SCM y,
1502 SCM *qp, SCM *rp);
1503
1504 SCM_PRIMITIVE_GENERIC (scm_i_floor_divide, "floor/", 2, 0, 0,
1505 (SCM x, SCM y),
1506 "Return the integer @var{q} and the real number @var{r}\n"
1507 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1508 "and @math{@var{q} = floor(@var{x} / @var{y})}.\n"
1509 "@lisp\n"
1510 "(floor/ 123 10) @result{} 12 and 3\n"
1511 "(floor/ 123 -10) @result{} -13 and -7\n"
1512 "(floor/ -123 10) @result{} -13 and 7\n"
1513 "(floor/ -123 -10) @result{} 12 and -3\n"
1514 "(floor/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
1515 "(floor/ 16/3 -10/7) @result{} -4 and -8/21\n"
1516 "@end lisp")
1517 #define FUNC_NAME s_scm_i_floor_divide
1518 {
1519 SCM q, r;
1520
1521 scm_floor_divide(x, y, &q, &r);
1522 return scm_values (scm_list_2 (q, r));
1523 }
1524 #undef FUNC_NAME
1525
1526 #define s_scm_floor_divide s_scm_i_floor_divide
1527 #define g_scm_floor_divide g_scm_i_floor_divide
1528
1529 void
scm_floor_divide(SCM x,SCM y,SCM * qp,SCM * rp)1530 scm_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1531 {
1532 if (SCM_LIKELY (SCM_I_INUMP (x)))
1533 {
1534 scm_t_inum xx = SCM_I_INUM (x);
1535 if (SCM_LIKELY (SCM_I_INUMP (y)))
1536 {
1537 scm_t_inum yy = SCM_I_INUM (y);
1538 if (SCM_UNLIKELY (yy == 0))
1539 scm_num_overflow (s_scm_floor_divide);
1540 else
1541 {
1542 scm_t_inum qq = xx / yy;
1543 scm_t_inum rr = xx % yy;
1544 int needs_adjustment;
1545
1546 if (SCM_LIKELY (yy > 0))
1547 needs_adjustment = (rr < 0);
1548 else
1549 needs_adjustment = (rr > 0);
1550
1551 if (needs_adjustment)
1552 {
1553 rr += yy;
1554 qq--;
1555 }
1556
1557 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1558 *qp = SCM_I_MAKINUM (qq);
1559 else
1560 *qp = scm_i_inum2big (qq);
1561 *rp = SCM_I_MAKINUM (rr);
1562 }
1563 }
1564 else if (SCM_BIGP (y))
1565 {
1566 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1567 scm_remember_upto_here_1 (y);
1568 if (sign > 0)
1569 {
1570 if (xx < 0)
1571 {
1572 SCM r = scm_i_mkbig ();
1573 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1574 scm_remember_upto_here_1 (y);
1575 *qp = SCM_I_MAKINUM (-1);
1576 *rp = scm_i_normbig (r);
1577 }
1578 else
1579 {
1580 *qp = SCM_INUM0;
1581 *rp = x;
1582 }
1583 }
1584 else if (xx <= 0)
1585 {
1586 *qp = SCM_INUM0;
1587 *rp = x;
1588 }
1589 else
1590 {
1591 SCM r = scm_i_mkbig ();
1592 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1593 scm_remember_upto_here_1 (y);
1594 *qp = SCM_I_MAKINUM (-1);
1595 *rp = scm_i_normbig (r);
1596 }
1597 }
1598 else if (SCM_REALP (y))
1599 scm_i_inexact_floor_divide (xx, SCM_REAL_VALUE (y), qp, rp);
1600 else if (SCM_FRACTIONP (y))
1601 scm_i_exact_rational_floor_divide (x, y, qp, rp);
1602 else
1603 two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1604 s_scm_floor_divide, qp, rp);
1605 }
1606 else if (SCM_BIGP (x))
1607 {
1608 if (SCM_LIKELY (SCM_I_INUMP (y)))
1609 {
1610 scm_t_inum yy = SCM_I_INUM (y);
1611 if (SCM_UNLIKELY (yy == 0))
1612 scm_num_overflow (s_scm_floor_divide);
1613 else
1614 {
1615 SCM q = scm_i_mkbig ();
1616 SCM r = scm_i_mkbig ();
1617 if (yy > 0)
1618 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1619 SCM_I_BIG_MPZ (x), yy);
1620 else
1621 {
1622 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1623 SCM_I_BIG_MPZ (x), -yy);
1624 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1625 }
1626 scm_remember_upto_here_1 (x);
1627 *qp = scm_i_normbig (q);
1628 *rp = scm_i_normbig (r);
1629 }
1630 }
1631 else if (SCM_BIGP (y))
1632 {
1633 SCM q = scm_i_mkbig ();
1634 SCM r = scm_i_mkbig ();
1635 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
1636 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
1637 scm_remember_upto_here_2 (x, y);
1638 *qp = scm_i_normbig (q);
1639 *rp = scm_i_normbig (r);
1640 }
1641 else if (SCM_REALP (y))
1642 scm_i_inexact_floor_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
1643 qp, rp);
1644 else if (SCM_FRACTIONP (y))
1645 scm_i_exact_rational_floor_divide (x, y, qp, rp);
1646 else
1647 two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1648 s_scm_floor_divide, qp, rp);
1649 }
1650 else if (SCM_REALP (x))
1651 {
1652 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1653 SCM_BIGP (y) || SCM_FRACTIONP (y))
1654 scm_i_inexact_floor_divide (SCM_REAL_VALUE (x), scm_to_double (y),
1655 qp, rp);
1656 else
1657 two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1658 s_scm_floor_divide, qp, rp);
1659 }
1660 else if (SCM_FRACTIONP (x))
1661 {
1662 if (SCM_REALP (y))
1663 scm_i_inexact_floor_divide
1664 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
1665 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1666 scm_i_exact_rational_floor_divide (x, y, qp, rp);
1667 else
1668 two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG2,
1669 s_scm_floor_divide, qp, rp);
1670 }
1671 else
1672 two_valued_wta_dispatch_2 (g_scm_floor_divide, x, y, SCM_ARG1,
1673 s_scm_floor_divide, qp, rp);
1674 }
1675
1676 static void
scm_i_inexact_floor_divide(double x,double y,SCM * qp,SCM * rp)1677 scm_i_inexact_floor_divide (double x, double y, SCM *qp, SCM *rp)
1678 {
1679 if (SCM_UNLIKELY (y == 0))
1680 scm_num_overflow (s_scm_floor_divide); /* or return a NaN? */
1681 else
1682 {
1683 double q = floor (x / y);
1684 double r = x - q * y;
1685 *qp = scm_i_from_double (q);
1686 *rp = scm_i_from_double (r);
1687 }
1688 }
1689
1690 static void
scm_i_exact_rational_floor_divide(SCM x,SCM y,SCM * qp,SCM * rp)1691 scm_i_exact_rational_floor_divide (SCM x, SCM y, SCM *qp, SCM *rp)
1692 {
1693 SCM r1;
1694 SCM xd = scm_denominator (x);
1695 SCM yd = scm_denominator (y);
1696
1697 scm_floor_divide (scm_product (scm_numerator (x), yd),
1698 scm_product (scm_numerator (y), xd),
1699 qp, &r1);
1700 *rp = scm_divide (r1, scm_product (xd, yd));
1701 }
1702
1703 static SCM scm_i_inexact_ceiling_quotient (double x, double y);
1704 static SCM scm_i_exact_rational_ceiling_quotient (SCM x, SCM y);
1705
1706 SCM_PRIMITIVE_GENERIC (scm_ceiling_quotient, "ceiling-quotient", 2, 0, 0,
1707 (SCM x, SCM y),
1708 "Return the ceiling of @math{@var{x} / @var{y}}.\n"
1709 "@lisp\n"
1710 "(ceiling-quotient 123 10) @result{} 13\n"
1711 "(ceiling-quotient 123 -10) @result{} -12\n"
1712 "(ceiling-quotient -123 10) @result{} -12\n"
1713 "(ceiling-quotient -123 -10) @result{} 13\n"
1714 "(ceiling-quotient -123.2 -63.5) @result{} 2.0\n"
1715 "(ceiling-quotient 16/3 -10/7) @result{} -3\n"
1716 "@end lisp")
1717 #define FUNC_NAME s_scm_ceiling_quotient
1718 {
1719 if (SCM_LIKELY (SCM_I_INUMP (x)))
1720 {
1721 scm_t_inum xx = SCM_I_INUM (x);
1722 if (SCM_LIKELY (SCM_I_INUMP (y)))
1723 {
1724 scm_t_inum yy = SCM_I_INUM (y);
1725 if (SCM_UNLIKELY (yy == 0))
1726 scm_num_overflow (s_scm_ceiling_quotient);
1727 else
1728 {
1729 scm_t_inum xx1 = xx;
1730 scm_t_inum qq;
1731 if (SCM_LIKELY (yy > 0))
1732 {
1733 if (SCM_LIKELY (xx >= 0))
1734 xx1 = xx + yy - 1;
1735 }
1736 else if (xx < 0)
1737 xx1 = xx + yy + 1;
1738 qq = xx1 / yy;
1739 if (SCM_LIKELY (SCM_FIXABLE (qq)))
1740 return SCM_I_MAKINUM (qq);
1741 else
1742 return scm_i_inum2big (qq);
1743 }
1744 }
1745 else if (SCM_BIGP (y))
1746 {
1747 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1748 scm_remember_upto_here_1 (y);
1749 if (SCM_LIKELY (sign > 0))
1750 {
1751 if (SCM_LIKELY (xx > 0))
1752 return SCM_INUM1;
1753 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
1754 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
1755 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
1756 {
1757 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1758 scm_remember_upto_here_1 (y);
1759 return SCM_I_MAKINUM (-1);
1760 }
1761 else
1762 return SCM_INUM0;
1763 }
1764 else if (xx >= 0)
1765 return SCM_INUM0;
1766 else
1767 return SCM_INUM1;
1768 }
1769 else if (SCM_REALP (y))
1770 return scm_i_inexact_ceiling_quotient (xx, SCM_REAL_VALUE (y));
1771 else if (SCM_FRACTIONP (y))
1772 return scm_i_exact_rational_ceiling_quotient (x, y);
1773 else
1774 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1775 s_scm_ceiling_quotient);
1776 }
1777 else if (SCM_BIGP (x))
1778 {
1779 if (SCM_LIKELY (SCM_I_INUMP (y)))
1780 {
1781 scm_t_inum yy = SCM_I_INUM (y);
1782 if (SCM_UNLIKELY (yy == 0))
1783 scm_num_overflow (s_scm_ceiling_quotient);
1784 else if (SCM_UNLIKELY (yy == 1))
1785 return x;
1786 else
1787 {
1788 SCM q = scm_i_mkbig ();
1789 if (yy > 0)
1790 mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
1791 else
1792 {
1793 mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
1794 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
1795 }
1796 scm_remember_upto_here_1 (x);
1797 return scm_i_normbig (q);
1798 }
1799 }
1800 else if (SCM_BIGP (y))
1801 {
1802 SCM q = scm_i_mkbig ();
1803 mpz_cdiv_q (SCM_I_BIG_MPZ (q),
1804 SCM_I_BIG_MPZ (x),
1805 SCM_I_BIG_MPZ (y));
1806 scm_remember_upto_here_2 (x, y);
1807 return scm_i_normbig (q);
1808 }
1809 else if (SCM_REALP (y))
1810 return scm_i_inexact_ceiling_quotient
1811 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1812 else if (SCM_FRACTIONP (y))
1813 return scm_i_exact_rational_ceiling_quotient (x, y);
1814 else
1815 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1816 s_scm_ceiling_quotient);
1817 }
1818 else if (SCM_REALP (x))
1819 {
1820 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1821 SCM_BIGP (y) || SCM_FRACTIONP (y))
1822 return scm_i_inexact_ceiling_quotient
1823 (SCM_REAL_VALUE (x), scm_to_double (y));
1824 else
1825 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1826 s_scm_ceiling_quotient);
1827 }
1828 else if (SCM_FRACTIONP (x))
1829 {
1830 if (SCM_REALP (y))
1831 return scm_i_inexact_ceiling_quotient
1832 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1833 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1834 return scm_i_exact_rational_ceiling_quotient (x, y);
1835 else
1836 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG2,
1837 s_scm_ceiling_quotient);
1838 }
1839 else
1840 return scm_wta_dispatch_2 (g_scm_ceiling_quotient, x, y, SCM_ARG1,
1841 s_scm_ceiling_quotient);
1842 }
1843 #undef FUNC_NAME
1844
1845 static SCM
scm_i_inexact_ceiling_quotient(double x,double y)1846 scm_i_inexact_ceiling_quotient (double x, double y)
1847 {
1848 if (SCM_UNLIKELY (y == 0))
1849 scm_num_overflow (s_scm_ceiling_quotient); /* or return a NaN? */
1850 else
1851 return scm_i_from_double (ceil (x / y));
1852 }
1853
1854 static SCM
scm_i_exact_rational_ceiling_quotient(SCM x,SCM y)1855 scm_i_exact_rational_ceiling_quotient (SCM x, SCM y)
1856 {
1857 return scm_ceiling_quotient
1858 (scm_product (scm_numerator (x), scm_denominator (y)),
1859 scm_product (scm_numerator (y), scm_denominator (x)));
1860 }
1861
1862 static SCM scm_i_inexact_ceiling_remainder (double x, double y);
1863 static SCM scm_i_exact_rational_ceiling_remainder (SCM x, SCM y);
1864
1865 SCM_PRIMITIVE_GENERIC (scm_ceiling_remainder, "ceiling-remainder", 2, 0, 0,
1866 (SCM x, SCM y),
1867 "Return the real number @var{r} such that\n"
1868 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
1869 "where @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
1870 "@lisp\n"
1871 "(ceiling-remainder 123 10) @result{} -7\n"
1872 "(ceiling-remainder 123 -10) @result{} 3\n"
1873 "(ceiling-remainder -123 10) @result{} -3\n"
1874 "(ceiling-remainder -123 -10) @result{} 7\n"
1875 "(ceiling-remainder -123.2 -63.5) @result{} 3.8\n"
1876 "(ceiling-remainder 16/3 -10/7) @result{} 22/21\n"
1877 "@end lisp")
1878 #define FUNC_NAME s_scm_ceiling_remainder
1879 {
1880 if (SCM_LIKELY (SCM_I_INUMP (x)))
1881 {
1882 scm_t_inum xx = SCM_I_INUM (x);
1883 if (SCM_LIKELY (SCM_I_INUMP (y)))
1884 {
1885 scm_t_inum yy = SCM_I_INUM (y);
1886 if (SCM_UNLIKELY (yy == 0))
1887 scm_num_overflow (s_scm_ceiling_remainder);
1888 else
1889 {
1890 scm_t_inum rr = xx % yy;
1891 int needs_adjustment;
1892
1893 if (SCM_LIKELY (yy > 0))
1894 needs_adjustment = (rr > 0);
1895 else
1896 needs_adjustment = (rr < 0);
1897
1898 if (needs_adjustment)
1899 rr -= yy;
1900 return SCM_I_MAKINUM (rr);
1901 }
1902 }
1903 else if (SCM_BIGP (y))
1904 {
1905 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
1906 scm_remember_upto_here_1 (y);
1907 if (SCM_LIKELY (sign > 0))
1908 {
1909 if (SCM_LIKELY (xx > 0))
1910 {
1911 SCM r = scm_i_mkbig ();
1912 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
1913 scm_remember_upto_here_1 (y);
1914 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1915 return scm_i_normbig (r);
1916 }
1917 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
1918 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
1919 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
1920 {
1921 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
1922 scm_remember_upto_here_1 (y);
1923 return SCM_INUM0;
1924 }
1925 else
1926 return x;
1927 }
1928 else if (xx >= 0)
1929 return x;
1930 else
1931 {
1932 SCM r = scm_i_mkbig ();
1933 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
1934 scm_remember_upto_here_1 (y);
1935 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
1936 return scm_i_normbig (r);
1937 }
1938 }
1939 else if (SCM_REALP (y))
1940 return scm_i_inexact_ceiling_remainder (xx, SCM_REAL_VALUE (y));
1941 else if (SCM_FRACTIONP (y))
1942 return scm_i_exact_rational_ceiling_remainder (x, y);
1943 else
1944 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1945 s_scm_ceiling_remainder);
1946 }
1947 else if (SCM_BIGP (x))
1948 {
1949 if (SCM_LIKELY (SCM_I_INUMP (y)))
1950 {
1951 scm_t_inum yy = SCM_I_INUM (y);
1952 if (SCM_UNLIKELY (yy == 0))
1953 scm_num_overflow (s_scm_ceiling_remainder);
1954 else
1955 {
1956 scm_t_inum rr;
1957 if (yy > 0)
1958 rr = -mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
1959 else
1960 rr = mpz_fdiv_ui (SCM_I_BIG_MPZ (x), -yy);
1961 scm_remember_upto_here_1 (x);
1962 return SCM_I_MAKINUM (rr);
1963 }
1964 }
1965 else if (SCM_BIGP (y))
1966 {
1967 SCM r = scm_i_mkbig ();
1968 mpz_cdiv_r (SCM_I_BIG_MPZ (r),
1969 SCM_I_BIG_MPZ (x),
1970 SCM_I_BIG_MPZ (y));
1971 scm_remember_upto_here_2 (x, y);
1972 return scm_i_normbig (r);
1973 }
1974 else if (SCM_REALP (y))
1975 return scm_i_inexact_ceiling_remainder
1976 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
1977 else if (SCM_FRACTIONP (y))
1978 return scm_i_exact_rational_ceiling_remainder (x, y);
1979 else
1980 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1981 s_scm_ceiling_remainder);
1982 }
1983 else if (SCM_REALP (x))
1984 {
1985 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
1986 SCM_BIGP (y) || SCM_FRACTIONP (y))
1987 return scm_i_inexact_ceiling_remainder
1988 (SCM_REAL_VALUE (x), scm_to_double (y));
1989 else
1990 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
1991 s_scm_ceiling_remainder);
1992 }
1993 else if (SCM_FRACTIONP (x))
1994 {
1995 if (SCM_REALP (y))
1996 return scm_i_inexact_ceiling_remainder
1997 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
1998 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
1999 return scm_i_exact_rational_ceiling_remainder (x, y);
2000 else
2001 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG2,
2002 s_scm_ceiling_remainder);
2003 }
2004 else
2005 return scm_wta_dispatch_2 (g_scm_ceiling_remainder, x, y, SCM_ARG1,
2006 s_scm_ceiling_remainder);
2007 }
2008 #undef FUNC_NAME
2009
2010 static SCM
scm_i_inexact_ceiling_remainder(double x,double y)2011 scm_i_inexact_ceiling_remainder (double x, double y)
2012 {
2013 /* Although it would be more efficient to use fmod here, we can't
2014 because it would in some cases produce results inconsistent with
2015 scm_i_inexact_ceiling_quotient, such that x != q * y + r (not even
2016 close). In particular, when x is very close to a multiple of y,
2017 then r might be either 0.0 or -y, but those two cases must
2018 correspond to different choices of q. If r = 0.0 then q must be
2019 x/y, and if r = -y then q must be x/y+1. If quotient chooses one
2020 and remainder chooses the other, it would be bad. */
2021 if (SCM_UNLIKELY (y == 0))
2022 scm_num_overflow (s_scm_ceiling_remainder); /* or return a NaN? */
2023 else
2024 return scm_i_from_double (x - y * ceil (x / y));
2025 }
2026
2027 static SCM
scm_i_exact_rational_ceiling_remainder(SCM x,SCM y)2028 scm_i_exact_rational_ceiling_remainder (SCM x, SCM y)
2029 {
2030 SCM xd = scm_denominator (x);
2031 SCM yd = scm_denominator (y);
2032 SCM r1 = scm_ceiling_remainder (scm_product (scm_numerator (x), yd),
2033 scm_product (scm_numerator (y), xd));
2034 return scm_divide (r1, scm_product (xd, yd));
2035 }
2036
2037 static void scm_i_inexact_ceiling_divide (double x, double y,
2038 SCM *qp, SCM *rp);
2039 static void scm_i_exact_rational_ceiling_divide (SCM x, SCM y,
2040 SCM *qp, SCM *rp);
2041
2042 SCM_PRIMITIVE_GENERIC (scm_i_ceiling_divide, "ceiling/", 2, 0, 0,
2043 (SCM x, SCM y),
2044 "Return the integer @var{q} and the real number @var{r}\n"
2045 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2046 "and @math{@var{q} = ceiling(@var{x} / @var{y})}.\n"
2047 "@lisp\n"
2048 "(ceiling/ 123 10) @result{} 13 and -7\n"
2049 "(ceiling/ 123 -10) @result{} -12 and 3\n"
2050 "(ceiling/ -123 10) @result{} -12 and -3\n"
2051 "(ceiling/ -123 -10) @result{} 13 and 7\n"
2052 "(ceiling/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
2053 "(ceiling/ 16/3 -10/7) @result{} -3 and 22/21\n"
2054 "@end lisp")
2055 #define FUNC_NAME s_scm_i_ceiling_divide
2056 {
2057 SCM q, r;
2058
2059 scm_ceiling_divide(x, y, &q, &r);
2060 return scm_values (scm_list_2 (q, r));
2061 }
2062 #undef FUNC_NAME
2063
2064 #define s_scm_ceiling_divide s_scm_i_ceiling_divide
2065 #define g_scm_ceiling_divide g_scm_i_ceiling_divide
2066
2067 void
scm_ceiling_divide(SCM x,SCM y,SCM * qp,SCM * rp)2068 scm_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2069 {
2070 if (SCM_LIKELY (SCM_I_INUMP (x)))
2071 {
2072 scm_t_inum xx = SCM_I_INUM (x);
2073 if (SCM_LIKELY (SCM_I_INUMP (y)))
2074 {
2075 scm_t_inum yy = SCM_I_INUM (y);
2076 if (SCM_UNLIKELY (yy == 0))
2077 scm_num_overflow (s_scm_ceiling_divide);
2078 else
2079 {
2080 scm_t_inum qq = xx / yy;
2081 scm_t_inum rr = xx % yy;
2082 int needs_adjustment;
2083
2084 if (SCM_LIKELY (yy > 0))
2085 needs_adjustment = (rr > 0);
2086 else
2087 needs_adjustment = (rr < 0);
2088
2089 if (needs_adjustment)
2090 {
2091 rr -= yy;
2092 qq++;
2093 }
2094 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2095 *qp = SCM_I_MAKINUM (qq);
2096 else
2097 *qp = scm_i_inum2big (qq);
2098 *rp = SCM_I_MAKINUM (rr);
2099 }
2100 }
2101 else if (SCM_BIGP (y))
2102 {
2103 int sign = mpz_sgn (SCM_I_BIG_MPZ (y));
2104 scm_remember_upto_here_1 (y);
2105 if (SCM_LIKELY (sign > 0))
2106 {
2107 if (SCM_LIKELY (xx > 0))
2108 {
2109 SCM r = scm_i_mkbig ();
2110 mpz_sub_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), xx);
2111 scm_remember_upto_here_1 (y);
2112 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
2113 *qp = SCM_INUM1;
2114 *rp = scm_i_normbig (r);
2115 }
2116 else if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2117 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2118 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2119 {
2120 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2121 scm_remember_upto_here_1 (y);
2122 *qp = SCM_I_MAKINUM (-1);
2123 *rp = SCM_INUM0;
2124 }
2125 else
2126 {
2127 *qp = SCM_INUM0;
2128 *rp = x;
2129 }
2130 }
2131 else if (xx >= 0)
2132 {
2133 *qp = SCM_INUM0;
2134 *rp = x;
2135 }
2136 else
2137 {
2138 SCM r = scm_i_mkbig ();
2139 mpz_add_ui (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y), -xx);
2140 scm_remember_upto_here_1 (y);
2141 mpz_neg (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r));
2142 *qp = SCM_INUM1;
2143 *rp = scm_i_normbig (r);
2144 }
2145 }
2146 else if (SCM_REALP (y))
2147 scm_i_inexact_ceiling_divide (xx, SCM_REAL_VALUE (y), qp, rp);
2148 else if (SCM_FRACTIONP (y))
2149 scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
2150 else
2151 two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2152 s_scm_ceiling_divide, qp, rp);
2153 }
2154 else if (SCM_BIGP (x))
2155 {
2156 if (SCM_LIKELY (SCM_I_INUMP (y)))
2157 {
2158 scm_t_inum yy = SCM_I_INUM (y);
2159 if (SCM_UNLIKELY (yy == 0))
2160 scm_num_overflow (s_scm_ceiling_divide);
2161 else
2162 {
2163 SCM q = scm_i_mkbig ();
2164 SCM r = scm_i_mkbig ();
2165 if (yy > 0)
2166 mpz_cdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2167 SCM_I_BIG_MPZ (x), yy);
2168 else
2169 {
2170 mpz_fdiv_qr_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2171 SCM_I_BIG_MPZ (x), -yy);
2172 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2173 }
2174 scm_remember_upto_here_1 (x);
2175 *qp = scm_i_normbig (q);
2176 *rp = scm_i_normbig (r);
2177 }
2178 }
2179 else if (SCM_BIGP (y))
2180 {
2181 SCM q = scm_i_mkbig ();
2182 SCM r = scm_i_mkbig ();
2183 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2184 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2185 scm_remember_upto_here_2 (x, y);
2186 *qp = scm_i_normbig (q);
2187 *rp = scm_i_normbig (r);
2188 }
2189 else if (SCM_REALP (y))
2190 scm_i_inexact_ceiling_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
2191 qp, rp);
2192 else if (SCM_FRACTIONP (y))
2193 scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
2194 else
2195 two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2196 s_scm_ceiling_divide, qp, rp);
2197 }
2198 else if (SCM_REALP (x))
2199 {
2200 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2201 SCM_BIGP (y) || SCM_FRACTIONP (y))
2202 scm_i_inexact_ceiling_divide (SCM_REAL_VALUE (x), scm_to_double (y),
2203 qp, rp);
2204 else
2205 two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2206 s_scm_ceiling_divide, qp, rp);
2207 }
2208 else if (SCM_FRACTIONP (x))
2209 {
2210 if (SCM_REALP (y))
2211 scm_i_inexact_ceiling_divide
2212 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
2213 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2214 scm_i_exact_rational_ceiling_divide (x, y, qp, rp);
2215 else
2216 two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG2,
2217 s_scm_ceiling_divide, qp, rp);
2218 }
2219 else
2220 two_valued_wta_dispatch_2 (g_scm_ceiling_divide, x, y, SCM_ARG1,
2221 s_scm_ceiling_divide, qp, rp);
2222 }
2223
2224 static void
scm_i_inexact_ceiling_divide(double x,double y,SCM * qp,SCM * rp)2225 scm_i_inexact_ceiling_divide (double x, double y, SCM *qp, SCM *rp)
2226 {
2227 if (SCM_UNLIKELY (y == 0))
2228 scm_num_overflow (s_scm_ceiling_divide); /* or return a NaN? */
2229 else
2230 {
2231 double q = ceil (x / y);
2232 double r = x - q * y;
2233 *qp = scm_i_from_double (q);
2234 *rp = scm_i_from_double (r);
2235 }
2236 }
2237
2238 static void
scm_i_exact_rational_ceiling_divide(SCM x,SCM y,SCM * qp,SCM * rp)2239 scm_i_exact_rational_ceiling_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2240 {
2241 SCM r1;
2242 SCM xd = scm_denominator (x);
2243 SCM yd = scm_denominator (y);
2244
2245 scm_ceiling_divide (scm_product (scm_numerator (x), yd),
2246 scm_product (scm_numerator (y), xd),
2247 qp, &r1);
2248 *rp = scm_divide (r1, scm_product (xd, yd));
2249 }
2250
2251 static SCM scm_i_inexact_truncate_quotient (double x, double y);
2252 static SCM scm_i_exact_rational_truncate_quotient (SCM x, SCM y);
2253
2254 SCM_PRIMITIVE_GENERIC (scm_truncate_quotient, "truncate-quotient", 2, 0, 0,
2255 (SCM x, SCM y),
2256 "Return @math{@var{x} / @var{y}} rounded toward zero.\n"
2257 "@lisp\n"
2258 "(truncate-quotient 123 10) @result{} 12\n"
2259 "(truncate-quotient 123 -10) @result{} -12\n"
2260 "(truncate-quotient -123 10) @result{} -12\n"
2261 "(truncate-quotient -123 -10) @result{} 12\n"
2262 "(truncate-quotient -123.2 -63.5) @result{} 1.0\n"
2263 "(truncate-quotient 16/3 -10/7) @result{} -3\n"
2264 "@end lisp")
2265 #define FUNC_NAME s_scm_truncate_quotient
2266 {
2267 if (SCM_LIKELY (SCM_I_INUMP (x)))
2268 {
2269 scm_t_inum xx = SCM_I_INUM (x);
2270 if (SCM_LIKELY (SCM_I_INUMP (y)))
2271 {
2272 scm_t_inum yy = SCM_I_INUM (y);
2273 if (SCM_UNLIKELY (yy == 0))
2274 scm_num_overflow (s_scm_truncate_quotient);
2275 else
2276 {
2277 scm_t_inum qq = xx / yy;
2278 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2279 return SCM_I_MAKINUM (qq);
2280 else
2281 return scm_i_inum2big (qq);
2282 }
2283 }
2284 else if (SCM_BIGP (y))
2285 {
2286 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2287 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2288 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2289 {
2290 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2291 scm_remember_upto_here_1 (y);
2292 return SCM_I_MAKINUM (-1);
2293 }
2294 else
2295 return SCM_INUM0;
2296 }
2297 else if (SCM_REALP (y))
2298 return scm_i_inexact_truncate_quotient (xx, SCM_REAL_VALUE (y));
2299 else if (SCM_FRACTIONP (y))
2300 return scm_i_exact_rational_truncate_quotient (x, y);
2301 else
2302 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2303 s_scm_truncate_quotient);
2304 }
2305 else if (SCM_BIGP (x))
2306 {
2307 if (SCM_LIKELY (SCM_I_INUMP (y)))
2308 {
2309 scm_t_inum yy = SCM_I_INUM (y);
2310 if (SCM_UNLIKELY (yy == 0))
2311 scm_num_overflow (s_scm_truncate_quotient);
2312 else if (SCM_UNLIKELY (yy == 1))
2313 return x;
2314 else
2315 {
2316 SCM q = scm_i_mkbig ();
2317 if (yy > 0)
2318 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), yy);
2319 else
2320 {
2321 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (x), -yy);
2322 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2323 }
2324 scm_remember_upto_here_1 (x);
2325 return scm_i_normbig (q);
2326 }
2327 }
2328 else if (SCM_BIGP (y))
2329 {
2330 SCM q = scm_i_mkbig ();
2331 mpz_tdiv_q (SCM_I_BIG_MPZ (q),
2332 SCM_I_BIG_MPZ (x),
2333 SCM_I_BIG_MPZ (y));
2334 scm_remember_upto_here_2 (x, y);
2335 return scm_i_normbig (q);
2336 }
2337 else if (SCM_REALP (y))
2338 return scm_i_inexact_truncate_quotient
2339 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2340 else if (SCM_FRACTIONP (y))
2341 return scm_i_exact_rational_truncate_quotient (x, y);
2342 else
2343 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2344 s_scm_truncate_quotient);
2345 }
2346 else if (SCM_REALP (x))
2347 {
2348 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2349 SCM_BIGP (y) || SCM_FRACTIONP (y))
2350 return scm_i_inexact_truncate_quotient
2351 (SCM_REAL_VALUE (x), scm_to_double (y));
2352 else
2353 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2354 s_scm_truncate_quotient);
2355 }
2356 else if (SCM_FRACTIONP (x))
2357 {
2358 if (SCM_REALP (y))
2359 return scm_i_inexact_truncate_quotient
2360 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2361 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2362 return scm_i_exact_rational_truncate_quotient (x, y);
2363 else
2364 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG2,
2365 s_scm_truncate_quotient);
2366 }
2367 else
2368 return scm_wta_dispatch_2 (g_scm_truncate_quotient, x, y, SCM_ARG1,
2369 s_scm_truncate_quotient);
2370 }
2371 #undef FUNC_NAME
2372
2373 static SCM
scm_i_inexact_truncate_quotient(double x,double y)2374 scm_i_inexact_truncate_quotient (double x, double y)
2375 {
2376 if (SCM_UNLIKELY (y == 0))
2377 scm_num_overflow (s_scm_truncate_quotient); /* or return a NaN? */
2378 else
2379 return scm_i_from_double (trunc (x / y));
2380 }
2381
2382 static SCM
scm_i_exact_rational_truncate_quotient(SCM x,SCM y)2383 scm_i_exact_rational_truncate_quotient (SCM x, SCM y)
2384 {
2385 return scm_truncate_quotient
2386 (scm_product (scm_numerator (x), scm_denominator (y)),
2387 scm_product (scm_numerator (y), scm_denominator (x)));
2388 }
2389
2390 static SCM scm_i_inexact_truncate_remainder (double x, double y);
2391 static SCM scm_i_exact_rational_truncate_remainder (SCM x, SCM y);
2392
2393 SCM_PRIMITIVE_GENERIC (scm_truncate_remainder, "truncate-remainder", 2, 0, 0,
2394 (SCM x, SCM y),
2395 "Return the real number @var{r} such that\n"
2396 "@math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2397 "where @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2398 "@lisp\n"
2399 "(truncate-remainder 123 10) @result{} 3\n"
2400 "(truncate-remainder 123 -10) @result{} 3\n"
2401 "(truncate-remainder -123 10) @result{} -3\n"
2402 "(truncate-remainder -123 -10) @result{} -3\n"
2403 "(truncate-remainder -123.2 -63.5) @result{} -59.7\n"
2404 "(truncate-remainder 16/3 -10/7) @result{} 22/21\n"
2405 "@end lisp")
2406 #define FUNC_NAME s_scm_truncate_remainder
2407 {
2408 if (SCM_LIKELY (SCM_I_INUMP (x)))
2409 {
2410 scm_t_inum xx = SCM_I_INUM (x);
2411 if (SCM_LIKELY (SCM_I_INUMP (y)))
2412 {
2413 scm_t_inum yy = SCM_I_INUM (y);
2414 if (SCM_UNLIKELY (yy == 0))
2415 scm_num_overflow (s_scm_truncate_remainder);
2416 else
2417 return SCM_I_MAKINUM (xx % yy);
2418 }
2419 else if (SCM_BIGP (y))
2420 {
2421 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2422 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2423 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2424 {
2425 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2426 scm_remember_upto_here_1 (y);
2427 return SCM_INUM0;
2428 }
2429 else
2430 return x;
2431 }
2432 else if (SCM_REALP (y))
2433 return scm_i_inexact_truncate_remainder (xx, SCM_REAL_VALUE (y));
2434 else if (SCM_FRACTIONP (y))
2435 return scm_i_exact_rational_truncate_remainder (x, y);
2436 else
2437 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2438 s_scm_truncate_remainder);
2439 }
2440 else if (SCM_BIGP (x))
2441 {
2442 if (SCM_LIKELY (SCM_I_INUMP (y)))
2443 {
2444 scm_t_inum yy = SCM_I_INUM (y);
2445 if (SCM_UNLIKELY (yy == 0))
2446 scm_num_overflow (s_scm_truncate_remainder);
2447 else
2448 {
2449 scm_t_inum rr = (mpz_tdiv_ui (SCM_I_BIG_MPZ (x),
2450 (yy > 0) ? yy : -yy)
2451 * mpz_sgn (SCM_I_BIG_MPZ (x)));
2452 scm_remember_upto_here_1 (x);
2453 return SCM_I_MAKINUM (rr);
2454 }
2455 }
2456 else if (SCM_BIGP (y))
2457 {
2458 SCM r = scm_i_mkbig ();
2459 mpz_tdiv_r (SCM_I_BIG_MPZ (r),
2460 SCM_I_BIG_MPZ (x),
2461 SCM_I_BIG_MPZ (y));
2462 scm_remember_upto_here_2 (x, y);
2463 return scm_i_normbig (r);
2464 }
2465 else if (SCM_REALP (y))
2466 return scm_i_inexact_truncate_remainder
2467 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2468 else if (SCM_FRACTIONP (y))
2469 return scm_i_exact_rational_truncate_remainder (x, y);
2470 else
2471 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2472 s_scm_truncate_remainder);
2473 }
2474 else if (SCM_REALP (x))
2475 {
2476 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2477 SCM_BIGP (y) || SCM_FRACTIONP (y))
2478 return scm_i_inexact_truncate_remainder
2479 (SCM_REAL_VALUE (x), scm_to_double (y));
2480 else
2481 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2482 s_scm_truncate_remainder);
2483 }
2484 else if (SCM_FRACTIONP (x))
2485 {
2486 if (SCM_REALP (y))
2487 return scm_i_inexact_truncate_remainder
2488 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2489 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2490 return scm_i_exact_rational_truncate_remainder (x, y);
2491 else
2492 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG2,
2493 s_scm_truncate_remainder);
2494 }
2495 else
2496 return scm_wta_dispatch_2 (g_scm_truncate_remainder, x, y, SCM_ARG1,
2497 s_scm_truncate_remainder);
2498 }
2499 #undef FUNC_NAME
2500
2501 static SCM
scm_i_inexact_truncate_remainder(double x,double y)2502 scm_i_inexact_truncate_remainder (double x, double y)
2503 {
2504 /* Although it would be more efficient to use fmod here, we can't
2505 because it would in some cases produce results inconsistent with
2506 scm_i_inexact_truncate_quotient, such that x != q * y + r (not even
2507 close). In particular, when x is very close to a multiple of y,
2508 then r might be either 0.0 or sgn(x)*|y|, but those two cases must
2509 correspond to different choices of q. If quotient chooses one and
2510 remainder chooses the other, it would be bad. */
2511 if (SCM_UNLIKELY (y == 0))
2512 scm_num_overflow (s_scm_truncate_remainder); /* or return a NaN? */
2513 else
2514 return scm_i_from_double (x - y * trunc (x / y));
2515 }
2516
2517 static SCM
scm_i_exact_rational_truncate_remainder(SCM x,SCM y)2518 scm_i_exact_rational_truncate_remainder (SCM x, SCM y)
2519 {
2520 SCM xd = scm_denominator (x);
2521 SCM yd = scm_denominator (y);
2522 SCM r1 = scm_truncate_remainder (scm_product (scm_numerator (x), yd),
2523 scm_product (scm_numerator (y), xd));
2524 return scm_divide (r1, scm_product (xd, yd));
2525 }
2526
2527
2528 static void scm_i_inexact_truncate_divide (double x, double y,
2529 SCM *qp, SCM *rp);
2530 static void scm_i_exact_rational_truncate_divide (SCM x, SCM y,
2531 SCM *qp, SCM *rp);
2532
2533 SCM_PRIMITIVE_GENERIC (scm_i_truncate_divide, "truncate/", 2, 0, 0,
2534 (SCM x, SCM y),
2535 "Return the integer @var{q} and the real number @var{r}\n"
2536 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2537 "and @math{@var{q} = truncate(@var{x} / @var{y})}.\n"
2538 "@lisp\n"
2539 "(truncate/ 123 10) @result{} 12 and 3\n"
2540 "(truncate/ 123 -10) @result{} -12 and 3\n"
2541 "(truncate/ -123 10) @result{} -12 and -3\n"
2542 "(truncate/ -123 -10) @result{} 12 and -3\n"
2543 "(truncate/ -123.2 -63.5) @result{} 1.0 and -59.7\n"
2544 "(truncate/ 16/3 -10/7) @result{} -3 and 22/21\n"
2545 "@end lisp")
2546 #define FUNC_NAME s_scm_i_truncate_divide
2547 {
2548 SCM q, r;
2549
2550 scm_truncate_divide(x, y, &q, &r);
2551 return scm_values (scm_list_2 (q, r));
2552 }
2553 #undef FUNC_NAME
2554
2555 #define s_scm_truncate_divide s_scm_i_truncate_divide
2556 #define g_scm_truncate_divide g_scm_i_truncate_divide
2557
2558 void
scm_truncate_divide(SCM x,SCM y,SCM * qp,SCM * rp)2559 scm_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2560 {
2561 if (SCM_LIKELY (SCM_I_INUMP (x)))
2562 {
2563 scm_t_inum xx = SCM_I_INUM (x);
2564 if (SCM_LIKELY (SCM_I_INUMP (y)))
2565 {
2566 scm_t_inum yy = SCM_I_INUM (y);
2567 if (SCM_UNLIKELY (yy == 0))
2568 scm_num_overflow (s_scm_truncate_divide);
2569 else
2570 {
2571 scm_t_inum qq = xx / yy;
2572 scm_t_inum rr = xx % yy;
2573 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2574 *qp = SCM_I_MAKINUM (qq);
2575 else
2576 *qp = scm_i_inum2big (qq);
2577 *rp = SCM_I_MAKINUM (rr);
2578 }
2579 }
2580 else if (SCM_BIGP (y))
2581 {
2582 if (SCM_UNLIKELY (xx == SCM_MOST_NEGATIVE_FIXNUM)
2583 && SCM_UNLIKELY (mpz_cmp_ui (SCM_I_BIG_MPZ (y),
2584 - SCM_MOST_NEGATIVE_FIXNUM) == 0))
2585 {
2586 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
2587 scm_remember_upto_here_1 (y);
2588 *qp = SCM_I_MAKINUM (-1);
2589 *rp = SCM_INUM0;
2590 }
2591 else
2592 {
2593 *qp = SCM_INUM0;
2594 *rp = x;
2595 }
2596 }
2597 else if (SCM_REALP (y))
2598 scm_i_inexact_truncate_divide (xx, SCM_REAL_VALUE (y), qp, rp);
2599 else if (SCM_FRACTIONP (y))
2600 scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2601 else
2602 two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
2603 s_scm_truncate_divide, qp, rp);
2604 }
2605 else if (SCM_BIGP (x))
2606 {
2607 if (SCM_LIKELY (SCM_I_INUMP (y)))
2608 {
2609 scm_t_inum yy = SCM_I_INUM (y);
2610 if (SCM_UNLIKELY (yy == 0))
2611 scm_num_overflow (s_scm_truncate_divide);
2612 else
2613 {
2614 SCM q = scm_i_mkbig ();
2615 scm_t_inum rr;
2616 if (yy > 0)
2617 rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
2618 SCM_I_BIG_MPZ (x), yy);
2619 else
2620 {
2621 rr = mpz_tdiv_q_ui (SCM_I_BIG_MPZ (q),
2622 SCM_I_BIG_MPZ (x), -yy);
2623 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2624 }
2625 rr *= mpz_sgn (SCM_I_BIG_MPZ (x));
2626 scm_remember_upto_here_1 (x);
2627 *qp = scm_i_normbig (q);
2628 *rp = SCM_I_MAKINUM (rr);
2629 }
2630 }
2631 else if (SCM_BIGP (y))
2632 {
2633 SCM q = scm_i_mkbig ();
2634 SCM r = scm_i_mkbig ();
2635 mpz_tdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2636 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2637 scm_remember_upto_here_2 (x, y);
2638 *qp = scm_i_normbig (q);
2639 *rp = scm_i_normbig (r);
2640 }
2641 else if (SCM_REALP (y))
2642 scm_i_inexact_truncate_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
2643 qp, rp);
2644 else if (SCM_FRACTIONP (y))
2645 scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2646 else
2647 two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
2648 s_scm_truncate_divide, qp, rp);
2649 }
2650 else if (SCM_REALP (x))
2651 {
2652 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2653 SCM_BIGP (y) || SCM_FRACTIONP (y))
2654 scm_i_inexact_truncate_divide (SCM_REAL_VALUE (x), scm_to_double (y),
2655 qp, rp);
2656 else
2657 two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
2658 s_scm_truncate_divide, qp, rp);
2659 }
2660 else if (SCM_FRACTIONP (x))
2661 {
2662 if (SCM_REALP (y))
2663 scm_i_inexact_truncate_divide
2664 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
2665 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2666 scm_i_exact_rational_truncate_divide (x, y, qp, rp);
2667 else
2668 two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG2,
2669 s_scm_truncate_divide, qp, rp);
2670 }
2671 else
2672 two_valued_wta_dispatch_2 (g_scm_truncate_divide, x, y, SCM_ARG1,
2673 s_scm_truncate_divide, qp, rp);
2674 }
2675
2676 static void
scm_i_inexact_truncate_divide(double x,double y,SCM * qp,SCM * rp)2677 scm_i_inexact_truncate_divide (double x, double y, SCM *qp, SCM *rp)
2678 {
2679 if (SCM_UNLIKELY (y == 0))
2680 scm_num_overflow (s_scm_truncate_divide); /* or return a NaN? */
2681 else
2682 {
2683 double q = trunc (x / y);
2684 double r = x - q * y;
2685 *qp = scm_i_from_double (q);
2686 *rp = scm_i_from_double (r);
2687 }
2688 }
2689
2690 static void
scm_i_exact_rational_truncate_divide(SCM x,SCM y,SCM * qp,SCM * rp)2691 scm_i_exact_rational_truncate_divide (SCM x, SCM y, SCM *qp, SCM *rp)
2692 {
2693 SCM r1;
2694 SCM xd = scm_denominator (x);
2695 SCM yd = scm_denominator (y);
2696
2697 scm_truncate_divide (scm_product (scm_numerator (x), yd),
2698 scm_product (scm_numerator (y), xd),
2699 qp, &r1);
2700 *rp = scm_divide (r1, scm_product (xd, yd));
2701 }
2702
2703 static SCM scm_i_inexact_centered_quotient (double x, double y);
2704 static SCM scm_i_bigint_centered_quotient (SCM x, SCM y);
2705 static SCM scm_i_exact_rational_centered_quotient (SCM x, SCM y);
2706
2707 SCM_PRIMITIVE_GENERIC (scm_centered_quotient, "centered-quotient", 2, 0, 0,
2708 (SCM x, SCM y),
2709 "Return the integer @var{q} such that\n"
2710 "@math{@var{x} = @var{q}*@var{y} + @var{r}} where\n"
2711 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
2712 "@lisp\n"
2713 "(centered-quotient 123 10) @result{} 12\n"
2714 "(centered-quotient 123 -10) @result{} -12\n"
2715 "(centered-quotient -123 10) @result{} -12\n"
2716 "(centered-quotient -123 -10) @result{} 12\n"
2717 "(centered-quotient -123.2 -63.5) @result{} 2.0\n"
2718 "(centered-quotient 16/3 -10/7) @result{} -4\n"
2719 "@end lisp")
2720 #define FUNC_NAME s_scm_centered_quotient
2721 {
2722 if (SCM_LIKELY (SCM_I_INUMP (x)))
2723 {
2724 scm_t_inum xx = SCM_I_INUM (x);
2725 if (SCM_LIKELY (SCM_I_INUMP (y)))
2726 {
2727 scm_t_inum yy = SCM_I_INUM (y);
2728 if (SCM_UNLIKELY (yy == 0))
2729 scm_num_overflow (s_scm_centered_quotient);
2730 else
2731 {
2732 scm_t_inum qq = xx / yy;
2733 scm_t_inum rr = xx % yy;
2734 if (SCM_LIKELY (xx > 0))
2735 {
2736 if (SCM_LIKELY (yy > 0))
2737 {
2738 if (rr >= (yy + 1) / 2)
2739 qq++;
2740 }
2741 else
2742 {
2743 if (rr >= (1 - yy) / 2)
2744 qq--;
2745 }
2746 }
2747 else
2748 {
2749 if (SCM_LIKELY (yy > 0))
2750 {
2751 if (rr < -yy / 2)
2752 qq--;
2753 }
2754 else
2755 {
2756 if (rr < yy / 2)
2757 qq++;
2758 }
2759 }
2760 if (SCM_LIKELY (SCM_FIXABLE (qq)))
2761 return SCM_I_MAKINUM (qq);
2762 else
2763 return scm_i_inum2big (qq);
2764 }
2765 }
2766 else if (SCM_BIGP (y))
2767 {
2768 /* Pass a denormalized bignum version of x (even though it
2769 can fit in a fixnum) to scm_i_bigint_centered_quotient */
2770 return scm_i_bigint_centered_quotient (scm_i_long2big (xx), y);
2771 }
2772 else if (SCM_REALP (y))
2773 return scm_i_inexact_centered_quotient (xx, SCM_REAL_VALUE (y));
2774 else if (SCM_FRACTIONP (y))
2775 return scm_i_exact_rational_centered_quotient (x, y);
2776 else
2777 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2778 s_scm_centered_quotient);
2779 }
2780 else if (SCM_BIGP (x))
2781 {
2782 if (SCM_LIKELY (SCM_I_INUMP (y)))
2783 {
2784 scm_t_inum yy = SCM_I_INUM (y);
2785 if (SCM_UNLIKELY (yy == 0))
2786 scm_num_overflow (s_scm_centered_quotient);
2787 else if (SCM_UNLIKELY (yy == 1))
2788 return x;
2789 else
2790 {
2791 SCM q = scm_i_mkbig ();
2792 scm_t_inum rr;
2793 /* Arrange for rr to initially be non-positive,
2794 because that simplifies the test to see
2795 if it is within the needed bounds. */
2796 if (yy > 0)
2797 {
2798 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
2799 SCM_I_BIG_MPZ (x), yy);
2800 scm_remember_upto_here_1 (x);
2801 if (rr < -yy / 2)
2802 mpz_sub_ui (SCM_I_BIG_MPZ (q),
2803 SCM_I_BIG_MPZ (q), 1);
2804 }
2805 else
2806 {
2807 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
2808 SCM_I_BIG_MPZ (x), -yy);
2809 scm_remember_upto_here_1 (x);
2810 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
2811 if (rr < yy / 2)
2812 mpz_add_ui (SCM_I_BIG_MPZ (q),
2813 SCM_I_BIG_MPZ (q), 1);
2814 }
2815 return scm_i_normbig (q);
2816 }
2817 }
2818 else if (SCM_BIGP (y))
2819 return scm_i_bigint_centered_quotient (x, y);
2820 else if (SCM_REALP (y))
2821 return scm_i_inexact_centered_quotient
2822 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
2823 else if (SCM_FRACTIONP (y))
2824 return scm_i_exact_rational_centered_quotient (x, y);
2825 else
2826 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2827 s_scm_centered_quotient);
2828 }
2829 else if (SCM_REALP (x))
2830 {
2831 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
2832 SCM_BIGP (y) || SCM_FRACTIONP (y))
2833 return scm_i_inexact_centered_quotient
2834 (SCM_REAL_VALUE (x), scm_to_double (y));
2835 else
2836 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2837 s_scm_centered_quotient);
2838 }
2839 else if (SCM_FRACTIONP (x))
2840 {
2841 if (SCM_REALP (y))
2842 return scm_i_inexact_centered_quotient
2843 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
2844 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
2845 return scm_i_exact_rational_centered_quotient (x, y);
2846 else
2847 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG2,
2848 s_scm_centered_quotient);
2849 }
2850 else
2851 return scm_wta_dispatch_2 (g_scm_centered_quotient, x, y, SCM_ARG1,
2852 s_scm_centered_quotient);
2853 }
2854 #undef FUNC_NAME
2855
2856 static SCM
scm_i_inexact_centered_quotient(double x,double y)2857 scm_i_inexact_centered_quotient (double x, double y)
2858 {
2859 if (SCM_LIKELY (y > 0))
2860 return scm_i_from_double (floor (x/y + 0.5));
2861 else if (SCM_LIKELY (y < 0))
2862 return scm_i_from_double (ceil (x/y - 0.5));
2863 else if (y == 0)
2864 scm_num_overflow (s_scm_centered_quotient); /* or return a NaN? */
2865 else
2866 return scm_nan ();
2867 }
2868
2869 /* Assumes that both x and y are bigints, though
2870 x might be able to fit into a fixnum. */
2871 static SCM
scm_i_bigint_centered_quotient(SCM x,SCM y)2872 scm_i_bigint_centered_quotient (SCM x, SCM y)
2873 {
2874 SCM q, r, min_r;
2875
2876 /* Note that x might be small enough to fit into a
2877 fixnum, so we must not let it escape into the wild */
2878 q = scm_i_mkbig ();
2879 r = scm_i_mkbig ();
2880
2881 /* min_r will eventually become -abs(y)/2 */
2882 min_r = scm_i_mkbig ();
2883 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
2884 SCM_I_BIG_MPZ (y), 1);
2885
2886 /* Arrange for rr to initially be non-positive,
2887 because that simplifies the test to see
2888 if it is within the needed bounds. */
2889 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
2890 {
2891 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2892 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2893 scm_remember_upto_here_2 (x, y);
2894 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
2895 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2896 mpz_sub_ui (SCM_I_BIG_MPZ (q),
2897 SCM_I_BIG_MPZ (q), 1);
2898 }
2899 else
2900 {
2901 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
2902 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2903 scm_remember_upto_here_2 (x, y);
2904 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
2905 mpz_add_ui (SCM_I_BIG_MPZ (q),
2906 SCM_I_BIG_MPZ (q), 1);
2907 }
2908 scm_remember_upto_here_2 (r, min_r);
2909 return scm_i_normbig (q);
2910 }
2911
2912 static SCM
scm_i_exact_rational_centered_quotient(SCM x,SCM y)2913 scm_i_exact_rational_centered_quotient (SCM x, SCM y)
2914 {
2915 return scm_centered_quotient
2916 (scm_product (scm_numerator (x), scm_denominator (y)),
2917 scm_product (scm_numerator (y), scm_denominator (x)));
2918 }
2919
2920 static SCM scm_i_inexact_centered_remainder (double x, double y);
2921 static SCM scm_i_bigint_centered_remainder (SCM x, SCM y);
2922 static SCM scm_i_exact_rational_centered_remainder (SCM x, SCM y);
2923
2924 SCM_PRIMITIVE_GENERIC (scm_centered_remainder, "centered-remainder", 2, 0, 0,
2925 (SCM x, SCM y),
2926 "Return the real number @var{r} such that\n"
2927 "@math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}\n"
2928 "and @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
2929 "for some integer @var{q}.\n"
2930 "@lisp\n"
2931 "(centered-remainder 123 10) @result{} 3\n"
2932 "(centered-remainder 123 -10) @result{} 3\n"
2933 "(centered-remainder -123 10) @result{} -3\n"
2934 "(centered-remainder -123 -10) @result{} -3\n"
2935 "(centered-remainder -123.2 -63.5) @result{} 3.8\n"
2936 "(centered-remainder 16/3 -10/7) @result{} -8/21\n"
2937 "@end lisp")
2938 #define FUNC_NAME s_scm_centered_remainder
2939 {
2940 if (SCM_LIKELY (SCM_I_INUMP (x)))
2941 {
2942 scm_t_inum xx = SCM_I_INUM (x);
2943 if (SCM_LIKELY (SCM_I_INUMP (y)))
2944 {
2945 scm_t_inum yy = SCM_I_INUM (y);
2946 if (SCM_UNLIKELY (yy == 0))
2947 scm_num_overflow (s_scm_centered_remainder);
2948 else
2949 {
2950 scm_t_inum rr = xx % yy;
2951 if (SCM_LIKELY (xx > 0))
2952 {
2953 if (SCM_LIKELY (yy > 0))
2954 {
2955 if (rr >= (yy + 1) / 2)
2956 rr -= yy;
2957 }
2958 else
2959 {
2960 if (rr >= (1 - yy) / 2)
2961 rr += yy;
2962 }
2963 }
2964 else
2965 {
2966 if (SCM_LIKELY (yy > 0))
2967 {
2968 if (rr < -yy / 2)
2969 rr += yy;
2970 }
2971 else
2972 {
2973 if (rr < yy / 2)
2974 rr -= yy;
2975 }
2976 }
2977 return SCM_I_MAKINUM (rr);
2978 }
2979 }
2980 else if (SCM_BIGP (y))
2981 {
2982 /* Pass a denormalized bignum version of x (even though it
2983 can fit in a fixnum) to scm_i_bigint_centered_remainder */
2984 return scm_i_bigint_centered_remainder (scm_i_long2big (xx), y);
2985 }
2986 else if (SCM_REALP (y))
2987 return scm_i_inexact_centered_remainder (xx, SCM_REAL_VALUE (y));
2988 else if (SCM_FRACTIONP (y))
2989 return scm_i_exact_rational_centered_remainder (x, y);
2990 else
2991 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
2992 s_scm_centered_remainder);
2993 }
2994 else if (SCM_BIGP (x))
2995 {
2996 if (SCM_LIKELY (SCM_I_INUMP (y)))
2997 {
2998 scm_t_inum yy = SCM_I_INUM (y);
2999 if (SCM_UNLIKELY (yy == 0))
3000 scm_num_overflow (s_scm_centered_remainder);
3001 else
3002 {
3003 scm_t_inum rr;
3004 /* Arrange for rr to initially be non-positive,
3005 because that simplifies the test to see
3006 if it is within the needed bounds. */
3007 if (yy > 0)
3008 {
3009 rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), yy);
3010 scm_remember_upto_here_1 (x);
3011 if (rr < -yy / 2)
3012 rr += yy;
3013 }
3014 else
3015 {
3016 rr = - mpz_cdiv_ui (SCM_I_BIG_MPZ (x), -yy);
3017 scm_remember_upto_here_1 (x);
3018 if (rr < yy / 2)
3019 rr -= yy;
3020 }
3021 return SCM_I_MAKINUM (rr);
3022 }
3023 }
3024 else if (SCM_BIGP (y))
3025 return scm_i_bigint_centered_remainder (x, y);
3026 else if (SCM_REALP (y))
3027 return scm_i_inexact_centered_remainder
3028 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
3029 else if (SCM_FRACTIONP (y))
3030 return scm_i_exact_rational_centered_remainder (x, y);
3031 else
3032 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
3033 s_scm_centered_remainder);
3034 }
3035 else if (SCM_REALP (x))
3036 {
3037 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3038 SCM_BIGP (y) || SCM_FRACTIONP (y))
3039 return scm_i_inexact_centered_remainder
3040 (SCM_REAL_VALUE (x), scm_to_double (y));
3041 else
3042 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
3043 s_scm_centered_remainder);
3044 }
3045 else if (SCM_FRACTIONP (x))
3046 {
3047 if (SCM_REALP (y))
3048 return scm_i_inexact_centered_remainder
3049 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
3050 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3051 return scm_i_exact_rational_centered_remainder (x, y);
3052 else
3053 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG2,
3054 s_scm_centered_remainder);
3055 }
3056 else
3057 return scm_wta_dispatch_2 (g_scm_centered_remainder, x, y, SCM_ARG1,
3058 s_scm_centered_remainder);
3059 }
3060 #undef FUNC_NAME
3061
3062 static SCM
scm_i_inexact_centered_remainder(double x,double y)3063 scm_i_inexact_centered_remainder (double x, double y)
3064 {
3065 double q;
3066
3067 /* Although it would be more efficient to use fmod here, we can't
3068 because it would in some cases produce results inconsistent with
3069 scm_i_inexact_centered_quotient, such that x != r + q * y (not even
3070 close). In particular, when x-y/2 is very close to a multiple of
3071 y, then r might be either -abs(y/2) or abs(y/2)-epsilon, but those
3072 two cases must correspond to different choices of q. If quotient
3073 chooses one and remainder chooses the other, it would be bad. */
3074 if (SCM_LIKELY (y > 0))
3075 q = floor (x/y + 0.5);
3076 else if (SCM_LIKELY (y < 0))
3077 q = ceil (x/y - 0.5);
3078 else if (y == 0)
3079 scm_num_overflow (s_scm_centered_remainder); /* or return a NaN? */
3080 else
3081 return scm_nan ();
3082 return scm_i_from_double (x - q * y);
3083 }
3084
3085 /* Assumes that both x and y are bigints, though
3086 x might be able to fit into a fixnum. */
3087 static SCM
scm_i_bigint_centered_remainder(SCM x,SCM y)3088 scm_i_bigint_centered_remainder (SCM x, SCM y)
3089 {
3090 SCM r, min_r;
3091
3092 /* Note that x might be small enough to fit into a
3093 fixnum, so we must not let it escape into the wild */
3094 r = scm_i_mkbig ();
3095
3096 /* min_r will eventually become -abs(y)/2 */
3097 min_r = scm_i_mkbig ();
3098 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
3099 SCM_I_BIG_MPZ (y), 1);
3100
3101 /* Arrange for rr to initially be non-positive,
3102 because that simplifies the test to see
3103 if it is within the needed bounds. */
3104 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
3105 {
3106 mpz_cdiv_r (SCM_I_BIG_MPZ (r),
3107 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3108 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
3109 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3110 mpz_add (SCM_I_BIG_MPZ (r),
3111 SCM_I_BIG_MPZ (r),
3112 SCM_I_BIG_MPZ (y));
3113 }
3114 else
3115 {
3116 mpz_fdiv_r (SCM_I_BIG_MPZ (r),
3117 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3118 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3119 mpz_sub (SCM_I_BIG_MPZ (r),
3120 SCM_I_BIG_MPZ (r),
3121 SCM_I_BIG_MPZ (y));
3122 }
3123 scm_remember_upto_here_2 (x, y);
3124 return scm_i_normbig (r);
3125 }
3126
3127 static SCM
scm_i_exact_rational_centered_remainder(SCM x,SCM y)3128 scm_i_exact_rational_centered_remainder (SCM x, SCM y)
3129 {
3130 SCM xd = scm_denominator (x);
3131 SCM yd = scm_denominator (y);
3132 SCM r1 = scm_centered_remainder (scm_product (scm_numerator (x), yd),
3133 scm_product (scm_numerator (y), xd));
3134 return scm_divide (r1, scm_product (xd, yd));
3135 }
3136
3137
3138 static void scm_i_inexact_centered_divide (double x, double y,
3139 SCM *qp, SCM *rp);
3140 static void scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp);
3141 static void scm_i_exact_rational_centered_divide (SCM x, SCM y,
3142 SCM *qp, SCM *rp);
3143
3144 SCM_PRIMITIVE_GENERIC (scm_i_centered_divide, "centered/", 2, 0, 0,
3145 (SCM x, SCM y),
3146 "Return the integer @var{q} and the real number @var{r}\n"
3147 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3148 "and @math{-abs(@var{y}/2) <= @var{r} < abs(@var{y}/2)}.\n"
3149 "@lisp\n"
3150 "(centered/ 123 10) @result{} 12 and 3\n"
3151 "(centered/ 123 -10) @result{} -12 and 3\n"
3152 "(centered/ -123 10) @result{} -12 and -3\n"
3153 "(centered/ -123 -10) @result{} 12 and -3\n"
3154 "(centered/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3155 "(centered/ 16/3 -10/7) @result{} -4 and -8/21\n"
3156 "@end lisp")
3157 #define FUNC_NAME s_scm_i_centered_divide
3158 {
3159 SCM q, r;
3160
3161 scm_centered_divide(x, y, &q, &r);
3162 return scm_values (scm_list_2 (q, r));
3163 }
3164 #undef FUNC_NAME
3165
3166 #define s_scm_centered_divide s_scm_i_centered_divide
3167 #define g_scm_centered_divide g_scm_i_centered_divide
3168
3169 void
scm_centered_divide(SCM x,SCM y,SCM * qp,SCM * rp)3170 scm_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3171 {
3172 if (SCM_LIKELY (SCM_I_INUMP (x)))
3173 {
3174 scm_t_inum xx = SCM_I_INUM (x);
3175 if (SCM_LIKELY (SCM_I_INUMP (y)))
3176 {
3177 scm_t_inum yy = SCM_I_INUM (y);
3178 if (SCM_UNLIKELY (yy == 0))
3179 scm_num_overflow (s_scm_centered_divide);
3180 else
3181 {
3182 scm_t_inum qq = xx / yy;
3183 scm_t_inum rr = xx % yy;
3184 if (SCM_LIKELY (xx > 0))
3185 {
3186 if (SCM_LIKELY (yy > 0))
3187 {
3188 if (rr >= (yy + 1) / 2)
3189 { qq++; rr -= yy; }
3190 }
3191 else
3192 {
3193 if (rr >= (1 - yy) / 2)
3194 { qq--; rr += yy; }
3195 }
3196 }
3197 else
3198 {
3199 if (SCM_LIKELY (yy > 0))
3200 {
3201 if (rr < -yy / 2)
3202 { qq--; rr += yy; }
3203 }
3204 else
3205 {
3206 if (rr < yy / 2)
3207 { qq++; rr -= yy; }
3208 }
3209 }
3210 if (SCM_LIKELY (SCM_FIXABLE (qq)))
3211 *qp = SCM_I_MAKINUM (qq);
3212 else
3213 *qp = scm_i_inum2big (qq);
3214 *rp = SCM_I_MAKINUM (rr);
3215 }
3216 }
3217 else if (SCM_BIGP (y))
3218 /* Pass a denormalized bignum version of x (even though it
3219 can fit in a fixnum) to scm_i_bigint_centered_divide */
3220 scm_i_bigint_centered_divide (scm_i_long2big (xx), y, qp, rp);
3221 else if (SCM_REALP (y))
3222 scm_i_inexact_centered_divide (xx, SCM_REAL_VALUE (y), qp, rp);
3223 else if (SCM_FRACTIONP (y))
3224 scm_i_exact_rational_centered_divide (x, y, qp, rp);
3225 else
3226 two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
3227 s_scm_centered_divide, qp, rp);
3228 }
3229 else if (SCM_BIGP (x))
3230 {
3231 if (SCM_LIKELY (SCM_I_INUMP (y)))
3232 {
3233 scm_t_inum yy = SCM_I_INUM (y);
3234 if (SCM_UNLIKELY (yy == 0))
3235 scm_num_overflow (s_scm_centered_divide);
3236 else
3237 {
3238 SCM q = scm_i_mkbig ();
3239 scm_t_inum rr;
3240 /* Arrange for rr to initially be non-positive,
3241 because that simplifies the test to see
3242 if it is within the needed bounds. */
3243 if (yy > 0)
3244 {
3245 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3246 SCM_I_BIG_MPZ (x), yy);
3247 scm_remember_upto_here_1 (x);
3248 if (rr < -yy / 2)
3249 {
3250 mpz_sub_ui (SCM_I_BIG_MPZ (q),
3251 SCM_I_BIG_MPZ (q), 1);
3252 rr += yy;
3253 }
3254 }
3255 else
3256 {
3257 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3258 SCM_I_BIG_MPZ (x), -yy);
3259 scm_remember_upto_here_1 (x);
3260 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
3261 if (rr < yy / 2)
3262 {
3263 mpz_add_ui (SCM_I_BIG_MPZ (q),
3264 SCM_I_BIG_MPZ (q), 1);
3265 rr -= yy;
3266 }
3267 }
3268 *qp = scm_i_normbig (q);
3269 *rp = SCM_I_MAKINUM (rr);
3270 }
3271 }
3272 else if (SCM_BIGP (y))
3273 scm_i_bigint_centered_divide (x, y, qp, rp);
3274 else if (SCM_REALP (y))
3275 scm_i_inexact_centered_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
3276 qp, rp);
3277 else if (SCM_FRACTIONP (y))
3278 scm_i_exact_rational_centered_divide (x, y, qp, rp);
3279 else
3280 two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
3281 s_scm_centered_divide, qp, rp);
3282 }
3283 else if (SCM_REALP (x))
3284 {
3285 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3286 SCM_BIGP (y) || SCM_FRACTIONP (y))
3287 scm_i_inexact_centered_divide (SCM_REAL_VALUE (x), scm_to_double (y),
3288 qp, rp);
3289 else
3290 two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
3291 s_scm_centered_divide, qp, rp);
3292 }
3293 else if (SCM_FRACTIONP (x))
3294 {
3295 if (SCM_REALP (y))
3296 scm_i_inexact_centered_divide
3297 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
3298 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3299 scm_i_exact_rational_centered_divide (x, y, qp, rp);
3300 else
3301 two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG2,
3302 s_scm_centered_divide, qp, rp);
3303 }
3304 else
3305 two_valued_wta_dispatch_2 (g_scm_centered_divide, x, y, SCM_ARG1,
3306 s_scm_centered_divide, qp, rp);
3307 }
3308
3309 static void
scm_i_inexact_centered_divide(double x,double y,SCM * qp,SCM * rp)3310 scm_i_inexact_centered_divide (double x, double y, SCM *qp, SCM *rp)
3311 {
3312 double q, r;
3313
3314 if (SCM_LIKELY (y > 0))
3315 q = floor (x/y + 0.5);
3316 else if (SCM_LIKELY (y < 0))
3317 q = ceil (x/y - 0.5);
3318 else if (y == 0)
3319 scm_num_overflow (s_scm_centered_divide); /* or return a NaN? */
3320 else
3321 q = guile_NaN;
3322 r = x - q * y;
3323 *qp = scm_i_from_double (q);
3324 *rp = scm_i_from_double (r);
3325 }
3326
3327 /* Assumes that both x and y are bigints, though
3328 x might be able to fit into a fixnum. */
3329 static void
scm_i_bigint_centered_divide(SCM x,SCM y,SCM * qp,SCM * rp)3330 scm_i_bigint_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3331 {
3332 SCM q, r, min_r;
3333
3334 /* Note that x might be small enough to fit into a
3335 fixnum, so we must not let it escape into the wild */
3336 q = scm_i_mkbig ();
3337 r = scm_i_mkbig ();
3338
3339 /* min_r will eventually become -abs(y/2) */
3340 min_r = scm_i_mkbig ();
3341 mpz_tdiv_q_2exp (SCM_I_BIG_MPZ (min_r),
3342 SCM_I_BIG_MPZ (y), 1);
3343
3344 /* Arrange for rr to initially be non-positive,
3345 because that simplifies the test to see
3346 if it is within the needed bounds. */
3347 if (mpz_sgn (SCM_I_BIG_MPZ (y)) > 0)
3348 {
3349 mpz_cdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3350 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3351 mpz_neg (SCM_I_BIG_MPZ (min_r), SCM_I_BIG_MPZ (min_r));
3352 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3353 {
3354 mpz_sub_ui (SCM_I_BIG_MPZ (q),
3355 SCM_I_BIG_MPZ (q), 1);
3356 mpz_add (SCM_I_BIG_MPZ (r),
3357 SCM_I_BIG_MPZ (r),
3358 SCM_I_BIG_MPZ (y));
3359 }
3360 }
3361 else
3362 {
3363 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3364 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3365 if (mpz_cmp (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (min_r)) < 0)
3366 {
3367 mpz_add_ui (SCM_I_BIG_MPZ (q),
3368 SCM_I_BIG_MPZ (q), 1);
3369 mpz_sub (SCM_I_BIG_MPZ (r),
3370 SCM_I_BIG_MPZ (r),
3371 SCM_I_BIG_MPZ (y));
3372 }
3373 }
3374 scm_remember_upto_here_2 (x, y);
3375 *qp = scm_i_normbig (q);
3376 *rp = scm_i_normbig (r);
3377 }
3378
3379 static void
scm_i_exact_rational_centered_divide(SCM x,SCM y,SCM * qp,SCM * rp)3380 scm_i_exact_rational_centered_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3381 {
3382 SCM r1;
3383 SCM xd = scm_denominator (x);
3384 SCM yd = scm_denominator (y);
3385
3386 scm_centered_divide (scm_product (scm_numerator (x), yd),
3387 scm_product (scm_numerator (y), xd),
3388 qp, &r1);
3389 *rp = scm_divide (r1, scm_product (xd, yd));
3390 }
3391
3392 static SCM scm_i_inexact_round_quotient (double x, double y);
3393 static SCM scm_i_bigint_round_quotient (SCM x, SCM y);
3394 static SCM scm_i_exact_rational_round_quotient (SCM x, SCM y);
3395
3396 SCM_PRIMITIVE_GENERIC (scm_round_quotient, "round-quotient", 2, 0, 0,
3397 (SCM x, SCM y),
3398 "Return @math{@var{x} / @var{y}} to the nearest integer,\n"
3399 "with ties going to the nearest even integer.\n"
3400 "@lisp\n"
3401 "(round-quotient 123 10) @result{} 12\n"
3402 "(round-quotient 123 -10) @result{} -12\n"
3403 "(round-quotient -123 10) @result{} -12\n"
3404 "(round-quotient -123 -10) @result{} 12\n"
3405 "(round-quotient 125 10) @result{} 12\n"
3406 "(round-quotient 127 10) @result{} 13\n"
3407 "(round-quotient 135 10) @result{} 14\n"
3408 "(round-quotient -123.2 -63.5) @result{} 2.0\n"
3409 "(round-quotient 16/3 -10/7) @result{} -4\n"
3410 "@end lisp")
3411 #define FUNC_NAME s_scm_round_quotient
3412 {
3413 if (SCM_LIKELY (SCM_I_INUMP (x)))
3414 {
3415 scm_t_inum xx = SCM_I_INUM (x);
3416 if (SCM_LIKELY (SCM_I_INUMP (y)))
3417 {
3418 scm_t_inum yy = SCM_I_INUM (y);
3419 if (SCM_UNLIKELY (yy == 0))
3420 scm_num_overflow (s_scm_round_quotient);
3421 else
3422 {
3423 scm_t_inum qq = xx / yy;
3424 scm_t_inum rr = xx % yy;
3425 scm_t_inum ay = yy;
3426 scm_t_inum r2 = 2 * rr;
3427
3428 if (SCM_LIKELY (yy < 0))
3429 {
3430 ay = -ay;
3431 r2 = -r2;
3432 }
3433
3434 if (qq & 1L)
3435 {
3436 if (r2 >= ay)
3437 qq++;
3438 else if (r2 <= -ay)
3439 qq--;
3440 }
3441 else
3442 {
3443 if (r2 > ay)
3444 qq++;
3445 else if (r2 < -ay)
3446 qq--;
3447 }
3448 if (SCM_LIKELY (SCM_FIXABLE (qq)))
3449 return SCM_I_MAKINUM (qq);
3450 else
3451 return scm_i_inum2big (qq);
3452 }
3453 }
3454 else if (SCM_BIGP (y))
3455 {
3456 /* Pass a denormalized bignum version of x (even though it
3457 can fit in a fixnum) to scm_i_bigint_round_quotient */
3458 return scm_i_bigint_round_quotient (scm_i_long2big (xx), y);
3459 }
3460 else if (SCM_REALP (y))
3461 return scm_i_inexact_round_quotient (xx, SCM_REAL_VALUE (y));
3462 else if (SCM_FRACTIONP (y))
3463 return scm_i_exact_rational_round_quotient (x, y);
3464 else
3465 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3466 s_scm_round_quotient);
3467 }
3468 else if (SCM_BIGP (x))
3469 {
3470 if (SCM_LIKELY (SCM_I_INUMP (y)))
3471 {
3472 scm_t_inum yy = SCM_I_INUM (y);
3473 if (SCM_UNLIKELY (yy == 0))
3474 scm_num_overflow (s_scm_round_quotient);
3475 else if (SCM_UNLIKELY (yy == 1))
3476 return x;
3477 else
3478 {
3479 SCM q = scm_i_mkbig ();
3480 scm_t_inum rr;
3481 int needs_adjustment;
3482
3483 if (yy > 0)
3484 {
3485 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3486 SCM_I_BIG_MPZ (x), yy);
3487 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3488 needs_adjustment = (2*rr >= yy);
3489 else
3490 needs_adjustment = (2*rr > yy);
3491 }
3492 else
3493 {
3494 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3495 SCM_I_BIG_MPZ (x), -yy);
3496 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
3497 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3498 needs_adjustment = (2*rr <= yy);
3499 else
3500 needs_adjustment = (2*rr < yy);
3501 }
3502 scm_remember_upto_here_1 (x);
3503 if (needs_adjustment)
3504 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3505 return scm_i_normbig (q);
3506 }
3507 }
3508 else if (SCM_BIGP (y))
3509 return scm_i_bigint_round_quotient (x, y);
3510 else if (SCM_REALP (y))
3511 return scm_i_inexact_round_quotient
3512 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
3513 else if (SCM_FRACTIONP (y))
3514 return scm_i_exact_rational_round_quotient (x, y);
3515 else
3516 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3517 s_scm_round_quotient);
3518 }
3519 else if (SCM_REALP (x))
3520 {
3521 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3522 SCM_BIGP (y) || SCM_FRACTIONP (y))
3523 return scm_i_inexact_round_quotient
3524 (SCM_REAL_VALUE (x), scm_to_double (y));
3525 else
3526 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3527 s_scm_round_quotient);
3528 }
3529 else if (SCM_FRACTIONP (x))
3530 {
3531 if (SCM_REALP (y))
3532 return scm_i_inexact_round_quotient
3533 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
3534 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3535 return scm_i_exact_rational_round_quotient (x, y);
3536 else
3537 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG2,
3538 s_scm_round_quotient);
3539 }
3540 else
3541 return scm_wta_dispatch_2 (g_scm_round_quotient, x, y, SCM_ARG1,
3542 s_scm_round_quotient);
3543 }
3544 #undef FUNC_NAME
3545
3546 static SCM
scm_i_inexact_round_quotient(double x,double y)3547 scm_i_inexact_round_quotient (double x, double y)
3548 {
3549 if (SCM_UNLIKELY (y == 0))
3550 scm_num_overflow (s_scm_round_quotient); /* or return a NaN? */
3551 else
3552 return scm_i_from_double (scm_c_round (x / y));
3553 }
3554
3555 /* Assumes that both x and y are bigints, though
3556 x might be able to fit into a fixnum. */
3557 static SCM
scm_i_bigint_round_quotient(SCM x,SCM y)3558 scm_i_bigint_round_quotient (SCM x, SCM y)
3559 {
3560 SCM q, r, r2;
3561 int cmp, needs_adjustment;
3562
3563 /* Note that x might be small enough to fit into a
3564 fixnum, so we must not let it escape into the wild */
3565 q = scm_i_mkbig ();
3566 r = scm_i_mkbig ();
3567 r2 = scm_i_mkbig ();
3568
3569 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3570 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3571 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
3572 scm_remember_upto_here_2 (x, r);
3573
3574 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
3575 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3576 needs_adjustment = (cmp >= 0);
3577 else
3578 needs_adjustment = (cmp > 0);
3579 scm_remember_upto_here_2 (r2, y);
3580
3581 if (needs_adjustment)
3582 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3583
3584 return scm_i_normbig (q);
3585 }
3586
3587 static SCM
scm_i_exact_rational_round_quotient(SCM x,SCM y)3588 scm_i_exact_rational_round_quotient (SCM x, SCM y)
3589 {
3590 return scm_round_quotient
3591 (scm_product (scm_numerator (x), scm_denominator (y)),
3592 scm_product (scm_numerator (y), scm_denominator (x)));
3593 }
3594
3595 static SCM scm_i_inexact_round_remainder (double x, double y);
3596 static SCM scm_i_bigint_round_remainder (SCM x, SCM y);
3597 static SCM scm_i_exact_rational_round_remainder (SCM x, SCM y);
3598
3599 SCM_PRIMITIVE_GENERIC (scm_round_remainder, "round-remainder", 2, 0, 0,
3600 (SCM x, SCM y),
3601 "Return the real number @var{r} such that\n"
3602 "@math{@var{x} = @var{q}*@var{y} + @var{r}}, where\n"
3603 "@var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3604 "nearest integer, with ties going to the nearest\n"
3605 "even integer.\n"
3606 "@lisp\n"
3607 "(round-remainder 123 10) @result{} 3\n"
3608 "(round-remainder 123 -10) @result{} 3\n"
3609 "(round-remainder -123 10) @result{} -3\n"
3610 "(round-remainder -123 -10) @result{} -3\n"
3611 "(round-remainder 125 10) @result{} 5\n"
3612 "(round-remainder 127 10) @result{} -3\n"
3613 "(round-remainder 135 10) @result{} -5\n"
3614 "(round-remainder -123.2 -63.5) @result{} 3.8\n"
3615 "(round-remainder 16/3 -10/7) @result{} -8/21\n"
3616 "@end lisp")
3617 #define FUNC_NAME s_scm_round_remainder
3618 {
3619 if (SCM_LIKELY (SCM_I_INUMP (x)))
3620 {
3621 scm_t_inum xx = SCM_I_INUM (x);
3622 if (SCM_LIKELY (SCM_I_INUMP (y)))
3623 {
3624 scm_t_inum yy = SCM_I_INUM (y);
3625 if (SCM_UNLIKELY (yy == 0))
3626 scm_num_overflow (s_scm_round_remainder);
3627 else
3628 {
3629 scm_t_inum qq = xx / yy;
3630 scm_t_inum rr = xx % yy;
3631 scm_t_inum ay = yy;
3632 scm_t_inum r2 = 2 * rr;
3633
3634 if (SCM_LIKELY (yy < 0))
3635 {
3636 ay = -ay;
3637 r2 = -r2;
3638 }
3639
3640 if (qq & 1L)
3641 {
3642 if (r2 >= ay)
3643 rr -= yy;
3644 else if (r2 <= -ay)
3645 rr += yy;
3646 }
3647 else
3648 {
3649 if (r2 > ay)
3650 rr -= yy;
3651 else if (r2 < -ay)
3652 rr += yy;
3653 }
3654 return SCM_I_MAKINUM (rr);
3655 }
3656 }
3657 else if (SCM_BIGP (y))
3658 {
3659 /* Pass a denormalized bignum version of x (even though it
3660 can fit in a fixnum) to scm_i_bigint_round_remainder */
3661 return scm_i_bigint_round_remainder
3662 (scm_i_long2big (xx), y);
3663 }
3664 else if (SCM_REALP (y))
3665 return scm_i_inexact_round_remainder (xx, SCM_REAL_VALUE (y));
3666 else if (SCM_FRACTIONP (y))
3667 return scm_i_exact_rational_round_remainder (x, y);
3668 else
3669 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3670 s_scm_round_remainder);
3671 }
3672 else if (SCM_BIGP (x))
3673 {
3674 if (SCM_LIKELY (SCM_I_INUMP (y)))
3675 {
3676 scm_t_inum yy = SCM_I_INUM (y);
3677 if (SCM_UNLIKELY (yy == 0))
3678 scm_num_overflow (s_scm_round_remainder);
3679 else
3680 {
3681 SCM q = scm_i_mkbig ();
3682 scm_t_inum rr;
3683 int needs_adjustment;
3684
3685 if (yy > 0)
3686 {
3687 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3688 SCM_I_BIG_MPZ (x), yy);
3689 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3690 needs_adjustment = (2*rr >= yy);
3691 else
3692 needs_adjustment = (2*rr > yy);
3693 }
3694 else
3695 {
3696 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3697 SCM_I_BIG_MPZ (x), -yy);
3698 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3699 needs_adjustment = (2*rr <= yy);
3700 else
3701 needs_adjustment = (2*rr < yy);
3702 }
3703 scm_remember_upto_here_2 (x, q);
3704 if (needs_adjustment)
3705 rr -= yy;
3706 return SCM_I_MAKINUM (rr);
3707 }
3708 }
3709 else if (SCM_BIGP (y))
3710 return scm_i_bigint_round_remainder (x, y);
3711 else if (SCM_REALP (y))
3712 return scm_i_inexact_round_remainder
3713 (scm_i_big2dbl (x), SCM_REAL_VALUE (y));
3714 else if (SCM_FRACTIONP (y))
3715 return scm_i_exact_rational_round_remainder (x, y);
3716 else
3717 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3718 s_scm_round_remainder);
3719 }
3720 else if (SCM_REALP (x))
3721 {
3722 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3723 SCM_BIGP (y) || SCM_FRACTIONP (y))
3724 return scm_i_inexact_round_remainder
3725 (SCM_REAL_VALUE (x), scm_to_double (y));
3726 else
3727 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3728 s_scm_round_remainder);
3729 }
3730 else if (SCM_FRACTIONP (x))
3731 {
3732 if (SCM_REALP (y))
3733 return scm_i_inexact_round_remainder
3734 (scm_i_fraction2double (x), SCM_REAL_VALUE (y));
3735 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3736 return scm_i_exact_rational_round_remainder (x, y);
3737 else
3738 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG2,
3739 s_scm_round_remainder);
3740 }
3741 else
3742 return scm_wta_dispatch_2 (g_scm_round_remainder, x, y, SCM_ARG1,
3743 s_scm_round_remainder);
3744 }
3745 #undef FUNC_NAME
3746
3747 static SCM
scm_i_inexact_round_remainder(double x,double y)3748 scm_i_inexact_round_remainder (double x, double y)
3749 {
3750 /* Although it would be more efficient to use fmod here, we can't
3751 because it would in some cases produce results inconsistent with
3752 scm_i_inexact_round_quotient, such that x != r + q * y (not even
3753 close). In particular, when x-y/2 is very close to a multiple of
3754 y, then r might be either -abs(y/2) or abs(y/2), but those two
3755 cases must correspond to different choices of q. If quotient
3756 chooses one and remainder chooses the other, it would be bad. */
3757
3758 if (SCM_UNLIKELY (y == 0))
3759 scm_num_overflow (s_scm_round_remainder); /* or return a NaN? */
3760 else
3761 {
3762 double q = scm_c_round (x / y);
3763 return scm_i_from_double (x - q * y);
3764 }
3765 }
3766
3767 /* Assumes that both x and y are bigints, though
3768 x might be able to fit into a fixnum. */
3769 static SCM
scm_i_bigint_round_remainder(SCM x,SCM y)3770 scm_i_bigint_round_remainder (SCM x, SCM y)
3771 {
3772 SCM q, r, r2;
3773 int cmp, needs_adjustment;
3774
3775 /* Note that x might be small enough to fit into a
3776 fixnum, so we must not let it escape into the wild */
3777 q = scm_i_mkbig ();
3778 r = scm_i_mkbig ();
3779 r2 = scm_i_mkbig ();
3780
3781 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
3782 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3783 scm_remember_upto_here_1 (x);
3784 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
3785
3786 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
3787 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3788 needs_adjustment = (cmp >= 0);
3789 else
3790 needs_adjustment = (cmp > 0);
3791 scm_remember_upto_here_2 (q, r2);
3792
3793 if (needs_adjustment)
3794 mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
3795
3796 scm_remember_upto_here_1 (y);
3797 return scm_i_normbig (r);
3798 }
3799
3800 static SCM
scm_i_exact_rational_round_remainder(SCM x,SCM y)3801 scm_i_exact_rational_round_remainder (SCM x, SCM y)
3802 {
3803 SCM xd = scm_denominator (x);
3804 SCM yd = scm_denominator (y);
3805 SCM r1 = scm_round_remainder (scm_product (scm_numerator (x), yd),
3806 scm_product (scm_numerator (y), xd));
3807 return scm_divide (r1, scm_product (xd, yd));
3808 }
3809
3810
3811 static void scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp);
3812 static void scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
3813 static void scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp);
3814
3815 SCM_PRIMITIVE_GENERIC (scm_i_round_divide, "round/", 2, 0, 0,
3816 (SCM x, SCM y),
3817 "Return the integer @var{q} and the real number @var{r}\n"
3818 "such that @math{@var{x} = @var{q}*@var{y} + @var{r}}\n"
3819 "and @var{q} is @math{@var{x} / @var{y}} rounded to the\n"
3820 "nearest integer, with ties going to the nearest even integer.\n"
3821 "@lisp\n"
3822 "(round/ 123 10) @result{} 12 and 3\n"
3823 "(round/ 123 -10) @result{} -12 and 3\n"
3824 "(round/ -123 10) @result{} -12 and -3\n"
3825 "(round/ -123 -10) @result{} 12 and -3\n"
3826 "(round/ 125 10) @result{} 12 and 5\n"
3827 "(round/ 127 10) @result{} 13 and -3\n"
3828 "(round/ 135 10) @result{} 14 and -5\n"
3829 "(round/ -123.2 -63.5) @result{} 2.0 and 3.8\n"
3830 "(round/ 16/3 -10/7) @result{} -4 and -8/21\n"
3831 "@end lisp")
3832 #define FUNC_NAME s_scm_i_round_divide
3833 {
3834 SCM q, r;
3835
3836 scm_round_divide(x, y, &q, &r);
3837 return scm_values (scm_list_2 (q, r));
3838 }
3839 #undef FUNC_NAME
3840
3841 #define s_scm_round_divide s_scm_i_round_divide
3842 #define g_scm_round_divide g_scm_i_round_divide
3843
3844 void
scm_round_divide(SCM x,SCM y,SCM * qp,SCM * rp)3845 scm_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3846 {
3847 if (SCM_LIKELY (SCM_I_INUMP (x)))
3848 {
3849 scm_t_inum xx = SCM_I_INUM (x);
3850 if (SCM_LIKELY (SCM_I_INUMP (y)))
3851 {
3852 scm_t_inum yy = SCM_I_INUM (y);
3853 if (SCM_UNLIKELY (yy == 0))
3854 scm_num_overflow (s_scm_round_divide);
3855 else
3856 {
3857 scm_t_inum qq = xx / yy;
3858 scm_t_inum rr = xx % yy;
3859 scm_t_inum ay = yy;
3860 scm_t_inum r2 = 2 * rr;
3861
3862 if (SCM_LIKELY (yy < 0))
3863 {
3864 ay = -ay;
3865 r2 = -r2;
3866 }
3867
3868 if (qq & 1L)
3869 {
3870 if (r2 >= ay)
3871 { qq++; rr -= yy; }
3872 else if (r2 <= -ay)
3873 { qq--; rr += yy; }
3874 }
3875 else
3876 {
3877 if (r2 > ay)
3878 { qq++; rr -= yy; }
3879 else if (r2 < -ay)
3880 { qq--; rr += yy; }
3881 }
3882 if (SCM_LIKELY (SCM_FIXABLE (qq)))
3883 *qp = SCM_I_MAKINUM (qq);
3884 else
3885 *qp = scm_i_inum2big (qq);
3886 *rp = SCM_I_MAKINUM (rr);
3887 }
3888 }
3889 else if (SCM_BIGP (y))
3890 /* Pass a denormalized bignum version of x (even though it
3891 can fit in a fixnum) to scm_i_bigint_round_divide */
3892 scm_i_bigint_round_divide (scm_i_long2big (SCM_I_INUM (x)), y, qp, rp);
3893 else if (SCM_REALP (y))
3894 scm_i_inexact_round_divide (xx, SCM_REAL_VALUE (y), qp, rp);
3895 else if (SCM_FRACTIONP (y))
3896 scm_i_exact_rational_round_divide (x, y, qp, rp);
3897 else
3898 two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3899 s_scm_round_divide, qp, rp);
3900 }
3901 else if (SCM_BIGP (x))
3902 {
3903 if (SCM_LIKELY (SCM_I_INUMP (y)))
3904 {
3905 scm_t_inum yy = SCM_I_INUM (y);
3906 if (SCM_UNLIKELY (yy == 0))
3907 scm_num_overflow (s_scm_round_divide);
3908 else
3909 {
3910 SCM q = scm_i_mkbig ();
3911 scm_t_inum rr;
3912 int needs_adjustment;
3913
3914 if (yy > 0)
3915 {
3916 rr = mpz_fdiv_q_ui (SCM_I_BIG_MPZ (q),
3917 SCM_I_BIG_MPZ (x), yy);
3918 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3919 needs_adjustment = (2*rr >= yy);
3920 else
3921 needs_adjustment = (2*rr > yy);
3922 }
3923 else
3924 {
3925 rr = - mpz_cdiv_q_ui (SCM_I_BIG_MPZ (q),
3926 SCM_I_BIG_MPZ (x), -yy);
3927 mpz_neg (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q));
3928 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
3929 needs_adjustment = (2*rr <= yy);
3930 else
3931 needs_adjustment = (2*rr < yy);
3932 }
3933 scm_remember_upto_here_1 (x);
3934 if (needs_adjustment)
3935 {
3936 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
3937 rr -= yy;
3938 }
3939 *qp = scm_i_normbig (q);
3940 *rp = SCM_I_MAKINUM (rr);
3941 }
3942 }
3943 else if (SCM_BIGP (y))
3944 scm_i_bigint_round_divide (x, y, qp, rp);
3945 else if (SCM_REALP (y))
3946 scm_i_inexact_round_divide (scm_i_big2dbl (x), SCM_REAL_VALUE (y),
3947 qp, rp);
3948 else if (SCM_FRACTIONP (y))
3949 scm_i_exact_rational_round_divide (x, y, qp, rp);
3950 else
3951 two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3952 s_scm_round_divide, qp, rp);
3953 }
3954 else if (SCM_REALP (x))
3955 {
3956 if (SCM_REALP (y) || SCM_I_INUMP (y) ||
3957 SCM_BIGP (y) || SCM_FRACTIONP (y))
3958 scm_i_inexact_round_divide (SCM_REAL_VALUE (x), scm_to_double (y),
3959 qp, rp);
3960 else
3961 two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3962 s_scm_round_divide, qp, rp);
3963 }
3964 else if (SCM_FRACTIONP (x))
3965 {
3966 if (SCM_REALP (y))
3967 scm_i_inexact_round_divide
3968 (scm_i_fraction2double (x), SCM_REAL_VALUE (y), qp, rp);
3969 else if (SCM_I_INUMP (y) || SCM_BIGP (y) || SCM_FRACTIONP (y))
3970 scm_i_exact_rational_round_divide (x, y, qp, rp);
3971 else
3972 two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG2,
3973 s_scm_round_divide, qp, rp);
3974 }
3975 else
3976 two_valued_wta_dispatch_2 (g_scm_round_divide, x, y, SCM_ARG1,
3977 s_scm_round_divide, qp, rp);
3978 }
3979
3980 static void
scm_i_inexact_round_divide(double x,double y,SCM * qp,SCM * rp)3981 scm_i_inexact_round_divide (double x, double y, SCM *qp, SCM *rp)
3982 {
3983 if (SCM_UNLIKELY (y == 0))
3984 scm_num_overflow (s_scm_round_divide); /* or return a NaN? */
3985 else
3986 {
3987 double q = scm_c_round (x / y);
3988 double r = x - q * y;
3989 *qp = scm_i_from_double (q);
3990 *rp = scm_i_from_double (r);
3991 }
3992 }
3993
3994 /* Assumes that both x and y are bigints, though
3995 x might be able to fit into a fixnum. */
3996 static void
scm_i_bigint_round_divide(SCM x,SCM y,SCM * qp,SCM * rp)3997 scm_i_bigint_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
3998 {
3999 SCM q, r, r2;
4000 int cmp, needs_adjustment;
4001
4002 /* Note that x might be small enough to fit into a
4003 fixnum, so we must not let it escape into the wild */
4004 q = scm_i_mkbig ();
4005 r = scm_i_mkbig ();
4006 r2 = scm_i_mkbig ();
4007
4008 mpz_fdiv_qr (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (r),
4009 SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
4010 scm_remember_upto_here_1 (x);
4011 mpz_mul_2exp (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (r), 1); /* r2 = 2*r */
4012
4013 cmp = mpz_cmpabs (SCM_I_BIG_MPZ (r2), SCM_I_BIG_MPZ (y));
4014 if (mpz_odd_p (SCM_I_BIG_MPZ (q)))
4015 needs_adjustment = (cmp >= 0);
4016 else
4017 needs_adjustment = (cmp > 0);
4018
4019 if (needs_adjustment)
4020 {
4021 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
4022 mpz_sub (SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (y));
4023 }
4024
4025 scm_remember_upto_here_2 (r2, y);
4026 *qp = scm_i_normbig (q);
4027 *rp = scm_i_normbig (r);
4028 }
4029
4030 static void
scm_i_exact_rational_round_divide(SCM x,SCM y,SCM * qp,SCM * rp)4031 scm_i_exact_rational_round_divide (SCM x, SCM y, SCM *qp, SCM *rp)
4032 {
4033 SCM r1;
4034 SCM xd = scm_denominator (x);
4035 SCM yd = scm_denominator (y);
4036
4037 scm_round_divide (scm_product (scm_numerator (x), yd),
4038 scm_product (scm_numerator (y), xd),
4039 qp, &r1);
4040 *rp = scm_divide (r1, scm_product (xd, yd));
4041 }
4042
4043
4044 SCM_PRIMITIVE_GENERIC (scm_i_gcd, "gcd", 0, 2, 1,
4045 (SCM x, SCM y, SCM rest),
4046 "Return the greatest common divisor of all parameter values.\n"
4047 "If called without arguments, 0 is returned.")
4048 #define FUNC_NAME s_scm_i_gcd
4049 {
4050 while (!scm_is_null (rest))
4051 { x = scm_gcd (x, y);
4052 y = scm_car (rest);
4053 rest = scm_cdr (rest);
4054 }
4055 return scm_gcd (x, y);
4056 }
4057 #undef FUNC_NAME
4058
4059 #define s_gcd s_scm_i_gcd
4060 #define g_gcd g_scm_i_gcd
4061
4062 SCM
scm_gcd(SCM x,SCM y)4063 scm_gcd (SCM x, SCM y)
4064 {
4065 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
4066 return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x);
4067
4068 if (SCM_LIKELY (SCM_I_INUMP (x)))
4069 {
4070 if (SCM_LIKELY (SCM_I_INUMP (y)))
4071 {
4072 scm_t_inum xx = SCM_I_INUM (x);
4073 scm_t_inum yy = SCM_I_INUM (y);
4074 scm_t_inum u = xx < 0 ? -xx : xx;
4075 scm_t_inum v = yy < 0 ? -yy : yy;
4076 scm_t_inum result;
4077 if (SCM_UNLIKELY (xx == 0))
4078 result = v;
4079 else if (SCM_UNLIKELY (yy == 0))
4080 result = u;
4081 else
4082 {
4083 int k = 0;
4084 /* Determine a common factor 2^k */
4085 while (((u | v) & 1) == 0)
4086 {
4087 k++;
4088 u >>= 1;
4089 v >>= 1;
4090 }
4091 /* Now, any factor 2^n can be eliminated */
4092 if ((u & 1) == 0)
4093 while ((u & 1) == 0)
4094 u >>= 1;
4095 else
4096 while ((v & 1) == 0)
4097 v >>= 1;
4098 /* Both u and v are now odd. Subtract the smaller one
4099 from the larger one to produce an even number, remove
4100 more factors of two, and repeat. */
4101 while (u != v)
4102 {
4103 if (u > v)
4104 {
4105 u -= v;
4106 while ((u & 1) == 0)
4107 u >>= 1;
4108 }
4109 else
4110 {
4111 v -= u;
4112 while ((v & 1) == 0)
4113 v >>= 1;
4114 }
4115 }
4116 result = u << k;
4117 }
4118 return (SCM_POSFIXABLE (result)
4119 ? SCM_I_MAKINUM (result)
4120 : scm_i_inum2big (result));
4121 }
4122 else if (SCM_BIGP (y))
4123 {
4124 SCM_SWAP (x, y);
4125 goto big_inum;
4126 }
4127 else if (SCM_REALP (y) && scm_is_integer (y))
4128 goto handle_inexacts;
4129 else
4130 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
4131 }
4132 else if (SCM_BIGP (x))
4133 {
4134 if (SCM_I_INUMP (y))
4135 {
4136 scm_t_bits result;
4137 scm_t_inum yy;
4138 big_inum:
4139 yy = SCM_I_INUM (y);
4140 if (yy == 0)
4141 return scm_abs (x);
4142 if (yy < 0)
4143 yy = -yy;
4144 result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
4145 scm_remember_upto_here_1 (x);
4146 return (SCM_POSFIXABLE (result)
4147 ? SCM_I_MAKINUM (result)
4148 : scm_from_unsigned_integer (result));
4149 }
4150 else if (SCM_BIGP (y))
4151 {
4152 SCM result = scm_i_mkbig ();
4153 mpz_gcd (SCM_I_BIG_MPZ (result),
4154 SCM_I_BIG_MPZ (x),
4155 SCM_I_BIG_MPZ (y));
4156 scm_remember_upto_here_2 (x, y);
4157 return scm_i_normbig (result);
4158 }
4159 else if (SCM_REALP (y) && scm_is_integer (y))
4160 goto handle_inexacts;
4161 else
4162 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
4163 }
4164 else if (SCM_REALP (x) && scm_is_integer (x))
4165 {
4166 if (SCM_I_INUMP (y) || SCM_BIGP (y)
4167 || (SCM_REALP (y) && scm_is_integer (y)))
4168 {
4169 handle_inexacts:
4170 return scm_exact_to_inexact (scm_gcd (scm_inexact_to_exact (x),
4171 scm_inexact_to_exact (y)));
4172 }
4173 else
4174 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
4175 }
4176 else
4177 return scm_wta_dispatch_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
4178 }
4179
4180 SCM_PRIMITIVE_GENERIC (scm_i_lcm, "lcm", 0, 2, 1,
4181 (SCM x, SCM y, SCM rest),
4182 "Return the least common multiple of the arguments.\n"
4183 "If called without arguments, 1 is returned.")
4184 #define FUNC_NAME s_scm_i_lcm
4185 {
4186 while (!scm_is_null (rest))
4187 { x = scm_lcm (x, y);
4188 y = scm_car (rest);
4189 rest = scm_cdr (rest);
4190 }
4191 return scm_lcm (x, y);
4192 }
4193 #undef FUNC_NAME
4194
4195 #define s_lcm s_scm_i_lcm
4196 #define g_lcm g_scm_i_lcm
4197
4198 SCM
scm_lcm(SCM n1,SCM n2)4199 scm_lcm (SCM n1, SCM n2)
4200 {
4201 if (SCM_UNLIKELY (SCM_UNBNDP (n2)))
4202 return SCM_UNBNDP (n1) ? SCM_INUM1 : scm_abs (n1);
4203
4204 if (SCM_LIKELY (SCM_I_INUMP (n1)))
4205 {
4206 if (SCM_LIKELY (SCM_I_INUMP (n2)))
4207 {
4208 SCM d = scm_gcd (n1, n2);
4209 if (scm_is_eq (d, SCM_INUM0))
4210 return d;
4211 else
4212 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
4213 }
4214 else if (SCM_LIKELY (SCM_BIGP (n2)))
4215 {
4216 /* inum n1, big n2 */
4217 inumbig:
4218 {
4219 SCM result = scm_i_mkbig ();
4220 scm_t_inum nn1 = SCM_I_INUM (n1);
4221 if (nn1 == 0) return SCM_INUM0;
4222 if (nn1 < 0) nn1 = - nn1;
4223 mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
4224 scm_remember_upto_here_1 (n2);
4225 return result;
4226 }
4227 }
4228 else if (SCM_REALP (n2) && scm_is_integer (n2))
4229 goto handle_inexacts;
4230 else
4231 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
4232 }
4233 else if (SCM_LIKELY (SCM_BIGP (n1)))
4234 {
4235 /* big n1 */
4236 if (SCM_I_INUMP (n2))
4237 {
4238 SCM_SWAP (n1, n2);
4239 goto inumbig;
4240 }
4241 else if (SCM_LIKELY (SCM_BIGP (n2)))
4242 {
4243 SCM result = scm_i_mkbig ();
4244 mpz_lcm(SCM_I_BIG_MPZ (result),
4245 SCM_I_BIG_MPZ (n1),
4246 SCM_I_BIG_MPZ (n2));
4247 scm_remember_upto_here_2(n1, n2);
4248 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
4249 return result;
4250 }
4251 else if (SCM_REALP (n2) && scm_is_integer (n2))
4252 goto handle_inexacts;
4253 else
4254 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
4255 }
4256 else if (SCM_REALP (n1) && scm_is_integer (n1))
4257 {
4258 if (SCM_I_INUMP (n2) || SCM_BIGP (n2)
4259 || (SCM_REALP (n2) && scm_is_integer (n2)))
4260 {
4261 handle_inexacts:
4262 return scm_exact_to_inexact (scm_lcm (scm_inexact_to_exact (n1),
4263 scm_inexact_to_exact (n2)));
4264 }
4265 else
4266 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG2, s_lcm);
4267 }
4268 else
4269 return scm_wta_dispatch_2 (g_lcm, n1, n2, SCM_ARG1, s_lcm);
4270 }
4271
4272 /* Emulating 2's complement bignums with sign magnitude arithmetic:
4273
4274 Logand:
4275 X Y Result Method:
4276 (len)
4277 + + + x (map digit:logand X Y)
4278 + - + x (map digit:logand X (lognot (+ -1 Y)))
4279 - + + y (map digit:logand (lognot (+ -1 X)) Y)
4280 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
4281
4282 Logior:
4283 X Y Result Method:
4284
4285 + + + (map digit:logior X Y)
4286 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
4287 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
4288 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
4289
4290 Logxor:
4291 X Y Result Method:
4292
4293 + + + (map digit:logxor X Y)
4294 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
4295 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
4296 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
4297
4298 Logtest:
4299 X Y Result
4300
4301 + + (any digit:logand X Y)
4302 + - (any digit:logand X (lognot (+ -1 Y)))
4303 - + (any digit:logand (lognot (+ -1 X)) Y)
4304 - - #t
4305
4306 */
4307
4308 SCM_DEFINE (scm_i_logand, "logand", 0, 2, 1,
4309 (SCM x, SCM y, SCM rest),
4310 "Return the bitwise AND of the integer arguments.\n\n"
4311 "@lisp\n"
4312 "(logand) @result{} -1\n"
4313 "(logand 7) @result{} 7\n"
4314 "(logand #b111 #b011 #b001) @result{} 1\n"
4315 "@end lisp")
4316 #define FUNC_NAME s_scm_i_logand
4317 {
4318 while (!scm_is_null (rest))
4319 { x = scm_logand (x, y);
4320 y = scm_car (rest);
4321 rest = scm_cdr (rest);
4322 }
4323 return scm_logand (x, y);
4324 }
4325 #undef FUNC_NAME
4326
4327 #define s_scm_logand s_scm_i_logand
4328
scm_logand(SCM n1,SCM n2)4329 SCM scm_logand (SCM n1, SCM n2)
4330 #define FUNC_NAME s_scm_logand
4331 {
4332 scm_t_inum nn1;
4333
4334 if (SCM_UNBNDP (n2))
4335 {
4336 if (SCM_UNBNDP (n1))
4337 return SCM_I_MAKINUM (-1);
4338 else if (!SCM_NUMBERP (n1))
4339 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4340 else if (SCM_NUMBERP (n1))
4341 return n1;
4342 else
4343 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4344 }
4345
4346 if (SCM_I_INUMP (n1))
4347 {
4348 nn1 = SCM_I_INUM (n1);
4349 if (SCM_I_INUMP (n2))
4350 {
4351 scm_t_inum nn2 = SCM_I_INUM (n2);
4352 return SCM_I_MAKINUM (nn1 & nn2);
4353 }
4354 else if SCM_BIGP (n2)
4355 {
4356 intbig:
4357 if (nn1 == 0)
4358 return SCM_INUM0;
4359 {
4360 SCM result_z = scm_i_mkbig ();
4361 mpz_t nn1_z;
4362 mpz_init_set_si (nn1_z, nn1);
4363 mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4364 scm_remember_upto_here_1 (n2);
4365 mpz_clear (nn1_z);
4366 return scm_i_normbig (result_z);
4367 }
4368 }
4369 else
4370 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4371 }
4372 else if (SCM_BIGP (n1))
4373 {
4374 if (SCM_I_INUMP (n2))
4375 {
4376 SCM_SWAP (n1, n2);
4377 nn1 = SCM_I_INUM (n1);
4378 goto intbig;
4379 }
4380 else if (SCM_BIGP (n2))
4381 {
4382 SCM result_z = scm_i_mkbig ();
4383 mpz_and (SCM_I_BIG_MPZ (result_z),
4384 SCM_I_BIG_MPZ (n1),
4385 SCM_I_BIG_MPZ (n2));
4386 scm_remember_upto_here_2 (n1, n2);
4387 return scm_i_normbig (result_z);
4388 }
4389 else
4390 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4391 }
4392 else
4393 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4394 }
4395 #undef FUNC_NAME
4396
4397
4398 SCM_DEFINE (scm_i_logior, "logior", 0, 2, 1,
4399 (SCM x, SCM y, SCM rest),
4400 "Return the bitwise OR of the integer arguments.\n\n"
4401 "@lisp\n"
4402 "(logior) @result{} 0\n"
4403 "(logior 7) @result{} 7\n"
4404 "(logior #b000 #b001 #b011) @result{} 3\n"
4405 "@end lisp")
4406 #define FUNC_NAME s_scm_i_logior
4407 {
4408 while (!scm_is_null (rest))
4409 { x = scm_logior (x, y);
4410 y = scm_car (rest);
4411 rest = scm_cdr (rest);
4412 }
4413 return scm_logior (x, y);
4414 }
4415 #undef FUNC_NAME
4416
4417 #define s_scm_logior s_scm_i_logior
4418
scm_logior(SCM n1,SCM n2)4419 SCM scm_logior (SCM n1, SCM n2)
4420 #define FUNC_NAME s_scm_logior
4421 {
4422 scm_t_inum nn1;
4423
4424 if (SCM_UNBNDP (n2))
4425 {
4426 if (SCM_UNBNDP (n1))
4427 return SCM_INUM0;
4428 else if (SCM_NUMBERP (n1))
4429 return n1;
4430 else
4431 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4432 }
4433
4434 if (SCM_I_INUMP (n1))
4435 {
4436 nn1 = SCM_I_INUM (n1);
4437 if (SCM_I_INUMP (n2))
4438 {
4439 long nn2 = SCM_I_INUM (n2);
4440 return SCM_I_MAKINUM (nn1 | nn2);
4441 }
4442 else if (SCM_BIGP (n2))
4443 {
4444 intbig:
4445 if (nn1 == 0)
4446 return n2;
4447 {
4448 SCM result_z = scm_i_mkbig ();
4449 mpz_t nn1_z;
4450 mpz_init_set_si (nn1_z, nn1);
4451 mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4452 scm_remember_upto_here_1 (n2);
4453 mpz_clear (nn1_z);
4454 return scm_i_normbig (result_z);
4455 }
4456 }
4457 else
4458 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4459 }
4460 else if (SCM_BIGP (n1))
4461 {
4462 if (SCM_I_INUMP (n2))
4463 {
4464 SCM_SWAP (n1, n2);
4465 nn1 = SCM_I_INUM (n1);
4466 goto intbig;
4467 }
4468 else if (SCM_BIGP (n2))
4469 {
4470 SCM result_z = scm_i_mkbig ();
4471 mpz_ior (SCM_I_BIG_MPZ (result_z),
4472 SCM_I_BIG_MPZ (n1),
4473 SCM_I_BIG_MPZ (n2));
4474 scm_remember_upto_here_2 (n1, n2);
4475 return scm_i_normbig (result_z);
4476 }
4477 else
4478 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4479 }
4480 else
4481 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4482 }
4483 #undef FUNC_NAME
4484
4485
4486 SCM_DEFINE (scm_i_logxor, "logxor", 0, 2, 1,
4487 (SCM x, SCM y, SCM rest),
4488 "Return the bitwise XOR of the integer arguments. A bit is\n"
4489 "set in the result if it is set in an odd number of arguments.\n"
4490 "@lisp\n"
4491 "(logxor) @result{} 0\n"
4492 "(logxor 7) @result{} 7\n"
4493 "(logxor #b000 #b001 #b011) @result{} 2\n"
4494 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
4495 "@end lisp")
4496 #define FUNC_NAME s_scm_i_logxor
4497 {
4498 while (!scm_is_null (rest))
4499 { x = scm_logxor (x, y);
4500 y = scm_car (rest);
4501 rest = scm_cdr (rest);
4502 }
4503 return scm_logxor (x, y);
4504 }
4505 #undef FUNC_NAME
4506
4507 #define s_scm_logxor s_scm_i_logxor
4508
scm_logxor(SCM n1,SCM n2)4509 SCM scm_logxor (SCM n1, SCM n2)
4510 #define FUNC_NAME s_scm_logxor
4511 {
4512 scm_t_inum nn1;
4513
4514 if (SCM_UNBNDP (n2))
4515 {
4516 if (SCM_UNBNDP (n1))
4517 return SCM_INUM0;
4518 else if (SCM_NUMBERP (n1))
4519 return n1;
4520 else
4521 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4522 }
4523
4524 if (SCM_I_INUMP (n1))
4525 {
4526 nn1 = SCM_I_INUM (n1);
4527 if (SCM_I_INUMP (n2))
4528 {
4529 scm_t_inum nn2 = SCM_I_INUM (n2);
4530 return SCM_I_MAKINUM (nn1 ^ nn2);
4531 }
4532 else if (SCM_BIGP (n2))
4533 {
4534 intbig:
4535 {
4536 SCM result_z = scm_i_mkbig ();
4537 mpz_t nn1_z;
4538 mpz_init_set_si (nn1_z, nn1);
4539 mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
4540 scm_remember_upto_here_1 (n2);
4541 mpz_clear (nn1_z);
4542 return scm_i_normbig (result_z);
4543 }
4544 }
4545 else
4546 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4547 }
4548 else if (SCM_BIGP (n1))
4549 {
4550 if (SCM_I_INUMP (n2))
4551 {
4552 SCM_SWAP (n1, n2);
4553 nn1 = SCM_I_INUM (n1);
4554 goto intbig;
4555 }
4556 else if (SCM_BIGP (n2))
4557 {
4558 SCM result_z = scm_i_mkbig ();
4559 mpz_xor (SCM_I_BIG_MPZ (result_z),
4560 SCM_I_BIG_MPZ (n1),
4561 SCM_I_BIG_MPZ (n2));
4562 scm_remember_upto_here_2 (n1, n2);
4563 return scm_i_normbig (result_z);
4564 }
4565 else
4566 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
4567 }
4568 else
4569 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
4570 }
4571 #undef FUNC_NAME
4572
4573
4574 SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
4575 (SCM j, SCM k),
4576 "Test whether @var{j} and @var{k} have any 1 bits in common.\n"
4577 "This is equivalent to @code{(not (zero? (logand j k)))}, but\n"
4578 "without actually calculating the @code{logand}, just testing\n"
4579 "for non-zero.\n"
4580 "\n"
4581 "@lisp\n"
4582 "(logtest #b0100 #b1011) @result{} #f\n"
4583 "(logtest #b0100 #b0111) @result{} #t\n"
4584 "@end lisp")
4585 #define FUNC_NAME s_scm_logtest
4586 {
4587 scm_t_inum nj;
4588
4589 if (SCM_I_INUMP (j))
4590 {
4591 nj = SCM_I_INUM (j);
4592 if (SCM_I_INUMP (k))
4593 {
4594 scm_t_inum nk = SCM_I_INUM (k);
4595 return scm_from_bool (nj & nk);
4596 }
4597 else if (SCM_BIGP (k))
4598 {
4599 intbig:
4600 if (nj == 0)
4601 return SCM_BOOL_F;
4602 {
4603 SCM result;
4604 mpz_t nj_z;
4605 mpz_init_set_si (nj_z, nj);
4606 mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
4607 scm_remember_upto_here_1 (k);
4608 result = scm_from_bool (mpz_sgn (nj_z) != 0);
4609 mpz_clear (nj_z);
4610 return result;
4611 }
4612 }
4613 else
4614 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
4615 }
4616 else if (SCM_BIGP (j))
4617 {
4618 if (SCM_I_INUMP (k))
4619 {
4620 SCM_SWAP (j, k);
4621 nj = SCM_I_INUM (j);
4622 goto intbig;
4623 }
4624 else if (SCM_BIGP (k))
4625 {
4626 SCM result;
4627 mpz_t result_z;
4628 mpz_init (result_z);
4629 mpz_and (result_z,
4630 SCM_I_BIG_MPZ (j),
4631 SCM_I_BIG_MPZ (k));
4632 scm_remember_upto_here_2 (j, k);
4633 result = scm_from_bool (mpz_sgn (result_z) != 0);
4634 mpz_clear (result_z);
4635 return result;
4636 }
4637 else
4638 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
4639 }
4640 else
4641 SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
4642 }
4643 #undef FUNC_NAME
4644
4645
4646 SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
4647 (SCM index, SCM j),
4648 "Test whether bit number @var{index} in @var{j} is set.\n"
4649 "@var{index} starts from 0 for the least significant bit.\n"
4650 "\n"
4651 "@lisp\n"
4652 "(logbit? 0 #b1101) @result{} #t\n"
4653 "(logbit? 1 #b1101) @result{} #f\n"
4654 "(logbit? 2 #b1101) @result{} #t\n"
4655 "(logbit? 3 #b1101) @result{} #t\n"
4656 "(logbit? 4 #b1101) @result{} #f\n"
4657 "@end lisp")
4658 #define FUNC_NAME s_scm_logbit_p
4659 {
4660 unsigned long int iindex;
4661 iindex = scm_to_ulong (index);
4662
4663 if (SCM_I_INUMP (j))
4664 {
4665 if (iindex < SCM_LONG_BIT - 1)
4666 /* Arrange for the number to be converted to unsigned before
4667 checking the bit, to ensure that we're testing the bit in a
4668 two's complement representation (regardless of the native
4669 representation. */
4670 return scm_from_bool ((1UL << iindex) & SCM_I_INUM (j));
4671 else
4672 /* Portably check the sign. */
4673 return scm_from_bool (SCM_I_INUM (j) < 0);
4674 }
4675 else if (SCM_BIGP (j))
4676 {
4677 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
4678 scm_remember_upto_here_1 (j);
4679 return scm_from_bool (val);
4680 }
4681 else
4682 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
4683 }
4684 #undef FUNC_NAME
4685
4686
4687 SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
4688 (SCM n),
4689 "Return the integer which is the ones-complement of the integer\n"
4690 "argument.\n"
4691 "\n"
4692 "@lisp\n"
4693 "(number->string (lognot #b10000000) 2)\n"
4694 " @result{} \"-10000001\"\n"
4695 "(number->string (lognot #b0) 2)\n"
4696 " @result{} \"-1\"\n"
4697 "@end lisp")
4698 #define FUNC_NAME s_scm_lognot
4699 {
4700 if (SCM_I_INUMP (n)) {
4701 /* No overflow here, just need to toggle all the bits making up the inum.
4702 Enhancement: No need to strip the tag and add it back, could just xor
4703 a block of 1 bits, if that worked with the various debug versions of
4704 the SCM typedef. */
4705 return SCM_I_MAKINUM (~ SCM_I_INUM (n));
4706
4707 } else if (SCM_BIGP (n)) {
4708 SCM result = scm_i_mkbig ();
4709 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
4710 scm_remember_upto_here_1 (n);
4711 return result;
4712
4713 } else {
4714 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
4715 }
4716 }
4717 #undef FUNC_NAME
4718
4719 /* returns 0 if IN is not an integer. OUT must already be
4720 initialized. */
4721 static int
coerce_to_big(SCM in,mpz_t out)4722 coerce_to_big (SCM in, mpz_t out)
4723 {
4724 if (SCM_BIGP (in))
4725 mpz_set (out, SCM_I_BIG_MPZ (in));
4726 else if (SCM_I_INUMP (in))
4727 mpz_set_si (out, SCM_I_INUM (in));
4728 else
4729 return 0;
4730
4731 return 1;
4732 }
4733
4734 SCM_DEFINE (scm_modulo_expt, "modulo-expt", 3, 0, 0,
4735 (SCM n, SCM k, SCM m),
4736 "Return @var{n} raised to the integer exponent\n"
4737 "@var{k}, modulo @var{m}.\n"
4738 "\n"
4739 "@lisp\n"
4740 "(modulo-expt 2 3 5)\n"
4741 " @result{} 3\n"
4742 "@end lisp")
4743 #define FUNC_NAME s_scm_modulo_expt
4744 {
4745 mpz_t n_tmp;
4746 mpz_t k_tmp;
4747 mpz_t m_tmp;
4748
4749 /* There are two classes of error we might encounter --
4750 1) Math errors, which we'll report by calling scm_num_overflow,
4751 and
4752 2) wrong-type errors, which of course we'll report by calling
4753 SCM_WRONG_TYPE_ARG.
4754 We don't report those errors immediately, however; instead we do
4755 some cleanup first. These variables tell us which error (if
4756 any) we should report after cleaning up.
4757 */
4758 int report_overflow = 0;
4759
4760 int position_of_wrong_type = 0;
4761 SCM value_of_wrong_type = SCM_INUM0;
4762
4763 SCM result = SCM_UNDEFINED;
4764
4765 mpz_init (n_tmp);
4766 mpz_init (k_tmp);
4767 mpz_init (m_tmp);
4768
4769 if (scm_is_eq (m, SCM_INUM0))
4770 {
4771 report_overflow = 1;
4772 goto cleanup;
4773 }
4774
4775 if (!coerce_to_big (n, n_tmp))
4776 {
4777 value_of_wrong_type = n;
4778 position_of_wrong_type = 1;
4779 goto cleanup;
4780 }
4781
4782 if (!coerce_to_big (k, k_tmp))
4783 {
4784 value_of_wrong_type = k;
4785 position_of_wrong_type = 2;
4786 goto cleanup;
4787 }
4788
4789 if (!coerce_to_big (m, m_tmp))
4790 {
4791 value_of_wrong_type = m;
4792 position_of_wrong_type = 3;
4793 goto cleanup;
4794 }
4795
4796 /* if the exponent K is negative, and we simply call mpz_powm, we
4797 will get a divide-by-zero exception when an inverse 1/n mod m
4798 doesn't exist (or is not unique). Since exceptions are hard to
4799 handle, we'll attempt the inversion "by hand" -- that way, we get
4800 a simple failure code, which is easy to handle. */
4801
4802 if (-1 == mpz_sgn (k_tmp))
4803 {
4804 if (!mpz_invert (n_tmp, n_tmp, m_tmp))
4805 {
4806 report_overflow = 1;
4807 goto cleanup;
4808 }
4809 mpz_neg (k_tmp, k_tmp);
4810 }
4811
4812 result = scm_i_mkbig ();
4813 mpz_powm (SCM_I_BIG_MPZ (result),
4814 n_tmp,
4815 k_tmp,
4816 m_tmp);
4817
4818 if (mpz_sgn (m_tmp) < 0 && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
4819 mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), m_tmp);
4820
4821 cleanup:
4822 mpz_clear (m_tmp);
4823 mpz_clear (k_tmp);
4824 mpz_clear (n_tmp);
4825
4826 if (report_overflow)
4827 scm_num_overflow (FUNC_NAME);
4828
4829 if (position_of_wrong_type)
4830 SCM_WRONG_TYPE_ARG (position_of_wrong_type,
4831 value_of_wrong_type);
4832
4833 return scm_i_normbig (result);
4834 }
4835 #undef FUNC_NAME
4836
4837 SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
4838 (SCM n, SCM k),
4839 "Return @var{n} raised to the power @var{k}. @var{k} must be an\n"
4840 "exact integer, @var{n} can be any number.\n"
4841 "\n"
4842 "Negative @var{k} is supported, and results in\n"
4843 "@math{1/@var{n}^abs(@var{k})} in the usual way.\n"
4844 "@math{@var{n}^0} is 1, as usual, and that\n"
4845 "includes @math{0^0} is 1.\n"
4846 "\n"
4847 "@lisp\n"
4848 "(integer-expt 2 5) @result{} 32\n"
4849 "(integer-expt -3 3) @result{} -27\n"
4850 "(integer-expt 5 -3) @result{} 1/125\n"
4851 "(integer-expt 0 0) @result{} 1\n"
4852 "@end lisp")
4853 #define FUNC_NAME s_scm_integer_expt
4854 {
4855 scm_t_inum i2 = 0;
4856 SCM z_i2 = SCM_BOOL_F;
4857 int i2_is_big = 0;
4858 SCM acc = SCM_I_MAKINUM (1L);
4859
4860 /* Specifically refrain from checking the type of the first argument.
4861 This allows us to exponentiate any object that can be multiplied.
4862 If we must raise to a negative power, we must also be able to
4863 take its reciprocal. */
4864 if (!SCM_LIKELY (SCM_I_INUMP (k)) && !SCM_LIKELY (SCM_BIGP (k)))
4865 SCM_WRONG_TYPE_ARG (2, k);
4866
4867 if (SCM_UNLIKELY (scm_is_eq (k, SCM_INUM0)))
4868 return SCM_INUM1; /* n^(exact0) is exact 1, regardless of n */
4869 else if (SCM_UNLIKELY (scm_is_eq (n, SCM_I_MAKINUM (-1L))))
4870 return scm_is_false (scm_even_p (k)) ? n : SCM_INUM1;
4871 /* The next check is necessary only because R6RS specifies different
4872 behavior for 0^(-k) than for (/ 0). If n is not a scheme number,
4873 we simply skip this case and move on. */
4874 else if (SCM_NUMBERP (n) && scm_is_true (scm_zero_p (n)))
4875 {
4876 /* k cannot be 0 at this point, because we
4877 have already checked for that case above */
4878 if (scm_is_true (scm_positive_p (k)))
4879 return n;
4880 else /* return NaN for (0 ^ k) for negative k per R6RS */
4881 return scm_nan ();
4882 }
4883 else if (SCM_FRACTIONP (n))
4884 {
4885 /* Optimize the fraction case by (a/b)^k ==> (a^k)/(b^k), to avoid
4886 needless reduction of intermediate products to lowest terms.
4887 If a and b have no common factors, then a^k and b^k have no
4888 common factors. Use 'scm_i_make_ratio_already_reduced' to
4889 construct the final result, so that no gcd computations are
4890 needed to exponentiate a fraction. */
4891 if (scm_is_true (scm_positive_p (k)))
4892 return scm_i_make_ratio_already_reduced
4893 (scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k),
4894 scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k));
4895 else
4896 {
4897 k = scm_difference (k, SCM_UNDEFINED);
4898 return scm_i_make_ratio_already_reduced
4899 (scm_integer_expt (SCM_FRACTION_DENOMINATOR (n), k),
4900 scm_integer_expt (SCM_FRACTION_NUMERATOR (n), k));
4901 }
4902 }
4903
4904 if (SCM_I_INUMP (k))
4905 i2 = SCM_I_INUM (k);
4906 else if (SCM_BIGP (k))
4907 {
4908 z_i2 = scm_i_clonebig (k, 1);
4909 scm_remember_upto_here_1 (k);
4910 i2_is_big = 1;
4911 }
4912 else
4913 SCM_WRONG_TYPE_ARG (2, k);
4914
4915 if (i2_is_big)
4916 {
4917 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
4918 {
4919 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
4920 n = scm_divide (n, SCM_UNDEFINED);
4921 }
4922 while (1)
4923 {
4924 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
4925 {
4926 return acc;
4927 }
4928 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
4929 {
4930 return scm_product (acc, n);
4931 }
4932 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
4933 acc = scm_product (acc, n);
4934 n = scm_product (n, n);
4935 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
4936 }
4937 }
4938 else
4939 {
4940 if (i2 < 0)
4941 {
4942 i2 = -i2;
4943 n = scm_divide (n, SCM_UNDEFINED);
4944 }
4945 while (1)
4946 {
4947 if (0 == i2)
4948 return acc;
4949 if (1 == i2)
4950 return scm_product (acc, n);
4951 if (i2 & 1)
4952 acc = scm_product (acc, n);
4953 n = scm_product (n, n);
4954 i2 >>= 1;
4955 }
4956 }
4957 }
4958 #undef FUNC_NAME
4959
4960 /* Efficiently compute (N * 2^COUNT),
4961 where N is an exact integer, and COUNT > 0. */
4962 static SCM
left_shift_exact_integer(SCM n,long count)4963 left_shift_exact_integer (SCM n, long count)
4964 {
4965 if (SCM_I_INUMP (n))
4966 {
4967 scm_t_inum nn = SCM_I_INUM (n);
4968
4969 /* Left shift of count >= SCM_I_FIXNUM_BIT-1 will almost[*] always
4970 overflow a non-zero fixnum. For smaller shifts we check the
4971 bits going into positions above SCM_I_FIXNUM_BIT-1. If they're
4972 all 0s for nn>=0, or all 1s for nn<0 then there's no overflow.
4973 Those bits are "nn >> (SCM_I_FIXNUM_BIT-1 - count)".
4974
4975 [*] There's one exception:
4976 (-1) << SCM_I_FIXNUM_BIT-1 == SCM_MOST_NEGATIVE_FIXNUM */
4977
4978 if (nn == 0)
4979 return n;
4980 else if (count < SCM_I_FIXNUM_BIT-1 &&
4981 ((scm_t_bits) (SCM_SRS (nn, (SCM_I_FIXNUM_BIT-1 - count)) + 1)
4982 <= 1))
4983 return SCM_I_MAKINUM (nn < 0 ? -(-nn << count) : (nn << count));
4984 else
4985 {
4986 SCM result = scm_i_inum2big (nn);
4987 mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
4988 count);
4989 return scm_i_normbig (result);
4990 }
4991 }
4992 else if (SCM_BIGP (n))
4993 {
4994 SCM result = scm_i_mkbig ();
4995 mpz_mul_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n), count);
4996 scm_remember_upto_here_1 (n);
4997 return result;
4998 }
4999 else
5000 assert (0);
5001 }
5002
5003 /* Efficiently compute floor (N / 2^COUNT),
5004 where N is an exact integer and COUNT > 0. */
5005 static SCM
floor_right_shift_exact_integer(SCM n,long count)5006 floor_right_shift_exact_integer (SCM n, long count)
5007 {
5008 if (SCM_I_INUMP (n))
5009 {
5010 scm_t_inum nn = SCM_I_INUM (n);
5011
5012 if (count >= SCM_I_FIXNUM_BIT)
5013 return (nn >= 0 ? SCM_INUM0 : SCM_I_MAKINUM (-1));
5014 else
5015 return SCM_I_MAKINUM (SCM_SRS (nn, count));
5016 }
5017 else if (SCM_BIGP (n))
5018 {
5019 SCM result = scm_i_mkbig ();
5020 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n),
5021 count);
5022 scm_remember_upto_here_1 (n);
5023 return scm_i_normbig (result);
5024 }
5025 else
5026 assert (0);
5027 }
5028
5029 /* Efficiently compute round (N / 2^COUNT),
5030 where N is an exact integer and COUNT > 0. */
5031 static SCM
round_right_shift_exact_integer(SCM n,long count)5032 round_right_shift_exact_integer (SCM n, long count)
5033 {
5034 if (SCM_I_INUMP (n))
5035 {
5036 if (count >= SCM_I_FIXNUM_BIT)
5037 return SCM_INUM0;
5038 else
5039 {
5040 scm_t_inum nn = SCM_I_INUM (n);
5041 scm_t_inum qq = SCM_SRS (nn, count);
5042
5043 if (0 == (nn & (1L << (count-1))))
5044 return SCM_I_MAKINUM (qq); /* round down */
5045 else if (nn & ((1L << (count-1)) - 1))
5046 return SCM_I_MAKINUM (qq + 1); /* round up */
5047 else
5048 return SCM_I_MAKINUM ((~1L) & (qq + 1)); /* round to even */
5049 }
5050 }
5051 else if (SCM_BIGP (n))
5052 {
5053 SCM q = scm_i_mkbig ();
5054
5055 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (n), count);
5056 if (mpz_tstbit (SCM_I_BIG_MPZ (n), count-1)
5057 && (mpz_odd_p (SCM_I_BIG_MPZ (q))
5058 || (mpz_scan1 (SCM_I_BIG_MPZ (n), 0) < count-1)))
5059 mpz_add_ui (SCM_I_BIG_MPZ (q), SCM_I_BIG_MPZ (q), 1);
5060 scm_remember_upto_here_1 (n);
5061 return scm_i_normbig (q);
5062 }
5063 else
5064 assert (0);
5065 }
5066
5067 /* 'scm_ash' and 'scm_round_ash' assume that fixnums fit within a long,
5068 and moreover that they can be negated without overflow. */
5069 verify (SCM_MOST_NEGATIVE_FIXNUM >= LONG_MIN + 1
5070 && SCM_MOST_POSITIVE_FIXNUM <= LONG_MAX);
5071
5072 SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
5073 (SCM n, SCM count),
5074 "Return @math{floor(@var{n} * 2^@var{count})}.\n"
5075 "@var{n} and @var{count} must be exact integers.\n"
5076 "\n"
5077 "With @var{n} viewed as an infinite-precision twos-complement\n"
5078 "integer, @code{ash} means a left shift introducing zero bits\n"
5079 "when @var{count} is positive, or a right shift dropping bits\n"
5080 "when @var{count} is negative. This is an ``arithmetic'' shift.\n"
5081 "\n"
5082 "@lisp\n"
5083 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
5084 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
5085 "\n"
5086 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
5087 "(ash -23 -2) @result{} -6\n"
5088 "@end lisp")
5089 #define FUNC_NAME s_scm_ash
5090 {
5091 if (SCM_I_INUMP (n) || SCM_BIGP (n))
5092 {
5093 long bits_to_shift;
5094
5095 if (SCM_I_INUMP (count)) /* fast path, not strictly needed */
5096 bits_to_shift = SCM_I_INUM (count);
5097 else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX))
5098 /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be
5099 negated without overflowing. */
5100 bits_to_shift = scm_to_long (count);
5101 else if (scm_is_false (scm_positive_p (scm_sum (scm_integer_length (n),
5102 count))))
5103 /* Huge right shift that eliminates all but the sign bit */
5104 return scm_is_false (scm_negative_p (n))
5105 ? SCM_INUM0 : SCM_I_MAKINUM (-1);
5106 else if (scm_is_true (scm_zero_p (n)))
5107 return SCM_INUM0;
5108 else
5109 scm_num_overflow ("ash");
5110
5111 if (bits_to_shift > 0)
5112 return left_shift_exact_integer (n, bits_to_shift);
5113 else if (SCM_LIKELY (bits_to_shift < 0))
5114 return floor_right_shift_exact_integer (n, -bits_to_shift);
5115 else
5116 return n;
5117 }
5118 else
5119 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
5120 }
5121 #undef FUNC_NAME
5122
5123 SCM_DEFINE (scm_round_ash, "round-ash", 2, 0, 0,
5124 (SCM n, SCM count),
5125 "Return @math{round(@var{n} * 2^@var{count})}.\n"
5126 "@var{n} and @var{count} must be exact integers.\n"
5127 "\n"
5128 "With @var{n} viewed as an infinite-precision twos-complement\n"
5129 "integer, @code{round-ash} means a left shift introducing zero\n"
5130 "bits when @var{count} is positive, or a right shift rounding\n"
5131 "to the nearest integer (with ties going to the nearest even\n"
5132 "integer) when @var{count} is negative. This is a rounded\n"
5133 "``arithmetic'' shift.\n"
5134 "\n"
5135 "@lisp\n"
5136 "(number->string (round-ash #b1 3) 2) @result{} \"1000\"\n"
5137 "(number->string (round-ash #b1010 -1) 2) @result{} \"101\"\n"
5138 "(number->string (round-ash #b1010 -2) 2) @result{} \"10\"\n"
5139 "(number->string (round-ash #b1011 -2) 2) @result{} \"11\"\n"
5140 "(number->string (round-ash #b1101 -2) 2) @result{} \"11\"\n"
5141 "(number->string (round-ash #b1110 -2) 2) @result{} \"100\"\n"
5142 "@end lisp")
5143 #define FUNC_NAME s_scm_round_ash
5144 {
5145 if (SCM_I_INUMP (n) || SCM_BIGP (n))
5146 {
5147 long bits_to_shift;
5148
5149 if (SCM_I_INUMP (count)) /* fast path, not strictly needed */
5150 bits_to_shift = SCM_I_INUM (count);
5151 else if (scm_is_signed_integer (count, LONG_MIN + 1, LONG_MAX))
5152 /* We exclude LONG_MIN to ensure that 'bits_to_shift' can be
5153 negated without overflowing. */
5154 bits_to_shift = scm_to_long (count);
5155 else if (scm_is_true (scm_negative_p (scm_sum (scm_integer_length (n),
5156 count)))
5157 || scm_is_true (scm_zero_p (n)))
5158 /* If N is zero, or the right shift count exceeds the integer
5159 length, the result is zero. */
5160 return SCM_INUM0;
5161 else
5162 scm_num_overflow ("round-ash");
5163
5164 if (bits_to_shift > 0)
5165 return left_shift_exact_integer (n, bits_to_shift);
5166 else if (SCM_LIKELY (bits_to_shift < 0))
5167 return round_right_shift_exact_integer (n, -bits_to_shift);
5168 else
5169 return n;
5170 }
5171 else
5172 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
5173 }
5174 #undef FUNC_NAME
5175
5176
5177 SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
5178 (SCM n, SCM start, SCM end),
5179 "Return the integer composed of the @var{start} (inclusive)\n"
5180 "through @var{end} (exclusive) bits of @var{n}. The\n"
5181 "@var{start}th bit becomes the 0-th bit in the result.\n"
5182 "\n"
5183 "@lisp\n"
5184 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
5185 " @result{} \"1010\"\n"
5186 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
5187 " @result{} \"10110\"\n"
5188 "@end lisp")
5189 #define FUNC_NAME s_scm_bit_extract
5190 {
5191 unsigned long int istart, iend, bits;
5192 istart = scm_to_ulong (start);
5193 iend = scm_to_ulong (end);
5194 SCM_ASSERT_RANGE (3, end, (iend >= istart));
5195
5196 /* how many bits to keep */
5197 bits = iend - istart;
5198
5199 if (SCM_I_INUMP (n))
5200 {
5201 scm_t_inum in = SCM_I_INUM (n);
5202
5203 /* When istart>=SCM_I_FIXNUM_BIT we can just limit the shift to
5204 SCM_I_FIXNUM_BIT-1 to get either 0 or -1 per the sign of "in". */
5205 in = SCM_SRS (in, min (istart, SCM_I_FIXNUM_BIT-1));
5206
5207 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
5208 {
5209 /* Since we emulate two's complement encoded numbers, this
5210 * special case requires us to produce a result that has
5211 * more bits than can be stored in a fixnum.
5212 */
5213 SCM result = scm_i_inum2big (in);
5214 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result),
5215 bits);
5216 return result;
5217 }
5218
5219 /* mask down to requisite bits */
5220 bits = min (bits, SCM_I_FIXNUM_BIT);
5221 return SCM_I_MAKINUM (in & ((1L << bits) - 1));
5222 }
5223 else if (SCM_BIGP (n))
5224 {
5225 SCM result;
5226 if (bits == 1)
5227 {
5228 result = SCM_I_MAKINUM (mpz_tstbit (SCM_I_BIG_MPZ (n), istart));
5229 }
5230 else
5231 {
5232 /* ENHANCE-ME: It'd be nice not to allocate a new bignum when
5233 bits<SCM_I_FIXNUM_BIT. Would want some help from GMP to get
5234 such bits into a ulong. */
5235 result = scm_i_mkbig ();
5236 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(n), istart);
5237 mpz_fdiv_r_2exp (SCM_I_BIG_MPZ(result), SCM_I_BIG_MPZ(result), bits);
5238 result = scm_i_normbig (result);
5239 }
5240 scm_remember_upto_here_1 (n);
5241 return result;
5242 }
5243 else
5244 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
5245 }
5246 #undef FUNC_NAME
5247
5248
5249 static const char scm_logtab[] = {
5250 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
5251 };
5252
5253 SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
5254 (SCM n),
5255 "Return the number of bits in integer @var{n}. If integer is\n"
5256 "positive, the 1-bits in its binary representation are counted.\n"
5257 "If negative, the 0-bits in its two's-complement binary\n"
5258 "representation are counted. If 0, 0 is returned.\n"
5259 "\n"
5260 "@lisp\n"
5261 "(logcount #b10101010)\n"
5262 " @result{} 4\n"
5263 "(logcount 0)\n"
5264 " @result{} 0\n"
5265 "(logcount -2)\n"
5266 " @result{} 1\n"
5267 "@end lisp")
5268 #define FUNC_NAME s_scm_logcount
5269 {
5270 if (SCM_I_INUMP (n))
5271 {
5272 unsigned long c = 0;
5273 scm_t_inum nn = SCM_I_INUM (n);
5274 if (nn < 0)
5275 nn = -1 - nn;
5276 while (nn)
5277 {
5278 c += scm_logtab[15 & nn];
5279 nn >>= 4;
5280 }
5281 return SCM_I_MAKINUM (c);
5282 }
5283 else if (SCM_BIGP (n))
5284 {
5285 unsigned long count;
5286 if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
5287 count = mpz_popcount (SCM_I_BIG_MPZ (n));
5288 else
5289 count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
5290 scm_remember_upto_here_1 (n);
5291 return SCM_I_MAKINUM (count);
5292 }
5293 else
5294 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
5295 }
5296 #undef FUNC_NAME
5297
5298
5299 static const char scm_ilentab[] = {
5300 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
5301 };
5302
5303
5304 SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
5305 (SCM n),
5306 "Return the number of bits necessary to represent @var{n}.\n"
5307 "\n"
5308 "@lisp\n"
5309 "(integer-length #b10101010)\n"
5310 " @result{} 8\n"
5311 "(integer-length 0)\n"
5312 " @result{} 0\n"
5313 "(integer-length #b1111)\n"
5314 " @result{} 4\n"
5315 "@end lisp")
5316 #define FUNC_NAME s_scm_integer_length
5317 {
5318 if (SCM_I_INUMP (n))
5319 {
5320 unsigned long c = 0;
5321 unsigned int l = 4;
5322 scm_t_inum nn = SCM_I_INUM (n);
5323 if (nn < 0)
5324 nn = -1 - nn;
5325 while (nn)
5326 {
5327 c += 4;
5328 l = scm_ilentab [15 & nn];
5329 nn >>= 4;
5330 }
5331 return SCM_I_MAKINUM (c - 4 + l);
5332 }
5333 else if (SCM_BIGP (n))
5334 {
5335 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
5336 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
5337 1 too big, so check for that and adjust. */
5338 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
5339 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
5340 && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
5341 mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
5342 size--;
5343 scm_remember_upto_here_1 (n);
5344 return SCM_I_MAKINUM (size);
5345 }
5346 else
5347 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
5348 }
5349 #undef FUNC_NAME
5350
5351 /*** NUMBERS -> STRINGS ***/
5352 #define SCM_MAX_DBL_RADIX 36
5353
5354 /* use this array as a way to generate a single digit */
5355 static const char number_chars[] = "0123456789abcdefghijklmnopqrstuvwxyz";
5356
5357 static mpz_t dbl_minimum_normal_mantissa;
5358
5359 static size_t
idbl2str(double dbl,char * a,int radix)5360 idbl2str (double dbl, char *a, int radix)
5361 {
5362 int ch = 0;
5363
5364 if (radix < 2 || radix > SCM_MAX_DBL_RADIX)
5365 /* revert to existing behavior */
5366 radix = 10;
5367
5368 if (isinf (dbl))
5369 {
5370 strcpy (a, (dbl > 0.0) ? "+inf.0" : "-inf.0");
5371 return 6;
5372 }
5373 else if (dbl > 0.0)
5374 ;
5375 else if (dbl < 0.0)
5376 {
5377 dbl = -dbl;
5378 a[ch++] = '-';
5379 }
5380 else if (dbl == 0.0)
5381 {
5382 if (copysign (1.0, dbl) < 0.0)
5383 a[ch++] = '-';
5384 strcpy (a + ch, "0.0");
5385 return ch + 3;
5386 }
5387 else if (isnan (dbl))
5388 {
5389 strcpy (a, "+nan.0");
5390 return 6;
5391 }
5392
5393 /* Algorithm taken from "Printing Floating-Point Numbers Quickly and
5394 Accurately" by Robert G. Burger and R. Kent Dybvig */
5395 {
5396 int e, k;
5397 mpz_t f, r, s, mplus, mminus, hi, digit;
5398 int f_is_even, f_is_odd;
5399 int expon;
5400 int show_exp = 0;
5401
5402 mpz_inits (f, r, s, mplus, mminus, hi, digit, NULL);
5403 mpz_set_d (f, ldexp (frexp (dbl, &e), DBL_MANT_DIG));
5404 if (e < DBL_MIN_EXP)
5405 {
5406 mpz_tdiv_q_2exp (f, f, DBL_MIN_EXP - e);
5407 e = DBL_MIN_EXP;
5408 }
5409 e -= DBL_MANT_DIG;
5410
5411 f_is_even = !mpz_odd_p (f);
5412 f_is_odd = !f_is_even;
5413
5414 /* Initialize r, s, mplus, and mminus according
5415 to Table 1 from the paper. */
5416 if (e < 0)
5417 {
5418 mpz_set_ui (mminus, 1);
5419 if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0
5420 || e == DBL_MIN_EXP - DBL_MANT_DIG)
5421 {
5422 mpz_set_ui (mplus, 1);
5423 mpz_mul_2exp (r, f, 1);
5424 mpz_mul_2exp (s, mminus, 1 - e);
5425 }
5426 else
5427 {
5428 mpz_set_ui (mplus, 2);
5429 mpz_mul_2exp (r, f, 2);
5430 mpz_mul_2exp (s, mminus, 2 - e);
5431 }
5432 }
5433 else
5434 {
5435 mpz_set_ui (mminus, 1);
5436 mpz_mul_2exp (mminus, mminus, e);
5437 if (mpz_cmp (f, dbl_minimum_normal_mantissa) != 0)
5438 {
5439 mpz_set (mplus, mminus);
5440 mpz_mul_2exp (r, f, 1 + e);
5441 mpz_set_ui (s, 2);
5442 }
5443 else
5444 {
5445 mpz_mul_2exp (mplus, mminus, 1);
5446 mpz_mul_2exp (r, f, 2 + e);
5447 mpz_set_ui (s, 4);
5448 }
5449 }
5450
5451 /* Find the smallest k such that:
5452 (r + mplus) / s < radix^k (if f is even)
5453 (r + mplus) / s <= radix^k (if f is odd) */
5454 {
5455 /* IMPROVE-ME: Make an initial guess to speed this up */
5456 mpz_add (hi, r, mplus);
5457 k = 0;
5458 while (mpz_cmp (hi, s) >= f_is_odd)
5459 {
5460 mpz_mul_ui (s, s, radix);
5461 k++;
5462 }
5463 if (k == 0)
5464 {
5465 mpz_mul_ui (hi, hi, radix);
5466 while (mpz_cmp (hi, s) < f_is_odd)
5467 {
5468 mpz_mul_ui (r, r, radix);
5469 mpz_mul_ui (mplus, mplus, radix);
5470 mpz_mul_ui (mminus, mminus, radix);
5471 mpz_mul_ui (hi, hi, radix);
5472 k--;
5473 }
5474 }
5475 }
5476
5477 expon = k - 1;
5478 if (k <= 0)
5479 {
5480 if (k <= -3)
5481 {
5482 /* Use scientific notation */
5483 show_exp = 1;
5484 k = 1;
5485 }
5486 else
5487 {
5488 int i;
5489
5490 /* Print leading zeroes */
5491 a[ch++] = '0';
5492 a[ch++] = '.';
5493 for (i = 0; i > k; i--)
5494 a[ch++] = '0';
5495 }
5496 }
5497
5498 for (;;)
5499 {
5500 int end_1_p, end_2_p;
5501 int d;
5502
5503 mpz_mul_ui (mplus, mplus, radix);
5504 mpz_mul_ui (mminus, mminus, radix);
5505 mpz_mul_ui (r, r, radix);
5506 mpz_fdiv_qr (digit, r, r, s);
5507 d = mpz_get_ui (digit);
5508
5509 mpz_add (hi, r, mplus);
5510 end_1_p = (mpz_cmp (r, mminus) < f_is_even);
5511 end_2_p = (mpz_cmp (s, hi) < f_is_even);
5512 if (end_1_p || end_2_p)
5513 {
5514 mpz_mul_2exp (r, r, 1);
5515 if (!end_2_p)
5516 ;
5517 else if (!end_1_p)
5518 d++;
5519 else if (mpz_cmp (r, s) >= !(d & 1))
5520 d++;
5521 a[ch++] = number_chars[d];
5522 if (--k == 0)
5523 a[ch++] = '.';
5524 break;
5525 }
5526 else
5527 {
5528 a[ch++] = number_chars[d];
5529 if (--k == 0)
5530 a[ch++] = '.';
5531 }
5532 }
5533
5534 if (k > 0)
5535 {
5536 if (expon >= 7 && k >= 4 && expon >= k)
5537 {
5538 /* Here we would have to print more than three zeroes
5539 followed by a decimal point and another zero. It
5540 makes more sense to use scientific notation. */
5541
5542 /* Adjust k to what it would have been if we had chosen
5543 scientific notation from the beginning. */
5544 k -= expon;
5545
5546 /* k will now be <= 0, with magnitude equal to the number of
5547 digits that we printed which should now be put after the
5548 decimal point. */
5549
5550 /* Insert a decimal point */
5551 memmove (a + ch + k + 1, a + ch + k, -k);
5552 a[ch + k] = '.';
5553 ch++;
5554
5555 show_exp = 1;
5556 }
5557 else
5558 {
5559 for (; k > 0; k--)
5560 a[ch++] = '0';
5561 a[ch++] = '.';
5562 }
5563 }
5564
5565 if (k == 0)
5566 a[ch++] = '0';
5567
5568 if (show_exp)
5569 {
5570 a[ch++] = 'e';
5571 ch += scm_iint2str (expon, radix, a + ch);
5572 }
5573
5574 mpz_clears (f, r, s, mplus, mminus, hi, digit, NULL);
5575 }
5576 return ch;
5577 }
5578
5579
5580 static size_t
icmplx2str(double real,double imag,char * str,int radix)5581 icmplx2str (double real, double imag, char *str, int radix)
5582 {
5583 size_t i;
5584 double sgn;
5585
5586 i = idbl2str (real, str, radix);
5587 #ifdef HAVE_COPYSIGN
5588 sgn = copysign (1.0, imag);
5589 #else
5590 sgn = imag;
5591 #endif
5592 /* Don't output a '+' for negative numbers or for Inf and
5593 NaN. They will provide their own sign. */
5594 if (sgn >= 0 && isfinite (imag))
5595 str[i++] = '+';
5596 i += idbl2str (imag, &str[i], radix);
5597 str[i++] = 'i';
5598 return i;
5599 }
5600
5601 static size_t
iflo2str(SCM flt,char * str,int radix)5602 iflo2str (SCM flt, char *str, int radix)
5603 {
5604 size_t i;
5605 if (SCM_REALP (flt))
5606 i = idbl2str (SCM_REAL_VALUE (flt), str, radix);
5607 else
5608 i = icmplx2str (SCM_COMPLEX_REAL (flt), SCM_COMPLEX_IMAG (flt),
5609 str, radix);
5610 return i;
5611 }
5612
5613 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5614 characters in the result.
5615 rad is output base
5616 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5617 size_t
scm_iint2str(scm_t_intmax num,int rad,char * p)5618 scm_iint2str (scm_t_intmax num, int rad, char *p)
5619 {
5620 if (num < 0)
5621 {
5622 *p++ = '-';
5623 return scm_iuint2str (-num, rad, p) + 1;
5624 }
5625 else
5626 return scm_iuint2str (num, rad, p);
5627 }
5628
5629 /* convert a scm_t_intmax to a string (unterminated). returns the number of
5630 characters in the result.
5631 rad is output base
5632 p is destination: worst case (base 2) is SCM_INTBUFLEN */
5633 size_t
scm_iuint2str(scm_t_uintmax num,int rad,char * p)5634 scm_iuint2str (scm_t_uintmax num, int rad, char *p)
5635 {
5636 size_t j = 1;
5637 size_t i;
5638 scm_t_uintmax n = num;
5639
5640 if (rad < 2 || rad > 36)
5641 scm_out_of_range ("scm_iuint2str", scm_from_int (rad));
5642
5643 for (n /= rad; n > 0; n /= rad)
5644 j++;
5645
5646 i = j;
5647 n = num;
5648 while (i--)
5649 {
5650 int d = n % rad;
5651
5652 n /= rad;
5653 p[i] = number_chars[d];
5654 }
5655 return j;
5656 }
5657
5658 SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
5659 (SCM n, SCM radix),
5660 "Return a string holding the external representation of the\n"
5661 "number @var{n} in the given @var{radix}. If @var{n} is\n"
5662 "inexact, a radix of 10 will be used.")
5663 #define FUNC_NAME s_scm_number_to_string
5664 {
5665 int base;
5666
5667 if (SCM_UNBNDP (radix))
5668 base = 10;
5669 else
5670 base = scm_to_signed_integer (radix, 2, 36);
5671
5672 if (SCM_I_INUMP (n))
5673 {
5674 char num_buf [SCM_INTBUFLEN];
5675 size_t length = scm_iint2str (SCM_I_INUM (n), base, num_buf);
5676 return scm_from_latin1_stringn (num_buf, length);
5677 }
5678 else if (SCM_BIGP (n))
5679 {
5680 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
5681 size_t len = strlen (str);
5682 void (*freefunc) (void *, size_t);
5683 SCM ret;
5684 mp_get_memory_functions (NULL, NULL, &freefunc);
5685 scm_remember_upto_here_1 (n);
5686 ret = scm_from_latin1_stringn (str, len);
5687 freefunc (str, len + 1);
5688 return ret;
5689 }
5690 else if (SCM_FRACTIONP (n))
5691 {
5692 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
5693 scm_from_latin1_string ("/"),
5694 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
5695 }
5696 else if (SCM_INEXACTP (n))
5697 {
5698 char num_buf [FLOBUFLEN];
5699 return scm_from_latin1_stringn (num_buf, iflo2str (n, num_buf, base));
5700 }
5701 else
5702 SCM_WRONG_TYPE_ARG (1, n);
5703 }
5704 #undef FUNC_NAME
5705
5706
5707 /* These print routines used to be stubbed here so that scm_repl.c
5708 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
5709
5710 int
scm_print_real(SCM sexp,SCM port,scm_print_state * pstate SCM_UNUSED)5711 scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
5712 {
5713 char num_buf[FLOBUFLEN];
5714 scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
5715 return !0;
5716 }
5717
5718 void
scm_i_print_double(double val,SCM port)5719 scm_i_print_double (double val, SCM port)
5720 {
5721 char num_buf[FLOBUFLEN];
5722 scm_lfwrite (num_buf, idbl2str (val, num_buf, 10), port);
5723 }
5724
5725 int
scm_print_complex(SCM sexp,SCM port,scm_print_state * pstate SCM_UNUSED)5726 scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
5727
5728 {
5729 char num_buf[FLOBUFLEN];
5730 scm_lfwrite (num_buf, iflo2str (sexp, num_buf, 10), port);
5731 return !0;
5732 }
5733
5734 void
scm_i_print_complex(double real,double imag,SCM port)5735 scm_i_print_complex (double real, double imag, SCM port)
5736 {
5737 char num_buf[FLOBUFLEN];
5738 scm_lfwrite (num_buf, icmplx2str (real, imag, num_buf, 10), port);
5739 }
5740
5741 int
scm_i_print_fraction(SCM sexp,SCM port,scm_print_state * pstate SCM_UNUSED)5742 scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
5743 {
5744 SCM str;
5745 str = scm_number_to_string (sexp, SCM_UNDEFINED);
5746 scm_display (str, port);
5747 scm_remember_upto_here_1 (str);
5748 return !0;
5749 }
5750
5751 int
scm_bigprint(SCM exp,SCM port,scm_print_state * pstate SCM_UNUSED)5752 scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
5753 {
5754 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
5755 size_t len = strlen (str);
5756 void (*freefunc) (void *, size_t);
5757 mp_get_memory_functions (NULL, NULL, &freefunc);
5758 scm_remember_upto_here_1 (exp);
5759 scm_lfwrite (str, len, port);
5760 freefunc (str, len + 1);
5761 return !0;
5762 }
5763 /*** END nums->strs ***/
5764
5765
5766 /*** STRINGS -> NUMBERS ***/
5767
5768 /* The following functions implement the conversion from strings to numbers.
5769 * The implementation somehow follows the grammar for numbers as it is given
5770 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
5771 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
5772 * points should be noted about the implementation:
5773 *
5774 * * Each function keeps a local index variable 'idx' that points at the
5775 * current position within the parsed string. The global index is only
5776 * updated if the function could parse the corresponding syntactic unit
5777 * successfully.
5778 *
5779 * * Similarly, the functions keep track of indicators of inexactness ('#',
5780 * '.' or exponents) using local variables ('hash_seen', 'x').
5781 *
5782 * * Sequences of digits are parsed into temporary variables holding fixnums.
5783 * Only if these fixnums would overflow, the result variables are updated
5784 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
5785 * the temporary variables holding the fixnums are cleared, and the process
5786 * starts over again. If for example fixnums were able to store five decimal
5787 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
5788 * and the result was computed as 12345 * 100000 + 67890. In other words,
5789 * only every five digits two bignum operations were performed.
5790 *
5791 * Notes on the handling of exactness specifiers:
5792 *
5793 * When parsing non-real complex numbers, we apply exactness specifiers on
5794 * per-component basis, as is done in PLT Scheme. For complex numbers
5795 * written in rectangular form, exactness specifiers are applied to the
5796 * real and imaginary parts before calling scm_make_rectangular. For
5797 * complex numbers written in polar form, exactness specifiers are applied
5798 * to the magnitude and angle before calling scm_make_polar.
5799 *
5800 * There are two kinds of exactness specifiers: forced and implicit. A
5801 * forced exactness specifier is a "#e" or "#i" prefix at the beginning of
5802 * the entire number, and applies to both components of a complex number.
5803 * "#e" causes each component to be made exact, and "#i" causes each
5804 * component to be made inexact. If no forced exactness specifier is
5805 * present, then the exactness of each component is determined
5806 * independently by the presence or absence of a decimal point or hash mark
5807 * within that component. If a decimal point or hash mark is present, the
5808 * component is made inexact, otherwise it is made exact.
5809 *
5810 * After the exactness specifiers have been applied to each component, they
5811 * are passed to either scm_make_rectangular or scm_make_polar to produce
5812 * the final result. Note that this will result in a real number if the
5813 * imaginary part, magnitude, or angle is an exact 0.
5814 *
5815 * For example, (string->number "#i5.0+0i") does the equivalent of:
5816 *
5817 * (make-rectangular (exact->inexact 5) (exact->inexact 0))
5818 */
5819
5820 enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
5821
5822 /* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
5823
5824 /* Caller is responsible for checking that the return value is in range
5825 for the given radix, which should be <= 36. */
5826 static unsigned int
char_decimal_value(scm_t_uint32 c)5827 char_decimal_value (scm_t_uint32 c)
5828 {
5829 if (c >= (scm_t_uint32) '0' && c <= (scm_t_uint32) '9')
5830 return c - (scm_t_uint32) '0';
5831 else
5832 {
5833 /* uc_decimal_value returns -1 on error. When cast to an unsigned int,
5834 that's certainly above any valid decimal, so we take advantage of
5835 that to elide some tests. */
5836 unsigned int d = (unsigned int) uc_decimal_value (c);
5837
5838 /* If that failed, try extended hexadecimals, then. Only accept ascii
5839 hexadecimals. */
5840 if (d >= 10U)
5841 {
5842 c = uc_tolower (c);
5843 if (c >= (scm_t_uint32) 'a')
5844 d = c - (scm_t_uint32)'a' + 10U;
5845 }
5846 return d;
5847 }
5848 }
5849
5850 /* Parse the substring of MEM starting at *P_IDX for an unsigned integer
5851 in base RADIX. Upon success, return the unsigned integer and update
5852 *P_IDX and *P_EXACTNESS accordingly. Return #f on failure. */
5853 static SCM
mem2uinteger(SCM mem,unsigned int * p_idx,unsigned int radix,enum t_exactness * p_exactness)5854 mem2uinteger (SCM mem, unsigned int *p_idx,
5855 unsigned int radix, enum t_exactness *p_exactness)
5856 {
5857 unsigned int idx = *p_idx;
5858 unsigned int hash_seen = 0;
5859 scm_t_bits shift = 1;
5860 scm_t_bits add = 0;
5861 unsigned int digit_value;
5862 SCM result;
5863 char c;
5864 size_t len = scm_i_string_length (mem);
5865
5866 if (idx == len)
5867 return SCM_BOOL_F;
5868
5869 c = scm_i_string_ref (mem, idx);
5870 digit_value = char_decimal_value (c);
5871 if (digit_value >= radix)
5872 return SCM_BOOL_F;
5873
5874 idx++;
5875 result = SCM_I_MAKINUM (digit_value);
5876 while (idx != len)
5877 {
5878 scm_t_wchar c = scm_i_string_ref (mem, idx);
5879 if (c == '#')
5880 {
5881 hash_seen = 1;
5882 digit_value = 0;
5883 }
5884 else if (hash_seen)
5885 break;
5886 else
5887 {
5888 digit_value = char_decimal_value (c);
5889 /* This check catches non-decimals in addition to out-of-range
5890 decimals. */
5891 if (digit_value >= radix)
5892 break;
5893 }
5894
5895 idx++;
5896 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
5897 {
5898 result = scm_product (result, SCM_I_MAKINUM (shift));
5899 if (add > 0)
5900 result = scm_sum (result, SCM_I_MAKINUM (add));
5901
5902 shift = radix;
5903 add = digit_value;
5904 }
5905 else
5906 {
5907 shift = shift * radix;
5908 add = add * radix + digit_value;
5909 }
5910 };
5911
5912 if (shift > 1)
5913 result = scm_product (result, SCM_I_MAKINUM (shift));
5914 if (add > 0)
5915 result = scm_sum (result, SCM_I_MAKINUM (add));
5916
5917 *p_idx = idx;
5918 if (hash_seen)
5919 *p_exactness = INEXACT;
5920
5921 return result;
5922 }
5923
5924
5925 /* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
5926 * covers the parts of the rules that start at a potential point. The value
5927 * of the digits up to the point have been parsed by the caller and are given
5928 * in variable result. The content of *p_exactness indicates, whether a hash
5929 * has already been seen in the digits before the point.
5930 */
5931
5932 #define DIGIT2UINT(d) (uc_numeric_value(d).numerator)
5933
5934 static SCM
mem2decimal_from_point(SCM result,SCM mem,unsigned int * p_idx,enum t_exactness * p_exactness)5935 mem2decimal_from_point (SCM result, SCM mem,
5936 unsigned int *p_idx, enum t_exactness *p_exactness)
5937 {
5938 unsigned int idx = *p_idx;
5939 enum t_exactness x = *p_exactness;
5940 size_t len = scm_i_string_length (mem);
5941
5942 if (idx == len)
5943 return result;
5944
5945 if (scm_i_string_ref (mem, idx) == '.')
5946 {
5947 scm_t_bits shift = 1;
5948 scm_t_bits add = 0;
5949 unsigned int digit_value;
5950 SCM big_shift = SCM_INUM1;
5951
5952 idx++;
5953 while (idx != len)
5954 {
5955 scm_t_wchar c = scm_i_string_ref (mem, idx);
5956 if (uc_is_property_decimal_digit ((scm_t_uint32) c))
5957 {
5958 if (x == INEXACT)
5959 return SCM_BOOL_F;
5960 else
5961 digit_value = DIGIT2UINT (c);
5962 }
5963 else if (c == '#')
5964 {
5965 x = INEXACT;
5966 digit_value = 0;
5967 }
5968 else
5969 break;
5970
5971 idx++;
5972 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
5973 {
5974 big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
5975 result = scm_product (result, SCM_I_MAKINUM (shift));
5976 if (add > 0)
5977 result = scm_sum (result, SCM_I_MAKINUM (add));
5978
5979 shift = 10;
5980 add = digit_value;
5981 }
5982 else
5983 {
5984 shift = shift * 10;
5985 add = add * 10 + digit_value;
5986 }
5987 };
5988
5989 if (add > 0)
5990 {
5991 big_shift = scm_product (big_shift, SCM_I_MAKINUM (shift));
5992 result = scm_product (result, SCM_I_MAKINUM (shift));
5993 result = scm_sum (result, SCM_I_MAKINUM (add));
5994 }
5995
5996 result = scm_divide (result, big_shift);
5997
5998 /* We've seen a decimal point, thus the value is implicitly inexact. */
5999 x = INEXACT;
6000 }
6001
6002 if (idx != len)
6003 {
6004 int sign = 1;
6005 unsigned int start;
6006 scm_t_wchar c;
6007 int exponent;
6008 SCM e;
6009
6010 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
6011
6012 switch (scm_i_string_ref (mem, idx))
6013 {
6014 case 'd': case 'D':
6015 case 'e': case 'E':
6016 case 'f': case 'F':
6017 case 'l': case 'L':
6018 case 's': case 'S':
6019 idx++;
6020 if (idx == len)
6021 return SCM_BOOL_F;
6022
6023 start = idx;
6024 c = scm_i_string_ref (mem, idx);
6025 if (c == '-')
6026 {
6027 idx++;
6028 if (idx == len)
6029 return SCM_BOOL_F;
6030
6031 sign = -1;
6032 c = scm_i_string_ref (mem, idx);
6033 }
6034 else if (c == '+')
6035 {
6036 idx++;
6037 if (idx == len)
6038 return SCM_BOOL_F;
6039
6040 sign = 1;
6041 c = scm_i_string_ref (mem, idx);
6042 }
6043 else
6044 sign = 1;
6045
6046 if (!uc_is_property_decimal_digit ((scm_t_uint32) c))
6047 return SCM_BOOL_F;
6048
6049 idx++;
6050 exponent = DIGIT2UINT (c);
6051 while (idx != len)
6052 {
6053 scm_t_wchar c = scm_i_string_ref (mem, idx);
6054 if (uc_is_property_decimal_digit ((scm_t_uint32) c))
6055 {
6056 idx++;
6057 if (exponent <= SCM_MAXEXP)
6058 exponent = exponent * 10 + DIGIT2UINT (c);
6059 }
6060 else
6061 break;
6062 }
6063
6064 if (exponent > ((sign == 1) ? SCM_MAXEXP : SCM_MAXEXP + DBL_DIG + 1))
6065 {
6066 size_t exp_len = idx - start;
6067 SCM exp_string = scm_i_substring_copy (mem, start, start + exp_len);
6068 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
6069 scm_out_of_range ("string->number", exp_num);
6070 }
6071
6072 e = scm_integer_expt (SCM_I_MAKINUM (10), SCM_I_MAKINUM (exponent));
6073 if (sign == 1)
6074 result = scm_product (result, e);
6075 else
6076 result = scm_divide (result, e);
6077
6078 /* We've seen an exponent, thus the value is implicitly inexact. */
6079 x = INEXACT;
6080
6081 break;
6082
6083 default:
6084 break;
6085 }
6086 }
6087
6088 *p_idx = idx;
6089 if (x == INEXACT)
6090 *p_exactness = x;
6091
6092 return result;
6093 }
6094
6095
6096 /* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
6097
6098 static SCM
mem2ureal(SCM mem,unsigned int * p_idx,unsigned int radix,enum t_exactness forced_x,int allow_inf_or_nan)6099 mem2ureal (SCM mem, unsigned int *p_idx,
6100 unsigned int radix, enum t_exactness forced_x,
6101 int allow_inf_or_nan)
6102 {
6103 unsigned int idx = *p_idx;
6104 SCM result;
6105 size_t len = scm_i_string_length (mem);
6106
6107 /* Start off believing that the number will be exact. This changes
6108 to INEXACT if we see a decimal point or a hash. */
6109 enum t_exactness implicit_x = EXACT;
6110
6111 if (idx == len)
6112 return SCM_BOOL_F;
6113
6114 if (allow_inf_or_nan && forced_x != EXACT && idx+5 <= len)
6115 switch (scm_i_string_ref (mem, idx))
6116 {
6117 case 'i': case 'I':
6118 switch (scm_i_string_ref (mem, idx + 1))
6119 {
6120 case 'n': case 'N':
6121 switch (scm_i_string_ref (mem, idx + 2))
6122 {
6123 case 'f': case 'F':
6124 if (scm_i_string_ref (mem, idx + 3) == '.'
6125 && scm_i_string_ref (mem, idx + 4) == '0')
6126 {
6127 *p_idx = idx+5;
6128 return scm_inf ();
6129 }
6130 }
6131 }
6132 case 'n': case 'N':
6133 switch (scm_i_string_ref (mem, idx + 1))
6134 {
6135 case 'a': case 'A':
6136 switch (scm_i_string_ref (mem, idx + 2))
6137 {
6138 case 'n': case 'N':
6139 if (scm_i_string_ref (mem, idx + 3) == '.')
6140 {
6141 /* Cobble up the fractional part. We might want to
6142 set the NaN's mantissa from it. */
6143 idx += 4;
6144 if (!scm_is_eq (mem2uinteger (mem, &idx, 10, &implicit_x),
6145 SCM_INUM0))
6146 {
6147 #if SCM_ENABLE_DEPRECATED == 1
6148 scm_c_issue_deprecation_warning
6149 ("Non-zero suffixes to `+nan.' are deprecated. Use `+nan.0'.");
6150 #else
6151 return SCM_BOOL_F;
6152 #endif
6153 }
6154
6155 *p_idx = idx;
6156 return scm_nan ();
6157 }
6158 }
6159 }
6160 }
6161
6162 if (scm_i_string_ref (mem, idx) == '.')
6163 {
6164 if (radix != 10)
6165 return SCM_BOOL_F;
6166 else if (idx + 1 == len)
6167 return SCM_BOOL_F;
6168 else if (!uc_is_property_decimal_digit ((scm_t_uint32) scm_i_string_ref (mem, idx+1)))
6169 return SCM_BOOL_F;
6170 else
6171 result = mem2decimal_from_point (SCM_INUM0, mem,
6172 p_idx, &implicit_x);
6173 }
6174 else
6175 {
6176 SCM uinteger;
6177
6178 uinteger = mem2uinteger (mem, &idx, radix, &implicit_x);
6179 if (scm_is_false (uinteger))
6180 return SCM_BOOL_F;
6181
6182 if (idx == len)
6183 result = uinteger;
6184 else if (scm_i_string_ref (mem, idx) == '/')
6185 {
6186 SCM divisor;
6187
6188 idx++;
6189 if (idx == len)
6190 return SCM_BOOL_F;
6191
6192 divisor = mem2uinteger (mem, &idx, radix, &implicit_x);
6193 if (scm_is_false (divisor) || scm_is_eq (divisor, SCM_INUM0))
6194 return SCM_BOOL_F;
6195
6196 /* both are int/big here, I assume */
6197 result = scm_i_make_ratio (uinteger, divisor);
6198 }
6199 else if (radix == 10)
6200 {
6201 result = mem2decimal_from_point (uinteger, mem, &idx, &implicit_x);
6202 if (scm_is_false (result))
6203 return SCM_BOOL_F;
6204 }
6205 else
6206 result = uinteger;
6207
6208 *p_idx = idx;
6209 }
6210
6211 switch (forced_x)
6212 {
6213 case EXACT:
6214 if (SCM_INEXACTP (result))
6215 return scm_inexact_to_exact (result);
6216 else
6217 return result;
6218 case INEXACT:
6219 if (SCM_INEXACTP (result))
6220 return result;
6221 else
6222 return scm_exact_to_inexact (result);
6223 case NO_EXACTNESS:
6224 if (implicit_x == INEXACT)
6225 {
6226 if (SCM_INEXACTP (result))
6227 return result;
6228 else
6229 return scm_exact_to_inexact (result);
6230 }
6231 else
6232 return result;
6233 }
6234
6235 /* We should never get here */
6236 assert (0);
6237 }
6238
6239
6240 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6241
6242 static SCM
mem2complex(SCM mem,unsigned int idx,unsigned int radix,enum t_exactness forced_x)6243 mem2complex (SCM mem, unsigned int idx,
6244 unsigned int radix, enum t_exactness forced_x)
6245 {
6246 scm_t_wchar c;
6247 int sign = 0;
6248 SCM ureal;
6249 size_t len = scm_i_string_length (mem);
6250
6251 if (idx == len)
6252 return SCM_BOOL_F;
6253
6254 c = scm_i_string_ref (mem, idx);
6255 if (c == '+')
6256 {
6257 idx++;
6258 sign = 1;
6259 }
6260 else if (c == '-')
6261 {
6262 idx++;
6263 sign = -1;
6264 }
6265
6266 if (idx == len)
6267 return SCM_BOOL_F;
6268
6269 ureal = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
6270 if (scm_is_false (ureal))
6271 {
6272 /* input must be either +i or -i */
6273
6274 if (sign == 0)
6275 return SCM_BOOL_F;
6276
6277 if (scm_i_string_ref (mem, idx) == 'i'
6278 || scm_i_string_ref (mem, idx) == 'I')
6279 {
6280 idx++;
6281 if (idx != len)
6282 return SCM_BOOL_F;
6283
6284 return scm_make_rectangular (SCM_INUM0, SCM_I_MAKINUM (sign));
6285 }
6286 else
6287 return SCM_BOOL_F;
6288 }
6289 else
6290 {
6291 if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
6292 ureal = scm_difference (ureal, SCM_UNDEFINED);
6293
6294 if (idx == len)
6295 return ureal;
6296
6297 c = scm_i_string_ref (mem, idx);
6298 switch (c)
6299 {
6300 case 'i': case 'I':
6301 /* either +<ureal>i or -<ureal>i */
6302
6303 idx++;
6304 if (sign == 0)
6305 return SCM_BOOL_F;
6306 if (idx != len)
6307 return SCM_BOOL_F;
6308 return scm_make_rectangular (SCM_INUM0, ureal);
6309
6310 case '@':
6311 /* polar input: <real>@<real>. */
6312
6313 idx++;
6314 if (idx == len)
6315 return SCM_BOOL_F;
6316 else
6317 {
6318 int sign;
6319 SCM angle;
6320 SCM result;
6321
6322 c = scm_i_string_ref (mem, idx);
6323 if (c == '+')
6324 {
6325 idx++;
6326 if (idx == len)
6327 return SCM_BOOL_F;
6328 sign = 1;
6329 }
6330 else if (c == '-')
6331 {
6332 idx++;
6333 if (idx == len)
6334 return SCM_BOOL_F;
6335 sign = -1;
6336 }
6337 else
6338 sign = 0;
6339
6340 angle = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
6341 if (scm_is_false (angle))
6342 return SCM_BOOL_F;
6343 if (idx != len)
6344 return SCM_BOOL_F;
6345
6346 if (sign == -1 && scm_is_false (scm_nan_p (ureal)))
6347 angle = scm_difference (angle, SCM_UNDEFINED);
6348
6349 result = scm_make_polar (ureal, angle);
6350 return result;
6351 }
6352 case '+':
6353 case '-':
6354 /* expecting input matching <real>[+-]<ureal>?i */
6355
6356 idx++;
6357 if (idx == len)
6358 return SCM_BOOL_F;
6359 else
6360 {
6361 int sign = (c == '+') ? 1 : -1;
6362 SCM imag = mem2ureal (mem, &idx, radix, forced_x, sign != 0);
6363
6364 if (scm_is_false (imag))
6365 imag = SCM_I_MAKINUM (sign);
6366 else if (sign == -1 && scm_is_false (scm_nan_p (imag)))
6367 imag = scm_difference (imag, SCM_UNDEFINED);
6368
6369 if (idx == len)
6370 return SCM_BOOL_F;
6371 if (scm_i_string_ref (mem, idx) != 'i'
6372 && scm_i_string_ref (mem, idx) != 'I')
6373 return SCM_BOOL_F;
6374
6375 idx++;
6376 if (idx != len)
6377 return SCM_BOOL_F;
6378
6379 return scm_make_rectangular (ureal, imag);
6380 }
6381 default:
6382 return SCM_BOOL_F;
6383 }
6384 }
6385 }
6386
6387
6388 /* R5RS, section 7.1.1, lexical structure of numbers: <number> */
6389
6390 enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
6391
6392 SCM
scm_i_string_to_number(SCM mem,unsigned int default_radix)6393 scm_i_string_to_number (SCM mem, unsigned int default_radix)
6394 {
6395 unsigned int idx = 0;
6396 unsigned int radix = NO_RADIX;
6397 enum t_exactness forced_x = NO_EXACTNESS;
6398 size_t len = scm_i_string_length (mem);
6399
6400 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
6401 while (idx + 2 < len && scm_i_string_ref (mem, idx) == '#')
6402 {
6403 switch (scm_i_string_ref (mem, idx + 1))
6404 {
6405 case 'b': case 'B':
6406 if (radix != NO_RADIX)
6407 return SCM_BOOL_F;
6408 radix = DUAL;
6409 break;
6410 case 'd': case 'D':
6411 if (radix != NO_RADIX)
6412 return SCM_BOOL_F;
6413 radix = DEC;
6414 break;
6415 case 'i': case 'I':
6416 if (forced_x != NO_EXACTNESS)
6417 return SCM_BOOL_F;
6418 forced_x = INEXACT;
6419 break;
6420 case 'e': case 'E':
6421 if (forced_x != NO_EXACTNESS)
6422 return SCM_BOOL_F;
6423 forced_x = EXACT;
6424 break;
6425 case 'o': case 'O':
6426 if (radix != NO_RADIX)
6427 return SCM_BOOL_F;
6428 radix = OCT;
6429 break;
6430 case 'x': case 'X':
6431 if (radix != NO_RADIX)
6432 return SCM_BOOL_F;
6433 radix = HEX;
6434 break;
6435 default:
6436 return SCM_BOOL_F;
6437 }
6438 idx += 2;
6439 }
6440
6441 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
6442 if (radix == NO_RADIX)
6443 radix = default_radix;
6444
6445 return mem2complex (mem, idx, radix, forced_x);
6446 }
6447
6448 SCM
scm_c_locale_stringn_to_number(const char * mem,size_t len,unsigned int default_radix)6449 scm_c_locale_stringn_to_number (const char* mem, size_t len,
6450 unsigned int default_radix)
6451 {
6452 SCM str = scm_from_locale_stringn (mem, len);
6453
6454 return scm_i_string_to_number (str, default_radix);
6455 }
6456
6457
6458 SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
6459 (SCM string, SCM radix),
6460 "Return a number of the maximally precise representation\n"
6461 "expressed by the given @var{string}. @var{radix} must be an\n"
6462 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
6463 "is a default radix that may be overridden by an explicit radix\n"
6464 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
6465 "supplied, then the default radix is 10. If string is not a\n"
6466 "syntactically valid notation for a number, then\n"
6467 "@code{string->number} returns @code{#f}.")
6468 #define FUNC_NAME s_scm_string_to_number
6469 {
6470 SCM answer;
6471 unsigned int base;
6472 SCM_VALIDATE_STRING (1, string);
6473
6474 if (SCM_UNBNDP (radix))
6475 base = 10;
6476 else
6477 base = scm_to_unsigned_integer (radix, 2, INT_MAX);
6478
6479 answer = scm_i_string_to_number (string, base);
6480 scm_remember_upto_here_1 (string);
6481 return answer;
6482 }
6483 #undef FUNC_NAME
6484
6485
6486 /*** END strs->nums ***/
6487
6488
6489 SCM_DEFINE (scm_number_p, "number?", 1, 0, 0,
6490 (SCM x),
6491 "Return @code{#t} if @var{x} is a number, @code{#f}\n"
6492 "otherwise.")
6493 #define FUNC_NAME s_scm_number_p
6494 {
6495 return scm_from_bool (SCM_NUMBERP (x));
6496 }
6497 #undef FUNC_NAME
6498
6499 SCM_DEFINE (scm_complex_p, "complex?", 1, 0, 0,
6500 (SCM x),
6501 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
6502 "otherwise. Note that the sets of real, rational and integer\n"
6503 "values form subsets of the set of complex numbers, i. e. the\n"
6504 "predicate will also be fulfilled if @var{x} is a real,\n"
6505 "rational or integer number.")
6506 #define FUNC_NAME s_scm_complex_p
6507 {
6508 /* all numbers are complex. */
6509 return scm_number_p (x);
6510 }
6511 #undef FUNC_NAME
6512
6513 SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
6514 (SCM x),
6515 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
6516 "otherwise. Note that the set of integer values forms a subset of\n"
6517 "the set of real numbers, i. e. the predicate will also be\n"
6518 "fulfilled if @var{x} is an integer number.")
6519 #define FUNC_NAME s_scm_real_p
6520 {
6521 return scm_from_bool
6522 (SCM_I_INUMP (x) || SCM_REALP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x));
6523 }
6524 #undef FUNC_NAME
6525
6526 SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
6527 (SCM x),
6528 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
6529 "otherwise. Note that the set of integer values forms a subset of\n"
6530 "the set of rational numbers, i. e. the predicate will also be\n"
6531 "fulfilled if @var{x} is an integer number.")
6532 #define FUNC_NAME s_scm_rational_p
6533 {
6534 if (SCM_I_INUMP (x) || SCM_BIGP (x) || SCM_FRACTIONP (x))
6535 return SCM_BOOL_T;
6536 else if (SCM_REALP (x))
6537 /* due to their limited precision, finite floating point numbers are
6538 rational as well. (finite means neither infinity nor a NaN) */
6539 return scm_from_bool (isfinite (SCM_REAL_VALUE (x)));
6540 else
6541 return SCM_BOOL_F;
6542 }
6543 #undef FUNC_NAME
6544
6545 SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
6546 (SCM x),
6547 "Return @code{#t} if @var{x} is an integer number,\n"
6548 "else return @code{#f}.")
6549 #define FUNC_NAME s_scm_integer_p
6550 {
6551 if (SCM_I_INUMP (x) || SCM_BIGP (x))
6552 return SCM_BOOL_T;
6553 else if (SCM_REALP (x))
6554 {
6555 double val = SCM_REAL_VALUE (x);
6556 return scm_from_bool (!isinf (val) && (val == floor (val)));
6557 }
6558 else
6559 return SCM_BOOL_F;
6560 }
6561 #undef FUNC_NAME
6562
6563 SCM_DEFINE (scm_exact_integer_p, "exact-integer?", 1, 0, 0,
6564 (SCM x),
6565 "Return @code{#t} if @var{x} is an exact integer number,\n"
6566 "else return @code{#f}.")
6567 #define FUNC_NAME s_scm_exact_integer_p
6568 {
6569 if (SCM_I_INUMP (x) || SCM_BIGP (x))
6570 return SCM_BOOL_T;
6571 else
6572 return SCM_BOOL_F;
6573 }
6574 #undef FUNC_NAME
6575
6576
6577 SCM scm_i_num_eq_p (SCM, SCM, SCM);
6578 SCM_PRIMITIVE_GENERIC (scm_i_num_eq_p, "=", 0, 2, 1,
6579 (SCM x, SCM y, SCM rest),
6580 "Return @code{#t} if all parameters are numerically equal.")
6581 #define FUNC_NAME s_scm_i_num_eq_p
6582 {
6583 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6584 return SCM_BOOL_T;
6585 while (!scm_is_null (rest))
6586 {
6587 if (scm_is_false (scm_num_eq_p (x, y)))
6588 return SCM_BOOL_F;
6589 x = y;
6590 y = scm_car (rest);
6591 rest = scm_cdr (rest);
6592 }
6593 return scm_num_eq_p (x, y);
6594 }
6595 #undef FUNC_NAME
6596 SCM
scm_num_eq_p(SCM x,SCM y)6597 scm_num_eq_p (SCM x, SCM y)
6598 {
6599 again:
6600 if (SCM_I_INUMP (x))
6601 {
6602 scm_t_signed_bits xx = SCM_I_INUM (x);
6603 if (SCM_I_INUMP (y))
6604 {
6605 scm_t_signed_bits yy = SCM_I_INUM (y);
6606 return scm_from_bool (xx == yy);
6607 }
6608 else if (SCM_BIGP (y))
6609 return SCM_BOOL_F;
6610 else if (SCM_REALP (y))
6611 {
6612 /* On a 32-bit system an inum fits a double, we can cast the inum
6613 to a double and compare.
6614
6615 But on a 64-bit system an inum is bigger than a double and
6616 casting it to a double (call that dxx) will round.
6617 Although dxx will not in general be equal to xx, dxx will
6618 always be an integer and within a factor of 2 of xx, so if
6619 dxx==yy, we know that yy is an integer and fits in
6620 scm_t_signed_bits. So we cast yy to scm_t_signed_bits and
6621 compare with plain xx.
6622
6623 An alternative (for any size system actually) would be to check
6624 yy is an integer (with floor) and is in range of an inum
6625 (compare against appropriate powers of 2) then test
6626 xx==(scm_t_signed_bits)yy. It's just a matter of which
6627 casts/comparisons might be fastest or easiest for the cpu. */
6628
6629 double yy = SCM_REAL_VALUE (y);
6630 return scm_from_bool ((double) xx == yy
6631 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
6632 || xx == (scm_t_signed_bits) yy));
6633 }
6634 else if (SCM_COMPLEXP (y))
6635 {
6636 /* see comments with inum/real above */
6637 double ry = SCM_COMPLEX_REAL (y);
6638 return scm_from_bool ((double) xx == ry
6639 && 0.0 == SCM_COMPLEX_IMAG (y)
6640 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
6641 || xx == (scm_t_signed_bits) ry));
6642 }
6643 else if (SCM_FRACTIONP (y))
6644 return SCM_BOOL_F;
6645 else
6646 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6647 s_scm_i_num_eq_p);
6648 }
6649 else if (SCM_BIGP (x))
6650 {
6651 if (SCM_I_INUMP (y))
6652 return SCM_BOOL_F;
6653 else if (SCM_BIGP (y))
6654 {
6655 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6656 scm_remember_upto_here_2 (x, y);
6657 return scm_from_bool (0 == cmp);
6658 }
6659 else if (SCM_REALP (y))
6660 {
6661 int cmp;
6662 if (isnan (SCM_REAL_VALUE (y)))
6663 return SCM_BOOL_F;
6664 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
6665 scm_remember_upto_here_1 (x);
6666 return scm_from_bool (0 == cmp);
6667 }
6668 else if (SCM_COMPLEXP (y))
6669 {
6670 int cmp;
6671 if (0.0 != SCM_COMPLEX_IMAG (y))
6672 return SCM_BOOL_F;
6673 if (isnan (SCM_COMPLEX_REAL (y)))
6674 return SCM_BOOL_F;
6675 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
6676 scm_remember_upto_here_1 (x);
6677 return scm_from_bool (0 == cmp);
6678 }
6679 else if (SCM_FRACTIONP (y))
6680 return SCM_BOOL_F;
6681 else
6682 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6683 s_scm_i_num_eq_p);
6684 }
6685 else if (SCM_REALP (x))
6686 {
6687 double xx = SCM_REAL_VALUE (x);
6688 if (SCM_I_INUMP (y))
6689 {
6690 /* see comments with inum/real above */
6691 scm_t_signed_bits yy = SCM_I_INUM (y);
6692 return scm_from_bool (xx == (double) yy
6693 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
6694 || (scm_t_signed_bits) xx == yy));
6695 }
6696 else if (SCM_BIGP (y))
6697 {
6698 int cmp;
6699 if (isnan (xx))
6700 return SCM_BOOL_F;
6701 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
6702 scm_remember_upto_here_1 (y);
6703 return scm_from_bool (0 == cmp);
6704 }
6705 else if (SCM_REALP (y))
6706 return scm_from_bool (xx == SCM_REAL_VALUE (y));
6707 else if (SCM_COMPLEXP (y))
6708 return scm_from_bool ((xx == SCM_COMPLEX_REAL (y))
6709 && (0.0 == SCM_COMPLEX_IMAG (y)));
6710 else if (SCM_FRACTIONP (y))
6711 {
6712 if (isnan (xx) || isinf (xx))
6713 return SCM_BOOL_F;
6714 x = scm_inexact_to_exact (x); /* with x as frac or int */
6715 goto again;
6716 }
6717 else
6718 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6719 s_scm_i_num_eq_p);
6720 }
6721 else if (SCM_COMPLEXP (x))
6722 {
6723 if (SCM_I_INUMP (y))
6724 {
6725 /* see comments with inum/real above */
6726 double rx = SCM_COMPLEX_REAL (x);
6727 scm_t_signed_bits yy = SCM_I_INUM (y);
6728 return scm_from_bool (rx == (double) yy
6729 && 0.0 == SCM_COMPLEX_IMAG (x)
6730 && (DBL_MANT_DIG >= SCM_I_FIXNUM_BIT-1
6731 || (scm_t_signed_bits) rx == yy));
6732 }
6733 else if (SCM_BIGP (y))
6734 {
6735 int cmp;
6736 if (0.0 != SCM_COMPLEX_IMAG (x))
6737 return SCM_BOOL_F;
6738 if (isnan (SCM_COMPLEX_REAL (x)))
6739 return SCM_BOOL_F;
6740 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
6741 scm_remember_upto_here_1 (y);
6742 return scm_from_bool (0 == cmp);
6743 }
6744 else if (SCM_REALP (y))
6745 return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
6746 && (SCM_COMPLEX_IMAG (x) == 0.0));
6747 else if (SCM_COMPLEXP (y))
6748 return scm_from_bool ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
6749 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
6750 else if (SCM_FRACTIONP (y))
6751 {
6752 double xx;
6753 if (SCM_COMPLEX_IMAG (x) != 0.0)
6754 return SCM_BOOL_F;
6755 xx = SCM_COMPLEX_REAL (x);
6756 if (isnan (xx) || isinf (xx))
6757 return SCM_BOOL_F;
6758 x = scm_inexact_to_exact (x); /* with x as frac or int */
6759 goto again;
6760 }
6761 else
6762 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6763 s_scm_i_num_eq_p);
6764 }
6765 else if (SCM_FRACTIONP (x))
6766 {
6767 if (SCM_I_INUMP (y))
6768 return SCM_BOOL_F;
6769 else if (SCM_BIGP (y))
6770 return SCM_BOOL_F;
6771 else if (SCM_REALP (y))
6772 {
6773 double yy = SCM_REAL_VALUE (y);
6774 if (isnan (yy) || isinf (yy))
6775 return SCM_BOOL_F;
6776 y = scm_inexact_to_exact (y); /* with y as frac or int */
6777 goto again;
6778 }
6779 else if (SCM_COMPLEXP (y))
6780 {
6781 double yy;
6782 if (SCM_COMPLEX_IMAG (y) != 0.0)
6783 return SCM_BOOL_F;
6784 yy = SCM_COMPLEX_REAL (y);
6785 if (isnan (yy) || isinf(yy))
6786 return SCM_BOOL_F;
6787 y = scm_inexact_to_exact (y); /* with y as frac or int */
6788 goto again;
6789 }
6790 else if (SCM_FRACTIONP (y))
6791 return scm_i_fraction_equalp (x, y);
6792 else
6793 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARGn,
6794 s_scm_i_num_eq_p);
6795 }
6796 else
6797 return scm_wta_dispatch_2 (g_scm_i_num_eq_p, x, y, SCM_ARG1,
6798 s_scm_i_num_eq_p);
6799 }
6800
6801
6802 /* OPTIMIZE-ME: For int/frac and frac/frac compares, the multiplications
6803 done are good for inums, but for bignums an answer can almost always be
6804 had by just examining a few high bits of the operands, as done by GMP in
6805 mpq_cmp. flonum/frac compares likewise, but with the slight complication
6806 of the float exponent to take into account. */
6807
6808 SCM_INTERNAL SCM scm_i_num_less_p (SCM, SCM, SCM);
6809 SCM_PRIMITIVE_GENERIC (scm_i_num_less_p, "<", 0, 2, 1,
6810 (SCM x, SCM y, SCM rest),
6811 "Return @code{#t} if the list of parameters is monotonically\n"
6812 "increasing.")
6813 #define FUNC_NAME s_scm_i_num_less_p
6814 {
6815 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
6816 return SCM_BOOL_T;
6817 while (!scm_is_null (rest))
6818 {
6819 if (scm_is_false (scm_less_p (x, y)))
6820 return SCM_BOOL_F;
6821 x = y;
6822 y = scm_car (rest);
6823 rest = scm_cdr (rest);
6824 }
6825 return scm_less_p (x, y);
6826 }
6827 #undef FUNC_NAME
6828 SCM
scm_less_p(SCM x,SCM y)6829 scm_less_p (SCM x, SCM y)
6830 {
6831 again:
6832 if (SCM_I_INUMP (x))
6833 {
6834 scm_t_inum xx = SCM_I_INUM (x);
6835 if (SCM_I_INUMP (y))
6836 {
6837 scm_t_inum yy = SCM_I_INUM (y);
6838 return scm_from_bool (xx < yy);
6839 }
6840 else if (SCM_BIGP (y))
6841 {
6842 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
6843 scm_remember_upto_here_1 (y);
6844 return scm_from_bool (sgn > 0);
6845 }
6846 else if (SCM_REALP (y))
6847 {
6848 /* We can safely take the ceiling of y without changing the
6849 result of x<y, given that x is an integer. */
6850 double yy = ceil (SCM_REAL_VALUE (y));
6851
6852 /* In the following comparisons, it's important that the right
6853 hand side always be a power of 2, so that it can be
6854 losslessly converted to a double even on 64-bit
6855 machines. */
6856 if (yy >= (double) (SCM_MOST_POSITIVE_FIXNUM+1))
6857 return SCM_BOOL_T;
6858 else if (!(yy > (double) SCM_MOST_NEGATIVE_FIXNUM))
6859 /* The condition above is carefully written to include the
6860 case where yy==NaN. */
6861 return SCM_BOOL_F;
6862 else
6863 /* yy is a finite integer that fits in an inum. */
6864 return scm_from_bool (xx < (scm_t_inum) yy);
6865 }
6866 else if (SCM_FRACTIONP (y))
6867 {
6868 /* "x < a/b" becomes "x*b < a" */
6869 int_frac:
6870 x = scm_product (x, SCM_FRACTION_DENOMINATOR (y));
6871 y = SCM_FRACTION_NUMERATOR (y);
6872 goto again;
6873 }
6874 else
6875 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6876 s_scm_i_num_less_p);
6877 }
6878 else if (SCM_BIGP (x))
6879 {
6880 if (SCM_I_INUMP (y))
6881 {
6882 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
6883 scm_remember_upto_here_1 (x);
6884 return scm_from_bool (sgn < 0);
6885 }
6886 else if (SCM_BIGP (y))
6887 {
6888 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
6889 scm_remember_upto_here_2 (x, y);
6890 return scm_from_bool (cmp < 0);
6891 }
6892 else if (SCM_REALP (y))
6893 {
6894 int cmp;
6895 if (isnan (SCM_REAL_VALUE (y)))
6896 return SCM_BOOL_F;
6897 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
6898 scm_remember_upto_here_1 (x);
6899 return scm_from_bool (cmp < 0);
6900 }
6901 else if (SCM_FRACTIONP (y))
6902 goto int_frac;
6903 else
6904 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6905 s_scm_i_num_less_p);
6906 }
6907 else if (SCM_REALP (x))
6908 {
6909 if (SCM_I_INUMP (y))
6910 {
6911 /* We can safely take the floor of x without changing the
6912 result of x<y, given that y is an integer. */
6913 double xx = floor (SCM_REAL_VALUE (x));
6914
6915 /* In the following comparisons, it's important that the right
6916 hand side always be a power of 2, so that it can be
6917 losslessly converted to a double even on 64-bit
6918 machines. */
6919 if (xx < (double) SCM_MOST_NEGATIVE_FIXNUM)
6920 return SCM_BOOL_T;
6921 else if (!(xx < (double) (SCM_MOST_POSITIVE_FIXNUM+1)))
6922 /* The condition above is carefully written to include the
6923 case where xx==NaN. */
6924 return SCM_BOOL_F;
6925 else
6926 /* xx is a finite integer that fits in an inum. */
6927 return scm_from_bool ((scm_t_inum) xx < SCM_I_INUM (y));
6928 }
6929 else if (SCM_BIGP (y))
6930 {
6931 int cmp;
6932 if (isnan (SCM_REAL_VALUE (x)))
6933 return SCM_BOOL_F;
6934 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
6935 scm_remember_upto_here_1 (y);
6936 return scm_from_bool (cmp > 0);
6937 }
6938 else if (SCM_REALP (y))
6939 return scm_from_bool (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
6940 else if (SCM_FRACTIONP (y))
6941 {
6942 double xx = SCM_REAL_VALUE (x);
6943 if (isnan (xx))
6944 return SCM_BOOL_F;
6945 if (isinf (xx))
6946 return scm_from_bool (xx < 0.0);
6947 x = scm_inexact_to_exact (x); /* with x as frac or int */
6948 goto again;
6949 }
6950 else
6951 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6952 s_scm_i_num_less_p);
6953 }
6954 else if (SCM_FRACTIONP (x))
6955 {
6956 if (SCM_I_INUMP (y) || SCM_BIGP (y))
6957 {
6958 /* "a/b < y" becomes "a < y*b" */
6959 y = scm_product (y, SCM_FRACTION_DENOMINATOR (x));
6960 x = SCM_FRACTION_NUMERATOR (x);
6961 goto again;
6962 }
6963 else if (SCM_REALP (y))
6964 {
6965 double yy = SCM_REAL_VALUE (y);
6966 if (isnan (yy))
6967 return SCM_BOOL_F;
6968 if (isinf (yy))
6969 return scm_from_bool (0.0 < yy);
6970 y = scm_inexact_to_exact (y); /* with y as frac or int */
6971 goto again;
6972 }
6973 else if (SCM_FRACTIONP (y))
6974 {
6975 /* "a/b < c/d" becomes "a*d < c*b" */
6976 SCM new_x = scm_product (SCM_FRACTION_NUMERATOR (x),
6977 SCM_FRACTION_DENOMINATOR (y));
6978 SCM new_y = scm_product (SCM_FRACTION_NUMERATOR (y),
6979 SCM_FRACTION_DENOMINATOR (x));
6980 x = new_x;
6981 y = new_y;
6982 goto again;
6983 }
6984 else
6985 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARGn,
6986 s_scm_i_num_less_p);
6987 }
6988 else
6989 return scm_wta_dispatch_2 (g_scm_i_num_less_p, x, y, SCM_ARG1,
6990 s_scm_i_num_less_p);
6991 }
6992
6993
6994 SCM scm_i_num_gr_p (SCM, SCM, SCM);
6995 SCM_PRIMITIVE_GENERIC (scm_i_num_gr_p, ">", 0, 2, 1,
6996 (SCM x, SCM y, SCM rest),
6997 "Return @code{#t} if the list of parameters is monotonically\n"
6998 "decreasing.")
6999 #define FUNC_NAME s_scm_i_num_gr_p
7000 {
7001 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
7002 return SCM_BOOL_T;
7003 while (!scm_is_null (rest))
7004 {
7005 if (scm_is_false (scm_gr_p (x, y)))
7006 return SCM_BOOL_F;
7007 x = y;
7008 y = scm_car (rest);
7009 rest = scm_cdr (rest);
7010 }
7011 return scm_gr_p (x, y);
7012 }
7013 #undef FUNC_NAME
7014 #define FUNC_NAME s_scm_i_num_gr_p
7015 SCM
scm_gr_p(SCM x,SCM y)7016 scm_gr_p (SCM x, SCM y)
7017 {
7018 if (!SCM_NUMBERP (x))
7019 return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG1, FUNC_NAME);
7020 else if (!SCM_NUMBERP (y))
7021 return scm_wta_dispatch_2 (g_scm_i_num_gr_p, x, y, SCM_ARG2, FUNC_NAME);
7022 else
7023 return scm_less_p (y, x);
7024 }
7025 #undef FUNC_NAME
7026
7027
7028 SCM scm_i_num_leq_p (SCM, SCM, SCM);
7029 SCM_PRIMITIVE_GENERIC (scm_i_num_leq_p, "<=", 0, 2, 1,
7030 (SCM x, SCM y, SCM rest),
7031 "Return @code{#t} if the list of parameters is monotonically\n"
7032 "non-decreasing.")
7033 #define FUNC_NAME s_scm_i_num_leq_p
7034 {
7035 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
7036 return SCM_BOOL_T;
7037 while (!scm_is_null (rest))
7038 {
7039 if (scm_is_false (scm_leq_p (x, y)))
7040 return SCM_BOOL_F;
7041 x = y;
7042 y = scm_car (rest);
7043 rest = scm_cdr (rest);
7044 }
7045 return scm_leq_p (x, y);
7046 }
7047 #undef FUNC_NAME
7048 #define FUNC_NAME s_scm_i_num_leq_p
7049 SCM
scm_leq_p(SCM x,SCM y)7050 scm_leq_p (SCM x, SCM y)
7051 {
7052 if (!SCM_NUMBERP (x))
7053 return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG1, FUNC_NAME);
7054 else if (!SCM_NUMBERP (y))
7055 return scm_wta_dispatch_2 (g_scm_i_num_leq_p, x, y, SCM_ARG2, FUNC_NAME);
7056 else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
7057 return SCM_BOOL_F;
7058 else
7059 return scm_not (scm_less_p (y, x));
7060 }
7061 #undef FUNC_NAME
7062
7063
7064 SCM scm_i_num_geq_p (SCM, SCM, SCM);
7065 SCM_PRIMITIVE_GENERIC (scm_i_num_geq_p, ">=", 0, 2, 1,
7066 (SCM x, SCM y, SCM rest),
7067 "Return @code{#t} if the list of parameters is monotonically\n"
7068 "non-increasing.")
7069 #define FUNC_NAME s_scm_i_num_geq_p
7070 {
7071 if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
7072 return SCM_BOOL_T;
7073 while (!scm_is_null (rest))
7074 {
7075 if (scm_is_false (scm_geq_p (x, y)))
7076 return SCM_BOOL_F;
7077 x = y;
7078 y = scm_car (rest);
7079 rest = scm_cdr (rest);
7080 }
7081 return scm_geq_p (x, y);
7082 }
7083 #undef FUNC_NAME
7084 #define FUNC_NAME s_scm_i_num_geq_p
7085 SCM
scm_geq_p(SCM x,SCM y)7086 scm_geq_p (SCM x, SCM y)
7087 {
7088 if (!SCM_NUMBERP (x))
7089 return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG1, FUNC_NAME);
7090 else if (!SCM_NUMBERP (y))
7091 return scm_wta_dispatch_2 (g_scm_i_num_geq_p, x, y, SCM_ARG2, FUNC_NAME);
7092 else if (scm_is_true (scm_nan_p (x)) || scm_is_true (scm_nan_p (y)))
7093 return SCM_BOOL_F;
7094 else
7095 return scm_not (scm_less_p (x, y));
7096 }
7097 #undef FUNC_NAME
7098
7099
7100 SCM_PRIMITIVE_GENERIC (scm_zero_p, "zero?", 1, 0, 0,
7101 (SCM z),
7102 "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
7103 "zero.")
7104 #define FUNC_NAME s_scm_zero_p
7105 {
7106 if (SCM_I_INUMP (z))
7107 return scm_from_bool (scm_is_eq (z, SCM_INUM0));
7108 else if (SCM_BIGP (z))
7109 return SCM_BOOL_F;
7110 else if (SCM_REALP (z))
7111 return scm_from_bool (SCM_REAL_VALUE (z) == 0.0);
7112 else if (SCM_COMPLEXP (z))
7113 return scm_from_bool (SCM_COMPLEX_REAL (z) == 0.0
7114 && SCM_COMPLEX_IMAG (z) == 0.0);
7115 else if (SCM_FRACTIONP (z))
7116 return SCM_BOOL_F;
7117 else
7118 return scm_wta_dispatch_1 (g_scm_zero_p, z, SCM_ARG1, s_scm_zero_p);
7119 }
7120 #undef FUNC_NAME
7121
7122
7123 SCM_PRIMITIVE_GENERIC (scm_positive_p, "positive?", 1, 0, 0,
7124 (SCM x),
7125 "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
7126 "zero.")
7127 #define FUNC_NAME s_scm_positive_p
7128 {
7129 if (SCM_I_INUMP (x))
7130 return scm_from_bool (SCM_I_INUM (x) > 0);
7131 else if (SCM_BIGP (x))
7132 {
7133 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7134 scm_remember_upto_here_1 (x);
7135 return scm_from_bool (sgn > 0);
7136 }
7137 else if (SCM_REALP (x))
7138 return scm_from_bool(SCM_REAL_VALUE (x) > 0.0);
7139 else if (SCM_FRACTIONP (x))
7140 return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
7141 else
7142 return scm_wta_dispatch_1 (g_scm_positive_p, x, SCM_ARG1, s_scm_positive_p);
7143 }
7144 #undef FUNC_NAME
7145
7146
7147 SCM_PRIMITIVE_GENERIC (scm_negative_p, "negative?", 1, 0, 0,
7148 (SCM x),
7149 "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
7150 "zero.")
7151 #define FUNC_NAME s_scm_negative_p
7152 {
7153 if (SCM_I_INUMP (x))
7154 return scm_from_bool (SCM_I_INUM (x) < 0);
7155 else if (SCM_BIGP (x))
7156 {
7157 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7158 scm_remember_upto_here_1 (x);
7159 return scm_from_bool (sgn < 0);
7160 }
7161 else if (SCM_REALP (x))
7162 return scm_from_bool(SCM_REAL_VALUE (x) < 0.0);
7163 else if (SCM_FRACTIONP (x))
7164 return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
7165 else
7166 return scm_wta_dispatch_1 (g_scm_negative_p, x, SCM_ARG1, s_scm_negative_p);
7167 }
7168 #undef FUNC_NAME
7169
7170
7171 /* scm_min and scm_max return an inexact when either argument is inexact, as
7172 required by r5rs. On that basis, for exact/inexact combinations the
7173 exact is converted to inexact to compare and possibly return. This is
7174 unlike scm_less_p above which takes some trouble to preserve all bits in
7175 its test, such trouble is not required for min and max. */
7176
7177 SCM_PRIMITIVE_GENERIC (scm_i_max, "max", 0, 2, 1,
7178 (SCM x, SCM y, SCM rest),
7179 "Return the maximum of all parameter values.")
7180 #define FUNC_NAME s_scm_i_max
7181 {
7182 while (!scm_is_null (rest))
7183 { x = scm_max (x, y);
7184 y = scm_car (rest);
7185 rest = scm_cdr (rest);
7186 }
7187 return scm_max (x, y);
7188 }
7189 #undef FUNC_NAME
7190
7191 #define s_max s_scm_i_max
7192 #define g_max g_scm_i_max
7193
7194 SCM
scm_max(SCM x,SCM y)7195 scm_max (SCM x, SCM y)
7196 {
7197 if (SCM_UNBNDP (y))
7198 {
7199 if (SCM_UNBNDP (x))
7200 return scm_wta_dispatch_0 (g_max, s_max);
7201 else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
7202 return x;
7203 else
7204 return scm_wta_dispatch_1 (g_max, x, SCM_ARG1, s_max);
7205 }
7206
7207 if (SCM_I_INUMP (x))
7208 {
7209 scm_t_inum xx = SCM_I_INUM (x);
7210 if (SCM_I_INUMP (y))
7211 {
7212 scm_t_inum yy = SCM_I_INUM (y);
7213 return (xx < yy) ? y : x;
7214 }
7215 else if (SCM_BIGP (y))
7216 {
7217 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
7218 scm_remember_upto_here_1 (y);
7219 return (sgn < 0) ? x : y;
7220 }
7221 else if (SCM_REALP (y))
7222 {
7223 double xxd = xx;
7224 double yyd = SCM_REAL_VALUE (y);
7225
7226 if (xxd > yyd)
7227 return scm_i_from_double (xxd);
7228 /* If y is a NaN, then "==" is false and we return the NaN */
7229 else if (SCM_LIKELY (!(xxd == yyd)))
7230 return y;
7231 /* Handle signed zeroes properly */
7232 else if (xx == 0)
7233 return flo0;
7234 else
7235 return y;
7236 }
7237 else if (SCM_FRACTIONP (y))
7238 {
7239 use_less:
7240 return (scm_is_false (scm_less_p (x, y)) ? x : y);
7241 }
7242 else
7243 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
7244 }
7245 else if (SCM_BIGP (x))
7246 {
7247 if (SCM_I_INUMP (y))
7248 {
7249 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7250 scm_remember_upto_here_1 (x);
7251 return (sgn < 0) ? y : x;
7252 }
7253 else if (SCM_BIGP (y))
7254 {
7255 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
7256 scm_remember_upto_here_2 (x, y);
7257 return (cmp > 0) ? x : y;
7258 }
7259 else if (SCM_REALP (y))
7260 {
7261 /* if y==NaN then xx>yy is false, so we return the NaN y */
7262 double xx, yy;
7263 big_real:
7264 xx = scm_i_big2dbl (x);
7265 yy = SCM_REAL_VALUE (y);
7266 return (xx > yy ? scm_i_from_double (xx) : y);
7267 }
7268 else if (SCM_FRACTIONP (y))
7269 {
7270 goto use_less;
7271 }
7272 else
7273 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
7274 }
7275 else if (SCM_REALP (x))
7276 {
7277 if (SCM_I_INUMP (y))
7278 {
7279 scm_t_inum yy = SCM_I_INUM (y);
7280 double xxd = SCM_REAL_VALUE (x);
7281 double yyd = yy;
7282
7283 if (yyd > xxd)
7284 return scm_i_from_double (yyd);
7285 /* If x is a NaN, then "==" is false and we return the NaN */
7286 else if (SCM_LIKELY (!(xxd == yyd)))
7287 return x;
7288 /* Handle signed zeroes properly */
7289 else if (yy == 0)
7290 return flo0;
7291 else
7292 return x;
7293 }
7294 else if (SCM_BIGP (y))
7295 {
7296 SCM_SWAP (x, y);
7297 goto big_real;
7298 }
7299 else if (SCM_REALP (y))
7300 {
7301 double xx = SCM_REAL_VALUE (x);
7302 double yy = SCM_REAL_VALUE (y);
7303
7304 /* For purposes of max: nan > +inf.0 > everything else,
7305 per the R6RS errata */
7306 if (xx > yy)
7307 return x;
7308 else if (SCM_LIKELY (xx < yy))
7309 return y;
7310 /* If neither (xx > yy) nor (xx < yy), then
7311 either they're equal or one is a NaN */
7312 else if (SCM_UNLIKELY (xx != yy))
7313 return (xx != xx) ? x : y; /* Return the NaN */
7314 /* xx == yy, but handle signed zeroes properly */
7315 else if (copysign (1.0, yy) < 0.0)
7316 return x;
7317 else
7318 return y;
7319 }
7320 else if (SCM_FRACTIONP (y))
7321 {
7322 double yy = scm_i_fraction2double (y);
7323 double xx = SCM_REAL_VALUE (x);
7324 return (xx < yy) ? scm_i_from_double (yy) : x;
7325 }
7326 else
7327 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
7328 }
7329 else if (SCM_FRACTIONP (x))
7330 {
7331 if (SCM_I_INUMP (y))
7332 {
7333 goto use_less;
7334 }
7335 else if (SCM_BIGP (y))
7336 {
7337 goto use_less;
7338 }
7339 else if (SCM_REALP (y))
7340 {
7341 double xx = scm_i_fraction2double (x);
7342 /* if y==NaN then ">" is false, so we return the NaN y */
7343 return (xx > SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
7344 }
7345 else if (SCM_FRACTIONP (y))
7346 {
7347 goto use_less;
7348 }
7349 else
7350 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARGn, s_max);
7351 }
7352 else
7353 return scm_wta_dispatch_2 (g_max, x, y, SCM_ARG1, s_max);
7354 }
7355
7356
7357 SCM_PRIMITIVE_GENERIC (scm_i_min, "min", 0, 2, 1,
7358 (SCM x, SCM y, SCM rest),
7359 "Return the minimum of all parameter values.")
7360 #define FUNC_NAME s_scm_i_min
7361 {
7362 while (!scm_is_null (rest))
7363 { x = scm_min (x, y);
7364 y = scm_car (rest);
7365 rest = scm_cdr (rest);
7366 }
7367 return scm_min (x, y);
7368 }
7369 #undef FUNC_NAME
7370
7371 #define s_min s_scm_i_min
7372 #define g_min g_scm_i_min
7373
7374 SCM
scm_min(SCM x,SCM y)7375 scm_min (SCM x, SCM y)
7376 {
7377 if (SCM_UNBNDP (y))
7378 {
7379 if (SCM_UNBNDP (x))
7380 return scm_wta_dispatch_0 (g_min, s_min);
7381 else if (SCM_I_INUMP(x) || SCM_BIGP(x) || SCM_REALP(x) || SCM_FRACTIONP(x))
7382 return x;
7383 else
7384 return scm_wta_dispatch_1 (g_min, x, SCM_ARG1, s_min);
7385 }
7386
7387 if (SCM_I_INUMP (x))
7388 {
7389 scm_t_inum xx = SCM_I_INUM (x);
7390 if (SCM_I_INUMP (y))
7391 {
7392 scm_t_inum yy = SCM_I_INUM (y);
7393 return (xx < yy) ? x : y;
7394 }
7395 else if (SCM_BIGP (y))
7396 {
7397 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
7398 scm_remember_upto_here_1 (y);
7399 return (sgn < 0) ? y : x;
7400 }
7401 else if (SCM_REALP (y))
7402 {
7403 double z = xx;
7404 /* if y==NaN then "<" is false and we return NaN */
7405 return (z < SCM_REAL_VALUE (y)) ? scm_i_from_double (z) : y;
7406 }
7407 else if (SCM_FRACTIONP (y))
7408 {
7409 use_less:
7410 return (scm_is_false (scm_less_p (x, y)) ? y : x);
7411 }
7412 else
7413 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
7414 }
7415 else if (SCM_BIGP (x))
7416 {
7417 if (SCM_I_INUMP (y))
7418 {
7419 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7420 scm_remember_upto_here_1 (x);
7421 return (sgn < 0) ? x : y;
7422 }
7423 else if (SCM_BIGP (y))
7424 {
7425 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
7426 scm_remember_upto_here_2 (x, y);
7427 return (cmp > 0) ? y : x;
7428 }
7429 else if (SCM_REALP (y))
7430 {
7431 /* if y==NaN then xx<yy is false, so we return the NaN y */
7432 double xx, yy;
7433 big_real:
7434 xx = scm_i_big2dbl (x);
7435 yy = SCM_REAL_VALUE (y);
7436 return (xx < yy ? scm_i_from_double (xx) : y);
7437 }
7438 else if (SCM_FRACTIONP (y))
7439 {
7440 goto use_less;
7441 }
7442 else
7443 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
7444 }
7445 else if (SCM_REALP (x))
7446 {
7447 if (SCM_I_INUMP (y))
7448 {
7449 double z = SCM_I_INUM (y);
7450 /* if x==NaN then "<" is false and we return NaN */
7451 return (z < SCM_REAL_VALUE (x)) ? scm_i_from_double (z) : x;
7452 }
7453 else if (SCM_BIGP (y))
7454 {
7455 SCM_SWAP (x, y);
7456 goto big_real;
7457 }
7458 else if (SCM_REALP (y))
7459 {
7460 double xx = SCM_REAL_VALUE (x);
7461 double yy = SCM_REAL_VALUE (y);
7462
7463 /* For purposes of min: nan < -inf.0 < everything else,
7464 per the R6RS errata */
7465 if (xx < yy)
7466 return x;
7467 else if (SCM_LIKELY (xx > yy))
7468 return y;
7469 /* If neither (xx < yy) nor (xx > yy), then
7470 either they're equal or one is a NaN */
7471 else if (SCM_UNLIKELY (xx != yy))
7472 return (xx != xx) ? x : y; /* Return the NaN */
7473 /* xx == yy, but handle signed zeroes properly */
7474 else if (copysign (1.0, xx) < 0.0)
7475 return x;
7476 else
7477 return y;
7478 }
7479 else if (SCM_FRACTIONP (y))
7480 {
7481 double yy = scm_i_fraction2double (y);
7482 double xx = SCM_REAL_VALUE (x);
7483 return (yy < xx) ? scm_i_from_double (yy) : x;
7484 }
7485 else
7486 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
7487 }
7488 else if (SCM_FRACTIONP (x))
7489 {
7490 if (SCM_I_INUMP (y))
7491 {
7492 goto use_less;
7493 }
7494 else if (SCM_BIGP (y))
7495 {
7496 goto use_less;
7497 }
7498 else if (SCM_REALP (y))
7499 {
7500 double xx = scm_i_fraction2double (x);
7501 /* if y==NaN then "<" is false, so we return the NaN y */
7502 return (xx < SCM_REAL_VALUE (y)) ? scm_i_from_double (xx) : y;
7503 }
7504 else if (SCM_FRACTIONP (y))
7505 {
7506 goto use_less;
7507 }
7508 else
7509 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARGn, s_min);
7510 }
7511 else
7512 return scm_wta_dispatch_2 (g_min, x, y, SCM_ARG1, s_min);
7513 }
7514
7515
7516 SCM_PRIMITIVE_GENERIC (scm_i_sum, "+", 0, 2, 1,
7517 (SCM x, SCM y, SCM rest),
7518 "Return the sum of all parameter values. Return 0 if called without\n"
7519 "any parameters." )
7520 #define FUNC_NAME s_scm_i_sum
7521 {
7522 while (!scm_is_null (rest))
7523 { x = scm_sum (x, y);
7524 y = scm_car (rest);
7525 rest = scm_cdr (rest);
7526 }
7527 return scm_sum (x, y);
7528 }
7529 #undef FUNC_NAME
7530
7531 #define s_sum s_scm_i_sum
7532 #define g_sum g_scm_i_sum
7533
7534 SCM
scm_sum(SCM x,SCM y)7535 scm_sum (SCM x, SCM y)
7536 {
7537 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
7538 {
7539 if (SCM_NUMBERP (x)) return x;
7540 if (SCM_UNBNDP (x)) return SCM_INUM0;
7541 return scm_wta_dispatch_1 (g_sum, x, SCM_ARG1, s_sum);
7542 }
7543
7544 if (SCM_LIKELY (SCM_I_INUMP (x)))
7545 {
7546 if (SCM_LIKELY (SCM_I_INUMP (y)))
7547 {
7548 scm_t_inum xx = SCM_I_INUM (x);
7549 scm_t_inum yy = SCM_I_INUM (y);
7550 scm_t_inum z = xx + yy;
7551 return SCM_FIXABLE (z) ? SCM_I_MAKINUM (z) : scm_i_inum2big (z);
7552 }
7553 else if (SCM_BIGP (y))
7554 {
7555 SCM_SWAP (x, y);
7556 goto add_big_inum;
7557 }
7558 else if (SCM_REALP (y))
7559 {
7560 scm_t_inum xx = SCM_I_INUM (x);
7561 return scm_i_from_double (xx + SCM_REAL_VALUE (y));
7562 }
7563 else if (SCM_COMPLEXP (y))
7564 {
7565 scm_t_inum xx = SCM_I_INUM (x);
7566 return scm_c_make_rectangular (xx + SCM_COMPLEX_REAL (y),
7567 SCM_COMPLEX_IMAG (y));
7568 }
7569 else if (SCM_FRACTIONP (y))
7570 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
7571 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
7572 SCM_FRACTION_DENOMINATOR (y));
7573 else
7574 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
7575 }
7576 else if (SCM_BIGP (x))
7577 {
7578 if (SCM_I_INUMP (y))
7579 {
7580 scm_t_inum inum;
7581 int bigsgn;
7582 add_big_inum:
7583 inum = SCM_I_INUM (y);
7584 if (inum == 0)
7585 return x;
7586 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
7587 if (inum < 0)
7588 {
7589 SCM result = scm_i_mkbig ();
7590 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
7591 scm_remember_upto_here_1 (x);
7592 /* we know the result will have to be a bignum */
7593 if (bigsgn == -1)
7594 return result;
7595 return scm_i_normbig (result);
7596 }
7597 else
7598 {
7599 SCM result = scm_i_mkbig ();
7600 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
7601 scm_remember_upto_here_1 (x);
7602 /* we know the result will have to be a bignum */
7603 if (bigsgn == 1)
7604 return result;
7605 return scm_i_normbig (result);
7606 }
7607 }
7608 else if (SCM_BIGP (y))
7609 {
7610 SCM result = scm_i_mkbig ();
7611 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
7612 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7613 mpz_add (SCM_I_BIG_MPZ (result),
7614 SCM_I_BIG_MPZ (x),
7615 SCM_I_BIG_MPZ (y));
7616 scm_remember_upto_here_2 (x, y);
7617 /* we know the result will have to be a bignum */
7618 if (sgn_x == sgn_y)
7619 return result;
7620 return scm_i_normbig (result);
7621 }
7622 else if (SCM_REALP (y))
7623 {
7624 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
7625 scm_remember_upto_here_1 (x);
7626 return scm_i_from_double (result);
7627 }
7628 else if (SCM_COMPLEXP (y))
7629 {
7630 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
7631 + SCM_COMPLEX_REAL (y));
7632 scm_remember_upto_here_1 (x);
7633 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
7634 }
7635 else if (SCM_FRACTIONP (y))
7636 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
7637 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
7638 SCM_FRACTION_DENOMINATOR (y));
7639 else
7640 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
7641 }
7642 else if (SCM_REALP (x))
7643 {
7644 if (SCM_I_INUMP (y))
7645 return scm_i_from_double (SCM_REAL_VALUE (x) + SCM_I_INUM (y));
7646 else if (SCM_BIGP (y))
7647 {
7648 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
7649 scm_remember_upto_here_1 (y);
7650 return scm_i_from_double (result);
7651 }
7652 else if (SCM_REALP (y))
7653 return scm_i_from_double (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
7654 else if (SCM_COMPLEXP (y))
7655 return scm_c_make_rectangular (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
7656 SCM_COMPLEX_IMAG (y));
7657 else if (SCM_FRACTIONP (y))
7658 return scm_i_from_double (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
7659 else
7660 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
7661 }
7662 else if (SCM_COMPLEXP (x))
7663 {
7664 if (SCM_I_INUMP (y))
7665 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_I_INUM (y),
7666 SCM_COMPLEX_IMAG (x));
7667 else if (SCM_BIGP (y))
7668 {
7669 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
7670 + SCM_COMPLEX_REAL (x));
7671 scm_remember_upto_here_1 (y);
7672 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (x));
7673 }
7674 else if (SCM_REALP (y))
7675 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
7676 SCM_COMPLEX_IMAG (x));
7677 else if (SCM_COMPLEXP (y))
7678 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
7679 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
7680 else if (SCM_FRACTIONP (y))
7681 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
7682 SCM_COMPLEX_IMAG (x));
7683 else
7684 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
7685 }
7686 else if (SCM_FRACTIONP (x))
7687 {
7688 if (SCM_I_INUMP (y))
7689 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
7690 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
7691 SCM_FRACTION_DENOMINATOR (x));
7692 else if (SCM_BIGP (y))
7693 return scm_i_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
7694 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
7695 SCM_FRACTION_DENOMINATOR (x));
7696 else if (SCM_REALP (y))
7697 return scm_i_from_double (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
7698 else if (SCM_COMPLEXP (y))
7699 return scm_c_make_rectangular (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
7700 SCM_COMPLEX_IMAG (y));
7701 else if (SCM_FRACTIONP (y))
7702 /* a/b + c/d = (ad + bc) / bd */
7703 return scm_i_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
7704 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
7705 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
7706 else
7707 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARGn, s_sum);
7708 }
7709 else
7710 return scm_wta_dispatch_2 (g_sum, x, y, SCM_ARG1, s_sum);
7711 }
7712
7713
7714 SCM_DEFINE (scm_oneplus, "1+", 1, 0, 0,
7715 (SCM x),
7716 "Return @math{@var{x}+1}.")
7717 #define FUNC_NAME s_scm_oneplus
7718 {
7719 return scm_sum (x, SCM_INUM1);
7720 }
7721 #undef FUNC_NAME
7722
7723
7724 SCM_PRIMITIVE_GENERIC (scm_i_difference, "-", 0, 2, 1,
7725 (SCM x, SCM y, SCM rest),
7726 "If called with one argument @var{z1}, -@var{z1} returned. Otherwise\n"
7727 "the sum of all but the first argument are subtracted from the first\n"
7728 "argument.")
7729 #define FUNC_NAME s_scm_i_difference
7730 {
7731 while (!scm_is_null (rest))
7732 { x = scm_difference (x, y);
7733 y = scm_car (rest);
7734 rest = scm_cdr (rest);
7735 }
7736 return scm_difference (x, y);
7737 }
7738 #undef FUNC_NAME
7739
7740 #define s_difference s_scm_i_difference
7741 #define g_difference g_scm_i_difference
7742
7743 SCM
scm_difference(SCM x,SCM y)7744 scm_difference (SCM x, SCM y)
7745 #define FUNC_NAME s_difference
7746 {
7747 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
7748 {
7749 if (SCM_UNBNDP (x))
7750 return scm_wta_dispatch_0 (g_difference, s_difference);
7751 else
7752 if (SCM_I_INUMP (x))
7753 {
7754 scm_t_inum xx = -SCM_I_INUM (x);
7755 if (SCM_FIXABLE (xx))
7756 return SCM_I_MAKINUM (xx);
7757 else
7758 return scm_i_inum2big (xx);
7759 }
7760 else if (SCM_BIGP (x))
7761 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7762 bignum, but negating that gives a fixnum. */
7763 return scm_i_normbig (scm_i_clonebig (x, 0));
7764 else if (SCM_REALP (x))
7765 return scm_i_from_double (-SCM_REAL_VALUE (x));
7766 else if (SCM_COMPLEXP (x))
7767 return scm_c_make_rectangular (-SCM_COMPLEX_REAL (x),
7768 -SCM_COMPLEX_IMAG (x));
7769 else if (SCM_FRACTIONP (x))
7770 return scm_i_make_ratio_already_reduced
7771 (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
7772 SCM_FRACTION_DENOMINATOR (x));
7773 else
7774 return scm_wta_dispatch_1 (g_difference, x, SCM_ARG1, s_difference);
7775 }
7776
7777 if (SCM_LIKELY (SCM_I_INUMP (x)))
7778 {
7779 if (SCM_LIKELY (SCM_I_INUMP (y)))
7780 {
7781 scm_t_inum xx = SCM_I_INUM (x);
7782 scm_t_inum yy = SCM_I_INUM (y);
7783 scm_t_inum z = xx - yy;
7784 if (SCM_FIXABLE (z))
7785 return SCM_I_MAKINUM (z);
7786 else
7787 return scm_i_inum2big (z);
7788 }
7789 else if (SCM_BIGP (y))
7790 {
7791 /* inum-x - big-y */
7792 scm_t_inum xx = SCM_I_INUM (x);
7793
7794 if (xx == 0)
7795 {
7796 /* Must scm_i_normbig here because -SCM_MOST_NEGATIVE_FIXNUM is a
7797 bignum, but negating that gives a fixnum. */
7798 return scm_i_normbig (scm_i_clonebig (y, 0));
7799 }
7800 else
7801 {
7802 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7803 SCM result = scm_i_mkbig ();
7804
7805 if (xx >= 0)
7806 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
7807 else
7808 {
7809 /* x - y == -(y + -x) */
7810 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
7811 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
7812 }
7813 scm_remember_upto_here_1 (y);
7814
7815 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
7816 /* we know the result will have to be a bignum */
7817 return result;
7818 else
7819 return scm_i_normbig (result);
7820 }
7821 }
7822 else if (SCM_REALP (y))
7823 {
7824 scm_t_inum xx = SCM_I_INUM (x);
7825
7826 /*
7827 * We need to handle x == exact 0
7828 * specially because R6RS states that:
7829 * (- 0.0) ==> -0.0 and
7830 * (- 0.0 0.0) ==> 0.0
7831 * and the scheme compiler changes
7832 * (- 0.0) into (- 0 0.0)
7833 * So we need to treat (- 0 0.0) like (- 0.0).
7834 * At the C level, (-x) is different than (0.0 - x).
7835 * (0.0 - 0.0) ==> 0.0, but (- 0.0) ==> -0.0.
7836 */
7837 if (xx == 0)
7838 return scm_i_from_double (- SCM_REAL_VALUE (y));
7839 else
7840 return scm_i_from_double (xx - SCM_REAL_VALUE (y));
7841 }
7842 else if (SCM_COMPLEXP (y))
7843 {
7844 scm_t_inum xx = SCM_I_INUM (x);
7845
7846 /* We need to handle x == exact 0 specially.
7847 See the comment above (for SCM_REALP (y)) */
7848 if (xx == 0)
7849 return scm_c_make_rectangular (- SCM_COMPLEX_REAL (y),
7850 - SCM_COMPLEX_IMAG (y));
7851 else
7852 return scm_c_make_rectangular (xx - SCM_COMPLEX_REAL (y),
7853 - SCM_COMPLEX_IMAG (y));
7854 }
7855 else if (SCM_FRACTIONP (y))
7856 /* a - b/c = (ac - b) / c */
7857 return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
7858 SCM_FRACTION_NUMERATOR (y)),
7859 SCM_FRACTION_DENOMINATOR (y));
7860 else
7861 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
7862 }
7863 else if (SCM_BIGP (x))
7864 {
7865 if (SCM_I_INUMP (y))
7866 {
7867 /* big-x - inum-y */
7868 scm_t_inum yy = SCM_I_INUM (y);
7869 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
7870
7871 scm_remember_upto_here_1 (x);
7872 if (sgn_x == 0)
7873 return (SCM_FIXABLE (-yy) ?
7874 SCM_I_MAKINUM (-yy) : scm_from_inum (-yy));
7875 else
7876 {
7877 SCM result = scm_i_mkbig ();
7878
7879 if (yy >= 0)
7880 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
7881 else
7882 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
7883 scm_remember_upto_here_1 (x);
7884
7885 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
7886 /* we know the result will have to be a bignum */
7887 return result;
7888 else
7889 return scm_i_normbig (result);
7890 }
7891 }
7892 else if (SCM_BIGP (y))
7893 {
7894 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
7895 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
7896 SCM result = scm_i_mkbig ();
7897 mpz_sub (SCM_I_BIG_MPZ (result),
7898 SCM_I_BIG_MPZ (x),
7899 SCM_I_BIG_MPZ (y));
7900 scm_remember_upto_here_2 (x, y);
7901 /* we know the result will have to be a bignum */
7902 if ((sgn_x == 1) && (sgn_y == -1))
7903 return result;
7904 if ((sgn_x == -1) && (sgn_y == 1))
7905 return result;
7906 return scm_i_normbig (result);
7907 }
7908 else if (SCM_REALP (y))
7909 {
7910 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
7911 scm_remember_upto_here_1 (x);
7912 return scm_i_from_double (result);
7913 }
7914 else if (SCM_COMPLEXP (y))
7915 {
7916 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
7917 - SCM_COMPLEX_REAL (y));
7918 scm_remember_upto_here_1 (x);
7919 return scm_c_make_rectangular (real_part, - SCM_COMPLEX_IMAG (y));
7920 }
7921 else if (SCM_FRACTIONP (y))
7922 return scm_i_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
7923 SCM_FRACTION_NUMERATOR (y)),
7924 SCM_FRACTION_DENOMINATOR (y));
7925 else
7926 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
7927 }
7928 else if (SCM_REALP (x))
7929 {
7930 if (SCM_I_INUMP (y))
7931 return scm_i_from_double (SCM_REAL_VALUE (x) - SCM_I_INUM (y));
7932 else if (SCM_BIGP (y))
7933 {
7934 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
7935 scm_remember_upto_here_1 (x);
7936 return scm_i_from_double (result);
7937 }
7938 else if (SCM_REALP (y))
7939 return scm_i_from_double (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
7940 else if (SCM_COMPLEXP (y))
7941 return scm_c_make_rectangular (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
7942 -SCM_COMPLEX_IMAG (y));
7943 else if (SCM_FRACTIONP (y))
7944 return scm_i_from_double (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
7945 else
7946 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
7947 }
7948 else if (SCM_COMPLEXP (x))
7949 {
7950 if (SCM_I_INUMP (y))
7951 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_I_INUM (y),
7952 SCM_COMPLEX_IMAG (x));
7953 else if (SCM_BIGP (y))
7954 {
7955 double real_part = (SCM_COMPLEX_REAL (x)
7956 - mpz_get_d (SCM_I_BIG_MPZ (y)));
7957 scm_remember_upto_here_1 (x);
7958 return scm_c_make_rectangular (real_part, SCM_COMPLEX_IMAG (y));
7959 }
7960 else if (SCM_REALP (y))
7961 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
7962 SCM_COMPLEX_IMAG (x));
7963 else if (SCM_COMPLEXP (y))
7964 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
7965 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
7966 else if (SCM_FRACTIONP (y))
7967 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
7968 SCM_COMPLEX_IMAG (x));
7969 else
7970 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
7971 }
7972 else if (SCM_FRACTIONP (x))
7973 {
7974 if (SCM_I_INUMP (y))
7975 /* a/b - c = (a - cb) / b */
7976 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
7977 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
7978 SCM_FRACTION_DENOMINATOR (x));
7979 else if (SCM_BIGP (y))
7980 return scm_i_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
7981 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
7982 SCM_FRACTION_DENOMINATOR (x));
7983 else if (SCM_REALP (y))
7984 return scm_i_from_double (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
7985 else if (SCM_COMPLEXP (y))
7986 return scm_c_make_rectangular (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
7987 -SCM_COMPLEX_IMAG (y));
7988 else if (SCM_FRACTIONP (y))
7989 /* a/b - c/d = (ad - bc) / bd */
7990 return scm_i_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
7991 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
7992 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
7993 else
7994 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARGn, s_difference);
7995 }
7996 else
7997 return scm_wta_dispatch_2 (g_difference, x, y, SCM_ARG1, s_difference);
7998 }
7999 #undef FUNC_NAME
8000
8001
8002 SCM_DEFINE (scm_oneminus, "1-", 1, 0, 0,
8003 (SCM x),
8004 "Return @math{@var{x}-1}.")
8005 #define FUNC_NAME s_scm_oneminus
8006 {
8007 return scm_difference (x, SCM_INUM1);
8008 }
8009 #undef FUNC_NAME
8010
8011
8012 SCM_PRIMITIVE_GENERIC (scm_i_product, "*", 0, 2, 1,
8013 (SCM x, SCM y, SCM rest),
8014 "Return the product of all arguments. If called without arguments,\n"
8015 "1 is returned.")
8016 #define FUNC_NAME s_scm_i_product
8017 {
8018 while (!scm_is_null (rest))
8019 { x = scm_product (x, y);
8020 y = scm_car (rest);
8021 rest = scm_cdr (rest);
8022 }
8023 return scm_product (x, y);
8024 }
8025 #undef FUNC_NAME
8026
8027 #define s_product s_scm_i_product
8028 #define g_product g_scm_i_product
8029
8030 SCM
scm_product(SCM x,SCM y)8031 scm_product (SCM x, SCM y)
8032 {
8033 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
8034 {
8035 if (SCM_UNBNDP (x))
8036 return SCM_I_MAKINUM (1L);
8037 else if (SCM_NUMBERP (x))
8038 return x;
8039 else
8040 return scm_wta_dispatch_1 (g_product, x, SCM_ARG1, s_product);
8041 }
8042
8043 if (SCM_LIKELY (SCM_I_INUMP (x)))
8044 {
8045 scm_t_inum xx;
8046
8047 xinum:
8048 xx = SCM_I_INUM (x);
8049
8050 switch (xx)
8051 {
8052 case 1:
8053 /* exact1 is the universal multiplicative identity */
8054 return y;
8055 break;
8056 case 0:
8057 /* exact0 times a fixnum is exact0: optimize this case */
8058 if (SCM_LIKELY (SCM_I_INUMP (y)))
8059 return SCM_INUM0;
8060 /* if the other argument is inexact, the result is inexact,
8061 and we must do the multiplication in order to handle
8062 infinities and NaNs properly. */
8063 else if (SCM_REALP (y))
8064 return scm_i_from_double (0.0 * SCM_REAL_VALUE (y));
8065 else if (SCM_COMPLEXP (y))
8066 return scm_c_make_rectangular (0.0 * SCM_COMPLEX_REAL (y),
8067 0.0 * SCM_COMPLEX_IMAG (y));
8068 /* we've already handled inexact numbers,
8069 so y must be exact, and we return exact0 */
8070 else if (SCM_NUMP (y))
8071 return SCM_INUM0;
8072 else
8073 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8074 break;
8075 }
8076
8077 if (SCM_LIKELY (SCM_I_INUMP (y)))
8078 {
8079 scm_t_inum yy = SCM_I_INUM (y);
8080 #if SCM_I_FIXNUM_BIT < 32 && SCM_HAVE_T_INT64
8081 scm_t_int64 kk = xx * (scm_t_int64) yy;
8082 if (SCM_FIXABLE (kk))
8083 return SCM_I_MAKINUM (kk);
8084 #else
8085 scm_t_inum axx = (xx > 0) ? xx : -xx;
8086 scm_t_inum ayy = (yy > 0) ? yy : -yy;
8087 if (SCM_MOST_POSITIVE_FIXNUM / axx >= ayy)
8088 return SCM_I_MAKINUM (xx * yy);
8089 #endif
8090 else
8091 {
8092 SCM result = scm_i_inum2big (xx);
8093 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
8094 return scm_i_normbig (result);
8095 }
8096 }
8097 else if (SCM_BIGP (y))
8098 {
8099 /* There is one bignum which, when multiplied by negative one,
8100 becomes a non-zero fixnum: (1+ most-positive-fixum). Since
8101 we know the type of X and Y are numbers, delegate this
8102 special case to scm_difference. */
8103 if (xx == -1)
8104 return scm_difference (y, SCM_UNDEFINED);
8105 else
8106 {
8107 SCM result = scm_i_mkbig ();
8108 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
8109 scm_remember_upto_here_1 (y);
8110 return result;
8111 }
8112 }
8113 else if (SCM_REALP (y))
8114 return scm_i_from_double (xx * SCM_REAL_VALUE (y));
8115 else if (SCM_COMPLEXP (y))
8116 return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
8117 xx * SCM_COMPLEX_IMAG (y));
8118 else if (SCM_FRACTIONP (y))
8119 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
8120 SCM_FRACTION_DENOMINATOR (y));
8121 else
8122 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8123 }
8124 else if (SCM_BIGP (x))
8125 {
8126 if (SCM_I_INUMP (y))
8127 {
8128 SCM_SWAP (x, y);
8129 goto xinum;
8130 }
8131 else if (SCM_BIGP (y))
8132 {
8133 SCM result = scm_i_mkbig ();
8134 mpz_mul (SCM_I_BIG_MPZ (result),
8135 SCM_I_BIG_MPZ (x),
8136 SCM_I_BIG_MPZ (y));
8137 scm_remember_upto_here_2 (x, y);
8138 return result;
8139 }
8140 else if (SCM_REALP (y))
8141 {
8142 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
8143 scm_remember_upto_here_1 (x);
8144 return scm_i_from_double (result);
8145 }
8146 else if (SCM_COMPLEXP (y))
8147 {
8148 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
8149 scm_remember_upto_here_1 (x);
8150 return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (y),
8151 z * SCM_COMPLEX_IMAG (y));
8152 }
8153 else if (SCM_FRACTIONP (y))
8154 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
8155 SCM_FRACTION_DENOMINATOR (y));
8156 else
8157 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8158 }
8159 else if (SCM_REALP (x))
8160 {
8161 if (SCM_I_INUMP (y))
8162 {
8163 SCM_SWAP (x, y);
8164 goto xinum;
8165 }
8166 else if (SCM_BIGP (y))
8167 {
8168 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
8169 scm_remember_upto_here_1 (y);
8170 return scm_i_from_double (result);
8171 }
8172 else if (SCM_REALP (y))
8173 return scm_i_from_double (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
8174 else if (SCM_COMPLEXP (y))
8175 return scm_c_make_rectangular (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
8176 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
8177 else if (SCM_FRACTIONP (y))
8178 return scm_i_from_double (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
8179 else
8180 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8181 }
8182 else if (SCM_COMPLEXP (x))
8183 {
8184 if (SCM_I_INUMP (y))
8185 {
8186 SCM_SWAP (x, y);
8187 goto xinum;
8188 }
8189 else if (SCM_BIGP (y))
8190 {
8191 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
8192 scm_remember_upto_here_1 (y);
8193 return scm_c_make_rectangular (z * SCM_COMPLEX_REAL (x),
8194 z * SCM_COMPLEX_IMAG (x));
8195 }
8196 else if (SCM_REALP (y))
8197 return scm_c_make_rectangular (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
8198 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
8199 else if (SCM_COMPLEXP (y))
8200 {
8201 return scm_c_make_rectangular (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
8202 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
8203 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
8204 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
8205 }
8206 else if (SCM_FRACTIONP (y))
8207 {
8208 double yy = scm_i_fraction2double (y);
8209 return scm_c_make_rectangular (yy * SCM_COMPLEX_REAL (x),
8210 yy * SCM_COMPLEX_IMAG (x));
8211 }
8212 else
8213 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8214 }
8215 else if (SCM_FRACTIONP (x))
8216 {
8217 if (SCM_I_INUMP (y))
8218 return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
8219 SCM_FRACTION_DENOMINATOR (x));
8220 else if (SCM_BIGP (y))
8221 return scm_i_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
8222 SCM_FRACTION_DENOMINATOR (x));
8223 else if (SCM_REALP (y))
8224 return scm_i_from_double (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
8225 else if (SCM_COMPLEXP (y))
8226 {
8227 double xx = scm_i_fraction2double (x);
8228 return scm_c_make_rectangular (xx * SCM_COMPLEX_REAL (y),
8229 xx * SCM_COMPLEX_IMAG (y));
8230 }
8231 else if (SCM_FRACTIONP (y))
8232 /* a/b * c/d = ac / bd */
8233 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
8234 SCM_FRACTION_NUMERATOR (y)),
8235 scm_product (SCM_FRACTION_DENOMINATOR (x),
8236 SCM_FRACTION_DENOMINATOR (y)));
8237 else
8238 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARGn, s_product);
8239 }
8240 else
8241 return scm_wta_dispatch_2 (g_product, x, y, SCM_ARG1, s_product);
8242 }
8243
8244 #if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
8245 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
8246 #define ALLOW_DIVIDE_BY_ZERO
8247 /* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
8248 #endif
8249
8250 /* The code below for complex division is adapted from the GNU
8251 libstdc++, which adapted it from f2c's libF77, and is subject to
8252 this copyright: */
8253
8254 /****************************************************************
8255 Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
8256
8257 Permission to use, copy, modify, and distribute this software
8258 and its documentation for any purpose and without fee is hereby
8259 granted, provided that the above copyright notice appear in all
8260 copies and that both that the copyright notice and this
8261 permission notice and warranty disclaimer appear in supporting
8262 documentation, and that the names of AT&T Bell Laboratories or
8263 Bellcore or any of their entities not be used in advertising or
8264 publicity pertaining to distribution of the software without
8265 specific, written prior permission.
8266
8267 AT&T and Bellcore disclaim all warranties with regard to this
8268 software, including all implied warranties of merchantability
8269 and fitness. In no event shall AT&T or Bellcore be liable for
8270 any special, indirect or consequential damages or any damages
8271 whatsoever resulting from loss of use, data or profits, whether
8272 in an action of contract, negligence or other tortious action,
8273 arising out of or in connection with the use or performance of
8274 this software.
8275 ****************************************************************/
8276
8277 SCM_PRIMITIVE_GENERIC (scm_i_divide, "/", 0, 2, 1,
8278 (SCM x, SCM y, SCM rest),
8279 "Divide the first argument by the product of the remaining\n"
8280 "arguments. If called with one argument @var{z1}, 1/@var{z1} is\n"
8281 "returned.")
8282 #define FUNC_NAME s_scm_i_divide
8283 {
8284 while (!scm_is_null (rest))
8285 { x = scm_divide (x, y);
8286 y = scm_car (rest);
8287 rest = scm_cdr (rest);
8288 }
8289 return scm_divide (x, y);
8290 }
8291 #undef FUNC_NAME
8292
8293 #define s_divide s_scm_i_divide
8294 #define g_divide g_scm_i_divide
8295
8296 SCM
scm_divide(SCM x,SCM y)8297 scm_divide (SCM x, SCM y)
8298 #define FUNC_NAME s_divide
8299 {
8300 double a;
8301
8302 if (SCM_UNLIKELY (SCM_UNBNDP (y)))
8303 {
8304 if (SCM_UNBNDP (x))
8305 return scm_wta_dispatch_0 (g_divide, s_divide);
8306 else if (SCM_I_INUMP (x))
8307 {
8308 scm_t_inum xx = SCM_I_INUM (x);
8309 if (xx == 1 || xx == -1)
8310 return x;
8311 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8312 else if (xx == 0)
8313 scm_num_overflow (s_divide);
8314 #endif
8315 else
8316 return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
8317 }
8318 else if (SCM_BIGP (x))
8319 return scm_i_make_ratio_already_reduced (SCM_INUM1, x);
8320 else if (SCM_REALP (x))
8321 {
8322 double xx = SCM_REAL_VALUE (x);
8323 #ifndef ALLOW_DIVIDE_BY_ZERO
8324 if (xx == 0.0)
8325 scm_num_overflow (s_divide);
8326 else
8327 #endif
8328 return scm_i_from_double (1.0 / xx);
8329 }
8330 else if (SCM_COMPLEXP (x))
8331 {
8332 double r = SCM_COMPLEX_REAL (x);
8333 double i = SCM_COMPLEX_IMAG (x);
8334 if (fabs(r) <= fabs(i))
8335 {
8336 double t = r / i;
8337 double d = i * (1.0 + t * t);
8338 return scm_c_make_rectangular (t / d, -1.0 / d);
8339 }
8340 else
8341 {
8342 double t = i / r;
8343 double d = r * (1.0 + t * t);
8344 return scm_c_make_rectangular (1.0 / d, -t / d);
8345 }
8346 }
8347 else if (SCM_FRACTIONP (x))
8348 return scm_i_make_ratio_already_reduced (SCM_FRACTION_DENOMINATOR (x),
8349 SCM_FRACTION_NUMERATOR (x));
8350 else
8351 return scm_wta_dispatch_1 (g_divide, x, SCM_ARG1, s_divide);
8352 }
8353
8354 if (SCM_LIKELY (SCM_I_INUMP (x)))
8355 {
8356 scm_t_inum xx = SCM_I_INUM (x);
8357 if (SCM_LIKELY (SCM_I_INUMP (y)))
8358 {
8359 scm_t_inum yy = SCM_I_INUM (y);
8360 if (yy == 0)
8361 {
8362 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8363 scm_num_overflow (s_divide);
8364 #else
8365 return scm_i_from_double ((double) xx / (double) yy);
8366 #endif
8367 }
8368 else if (xx % yy != 0)
8369 return scm_i_make_ratio (x, y);
8370 else
8371 {
8372 scm_t_inum z = xx / yy;
8373 if (SCM_FIXABLE (z))
8374 return SCM_I_MAKINUM (z);
8375 else
8376 return scm_i_inum2big (z);
8377 }
8378 }
8379 else if (SCM_BIGP (y))
8380 return scm_i_make_ratio (x, y);
8381 else if (SCM_REALP (y))
8382 {
8383 double yy = SCM_REAL_VALUE (y);
8384 #ifndef ALLOW_DIVIDE_BY_ZERO
8385 if (yy == 0.0)
8386 scm_num_overflow (s_divide);
8387 else
8388 #endif
8389 /* FIXME: Precision may be lost here due to:
8390 (1) The cast from 'scm_t_inum' to 'double'
8391 (2) Double rounding */
8392 return scm_i_from_double ((double) xx / yy);
8393 }
8394 else if (SCM_COMPLEXP (y))
8395 {
8396 a = xx;
8397 complex_div: /* y _must_ be a complex number */
8398 {
8399 double r = SCM_COMPLEX_REAL (y);
8400 double i = SCM_COMPLEX_IMAG (y);
8401 if (fabs(r) <= fabs(i))
8402 {
8403 double t = r / i;
8404 double d = i * (1.0 + t * t);
8405 return scm_c_make_rectangular ((a * t) / d, -a / d);
8406 }
8407 else
8408 {
8409 double t = i / r;
8410 double d = r * (1.0 + t * t);
8411 return scm_c_make_rectangular (a / d, -(a * t) / d);
8412 }
8413 }
8414 }
8415 else if (SCM_FRACTIONP (y))
8416 /* a / b/c = ac / b */
8417 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
8418 SCM_FRACTION_NUMERATOR (y));
8419 else
8420 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
8421 }
8422 else if (SCM_BIGP (x))
8423 {
8424 if (SCM_I_INUMP (y))
8425 {
8426 scm_t_inum yy = SCM_I_INUM (y);
8427 if (yy == 0)
8428 {
8429 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8430 scm_num_overflow (s_divide);
8431 #else
8432 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
8433 scm_remember_upto_here_1 (x);
8434 return (sgn == 0) ? scm_nan () : scm_inf ();
8435 #endif
8436 }
8437 else if (yy == 1)
8438 return x;
8439 else
8440 {
8441 /* FIXME: HMM, what are the relative performance issues here?
8442 We need to test. Is it faster on average to test
8443 divisible_p, then perform whichever operation, or is it
8444 faster to perform the integer div opportunistically and
8445 switch to real if there's a remainder? For now we take the
8446 middle ground: test, then if divisible, use the faster div
8447 func. */
8448
8449 scm_t_inum abs_yy = yy < 0 ? -yy : yy;
8450 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
8451
8452 if (divisible_p)
8453 {
8454 SCM result = scm_i_mkbig ();
8455 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
8456 scm_remember_upto_here_1 (x);
8457 if (yy < 0)
8458 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
8459 return scm_i_normbig (result);
8460 }
8461 else
8462 return scm_i_make_ratio (x, y);
8463 }
8464 }
8465 else if (SCM_BIGP (y))
8466 {
8467 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
8468 SCM_I_BIG_MPZ (y));
8469 if (divisible_p)
8470 {
8471 SCM result = scm_i_mkbig ();
8472 mpz_divexact (SCM_I_BIG_MPZ (result),
8473 SCM_I_BIG_MPZ (x),
8474 SCM_I_BIG_MPZ (y));
8475 scm_remember_upto_here_2 (x, y);
8476 return scm_i_normbig (result);
8477 }
8478 else
8479 return scm_i_make_ratio (x, y);
8480 }
8481 else if (SCM_REALP (y))
8482 {
8483 double yy = SCM_REAL_VALUE (y);
8484 #ifndef ALLOW_DIVIDE_BY_ZERO
8485 if (yy == 0.0)
8486 scm_num_overflow (s_divide);
8487 else
8488 #endif
8489 /* FIXME: Precision may be lost here due to:
8490 (1) scm_i_big2dbl (2) Double rounding */
8491 return scm_i_from_double (scm_i_big2dbl (x) / yy);
8492 }
8493 else if (SCM_COMPLEXP (y))
8494 {
8495 a = scm_i_big2dbl (x);
8496 goto complex_div;
8497 }
8498 else if (SCM_FRACTIONP (y))
8499 return scm_i_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
8500 SCM_FRACTION_NUMERATOR (y));
8501 else
8502 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
8503 }
8504 else if (SCM_REALP (x))
8505 {
8506 double rx = SCM_REAL_VALUE (x);
8507 if (SCM_I_INUMP (y))
8508 {
8509 scm_t_inum yy = SCM_I_INUM (y);
8510 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8511 if (yy == 0)
8512 scm_num_overflow (s_divide);
8513 else
8514 #endif
8515 /* FIXME: Precision may be lost here due to:
8516 (1) The cast from 'scm_t_inum' to 'double'
8517 (2) Double rounding */
8518 return scm_i_from_double (rx / (double) yy);
8519 }
8520 else if (SCM_BIGP (y))
8521 {
8522 /* FIXME: Precision may be lost here due to:
8523 (1) The conversion from bignum to double
8524 (2) Double rounding */
8525 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
8526 scm_remember_upto_here_1 (y);
8527 return scm_i_from_double (rx / dby);
8528 }
8529 else if (SCM_REALP (y))
8530 {
8531 double yy = SCM_REAL_VALUE (y);
8532 #ifndef ALLOW_DIVIDE_BY_ZERO
8533 if (yy == 0.0)
8534 scm_num_overflow (s_divide);
8535 else
8536 #endif
8537 return scm_i_from_double (rx / yy);
8538 }
8539 else if (SCM_COMPLEXP (y))
8540 {
8541 a = rx;
8542 goto complex_div;
8543 }
8544 else if (SCM_FRACTIONP (y))
8545 return scm_i_from_double (rx / scm_i_fraction2double (y));
8546 else
8547 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
8548 }
8549 else if (SCM_COMPLEXP (x))
8550 {
8551 double rx = SCM_COMPLEX_REAL (x);
8552 double ix = SCM_COMPLEX_IMAG (x);
8553 if (SCM_I_INUMP (y))
8554 {
8555 scm_t_inum yy = SCM_I_INUM (y);
8556 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8557 if (yy == 0)
8558 scm_num_overflow (s_divide);
8559 else
8560 #endif
8561 {
8562 /* FIXME: Precision may be lost here due to:
8563 (1) The conversion from 'scm_t_inum' to double
8564 (2) Double rounding */
8565 double d = yy;
8566 return scm_c_make_rectangular (rx / d, ix / d);
8567 }
8568 }
8569 else if (SCM_BIGP (y))
8570 {
8571 /* FIXME: Precision may be lost here due to:
8572 (1) The conversion from bignum to double
8573 (2) Double rounding */
8574 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
8575 scm_remember_upto_here_1 (y);
8576 return scm_c_make_rectangular (rx / dby, ix / dby);
8577 }
8578 else if (SCM_REALP (y))
8579 {
8580 double yy = SCM_REAL_VALUE (y);
8581 #ifndef ALLOW_DIVIDE_BY_ZERO
8582 if (yy == 0.0)
8583 scm_num_overflow (s_divide);
8584 else
8585 #endif
8586 return scm_c_make_rectangular (rx / yy, ix / yy);
8587 }
8588 else if (SCM_COMPLEXP (y))
8589 {
8590 double ry = SCM_COMPLEX_REAL (y);
8591 double iy = SCM_COMPLEX_IMAG (y);
8592 if (fabs(ry) <= fabs(iy))
8593 {
8594 double t = ry / iy;
8595 double d = iy * (1.0 + t * t);
8596 return scm_c_make_rectangular ((rx * t + ix) / d, (ix * t - rx) / d);
8597 }
8598 else
8599 {
8600 double t = iy / ry;
8601 double d = ry * (1.0 + t * t);
8602 return scm_c_make_rectangular ((rx + ix * t) / d, (ix - rx * t) / d);
8603 }
8604 }
8605 else if (SCM_FRACTIONP (y))
8606 {
8607 /* FIXME: Precision may be lost here due to:
8608 (1) The conversion from fraction to double
8609 (2) Double rounding */
8610 double yy = scm_i_fraction2double (y);
8611 return scm_c_make_rectangular (rx / yy, ix / yy);
8612 }
8613 else
8614 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
8615 }
8616 else if (SCM_FRACTIONP (x))
8617 {
8618 if (SCM_I_INUMP (y))
8619 {
8620 scm_t_inum yy = SCM_I_INUM (y);
8621 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
8622 if (yy == 0)
8623 scm_num_overflow (s_divide);
8624 else
8625 #endif
8626 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
8627 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
8628 }
8629 else if (SCM_BIGP (y))
8630 {
8631 return scm_i_make_ratio (SCM_FRACTION_NUMERATOR (x),
8632 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
8633 }
8634 else if (SCM_REALP (y))
8635 {
8636 double yy = SCM_REAL_VALUE (y);
8637 #ifndef ALLOW_DIVIDE_BY_ZERO
8638 if (yy == 0.0)
8639 scm_num_overflow (s_divide);
8640 else
8641 #endif
8642 /* FIXME: Precision may be lost here due to:
8643 (1) The conversion from fraction to double
8644 (2) Double rounding */
8645 return scm_i_from_double (scm_i_fraction2double (x) / yy);
8646 }
8647 else if (SCM_COMPLEXP (y))
8648 {
8649 /* FIXME: Precision may be lost here due to:
8650 (1) The conversion from fraction to double
8651 (2) Double rounding */
8652 a = scm_i_fraction2double (x);
8653 goto complex_div;
8654 }
8655 else if (SCM_FRACTIONP (y))
8656 return scm_i_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
8657 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
8658 else
8659 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARGn, s_divide);
8660 }
8661 else
8662 return scm_wta_dispatch_2 (g_divide, x, y, SCM_ARG1, s_divide);
8663 }
8664 #undef FUNC_NAME
8665
8666
8667 double
scm_c_truncate(double x)8668 scm_c_truncate (double x)
8669 {
8670 return trunc (x);
8671 }
8672
8673 /* scm_c_round is done using floor(x+0.5) to round to nearest and with
8674 half-way case (ie. when x is an integer plus 0.5) going upwards.
8675 Then half-way cases are identified and adjusted down if the
8676 round-upwards didn't give the desired even integer.
8677
8678 "plus_half == result" identifies a half-way case. If plus_half, which is
8679 x + 0.5, is an integer then x must be an integer plus 0.5.
8680
8681 An odd "result" value is identified with result/2 != floor(result/2).
8682 This is done with plus_half, since that value is ready for use sooner in
8683 a pipelined cpu, and we're already requiring plus_half == result.
8684
8685 Note however that we need to be careful when x is big and already an
8686 integer. In that case "x+0.5" may round to an adjacent integer, causing
8687 us to return such a value, incorrectly. For instance if the hardware is
8688 in the usual default nearest-even rounding, then for x = 0x1FFFFFFFFFFFFF
8689 (ie. 53 one bits) we will have x+0.5 = 0x20000000000000 and that value
8690 returned. Or if the hardware is in round-upwards mode, then other bigger
8691 values like say x == 2^128 will see x+0.5 rounding up to the next higher
8692 representable value, 2^128+2^76 (or whatever), again incorrect.
8693
8694 These bad roundings of x+0.5 are avoided by testing at the start whether
8695 x is already an integer. If it is then clearly that's the desired result
8696 already. And if it's not then the exponent must be small enough to allow
8697 an 0.5 to be represented, and hence added without a bad rounding. */
8698
8699 double
scm_c_round(double x)8700 scm_c_round (double x)
8701 {
8702 double plus_half, result;
8703
8704 if (x == floor (x))
8705 return x;
8706
8707 plus_half = x + 0.5;
8708 result = floor (plus_half);
8709 /* Adjust so that the rounding is towards even. */
8710 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
8711 ? result - 1
8712 : result);
8713 }
8714
8715 SCM_PRIMITIVE_GENERIC (scm_truncate_number, "truncate", 1, 0, 0,
8716 (SCM x),
8717 "Round the number @var{x} towards zero.")
8718 #define FUNC_NAME s_scm_truncate_number
8719 {
8720 if (SCM_I_INUMP (x) || SCM_BIGP (x))
8721 return x;
8722 else if (SCM_REALP (x))
8723 return scm_i_from_double (trunc (SCM_REAL_VALUE (x)));
8724 else if (SCM_FRACTIONP (x))
8725 return scm_truncate_quotient (SCM_FRACTION_NUMERATOR (x),
8726 SCM_FRACTION_DENOMINATOR (x));
8727 else
8728 return scm_wta_dispatch_1 (g_scm_truncate_number, x, SCM_ARG1,
8729 s_scm_truncate_number);
8730 }
8731 #undef FUNC_NAME
8732
8733 SCM_PRIMITIVE_GENERIC (scm_round_number, "round", 1, 0, 0,
8734 (SCM x),
8735 "Round the number @var{x} towards the nearest integer. "
8736 "When it is exactly halfway between two integers, "
8737 "round towards the even one.")
8738 #define FUNC_NAME s_scm_round_number
8739 {
8740 if (SCM_I_INUMP (x) || SCM_BIGP (x))
8741 return x;
8742 else if (SCM_REALP (x))
8743 return scm_i_from_double (scm_c_round (SCM_REAL_VALUE (x)));
8744 else if (SCM_FRACTIONP (x))
8745 return scm_round_quotient (SCM_FRACTION_NUMERATOR (x),
8746 SCM_FRACTION_DENOMINATOR (x));
8747 else
8748 return scm_wta_dispatch_1 (g_scm_round_number, x, SCM_ARG1,
8749 s_scm_round_number);
8750 }
8751 #undef FUNC_NAME
8752
8753 SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
8754 (SCM x),
8755 "Round the number @var{x} towards minus infinity.")
8756 #define FUNC_NAME s_scm_floor
8757 {
8758 if (SCM_I_INUMP (x) || SCM_BIGP (x))
8759 return x;
8760 else if (SCM_REALP (x))
8761 return scm_i_from_double (floor (SCM_REAL_VALUE (x)));
8762 else if (SCM_FRACTIONP (x))
8763 return scm_floor_quotient (SCM_FRACTION_NUMERATOR (x),
8764 SCM_FRACTION_DENOMINATOR (x));
8765 else
8766 return scm_wta_dispatch_1 (g_scm_floor, x, 1, s_scm_floor);
8767 }
8768 #undef FUNC_NAME
8769
8770 SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
8771 (SCM x),
8772 "Round the number @var{x} towards infinity.")
8773 #define FUNC_NAME s_scm_ceiling
8774 {
8775 if (SCM_I_INUMP (x) || SCM_BIGP (x))
8776 return x;
8777 else if (SCM_REALP (x))
8778 return scm_i_from_double (ceil (SCM_REAL_VALUE (x)));
8779 else if (SCM_FRACTIONP (x))
8780 return scm_ceiling_quotient (SCM_FRACTION_NUMERATOR (x),
8781 SCM_FRACTION_DENOMINATOR (x));
8782 else
8783 return scm_wta_dispatch_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
8784 }
8785 #undef FUNC_NAME
8786
8787 SCM_PRIMITIVE_GENERIC (scm_expt, "expt", 2, 0, 0,
8788 (SCM x, SCM y),
8789 "Return @var{x} raised to the power of @var{y}.")
8790 #define FUNC_NAME s_scm_expt
8791 {
8792 if (scm_is_integer (y))
8793 {
8794 if (scm_is_true (scm_exact_p (y)))
8795 return scm_integer_expt (x, y);
8796 else
8797 {
8798 /* Here we handle the case where the exponent is an inexact
8799 integer. We make the exponent exact in order to use
8800 scm_integer_expt, and thus avoid the spurious imaginary
8801 parts that may result from round-off errors in the general
8802 e^(y log x) method below (for example when squaring a large
8803 negative number). In this case, we must return an inexact
8804 result for correctness. We also make the base inexact so
8805 that scm_integer_expt will use fast inexact arithmetic
8806 internally. Note that making the base inexact is not
8807 sufficient to guarantee an inexact result, because
8808 scm_integer_expt will return an exact 1 when the exponent
8809 is 0, even if the base is inexact. */
8810 return scm_exact_to_inexact
8811 (scm_integer_expt (scm_exact_to_inexact (x),
8812 scm_inexact_to_exact (y)));
8813 }
8814 }
8815 else if (scm_is_real (x) && scm_is_real (y) && scm_to_double (x) >= 0.0)
8816 {
8817 return scm_i_from_double (pow (scm_to_double (x), scm_to_double (y)));
8818 }
8819 else if (scm_is_complex (x) && scm_is_complex (y))
8820 return scm_exp (scm_product (scm_log (x), y));
8821 else if (scm_is_complex (x))
8822 return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG2, s_scm_expt);
8823 else
8824 return scm_wta_dispatch_2 (g_scm_expt, x, y, SCM_ARG1, s_scm_expt);
8825 }
8826 #undef FUNC_NAME
8827
8828 /* sin/cos/tan/asin/acos/atan
8829 sinh/cosh/tanh/asinh/acosh/atanh
8830 Derived from "Transcen.scm", Complex trancendental functions for SCM.
8831 Written by Jerry D. Hedden, (C) FSF.
8832 See the file `COPYING' for terms applying to this program. */
8833
8834 SCM_PRIMITIVE_GENERIC (scm_sin, "sin", 1, 0, 0,
8835 (SCM z),
8836 "Compute the sine of @var{z}.")
8837 #define FUNC_NAME s_scm_sin
8838 {
8839 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8840 return z; /* sin(exact0) = exact0 */
8841 else if (scm_is_real (z))
8842 return scm_i_from_double (sin (scm_to_double (z)));
8843 else if (SCM_COMPLEXP (z))
8844 { double x, y;
8845 x = SCM_COMPLEX_REAL (z);
8846 y = SCM_COMPLEX_IMAG (z);
8847 return scm_c_make_rectangular (sin (x) * cosh (y),
8848 cos (x) * sinh (y));
8849 }
8850 else
8851 return scm_wta_dispatch_1 (g_scm_sin, z, 1, s_scm_sin);
8852 }
8853 #undef FUNC_NAME
8854
8855 SCM_PRIMITIVE_GENERIC (scm_cos, "cos", 1, 0, 0,
8856 (SCM z),
8857 "Compute the cosine of @var{z}.")
8858 #define FUNC_NAME s_scm_cos
8859 {
8860 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8861 return SCM_INUM1; /* cos(exact0) = exact1 */
8862 else if (scm_is_real (z))
8863 return scm_i_from_double (cos (scm_to_double (z)));
8864 else if (SCM_COMPLEXP (z))
8865 { double x, y;
8866 x = SCM_COMPLEX_REAL (z);
8867 y = SCM_COMPLEX_IMAG (z);
8868 return scm_c_make_rectangular (cos (x) * cosh (y),
8869 -sin (x) * sinh (y));
8870 }
8871 else
8872 return scm_wta_dispatch_1 (g_scm_cos, z, 1, s_scm_cos);
8873 }
8874 #undef FUNC_NAME
8875
8876 SCM_PRIMITIVE_GENERIC (scm_tan, "tan", 1, 0, 0,
8877 (SCM z),
8878 "Compute the tangent of @var{z}.")
8879 #define FUNC_NAME s_scm_tan
8880 {
8881 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8882 return z; /* tan(exact0) = exact0 */
8883 else if (scm_is_real (z))
8884 return scm_i_from_double (tan (scm_to_double (z)));
8885 else if (SCM_COMPLEXP (z))
8886 { double x, y, w;
8887 x = 2.0 * SCM_COMPLEX_REAL (z);
8888 y = 2.0 * SCM_COMPLEX_IMAG (z);
8889 w = cos (x) + cosh (y);
8890 #ifndef ALLOW_DIVIDE_BY_ZERO
8891 if (w == 0.0)
8892 scm_num_overflow (s_scm_tan);
8893 #endif
8894 return scm_c_make_rectangular (sin (x) / w, sinh (y) / w);
8895 }
8896 else
8897 return scm_wta_dispatch_1 (g_scm_tan, z, 1, s_scm_tan);
8898 }
8899 #undef FUNC_NAME
8900
8901 SCM_PRIMITIVE_GENERIC (scm_sinh, "sinh", 1, 0, 0,
8902 (SCM z),
8903 "Compute the hyperbolic sine of @var{z}.")
8904 #define FUNC_NAME s_scm_sinh
8905 {
8906 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8907 return z; /* sinh(exact0) = exact0 */
8908 else if (scm_is_real (z))
8909 return scm_i_from_double (sinh (scm_to_double (z)));
8910 else if (SCM_COMPLEXP (z))
8911 { double x, y;
8912 x = SCM_COMPLEX_REAL (z);
8913 y = SCM_COMPLEX_IMAG (z);
8914 return scm_c_make_rectangular (sinh (x) * cos (y),
8915 cosh (x) * sin (y));
8916 }
8917 else
8918 return scm_wta_dispatch_1 (g_scm_sinh, z, 1, s_scm_sinh);
8919 }
8920 #undef FUNC_NAME
8921
8922 SCM_PRIMITIVE_GENERIC (scm_cosh, "cosh", 1, 0, 0,
8923 (SCM z),
8924 "Compute the hyperbolic cosine of @var{z}.")
8925 #define FUNC_NAME s_scm_cosh
8926 {
8927 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8928 return SCM_INUM1; /* cosh(exact0) = exact1 */
8929 else if (scm_is_real (z))
8930 return scm_i_from_double (cosh (scm_to_double (z)));
8931 else if (SCM_COMPLEXP (z))
8932 { double x, y;
8933 x = SCM_COMPLEX_REAL (z);
8934 y = SCM_COMPLEX_IMAG (z);
8935 return scm_c_make_rectangular (cosh (x) * cos (y),
8936 sinh (x) * sin (y));
8937 }
8938 else
8939 return scm_wta_dispatch_1 (g_scm_cosh, z, 1, s_scm_cosh);
8940 }
8941 #undef FUNC_NAME
8942
8943 SCM_PRIMITIVE_GENERIC (scm_tanh, "tanh", 1, 0, 0,
8944 (SCM z),
8945 "Compute the hyperbolic tangent of @var{z}.")
8946 #define FUNC_NAME s_scm_tanh
8947 {
8948 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8949 return z; /* tanh(exact0) = exact0 */
8950 else if (scm_is_real (z))
8951 return scm_i_from_double (tanh (scm_to_double (z)));
8952 else if (SCM_COMPLEXP (z))
8953 { double x, y, w;
8954 x = 2.0 * SCM_COMPLEX_REAL (z);
8955 y = 2.0 * SCM_COMPLEX_IMAG (z);
8956 w = cosh (x) + cos (y);
8957 #ifndef ALLOW_DIVIDE_BY_ZERO
8958 if (w == 0.0)
8959 scm_num_overflow (s_scm_tanh);
8960 #endif
8961 return scm_c_make_rectangular (sinh (x) / w, sin (y) / w);
8962 }
8963 else
8964 return scm_wta_dispatch_1 (g_scm_tanh, z, 1, s_scm_tanh);
8965 }
8966 #undef FUNC_NAME
8967
8968 SCM_PRIMITIVE_GENERIC (scm_asin, "asin", 1, 0, 0,
8969 (SCM z),
8970 "Compute the arc sine of @var{z}.")
8971 #define FUNC_NAME s_scm_asin
8972 {
8973 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
8974 return z; /* asin(exact0) = exact0 */
8975 else if (scm_is_real (z))
8976 {
8977 double w = scm_to_double (z);
8978 if (w >= -1.0 && w <= 1.0)
8979 return scm_i_from_double (asin (w));
8980 else
8981 return scm_product (scm_c_make_rectangular (0, -1),
8982 scm_sys_asinh (scm_c_make_rectangular (0, w)));
8983 }
8984 else if (SCM_COMPLEXP (z))
8985 { double x, y;
8986 x = SCM_COMPLEX_REAL (z);
8987 y = SCM_COMPLEX_IMAG (z);
8988 return scm_product (scm_c_make_rectangular (0, -1),
8989 scm_sys_asinh (scm_c_make_rectangular (-y, x)));
8990 }
8991 else
8992 return scm_wta_dispatch_1 (g_scm_asin, z, 1, s_scm_asin);
8993 }
8994 #undef FUNC_NAME
8995
8996 SCM_PRIMITIVE_GENERIC (scm_acos, "acos", 1, 0, 0,
8997 (SCM z),
8998 "Compute the arc cosine of @var{z}.")
8999 #define FUNC_NAME s_scm_acos
9000 {
9001 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
9002 return SCM_INUM0; /* acos(exact1) = exact0 */
9003 else if (scm_is_real (z))
9004 {
9005 double w = scm_to_double (z);
9006 if (w >= -1.0 && w <= 1.0)
9007 return scm_i_from_double (acos (w));
9008 else
9009 return scm_sum (scm_i_from_double (acos (0.0)),
9010 scm_product (scm_c_make_rectangular (0, 1),
9011 scm_sys_asinh (scm_c_make_rectangular (0, w))));
9012 }
9013 else if (SCM_COMPLEXP (z))
9014 { double x, y;
9015 x = SCM_COMPLEX_REAL (z);
9016 y = SCM_COMPLEX_IMAG (z);
9017 return scm_sum (scm_i_from_double (acos (0.0)),
9018 scm_product (scm_c_make_rectangular (0, 1),
9019 scm_sys_asinh (scm_c_make_rectangular (-y, x))));
9020 }
9021 else
9022 return scm_wta_dispatch_1 (g_scm_acos, z, 1, s_scm_acos);
9023 }
9024 #undef FUNC_NAME
9025
9026 SCM_PRIMITIVE_GENERIC (scm_atan, "atan", 1, 1, 0,
9027 (SCM z, SCM y),
9028 "With one argument, compute the arc tangent of @var{z}.\n"
9029 "If @var{y} is present, compute the arc tangent of @var{z}/@var{y},\n"
9030 "using the sign of @var{z} and @var{y} to determine the quadrant.")
9031 #define FUNC_NAME s_scm_atan
9032 {
9033 if (SCM_UNBNDP (y))
9034 {
9035 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
9036 return z; /* atan(exact0) = exact0 */
9037 else if (scm_is_real (z))
9038 return scm_i_from_double (atan (scm_to_double (z)));
9039 else if (SCM_COMPLEXP (z))
9040 {
9041 double v, w;
9042 v = SCM_COMPLEX_REAL (z);
9043 w = SCM_COMPLEX_IMAG (z);
9044 return scm_divide (scm_log (scm_divide (scm_c_make_rectangular (-v, 1.0 - w),
9045 scm_c_make_rectangular ( v, 1.0 + w))),
9046 scm_c_make_rectangular (0, 2));
9047 }
9048 else
9049 return scm_wta_dispatch_1 (g_scm_atan, z, SCM_ARG1, s_scm_atan);
9050 }
9051 else if (scm_is_real (z))
9052 {
9053 if (scm_is_real (y))
9054 return scm_i_from_double (atan2 (scm_to_double (z), scm_to_double (y)));
9055 else
9056 return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG2, s_scm_atan);
9057 }
9058 else
9059 return scm_wta_dispatch_2 (g_scm_atan, z, y, SCM_ARG1, s_scm_atan);
9060 }
9061 #undef FUNC_NAME
9062
9063 SCM_PRIMITIVE_GENERIC (scm_sys_asinh, "asinh", 1, 0, 0,
9064 (SCM z),
9065 "Compute the inverse hyperbolic sine of @var{z}.")
9066 #define FUNC_NAME s_scm_sys_asinh
9067 {
9068 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
9069 return z; /* asinh(exact0) = exact0 */
9070 else if (scm_is_real (z))
9071 return scm_i_from_double (asinh (scm_to_double (z)));
9072 else if (scm_is_number (z))
9073 return scm_log (scm_sum (z,
9074 scm_sqrt (scm_sum (scm_product (z, z),
9075 SCM_INUM1))));
9076 else
9077 return scm_wta_dispatch_1 (g_scm_sys_asinh, z, 1, s_scm_sys_asinh);
9078 }
9079 #undef FUNC_NAME
9080
9081 SCM_PRIMITIVE_GENERIC (scm_sys_acosh, "acosh", 1, 0, 0,
9082 (SCM z),
9083 "Compute the inverse hyperbolic cosine of @var{z}.")
9084 #define FUNC_NAME s_scm_sys_acosh
9085 {
9086 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM1)))
9087 return SCM_INUM0; /* acosh(exact1) = exact0 */
9088 else if (scm_is_real (z) && scm_to_double (z) >= 1.0)
9089 return scm_i_from_double (acosh (scm_to_double (z)));
9090 else if (scm_is_number (z))
9091 return scm_log (scm_sum (z,
9092 scm_sqrt (scm_difference (scm_product (z, z),
9093 SCM_INUM1))));
9094 else
9095 return scm_wta_dispatch_1 (g_scm_sys_acosh, z, 1, s_scm_sys_acosh);
9096 }
9097 #undef FUNC_NAME
9098
9099 SCM_PRIMITIVE_GENERIC (scm_sys_atanh, "atanh", 1, 0, 0,
9100 (SCM z),
9101 "Compute the inverse hyperbolic tangent of @var{z}.")
9102 #define FUNC_NAME s_scm_sys_atanh
9103 {
9104 if (SCM_UNLIKELY (scm_is_eq (z, SCM_INUM0)))
9105 return z; /* atanh(exact0) = exact0 */
9106 else if (scm_is_real (z) && scm_to_double (z) >= -1.0 && scm_to_double (z) <= 1.0)
9107 return scm_i_from_double (atanh (scm_to_double (z)));
9108 else if (scm_is_number (z))
9109 return scm_divide (scm_log (scm_divide (scm_sum (SCM_INUM1, z),
9110 scm_difference (SCM_INUM1, z))),
9111 SCM_I_MAKINUM (2));
9112 else
9113 return scm_wta_dispatch_1 (g_scm_sys_atanh, z, 1, s_scm_sys_atanh);
9114 }
9115 #undef FUNC_NAME
9116
9117 SCM
scm_c_make_rectangular(double re,double im)9118 scm_c_make_rectangular (double re, double im)
9119 {
9120 SCM z;
9121
9122 z = SCM_PACK_POINTER (scm_gc_malloc_pointerless (sizeof (scm_t_complex),
9123 "complex"));
9124 SCM_SET_CELL_TYPE (z, scm_tc16_complex);
9125 SCM_COMPLEX_REAL (z) = re;
9126 SCM_COMPLEX_IMAG (z) = im;
9127 return z;
9128 }
9129
9130 SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
9131 (SCM real_part, SCM imaginary_part),
9132 "Return a complex number constructed of the given @var{real_part} "
9133 "and @var{imaginary_part} parts.")
9134 #define FUNC_NAME s_scm_make_rectangular
9135 {
9136 SCM_ASSERT_TYPE (scm_is_real (real_part), real_part,
9137 SCM_ARG1, FUNC_NAME, "real");
9138 SCM_ASSERT_TYPE (scm_is_real (imaginary_part), imaginary_part,
9139 SCM_ARG2, FUNC_NAME, "real");
9140
9141 /* Return a real if and only if the imaginary_part is an _exact_ 0 */
9142 if (scm_is_eq (imaginary_part, SCM_INUM0))
9143 return real_part;
9144 else
9145 return scm_c_make_rectangular (scm_to_double (real_part),
9146 scm_to_double (imaginary_part));
9147 }
9148 #undef FUNC_NAME
9149
9150 SCM
scm_c_make_polar(double mag,double ang)9151 scm_c_make_polar (double mag, double ang)
9152 {
9153 double s, c;
9154
9155 /* The sincos(3) function is undocumented an broken on Tru64. Thus we only
9156 use it on Glibc-based systems that have it (it's a GNU extension). See
9157 http://lists.gnu.org/archive/html/guile-user/2009-04/msg00033.html for
9158 details. */
9159 #if (defined HAVE_SINCOS) && (defined __GLIBC__) && (defined _GNU_SOURCE)
9160 sincos (ang, &s, &c);
9161 #elif (defined HAVE___SINCOS)
9162 __sincos (ang, &s, &c);
9163 #else
9164 s = sin (ang);
9165 c = cos (ang);
9166 #endif
9167
9168 /* If s and c are NaNs, this indicates that the angle is a NaN,
9169 infinite, or perhaps simply too large to determine its value
9170 mod 2*pi. However, we know something that the floating-point
9171 implementation doesn't know: We know that s and c are finite.
9172 Therefore, if the magnitude is zero, return a complex zero.
9173
9174 The reason we check for the NaNs instead of using this case
9175 whenever mag == 0.0 is because when the angle is known, we'd
9176 like to return the correct kind of non-real complex zero:
9177 +0.0+0.0i, -0.0+0.0i, -0.0-0.0i, or +0.0-0.0i, depending
9178 on which quadrant the angle is in.
9179 */
9180 if (SCM_UNLIKELY (isnan(s)) && isnan(c) && (mag == 0.0))
9181 return scm_c_make_rectangular (0.0, 0.0);
9182 else
9183 return scm_c_make_rectangular (mag * c, mag * s);
9184 }
9185
9186 SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
9187 (SCM mag, SCM ang),
9188 "Return the complex number @var{mag} * e^(i * @var{ang}).")
9189 #define FUNC_NAME s_scm_make_polar
9190 {
9191 SCM_ASSERT_TYPE (scm_is_real (mag), mag, SCM_ARG1, FUNC_NAME, "real");
9192 SCM_ASSERT_TYPE (scm_is_real (ang), ang, SCM_ARG2, FUNC_NAME, "real");
9193
9194 /* If mag is exact0, return exact0 */
9195 if (scm_is_eq (mag, SCM_INUM0))
9196 return SCM_INUM0;
9197 /* Return a real if ang is exact0 */
9198 else if (scm_is_eq (ang, SCM_INUM0))
9199 return mag;
9200 else
9201 return scm_c_make_polar (scm_to_double (mag), scm_to_double (ang));
9202 }
9203 #undef FUNC_NAME
9204
9205
9206 SCM_PRIMITIVE_GENERIC (scm_real_part, "real-part", 1, 0, 0,
9207 (SCM z),
9208 "Return the real part of the number @var{z}.")
9209 #define FUNC_NAME s_scm_real_part
9210 {
9211 if (SCM_COMPLEXP (z))
9212 return scm_i_from_double (SCM_COMPLEX_REAL (z));
9213 else if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_REALP (z) || SCM_FRACTIONP (z))
9214 return z;
9215 else
9216 return scm_wta_dispatch_1 (g_scm_real_part, z, SCM_ARG1, s_scm_real_part);
9217 }
9218 #undef FUNC_NAME
9219
9220
9221 SCM_PRIMITIVE_GENERIC (scm_imag_part, "imag-part", 1, 0, 0,
9222 (SCM z),
9223 "Return the imaginary part of the number @var{z}.")
9224 #define FUNC_NAME s_scm_imag_part
9225 {
9226 if (SCM_COMPLEXP (z))
9227 return scm_i_from_double (SCM_COMPLEX_IMAG (z));
9228 else if (SCM_I_INUMP (z) || SCM_REALP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
9229 return SCM_INUM0;
9230 else
9231 return scm_wta_dispatch_1 (g_scm_imag_part, z, SCM_ARG1, s_scm_imag_part);
9232 }
9233 #undef FUNC_NAME
9234
9235 SCM_PRIMITIVE_GENERIC (scm_numerator, "numerator", 1, 0, 0,
9236 (SCM z),
9237 "Return the numerator of the number @var{z}.")
9238 #define FUNC_NAME s_scm_numerator
9239 {
9240 if (SCM_I_INUMP (z) || SCM_BIGP (z))
9241 return z;
9242 else if (SCM_FRACTIONP (z))
9243 return SCM_FRACTION_NUMERATOR (z);
9244 else if (SCM_REALP (z))
9245 {
9246 double zz = SCM_REAL_VALUE (z);
9247 if (zz == floor (zz))
9248 /* Handle -0.0 and infinities in accordance with R6RS
9249 flnumerator, and optimize handling of integers. */
9250 return z;
9251 else
9252 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
9253 }
9254 else
9255 return scm_wta_dispatch_1 (g_scm_numerator, z, SCM_ARG1, s_scm_numerator);
9256 }
9257 #undef FUNC_NAME
9258
9259
9260 SCM_PRIMITIVE_GENERIC (scm_denominator, "denominator", 1, 0, 0,
9261 (SCM z),
9262 "Return the denominator of the number @var{z}.")
9263 #define FUNC_NAME s_scm_denominator
9264 {
9265 if (SCM_I_INUMP (z) || SCM_BIGP (z))
9266 return SCM_INUM1;
9267 else if (SCM_FRACTIONP (z))
9268 return SCM_FRACTION_DENOMINATOR (z);
9269 else if (SCM_REALP (z))
9270 {
9271 double zz = SCM_REAL_VALUE (z);
9272 if (zz == floor (zz))
9273 /* Handle infinities in accordance with R6RS fldenominator, and
9274 optimize handling of integers. */
9275 return scm_i_from_double (1.0);
9276 else
9277 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
9278 }
9279 else
9280 return scm_wta_dispatch_1 (g_scm_denominator, z, SCM_ARG1,
9281 s_scm_denominator);
9282 }
9283 #undef FUNC_NAME
9284
9285
9286 SCM_PRIMITIVE_GENERIC (scm_magnitude, "magnitude", 1, 0, 0,
9287 (SCM z),
9288 "Return the magnitude of the number @var{z}. This is the same as\n"
9289 "@code{abs} for real arguments, but also allows complex numbers.")
9290 #define FUNC_NAME s_scm_magnitude
9291 {
9292 if (SCM_I_INUMP (z))
9293 {
9294 scm_t_inum zz = SCM_I_INUM (z);
9295 if (zz >= 0)
9296 return z;
9297 else if (SCM_POSFIXABLE (-zz))
9298 return SCM_I_MAKINUM (-zz);
9299 else
9300 return scm_i_inum2big (-zz);
9301 }
9302 else if (SCM_BIGP (z))
9303 {
9304 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
9305 scm_remember_upto_here_1 (z);
9306 if (sgn < 0)
9307 return scm_i_clonebig (z, 0);
9308 else
9309 return z;
9310 }
9311 else if (SCM_REALP (z))
9312 return scm_i_from_double (fabs (SCM_REAL_VALUE (z)));
9313 else if (SCM_COMPLEXP (z))
9314 return scm_i_from_double (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
9315 else if (SCM_FRACTIONP (z))
9316 {
9317 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
9318 return z;
9319 return scm_i_make_ratio_already_reduced
9320 (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
9321 SCM_FRACTION_DENOMINATOR (z));
9322 }
9323 else
9324 return scm_wta_dispatch_1 (g_scm_magnitude, z, SCM_ARG1,
9325 s_scm_magnitude);
9326 }
9327 #undef FUNC_NAME
9328
9329
9330 SCM_PRIMITIVE_GENERIC (scm_angle, "angle", 1, 0, 0,
9331 (SCM z),
9332 "Return the angle of the complex number @var{z}.")
9333 #define FUNC_NAME s_scm_angle
9334 {
9335 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
9336 flo0 to save allocating a new flonum with scm_i_from_double each time.
9337 But if atan2 follows the floating point rounding mode, then the value
9338 is not a constant. Maybe it'd be close enough though. */
9339 if (SCM_I_INUMP (z))
9340 {
9341 if (SCM_I_INUM (z) >= 0)
9342 return flo0;
9343 else
9344 return scm_i_from_double (atan2 (0.0, -1.0));
9345 }
9346 else if (SCM_BIGP (z))
9347 {
9348 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
9349 scm_remember_upto_here_1 (z);
9350 if (sgn < 0)
9351 return scm_i_from_double (atan2 (0.0, -1.0));
9352 else
9353 return flo0;
9354 }
9355 else if (SCM_REALP (z))
9356 {
9357 double x = SCM_REAL_VALUE (z);
9358 if (copysign (1.0, x) > 0.0)
9359 return flo0;
9360 else
9361 return scm_i_from_double (atan2 (0.0, -1.0));
9362 }
9363 else if (SCM_COMPLEXP (z))
9364 return scm_i_from_double (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
9365 else if (SCM_FRACTIONP (z))
9366 {
9367 if (scm_is_false (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
9368 return flo0;
9369 else return scm_i_from_double (atan2 (0.0, -1.0));
9370 }
9371 else
9372 return scm_wta_dispatch_1 (g_scm_angle, z, SCM_ARG1, s_scm_angle);
9373 }
9374 #undef FUNC_NAME
9375
9376
9377 SCM_PRIMITIVE_GENERIC (scm_exact_to_inexact, "exact->inexact", 1, 0, 0,
9378 (SCM z),
9379 "Convert the number @var{z} to its inexact representation.\n")
9380 #define FUNC_NAME s_scm_exact_to_inexact
9381 {
9382 if (SCM_I_INUMP (z))
9383 return scm_i_from_double ((double) SCM_I_INUM (z));
9384 else if (SCM_BIGP (z))
9385 return scm_i_from_double (scm_i_big2dbl (z));
9386 else if (SCM_FRACTIONP (z))
9387 return scm_i_from_double (scm_i_fraction2double (z));
9388 else if (SCM_INEXACTP (z))
9389 return z;
9390 else
9391 return scm_wta_dispatch_1 (g_scm_exact_to_inexact, z, 1,
9392 s_scm_exact_to_inexact);
9393 }
9394 #undef FUNC_NAME
9395
9396
9397 SCM_PRIMITIVE_GENERIC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
9398 (SCM z),
9399 "Return an exact number that is numerically closest to @var{z}.")
9400 #define FUNC_NAME s_scm_inexact_to_exact
9401 {
9402 if (SCM_I_INUMP (z) || SCM_BIGP (z) || SCM_FRACTIONP (z))
9403 return z;
9404 else
9405 {
9406 double val;
9407
9408 if (SCM_REALP (z))
9409 val = SCM_REAL_VALUE (z);
9410 else if (SCM_COMPLEXP (z) && SCM_COMPLEX_IMAG (z) == 0.0)
9411 val = SCM_COMPLEX_REAL (z);
9412 else
9413 return scm_wta_dispatch_1 (g_scm_inexact_to_exact, z, 1,
9414 s_scm_inexact_to_exact);
9415
9416 if (!SCM_LIKELY (isfinite (val)))
9417 SCM_OUT_OF_RANGE (1, z);
9418 else if (val == 0.0)
9419 return SCM_INUM0;
9420 else
9421 {
9422 int expon;
9423 SCM numerator;
9424
9425 numerator = scm_i_dbl2big (ldexp (frexp (val, &expon),
9426 DBL_MANT_DIG));
9427 expon -= DBL_MANT_DIG;
9428 if (expon < 0)
9429 {
9430 int shift = mpz_scan1 (SCM_I_BIG_MPZ (numerator), 0);
9431
9432 if (shift > -expon)
9433 shift = -expon;
9434 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (numerator),
9435 SCM_I_BIG_MPZ (numerator),
9436 shift);
9437 expon += shift;
9438 }
9439 numerator = scm_i_normbig (numerator);
9440 if (expon < 0)
9441 return scm_i_make_ratio_already_reduced
9442 (numerator, left_shift_exact_integer (SCM_INUM1, -expon));
9443 else if (expon > 0)
9444 return left_shift_exact_integer (numerator, expon);
9445 else
9446 return numerator;
9447 }
9448 }
9449 }
9450 #undef FUNC_NAME
9451
9452 SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
9453 (SCM x, SCM eps),
9454 "Returns the @emph{simplest} rational number differing\n"
9455 "from @var{x} by no more than @var{eps}.\n"
9456 "\n"
9457 "As required by @acronym{R5RS}, @code{rationalize} only returns an\n"
9458 "exact result when both its arguments are exact. Thus, you might need\n"
9459 "to use @code{inexact->exact} on the arguments.\n"
9460 "\n"
9461 "@lisp\n"
9462 "(rationalize (inexact->exact 1.2) 1/100)\n"
9463 "@result{} 6/5\n"
9464 "@end lisp")
9465 #define FUNC_NAME s_scm_rationalize
9466 {
9467 SCM_ASSERT_TYPE (scm_is_real (x), x, SCM_ARG1, FUNC_NAME, "real");
9468 SCM_ASSERT_TYPE (scm_is_real (eps), eps, SCM_ARG2, FUNC_NAME, "real");
9469
9470 if (SCM_UNLIKELY (!scm_is_exact (eps) || !scm_is_exact (x)))
9471 {
9472 if (SCM_UNLIKELY (scm_is_false (scm_finite_p (eps))))
9473 {
9474 if (scm_is_false (scm_nan_p (eps)) && scm_is_true (scm_finite_p (x)))
9475 return flo0;
9476 else
9477 return scm_nan ();
9478 }
9479 else if (SCM_UNLIKELY (scm_is_false (scm_finite_p (x))))
9480 return x;
9481 else
9482 return scm_exact_to_inexact
9483 (scm_rationalize (scm_inexact_to_exact (x),
9484 scm_inexact_to_exact (eps)));
9485 }
9486 else
9487 {
9488 /* X and EPS are exact rationals.
9489
9490 The code that follows is equivalent to the following Scheme code:
9491
9492 (define (exact-rationalize x eps)
9493 (let ((n1 (if (negative? x) -1 1))
9494 (x (abs x))
9495 (eps (abs eps)))
9496 (let ((lo (- x eps))
9497 (hi (+ x eps)))
9498 (if (<= lo 0)
9499 0
9500 (let loop ((nlo (numerator lo)) (dlo (denominator lo))
9501 (nhi (numerator hi)) (dhi (denominator hi))
9502 (n1 n1) (d1 0) (n2 0) (d2 1))
9503 (let-values (((qlo rlo) (floor/ nlo dlo))
9504 ((qhi rhi) (floor/ nhi dhi)))
9505 (let ((n0 (+ n2 (* n1 qlo)))
9506 (d0 (+ d2 (* d1 qlo))))
9507 (cond ((zero? rlo) (/ n0 d0))
9508 ((< qlo qhi) (/ (+ n0 n1) (+ d0 d1)))
9509 (else (loop dhi rhi dlo rlo n0 d0 n1 d1))))))))))
9510 */
9511
9512 int n1_init = 1;
9513 SCM lo, hi;
9514
9515 eps = scm_abs (eps);
9516 if (scm_is_true (scm_negative_p (x)))
9517 {
9518 n1_init = -1;
9519 x = scm_difference (x, SCM_UNDEFINED);
9520 }
9521
9522 /* X and EPS are non-negative exact rationals. */
9523
9524 lo = scm_difference (x, eps);
9525 hi = scm_sum (x, eps);
9526
9527 if (scm_is_false (scm_positive_p (lo)))
9528 /* If zero is included in the interval, return it.
9529 It is the simplest rational of all. */
9530 return SCM_INUM0;
9531 else
9532 {
9533 SCM result;
9534 mpz_t n0, d0, n1, d1, n2, d2;
9535 mpz_t nlo, dlo, nhi, dhi;
9536 mpz_t qlo, rlo, qhi, rhi;
9537
9538 /* LO and HI are positive exact rationals. */
9539
9540 /* Our approach here follows the method described by Alan
9541 Bawden in a message entitled "(rationalize x y)" on the
9542 rrrs-authors mailing list, dated 16 Feb 1988 14:08:28 EST:
9543
9544 http://groups.csail.mit.edu/mac/ftpdir/scheme-mail/HTML/rrrs-1988/msg00063.html
9545
9546 In brief, we compute the continued fractions of the two
9547 endpoints of the interval (LO and HI). The continued
9548 fraction of the result consists of the common prefix of the
9549 continued fractions of LO and HI, plus one final term. The
9550 final term of the result is the smallest integer contained
9551 in the interval between the remainders of LO and HI after
9552 the common prefix has been removed.
9553
9554 The following code lazily computes the continued fraction
9555 representations of LO and HI, and simultaneously converts
9556 the continued fraction of the result into a rational
9557 number. We use MPZ functions directly to avoid type
9558 dispatch and GC allocation during the loop. */
9559
9560 mpz_inits (n0, d0, n1, d1, n2, d2,
9561 nlo, dlo, nhi, dhi,
9562 qlo, rlo, qhi, rhi,
9563 NULL);
9564
9565 /* The variables N1, D1, N2 and D2 are used to compute the
9566 resulting rational from its continued fraction. At each
9567 step, N2/D2 and N1/D1 are the last two convergents. They
9568 are normally initialized to 0/1 and 1/0, respectively.
9569 However, if we negated X then we must negate the result as
9570 well, and we do that by initializing N1/D1 to -1/0. */
9571 mpz_set_si (n1, n1_init);
9572 mpz_set_ui (d1, 0);
9573 mpz_set_ui (n2, 0);
9574 mpz_set_ui (d2, 1);
9575
9576 /* The variables NLO, DLO, NHI, and DHI are used to lazily
9577 compute the continued fraction representations of LO and HI
9578 using Euclid's algorithm. Initially, NLO/DLO == LO and
9579 NHI/DHI == HI. */
9580 scm_to_mpz (scm_numerator (lo), nlo);
9581 scm_to_mpz (scm_denominator (lo), dlo);
9582 scm_to_mpz (scm_numerator (hi), nhi);
9583 scm_to_mpz (scm_denominator (hi), dhi);
9584
9585 /* As long as we're using exact arithmetic, the following loop
9586 is guaranteed to terminate. */
9587 for (;;)
9588 {
9589 /* Compute the next terms (QLO and QHI) of the continued
9590 fractions of LO and HI. */
9591 mpz_fdiv_qr (qlo, rlo, nlo, dlo); /* QLO <-- floor (NLO/DLO), RLO <-- NLO - QLO * DLO */
9592 mpz_fdiv_qr (qhi, rhi, nhi, dhi); /* QHI <-- floor (NHI/DHI), RHI <-- NHI - QHI * DHI */
9593
9594 /* The next term of the result will be either QLO or
9595 QLO+1. Here we compute the next convergent of the
9596 result based on the assumption that QLO is the next
9597 term. If that turns out to be wrong, we'll adjust
9598 these later by adding N1 to N0 and D1 to D0. */
9599 mpz_set (n0, n2); mpz_addmul (n0, n1, qlo); /* N0 <-- N2 + (QLO * N1) */
9600 mpz_set (d0, d2); mpz_addmul (d0, d1, qlo); /* D0 <-- D2 + (QLO * D1) */
9601
9602 /* We stop iterating when an integer is contained in the
9603 interval between the remainders NLO/DLO and NHI/DHI.
9604 There are two cases to consider: either NLO/DLO == QLO
9605 is an integer (indicated by RLO == 0), or QLO < QHI. */
9606 if (mpz_sgn (rlo) == 0 || mpz_cmp (qlo, qhi) != 0)
9607 break;
9608
9609 /* Efficiently shuffle variables around for the next
9610 iteration. First we shift the recent convergents. */
9611 mpz_swap (n2, n1); mpz_swap (n1, n0); /* N2 <-- N1 <-- N0 */
9612 mpz_swap (d2, d1); mpz_swap (d1, d0); /* D2 <-- D1 <-- D0 */
9613
9614 /* The following shuffling is a bit confusing, so some
9615 explanation is in order. Conceptually, we're doing a
9616 couple of things here. After substracting the floor of
9617 NLO/DLO, the remainder is RLO/DLO. The rest of the
9618 continued fraction will represent the remainder's
9619 reciprocal DLO/RLO. Similarly for the HI endpoint.
9620 So in the next iteration, the new endpoints will be
9621 DLO/RLO and DHI/RHI. However, when we take the
9622 reciprocals of these endpoints, their order is
9623 switched. So in summary, we want NLO/DLO <-- DHI/RHI
9624 and NHI/DHI <-- DLO/RLO. */
9625 mpz_swap (nlo, dhi); mpz_swap (dhi, rlo); /* NLO <-- DHI <-- RLO */
9626 mpz_swap (nhi, dlo); mpz_swap (dlo, rhi); /* NHI <-- DLO <-- RHI */
9627 }
9628
9629 /* There is now an integer in the interval [NLO/DLO NHI/DHI].
9630 The last term of the result will be the smallest integer in
9631 that interval, which is ceiling(NLO/DLO). We have already
9632 computed floor(NLO/DLO) in QLO, so now we adjust QLO to be
9633 equal to the ceiling. */
9634 if (mpz_sgn (rlo) != 0)
9635 {
9636 /* If RLO is non-zero, then NLO/DLO is not an integer and
9637 the next term will be QLO+1. QLO was used in the
9638 computation of N0 and D0 above. Here we adjust N0 and
9639 D0 to be based on QLO+1 instead of QLO. */
9640 mpz_add (n0, n0, n1); /* N0 <-- N0 + N1 */
9641 mpz_add (d0, d0, d1); /* D0 <-- D0 + D1 */
9642 }
9643
9644 /* The simplest rational in the interval is N0/D0 */
9645 result = scm_i_make_ratio_already_reduced (scm_from_mpz (n0),
9646 scm_from_mpz (d0));
9647 mpz_clears (n0, d0, n1, d1, n2, d2,
9648 nlo, dlo, nhi, dhi,
9649 qlo, rlo, qhi, rhi,
9650 NULL);
9651 return result;
9652 }
9653 }
9654 }
9655 #undef FUNC_NAME
9656
9657 /* conversion functions */
9658
9659 int
scm_is_integer(SCM val)9660 scm_is_integer (SCM val)
9661 {
9662 return scm_is_true (scm_integer_p (val));
9663 }
9664
9665 int
scm_is_exact_integer(SCM val)9666 scm_is_exact_integer (SCM val)
9667 {
9668 return scm_is_true (scm_exact_integer_p (val));
9669 }
9670
9671 int
scm_is_signed_integer(SCM val,scm_t_intmax min,scm_t_intmax max)9672 scm_is_signed_integer (SCM val, scm_t_intmax min, scm_t_intmax max)
9673 {
9674 if (SCM_I_INUMP (val))
9675 {
9676 scm_t_signed_bits n = SCM_I_INUM (val);
9677 return n >= min && n <= max;
9678 }
9679 else if (SCM_BIGP (val))
9680 {
9681 if (min >= SCM_MOST_NEGATIVE_FIXNUM && max <= SCM_MOST_POSITIVE_FIXNUM)
9682 return 0;
9683 else if (min >= LONG_MIN && max <= LONG_MAX)
9684 {
9685 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (val)))
9686 {
9687 long n = mpz_get_si (SCM_I_BIG_MPZ (val));
9688 return n >= min && n <= max;
9689 }
9690 else
9691 return 0;
9692 }
9693 else
9694 {
9695 scm_t_uintmax abs_n;
9696 scm_t_intmax n;
9697 size_t count;
9698
9699 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
9700 > CHAR_BIT*sizeof (scm_t_uintmax))
9701 return 0;
9702
9703 mpz_export (&abs_n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
9704 SCM_I_BIG_MPZ (val));
9705
9706 if (mpz_sgn (SCM_I_BIG_MPZ (val)) >= 0)
9707 {
9708 if (abs_n <= max)
9709 n = abs_n;
9710 else
9711 return 0;
9712 }
9713 else
9714 {
9715 /* Carefully avoid signed integer overflow. */
9716 if (min < 0 && abs_n - 1 <= -(min + 1))
9717 n = -1 - (scm_t_intmax)(abs_n - 1);
9718 else
9719 return 0;
9720 }
9721
9722 return n >= min && n <= max;
9723 }
9724 }
9725 else
9726 return 0;
9727 }
9728
9729 int
scm_is_unsigned_integer(SCM val,scm_t_uintmax min,scm_t_uintmax max)9730 scm_is_unsigned_integer (SCM val, scm_t_uintmax min, scm_t_uintmax max)
9731 {
9732 if (SCM_I_INUMP (val))
9733 {
9734 scm_t_signed_bits n = SCM_I_INUM (val);
9735 return n >= 0 && ((scm_t_uintmax)n) >= min && ((scm_t_uintmax)n) <= max;
9736 }
9737 else if (SCM_BIGP (val))
9738 {
9739 if (max <= SCM_MOST_POSITIVE_FIXNUM)
9740 return 0;
9741 else if (max <= ULONG_MAX)
9742 {
9743 if (mpz_fits_ulong_p (SCM_I_BIG_MPZ (val)))
9744 {
9745 unsigned long n = mpz_get_ui (SCM_I_BIG_MPZ (val));
9746 return n >= min && n <= max;
9747 }
9748 else
9749 return 0;
9750 }
9751 else
9752 {
9753 scm_t_uintmax n;
9754 size_t count;
9755
9756 if (mpz_sgn (SCM_I_BIG_MPZ (val)) < 0)
9757 return 0;
9758
9759 if (mpz_sizeinbase (SCM_I_BIG_MPZ (val), 2)
9760 > CHAR_BIT*sizeof (scm_t_uintmax))
9761 return 0;
9762
9763 mpz_export (&n, &count, 1, sizeof (scm_t_uintmax), 0, 0,
9764 SCM_I_BIG_MPZ (val));
9765
9766 return n >= min && n <= max;
9767 }
9768 }
9769 else
9770 return 0;
9771 }
9772
9773 static void
scm_i_range_error(SCM bad_val,SCM min,SCM max)9774 scm_i_range_error (SCM bad_val, SCM min, SCM max)
9775 {
9776 scm_error (scm_out_of_range_key,
9777 NULL,
9778 "Value out of range ~S to ~S: ~S",
9779 scm_list_3 (min, max, bad_val),
9780 scm_list_1 (bad_val));
9781 }
9782
9783 #define TYPE scm_t_intmax
9784 #define TYPE_MIN min
9785 #define TYPE_MAX max
9786 #define SIZEOF_TYPE 0
9787 #define SCM_TO_TYPE_PROTO(arg) scm_to_signed_integer (arg, scm_t_intmax min, scm_t_intmax max)
9788 #define SCM_FROM_TYPE_PROTO(arg) scm_from_signed_integer (arg)
9789 #include "libguile/conv-integer.i.c"
9790
9791 #define TYPE scm_t_uintmax
9792 #define TYPE_MIN min
9793 #define TYPE_MAX max
9794 #define SIZEOF_TYPE 0
9795 #define SCM_TO_TYPE_PROTO(arg) scm_to_unsigned_integer (arg, scm_t_uintmax min, scm_t_uintmax max)
9796 #define SCM_FROM_TYPE_PROTO(arg) scm_from_unsigned_integer (arg)
9797 #include "libguile/conv-uinteger.i.c"
9798
9799 #define TYPE scm_t_int8
9800 #define TYPE_MIN SCM_T_INT8_MIN
9801 #define TYPE_MAX SCM_T_INT8_MAX
9802 #define SIZEOF_TYPE 1
9803 #define SCM_TO_TYPE_PROTO(arg) scm_to_int8 (arg)
9804 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int8 (arg)
9805 #include "libguile/conv-integer.i.c"
9806
9807 #define TYPE scm_t_uint8
9808 #define TYPE_MIN 0
9809 #define TYPE_MAX SCM_T_UINT8_MAX
9810 #define SIZEOF_TYPE 1
9811 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint8 (arg)
9812 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint8 (arg)
9813 #include "libguile/conv-uinteger.i.c"
9814
9815 #define TYPE scm_t_int16
9816 #define TYPE_MIN SCM_T_INT16_MIN
9817 #define TYPE_MAX SCM_T_INT16_MAX
9818 #define SIZEOF_TYPE 2
9819 #define SCM_TO_TYPE_PROTO(arg) scm_to_int16 (arg)
9820 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int16 (arg)
9821 #include "libguile/conv-integer.i.c"
9822
9823 #define TYPE scm_t_uint16
9824 #define TYPE_MIN 0
9825 #define TYPE_MAX SCM_T_UINT16_MAX
9826 #define SIZEOF_TYPE 2
9827 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint16 (arg)
9828 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint16 (arg)
9829 #include "libguile/conv-uinteger.i.c"
9830
9831 #define TYPE scm_t_int32
9832 #define TYPE_MIN SCM_T_INT32_MIN
9833 #define TYPE_MAX SCM_T_INT32_MAX
9834 #define SIZEOF_TYPE 4
9835 #define SCM_TO_TYPE_PROTO(arg) scm_to_int32 (arg)
9836 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int32 (arg)
9837 #include "libguile/conv-integer.i.c"
9838
9839 #define TYPE scm_t_uint32
9840 #define TYPE_MIN 0
9841 #define TYPE_MAX SCM_T_UINT32_MAX
9842 #define SIZEOF_TYPE 4
9843 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint32 (arg)
9844 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint32 (arg)
9845 #include "libguile/conv-uinteger.i.c"
9846
9847 #define TYPE scm_t_wchar
9848 #define TYPE_MIN (scm_t_int32)-1
9849 #define TYPE_MAX (scm_t_int32)0x10ffff
9850 #define SIZEOF_TYPE 4
9851 #define SCM_TO_TYPE_PROTO(arg) scm_to_wchar (arg)
9852 #define SCM_FROM_TYPE_PROTO(arg) scm_from_wchar (arg)
9853 #include "libguile/conv-integer.i.c"
9854
9855 #define TYPE scm_t_int64
9856 #define TYPE_MIN SCM_T_INT64_MIN
9857 #define TYPE_MAX SCM_T_INT64_MAX
9858 #define SIZEOF_TYPE 8
9859 #define SCM_TO_TYPE_PROTO(arg) scm_to_int64 (arg)
9860 #define SCM_FROM_TYPE_PROTO(arg) scm_from_int64 (arg)
9861 #include "libguile/conv-integer.i.c"
9862
9863 #define TYPE scm_t_uint64
9864 #define TYPE_MIN 0
9865 #define TYPE_MAX SCM_T_UINT64_MAX
9866 #define SIZEOF_TYPE 8
9867 #define SCM_TO_TYPE_PROTO(arg) scm_to_uint64 (arg)
9868 #define SCM_FROM_TYPE_PROTO(arg) scm_from_uint64 (arg)
9869 #include "libguile/conv-uinteger.i.c"
9870
9871 void
scm_to_mpz(SCM val,mpz_t rop)9872 scm_to_mpz (SCM val, mpz_t rop)
9873 {
9874 if (SCM_I_INUMP (val))
9875 mpz_set_si (rop, SCM_I_INUM (val));
9876 else if (SCM_BIGP (val))
9877 mpz_set (rop, SCM_I_BIG_MPZ (val));
9878 else
9879 scm_wrong_type_arg_msg (NULL, 0, val, "exact integer");
9880 }
9881
9882 SCM
scm_from_mpz(mpz_t val)9883 scm_from_mpz (mpz_t val)
9884 {
9885 return scm_i_mpz2num (val);
9886 }
9887
9888 int
scm_is_real(SCM val)9889 scm_is_real (SCM val)
9890 {
9891 return scm_is_true (scm_real_p (val));
9892 }
9893
9894 int
scm_is_rational(SCM val)9895 scm_is_rational (SCM val)
9896 {
9897 return scm_is_true (scm_rational_p (val));
9898 }
9899
9900 double
scm_to_double(SCM val)9901 scm_to_double (SCM val)
9902 {
9903 if (SCM_I_INUMP (val))
9904 return SCM_I_INUM (val);
9905 else if (SCM_BIGP (val))
9906 return scm_i_big2dbl (val);
9907 else if (SCM_FRACTIONP (val))
9908 return scm_i_fraction2double (val);
9909 else if (SCM_REALP (val))
9910 return SCM_REAL_VALUE (val);
9911 else
9912 scm_wrong_type_arg_msg (NULL, 0, val, "real number");
9913 }
9914
9915 SCM
scm_from_double(double val)9916 scm_from_double (double val)
9917 {
9918 return scm_i_from_double (val);
9919 }
9920
9921 int
scm_is_complex(SCM val)9922 scm_is_complex (SCM val)
9923 {
9924 return scm_is_true (scm_complex_p (val));
9925 }
9926
9927 double
scm_c_real_part(SCM z)9928 scm_c_real_part (SCM z)
9929 {
9930 if (SCM_COMPLEXP (z))
9931 return SCM_COMPLEX_REAL (z);
9932 else
9933 {
9934 /* Use the scm_real_part to get proper error checking and
9935 dispatching.
9936 */
9937 return scm_to_double (scm_real_part (z));
9938 }
9939 }
9940
9941 double
scm_c_imag_part(SCM z)9942 scm_c_imag_part (SCM z)
9943 {
9944 if (SCM_COMPLEXP (z))
9945 return SCM_COMPLEX_IMAG (z);
9946 else
9947 {
9948 /* Use the scm_imag_part to get proper error checking and
9949 dispatching. The result will almost always be 0.0, but not
9950 always.
9951 */
9952 return scm_to_double (scm_imag_part (z));
9953 }
9954 }
9955
9956 double
scm_c_magnitude(SCM z)9957 scm_c_magnitude (SCM z)
9958 {
9959 return scm_to_double (scm_magnitude (z));
9960 }
9961
9962 double
scm_c_angle(SCM z)9963 scm_c_angle (SCM z)
9964 {
9965 return scm_to_double (scm_angle (z));
9966 }
9967
9968 int
scm_is_number(SCM z)9969 scm_is_number (SCM z)
9970 {
9971 return scm_is_true (scm_number_p (z));
9972 }
9973
9974
9975 /* Returns log(x * 2^shift) */
9976 static SCM
log_of_shifted_double(double x,long shift)9977 log_of_shifted_double (double x, long shift)
9978 {
9979 double ans = log (fabs (x)) + shift * M_LN2;
9980
9981 if (copysign (1.0, x) > 0.0)
9982 return scm_i_from_double (ans);
9983 else
9984 return scm_c_make_rectangular (ans, M_PI);
9985 }
9986
9987 /* Returns log(n), for exact integer n */
9988 static SCM
log_of_exact_integer(SCM n)9989 log_of_exact_integer (SCM n)
9990 {
9991 if (SCM_I_INUMP (n))
9992 return log_of_shifted_double (SCM_I_INUM (n), 0);
9993 else if (SCM_BIGP (n))
9994 {
9995 long expon;
9996 double signif = scm_i_big2dbl_2exp (n, &expon);
9997 return log_of_shifted_double (signif, expon);
9998 }
9999 else
10000 scm_wrong_type_arg ("log_of_exact_integer", SCM_ARG1, n);
10001 }
10002
10003 /* Returns log(n/d), for exact non-zero integers n and d */
10004 static SCM
log_of_fraction(SCM n,SCM d)10005 log_of_fraction (SCM n, SCM d)
10006 {
10007 long n_size = scm_to_long (scm_integer_length (n));
10008 long d_size = scm_to_long (scm_integer_length (d));
10009
10010 if (labs (n_size - d_size) > 1)
10011 return (scm_difference (log_of_exact_integer (n),
10012 log_of_exact_integer (d)));
10013 else if (scm_is_false (scm_negative_p (n)))
10014 return scm_i_from_double
10015 (log1p (scm_i_divide2double (scm_difference (n, d), d)));
10016 else
10017 return scm_c_make_rectangular
10018 (log1p (scm_i_divide2double (scm_difference (scm_abs (n), d),
10019 d)),
10020 M_PI);
10021 }
10022
10023
10024 /* In the following functions we dispatch to the real-arg funcs like log()
10025 when we know the arg is real, instead of just handing everything to
10026 clog() for instance. This is in case clog() doesn't optimize for a
10027 real-only case, and because we have to test SCM_COMPLEXP anyway so may as
10028 well use it to go straight to the applicable C func. */
10029
10030 SCM_PRIMITIVE_GENERIC (scm_log, "log", 1, 0, 0,
10031 (SCM z),
10032 "Return the natural logarithm of @var{z}.")
10033 #define FUNC_NAME s_scm_log
10034 {
10035 if (SCM_COMPLEXP (z))
10036 {
10037 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG \
10038 && defined (SCM_COMPLEX_VALUE)
10039 return scm_from_complex_double (clog (SCM_COMPLEX_VALUE (z)));
10040 #else
10041 double re = SCM_COMPLEX_REAL (z);
10042 double im = SCM_COMPLEX_IMAG (z);
10043 return scm_c_make_rectangular (log (hypot (re, im)),
10044 atan2 (im, re));
10045 #endif
10046 }
10047 else if (SCM_REALP (z))
10048 return log_of_shifted_double (SCM_REAL_VALUE (z), 0);
10049 else if (SCM_I_INUMP (z))
10050 {
10051 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10052 if (scm_is_eq (z, SCM_INUM0))
10053 scm_num_overflow (s_scm_log);
10054 #endif
10055 return log_of_shifted_double (SCM_I_INUM (z), 0);
10056 }
10057 else if (SCM_BIGP (z))
10058 return log_of_exact_integer (z);
10059 else if (SCM_FRACTIONP (z))
10060 return log_of_fraction (SCM_FRACTION_NUMERATOR (z),
10061 SCM_FRACTION_DENOMINATOR (z));
10062 else
10063 return scm_wta_dispatch_1 (g_scm_log, z, 1, s_scm_log);
10064 }
10065 #undef FUNC_NAME
10066
10067
10068 SCM_PRIMITIVE_GENERIC (scm_log10, "log10", 1, 0, 0,
10069 (SCM z),
10070 "Return the base 10 logarithm of @var{z}.")
10071 #define FUNC_NAME s_scm_log10
10072 {
10073 if (SCM_COMPLEXP (z))
10074 {
10075 /* Mingw has clog() but not clog10(). (Maybe it'd be worth using
10076 clog() and a multiply by M_LOG10E, rather than the fallback
10077 log10+hypot+atan2.) */
10078 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CLOG10 \
10079 && defined SCM_COMPLEX_VALUE
10080 return scm_from_complex_double (clog10 (SCM_COMPLEX_VALUE (z)));
10081 #else
10082 double re = SCM_COMPLEX_REAL (z);
10083 double im = SCM_COMPLEX_IMAG (z);
10084 return scm_c_make_rectangular (log10 (hypot (re, im)),
10085 M_LOG10E * atan2 (im, re));
10086 #endif
10087 }
10088 else if (SCM_REALP (z) || SCM_I_INUMP (z))
10089 {
10090 #ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
10091 if (scm_is_eq (z, SCM_INUM0))
10092 scm_num_overflow (s_scm_log10);
10093 #endif
10094 {
10095 double re = scm_to_double (z);
10096 double l = log10 (fabs (re));
10097 if (copysign (1.0, re) > 0.0)
10098 return scm_i_from_double (l);
10099 else
10100 return scm_c_make_rectangular (l, M_LOG10E * M_PI);
10101 }
10102 }
10103 else if (SCM_BIGP (z))
10104 return scm_product (flo_log10e, log_of_exact_integer (z));
10105 else if (SCM_FRACTIONP (z))
10106 return scm_product (flo_log10e,
10107 log_of_fraction (SCM_FRACTION_NUMERATOR (z),
10108 SCM_FRACTION_DENOMINATOR (z)));
10109 else
10110 return scm_wta_dispatch_1 (g_scm_log10, z, 1, s_scm_log10);
10111 }
10112 #undef FUNC_NAME
10113
10114
10115 SCM_PRIMITIVE_GENERIC (scm_exp, "exp", 1, 0, 0,
10116 (SCM z),
10117 "Return @math{e} to the power of @var{z}, where @math{e} is the\n"
10118 "base of natural logarithms (2.71828@dots{}).")
10119 #define FUNC_NAME s_scm_exp
10120 {
10121 if (SCM_COMPLEXP (z))
10122 {
10123 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_CEXP \
10124 && defined (SCM_COMPLEX_VALUE)
10125 return scm_from_complex_double (cexp (SCM_COMPLEX_VALUE (z)));
10126 #else
10127 return scm_c_make_polar (exp (SCM_COMPLEX_REAL (z)),
10128 SCM_COMPLEX_IMAG (z));
10129 #endif
10130 }
10131 else if (SCM_NUMBERP (z))
10132 {
10133 /* When z is a negative bignum the conversion to double overflows,
10134 giving -infinity, but that's ok, the exp is still 0.0. */
10135 return scm_i_from_double (exp (scm_to_double (z)));
10136 }
10137 else
10138 return scm_wta_dispatch_1 (g_scm_exp, z, 1, s_scm_exp);
10139 }
10140 #undef FUNC_NAME
10141
10142
10143 SCM_DEFINE (scm_i_exact_integer_sqrt, "exact-integer-sqrt", 1, 0, 0,
10144 (SCM k),
10145 "Return two exact non-negative integers @var{s} and @var{r}\n"
10146 "such that @math{@var{k} = @var{s}^2 + @var{r}} and\n"
10147 "@math{@var{s}^2 <= @var{k} < (@var{s} + 1)^2}.\n"
10148 "An error is raised if @var{k} is not an exact non-negative integer.\n"
10149 "\n"
10150 "@lisp\n"
10151 "(exact-integer-sqrt 10) @result{} 3 and 1\n"
10152 "@end lisp")
10153 #define FUNC_NAME s_scm_i_exact_integer_sqrt
10154 {
10155 SCM s, r;
10156
10157 scm_exact_integer_sqrt (k, &s, &r);
10158 return scm_values (scm_list_2 (s, r));
10159 }
10160 #undef FUNC_NAME
10161
10162 void
scm_exact_integer_sqrt(SCM k,SCM * sp,SCM * rp)10163 scm_exact_integer_sqrt (SCM k, SCM *sp, SCM *rp)
10164 {
10165 if (SCM_LIKELY (SCM_I_INUMP (k)))
10166 {
10167 if (SCM_I_INUM (k) > 0)
10168 {
10169 mp_limb_t kk, ss, rr;
10170
10171 kk = SCM_I_INUM (k);
10172 if (mpn_sqrtrem (&ss, &rr, &kk, 1) == 0)
10173 rr = 0;
10174 *sp = SCM_I_MAKINUM (ss);
10175 *rp = SCM_I_MAKINUM (rr);
10176 }
10177 else if (SCM_I_INUM (k) == 0)
10178 *sp = *rp = SCM_INUM0;
10179 else
10180 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
10181 "exact non-negative integer");
10182 }
10183 else if (SCM_LIKELY (SCM_BIGP (k)))
10184 {
10185 SCM s, r;
10186
10187 if (mpz_sgn (SCM_I_BIG_MPZ (k)) < 0)
10188 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
10189 "exact non-negative integer");
10190 s = scm_i_mkbig ();
10191 r = scm_i_mkbig ();
10192 mpz_sqrtrem (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (r), SCM_I_BIG_MPZ (k));
10193 scm_remember_upto_here_1 (k);
10194 *sp = scm_i_normbig (s);
10195 *rp = scm_i_normbig (r);
10196 }
10197 else
10198 scm_wrong_type_arg_msg ("exact-integer-sqrt", SCM_ARG1, k,
10199 "exact non-negative integer");
10200 }
10201
10202 /* Return true iff K is a perfect square.
10203 K must be an exact integer. */
10204 static int
exact_integer_is_perfect_square(SCM k)10205 exact_integer_is_perfect_square (SCM k)
10206 {
10207 int result;
10208
10209 if (SCM_LIKELY (SCM_I_INUMP (k)))
10210 {
10211 if (SCM_I_INUM (k) > 0)
10212 {
10213 mp_limb_t kk = SCM_I_INUM (k);
10214
10215 result = mpn_perfect_square_p (&kk, 1);
10216 }
10217 else
10218 result = (SCM_I_INUM (k) == 0);
10219 }
10220 else
10221 {
10222 result = mpz_perfect_square_p (SCM_I_BIG_MPZ (k));
10223 scm_remember_upto_here_1 (k);
10224 }
10225 return result;
10226 }
10227
10228 /* Return the floor of the square root of K.
10229 K must be an exact non-negative integer. */
10230 static SCM
exact_integer_floor_square_root(SCM k)10231 exact_integer_floor_square_root (SCM k)
10232 {
10233 if (SCM_LIKELY (SCM_I_INUMP (k)))
10234 {
10235 if (SCM_I_INUM (k) > 0)
10236 {
10237 mp_limb_t kk, ss, rr;
10238
10239 kk = SCM_I_INUM (k);
10240 mpn_sqrtrem (&ss, &rr, &kk, 1);
10241 return SCM_I_MAKINUM (ss);
10242 }
10243 else
10244 return SCM_INUM0;
10245 }
10246 else
10247 {
10248 SCM s;
10249
10250 s = scm_i_mkbig ();
10251 mpz_sqrt (SCM_I_BIG_MPZ (s), SCM_I_BIG_MPZ (k));
10252 scm_remember_upto_here_1 (k);
10253 return scm_i_normbig (s);
10254 }
10255 }
10256
10257
10258 SCM_PRIMITIVE_GENERIC (scm_sqrt, "sqrt", 1, 0, 0,
10259 (SCM z),
10260 "Return the square root of @var{z}. Of the two possible roots\n"
10261 "(positive and negative), the one with positive real part\n"
10262 "is returned, or if that's zero then a positive imaginary part.\n"
10263 "Thus,\n"
10264 "\n"
10265 "@example\n"
10266 "(sqrt 9.0) @result{} 3.0\n"
10267 "(sqrt -9.0) @result{} 0.0+3.0i\n"
10268 "(sqrt 1.0+1.0i) @result{} 1.09868411346781+0.455089860562227i\n"
10269 "(sqrt -1.0-1.0i) @result{} 0.455089860562227-1.09868411346781i\n"
10270 "@end example")
10271 #define FUNC_NAME s_scm_sqrt
10272 {
10273 if (SCM_COMPLEXP (z))
10274 {
10275 #if defined HAVE_COMPLEX_DOUBLE && defined HAVE_USABLE_CSQRT \
10276 && defined SCM_COMPLEX_VALUE
10277 return scm_from_complex_double (csqrt (SCM_COMPLEX_VALUE (z)));
10278 #else
10279 double re = SCM_COMPLEX_REAL (z);
10280 double im = SCM_COMPLEX_IMAG (z);
10281 return scm_c_make_polar (sqrt (hypot (re, im)),
10282 0.5 * atan2 (im, re));
10283 #endif
10284 }
10285 else if (SCM_NUMBERP (z))
10286 {
10287 if (SCM_I_INUMP (z))
10288 {
10289 scm_t_inum x = SCM_I_INUM (z);
10290
10291 if (SCM_LIKELY (x >= 0))
10292 {
10293 if (SCM_LIKELY (SCM_I_FIXNUM_BIT < DBL_MANT_DIG
10294 || x < (1L << (DBL_MANT_DIG - 1))))
10295 {
10296 double root = sqrt (x);
10297
10298 /* If 0 <= x < 2^(DBL_MANT_DIG-1) and sqrt(x) is an
10299 integer, then the result is exact. */
10300 if (root == floor (root))
10301 return SCM_I_MAKINUM ((scm_t_inum) root);
10302 else
10303 return scm_i_from_double (root);
10304 }
10305 else
10306 {
10307 mp_limb_t xx, root, rem;
10308
10309 assert (x != 0);
10310 xx = x;
10311 if (mpn_perfect_square_p (&xx, 1))
10312 {
10313 mpn_sqrtrem (&root, &rem, &xx, 1);
10314 return SCM_I_MAKINUM (root);
10315 }
10316 }
10317 }
10318 }
10319 else if (SCM_BIGP (z))
10320 {
10321 if (mpz_perfect_square_p (SCM_I_BIG_MPZ (z)))
10322 {
10323 SCM root = scm_i_mkbig ();
10324
10325 mpz_sqrt (SCM_I_BIG_MPZ (root), SCM_I_BIG_MPZ (z));
10326 scm_remember_upto_here_1 (z);
10327 return scm_i_normbig (root);
10328 }
10329 else
10330 {
10331 long expon;
10332 double signif = scm_i_big2dbl_2exp (z, &expon);
10333
10334 if (expon & 1)
10335 {
10336 signif *= 2;
10337 expon--;
10338 }
10339 if (signif < 0)
10340 return scm_c_make_rectangular
10341 (0.0, ldexp (sqrt (-signif), expon / 2));
10342 else
10343 return scm_i_from_double (ldexp (sqrt (signif), expon / 2));
10344 }
10345 }
10346 else if (SCM_FRACTIONP (z))
10347 {
10348 SCM n = SCM_FRACTION_NUMERATOR (z);
10349 SCM d = SCM_FRACTION_DENOMINATOR (z);
10350
10351 if (exact_integer_is_perfect_square (n)
10352 && exact_integer_is_perfect_square (d))
10353 return scm_i_make_ratio_already_reduced
10354 (exact_integer_floor_square_root (n),
10355 exact_integer_floor_square_root (d));
10356 else
10357 {
10358 double xx = scm_i_divide2double (n, d);
10359 double abs_xx = fabs (xx);
10360 long shift = 0;
10361
10362 if (SCM_UNLIKELY (abs_xx > DBL_MAX || abs_xx < DBL_MIN))
10363 {
10364 shift = (scm_to_long (scm_integer_length (n))
10365 - scm_to_long (scm_integer_length (d))) / 2;
10366 if (shift > 0)
10367 d = left_shift_exact_integer (d, 2 * shift);
10368 else
10369 n = left_shift_exact_integer (n, -2 * shift);
10370 xx = scm_i_divide2double (n, d);
10371 }
10372
10373 if (xx < 0)
10374 return scm_c_make_rectangular (0.0, ldexp (sqrt (-xx), shift));
10375 else
10376 return scm_i_from_double (ldexp (sqrt (xx), shift));
10377 }
10378 }
10379
10380 /* Fallback method, when the cases above do not apply. */
10381 {
10382 double xx = scm_to_double (z);
10383 if (xx < 0)
10384 return scm_c_make_rectangular (0.0, sqrt (-xx));
10385 else
10386 return scm_i_from_double (sqrt (xx));
10387 }
10388 }
10389 else
10390 return scm_wta_dispatch_1 (g_scm_sqrt, z, 1, s_scm_sqrt);
10391 }
10392 #undef FUNC_NAME
10393
10394
10395
10396 void
scm_init_numbers()10397 scm_init_numbers ()
10398 {
10399 if (scm_install_gmp_memory_functions)
10400 mp_set_memory_functions (custom_gmp_malloc,
10401 custom_gmp_realloc,
10402 custom_gmp_free);
10403
10404 mpz_init_set_si (z_negative_one, -1);
10405
10406 /* It may be possible to tune the performance of some algorithms by using
10407 * the following constants to avoid the creation of bignums. Please, before
10408 * using these values, remember the two rules of program optimization:
10409 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
10410 scm_c_define ("most-positive-fixnum",
10411 SCM_I_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
10412 scm_c_define ("most-negative-fixnum",
10413 SCM_I_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
10414
10415 scm_add_feature ("complex");
10416 scm_add_feature ("inexact");
10417 flo0 = scm_i_from_double (0.0);
10418 flo_log10e = scm_i_from_double (M_LOG10E);
10419
10420 exactly_one_half = scm_divide (SCM_INUM1, SCM_I_MAKINUM (2));
10421
10422 {
10423 /* Set scm_i_divide2double_lo2b to (2 b^p - 1) */
10424 mpz_init_set_ui (scm_i_divide2double_lo2b, 1);
10425 mpz_mul_2exp (scm_i_divide2double_lo2b,
10426 scm_i_divide2double_lo2b,
10427 DBL_MANT_DIG + 1); /* 2 b^p */
10428 mpz_sub_ui (scm_i_divide2double_lo2b, scm_i_divide2double_lo2b, 1);
10429 }
10430
10431 {
10432 /* Set dbl_minimum_normal_mantissa to b^{p-1} */
10433 mpz_init_set_ui (dbl_minimum_normal_mantissa, 1);
10434 mpz_mul_2exp (dbl_minimum_normal_mantissa,
10435 dbl_minimum_normal_mantissa,
10436 DBL_MANT_DIG - 1);
10437 }
10438
10439 #include "libguile/numbers.x"
10440 }
10441
10442 /*
10443 Local Variables:
10444 c-file-style: "gnu"
10445 End:
10446 */
10447