HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
(scm_integer_expt): Don't mpz_init after scm_i_clonebig or
[bpt/guile.git] / libguile / numbers.c
CommitLineData
14b18ed6 1/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003 Free Software Foundation, Inc.
ba74ef4e
MV		 2 *
3 * Portions Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories
4 * and Bellcore. See scm_divide.
5 *
f81e080b 6 *
73be1d9e
MV		 7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public
9 * License as published by the Free Software Foundation; either
10 * version 2.1 of the License, or (at your option) any later version.
0f2d19dd 11 *
73be1d9e
MV		 12 * This library is distributed in the hope that it will be useful,
13 * but 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.
0f2d19dd 16 *
73be1d9e
MV		 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
20 */
1bbd0b84 21
0f2d19dd 22\f
ca46fb90
RB		 23/* General assumptions:
24 * All objects satisfying SCM_COMPLEXP() have a non-zero complex component.
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.
f92e85f7 28 * All objects satisfying SCM_FRACTIONP are never an integer.
ca46fb90
RB		 29 */
30
31/* TODO:
32
33 - see if special casing bignums and reals in integer-exponent when
34 possible (to use mpz_pow and mpf_pow_ui) is faster.
35
36 - look in to better short-circuiting of common cases in
37 integer-expt and elsewhere.
38
39 - see if direct mpz operations can help in ash and elsewhere.
40
41 */
0f2d19dd 42
fa605590
KR		 43/* tell glibc (2.3) to give prototype for C99 trunc() */
44#define _GNU_SOURCE
45
ee33d62a
RB		 46#if HAVE_CONFIG_H
47# include <config.h>
48#endif
49
0f2d19dd 50#include <math.h>
3c9a524f 51#include <ctype.h>
fc194577 52#include <string.h>
ca46fb90 53#include <gmp.h>
f92e85f7 54
a0599745 55#include "libguile/_scm.h"
a0599745
MD		 56#include "libguile/feature.h"
57#include "libguile/ports.h"
58#include "libguile/root.h"
59#include "libguile/smob.h"
60#include "libguile/strings.h"
a0599745
MD		 61
62#include "libguile/validate.h"
63#include "libguile/numbers.h"
1be6b49c 64#include "libguile/deprecation.h"
f4c627b3 65
f92e85f7
MV		 66#include "libguile/eq.h"
67
0f2d19dd 68\f
f4c627b3 69
ca46fb90
RB		 70/*
71 Wonder if this might be faster for some of our code? A switch on
72 the numtag would jump directly to the right case, and the
73 SCM_I_NUMTAG code might be faster than repeated SCM_FOOP tests...
74
75 #define SCM_I_NUMTAG_NOTNUM 0
76 #define SCM_I_NUMTAG_INUM 1
77 #define SCM_I_NUMTAG_BIG scm_tc16_big
78 #define SCM_I_NUMTAG_REAL scm_tc16_real
79 #define SCM_I_NUMTAG_COMPLEX scm_tc16_complex
80 #define SCM_I_NUMTAG(x) \
81 (SCM_INUMP(x) ? SCM_I_NUMTAG_INUM \
82 : (SCM_IMP(x) ? SCM_I_NUMTAG_NOTNUM \
534c55a9 83 : (((0xfcff & SCM_CELL_TYPE (x)) == scm_tc7_number) ? SCM_TYP16(x) \
ca46fb90
RB		 84 : SCM_I_NUMTAG_NOTNUM)))
85*/
f92e85f7 86/* the macro above will not work as is with fractions */
f4c627b3
DH		 87
88
34d19ef6 89#define SCM_SWAP(x, y) do { SCM __t = x; x = y; y = __t; } while (0)
09fb7599 90
56e55ac7 91/* FLOBUFLEN is the maximum number of characters neccessary for the
3a9809df
DH		 92 * printed or scm_string representation of an inexact number.
93 */
56e55ac7 94#define FLOBUFLEN (10+2*(sizeof(double)/sizeof(char)*SCM_CHAR_BIT*3+9)/10)
3a9809df 95
7351e207
MV		 96#if defined (SCO)
97#if ! defined (HAVE_ISNAN)
98#define HAVE_ISNAN
99static int
100isnan (double x)
101{
102 return (IsNANorINF (x) && NaN (x) && ! IsINF (x)) ? 1 : 0;
103}
0f2d19dd 104#endif
7351e207
MV		 105#if ! defined (HAVE_ISINF)
106#define HAVE_ISINF
107static int
108isinf (double x)
109{
110 return (IsNANorINF (x) && IsINF (x)) ? 1 : 0;
111}
0f2d19dd 112
7351e207 113#endif
e6f3ef58
MD		 114#endif
115
b127c712
KR		 116
117/* mpz_cmp_d only recognises infinities in gmp 4.2 and up.
118 For prior versions use an explicit check here. */
119#if __GNU_MP_VERSION < 4 \
120 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
121#define xmpz_cmp_d(z, d) \
122 (xisinf (d) ? (d < 0.0 ? 1 : -1) : mpz_cmp_d (z, d))
123#else
124#define xmpz_cmp_d(z, d) mpz_cmp_d (z, d)
125#endif
126
f92e85f7
MV		 127static int
128xisinf (double x)
129{
130#if defined (HAVE_ISINF)
131 return isinf (x);
132#elif defined (HAVE_FINITE) && defined (HAVE_ISNAN)
133 return (! (finite (x) || isnan (x)));
134#else
135 return 0;
136#endif
137}
138
139static int
140xisnan (double x)
141{
142#if defined (HAVE_ISNAN)
143 return isnan (x);
144#else
145 return 0;
146#endif
147}
148
0f2d19dd
JB		 149\f
150
ac0c002c 151static SCM abs_most_negative_fixnum;
713a4259 152static mpz_t z_negative_one;
ac0c002c
DH		 153
154\f
155
ca46fb90
RB		 156static const char s_bignum[] = "bignum";
157
570b6821 158SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 159scm_i_mkbig ()
160{
161 /* Return a newly created bignum. */
162 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
163 mpz_init (SCM_I_BIG_MPZ (z));
164 return z;
165}
166
570b6821 167SCM_C_INLINE_KEYWORD static SCM
ca46fb90
RB		 168scm_i_clonebig (SCM src_big, int same_sign_p)
169{
170 /* Copy src_big's value, negate it if same_sign_p is false, and return. */
171 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
172 mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big));
0aacf84e
MD		 173 if (!same_sign_p)
174 mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z));
ca46fb90
RB		 175 return z;
176}
177
570b6821 178SCM_C_INLINE_KEYWORD int
ca46fb90
RB		 179scm_i_bigcmp (SCM x, SCM y)
180{
181 /* Return neg if x < y, pos if x > y, and 0 if x == y */
182 /* presume we already know x and y are bignums */
183 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
184 scm_remember_upto_here_2 (x, y);
185 return result;
186}
187
570b6821 188SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 189scm_i_dbl2big (double d)
190{
191 /* results are only defined if d is an integer */
192 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
193 mpz_init_set_d (SCM_I_BIG_MPZ (z), d);
194 return z;
195}
196
f92e85f7
MV		 197/* Convert a integer in double representation to a SCM number. */
198
199SCM_C_INLINE_KEYWORD SCM
200scm_i_dbl2num (double u)
201{
202 /* SCM_MOST_POSITIVE_FIXNUM+1 and SCM_MOST_NEGATIVE_FIXNUM are both
203 powers of 2, so there's no rounding when making "double" values
204 from them. If plain SCM_MOST_POSITIVE_FIXNUM was used it could
205 get rounded on a 64-bit machine, hence the "+1".
206
207 The use of floor() to force to an integer value ensures we get a
208 "numerically closest" value without depending on how a
209 double->long cast or how mpz_set_d will round. For reference,
210 double->long probably follows the hardware rounding mode,
211 mpz_set_d truncates towards zero. */
212
213 /* XXX - what happens when SCM_MOST_POSITIVE_FIXNUM etc is not
214 representable as a double? */
215
216 if (u < (double) (SCM_MOST_POSITIVE_FIXNUM+1)
217 && u >= (double) SCM_MOST_NEGATIVE_FIXNUM)
218 return SCM_MAKINUM ((long) u);
219 else
220 return scm_i_dbl2big (u);
221}
222
089c9a59
KR		 223/* scm_i_big2dbl() rounds to the closest representable double, in accordance
224 with R5RS exact->inexact.
225
226 The approach is to use mpz_get_d to pick out the high DBL_MANT_DIG bits
227 (ie. it truncates towards zero), then adjust to get the closest double by
228 examining the next lower bit and adding 1 if necessary.
229
230 Note that bignums exactly half way between representable doubles are
231 rounded to the next higher absolute value (ie. away from zero). This
232 seems like an adequate interpretation of R5RS "numerically closest", and
233 it's easier and faster than a full "nearest-even" style.
234
235 The bit test is done on the absolute value of the mpz_t, which means we
236 must use mpz_getlimbn. mpz_tstbit is not right, it treats negatives as
237 twos complement.
238
239 Prior to GMP 4.2, the rounding done by mpz_get_d was unspecified. It
240 happened to follow the hardware rounding mode, but on the absolute value
241 of its operand. This is not what we want, so we put the high
242 DBL_MANT_DIG bits into a temporary. This extra init/clear is a slowdown,
243 but doesn't matter too much since it's only for older GMP. */
244
245double
ca46fb90
RB		 246scm_i_big2dbl (SCM b)
247{
089c9a59
KR		 248 double result;
249 size_t bits;
250
251 bits = mpz_sizeinbase (SCM_I_BIG_MPZ (b), 2);
252
253#if __GNU_MP_VERSION < 4 \
254 || (__GNU_MP_VERSION == 4 && __GNU_MP_VERSION_MINOR < 2)
255 {
256 /* GMP prior to 4.2, force truncate towards zero */
257 mpz_t tmp;
258 if (bits > DBL_MANT_DIG)
259 {
260 size_t shift = bits - DBL_MANT_DIG;
261 mpz_init2 (tmp, DBL_MANT_DIG);
262 mpz_tdiv_q_2exp (tmp, SCM_I_BIG_MPZ (b), shift);
263 result = ldexp (mpz_get_d (tmp), shift);
264 mpz_clear (tmp);
265 }
266 else
267 {
268 result = mpz_get_d (SCM_I_BIG_MPZ (b));
269 }
270 }
271#else
272 /* GMP 4.2 and up */
273 result = mpz_get_d (SCM_I_BIG_MPZ (b));
274#endif
275
276 if (bits > DBL_MANT_DIG)
277 {
278 unsigned long pos = bits - DBL_MANT_DIG - 1;
279 /* test bit number "pos" in absolute value */
280 if (mpz_getlimbn (SCM_I_BIG_MPZ (b), pos / GMP_NUMB_BITS)
281 & ((mp_limb_t) 1 << (pos % GMP_NUMB_BITS)))
282 {
283 result += ldexp ((double) mpz_sgn (SCM_I_BIG_MPZ (b)), pos + 1);
284 }
285 }
286
ca46fb90
RB		 287 scm_remember_upto_here_1 (b);
288 return result;
289}
290
570b6821 291SCM_C_INLINE_KEYWORD SCM
ca46fb90
RB		 292scm_i_normbig (SCM b)
293{
294 /* convert a big back to a fixnum if it'll fit */
295 /* presume b is a bignum */
296 if (mpz_fits_slong_p (SCM_I_BIG_MPZ (b)))
297 {
298 long val = mpz_get_si (SCM_I_BIG_MPZ (b));
299 if (SCM_FIXABLE (val))
300 b = SCM_MAKINUM (val);
301 }
302 return b;
303}
f872b822 304
f92e85f7
MV		 305static SCM_C_INLINE_KEYWORD SCM
306scm_i_mpz2num (mpz_t b)
307{
308 /* convert a mpz number to a SCM number. */
309 if (mpz_fits_slong_p (b))
310 {
311 long val = mpz_get_si (b);
312 if (SCM_FIXABLE (val))
313 return SCM_MAKINUM (val);
314 }
315
316 {
317 SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0);
318 mpz_init_set (SCM_I_BIG_MPZ (z), b);
319 return z;
320 }
321}
322
323/* this is needed when we want scm_divide to make a float, not a ratio, even if passed two ints */
324static SCM scm_divide2real (SCM x, SCM y);
325
326SCM
327scm_make_ratio (SCM numerator, SCM denominator)
c60e130c 328#define FUNC_NAME "make-ratio"
f92e85f7 329{
c60e130c
MV		 330 /* First make sure the arguments are proper.
331 */
f92e85f7
MV		 332 if (SCM_INUMP (denominator))
333 {
334 if (SCM_EQ_P (denominator, SCM_INUM0))
335 scm_num_overflow ("make-ratio");
336 if (SCM_EQ_P (denominator, SCM_MAKINUM(1)))
337 return numerator;
338 }
339 else
340 {
341 if (!(SCM_BIGP(denominator)))
342 SCM_WRONG_TYPE_ARG (2, denominator);
343 }
c60e130c
MV		 344 if (!SCM_INUMP (numerator) && !SCM_BIGP (numerator))
345 SCM_WRONG_TYPE_ARG (1, numerator);
346
347 /* Then flip signs so that the denominator is positive.
348 */
349 if (SCM_NFALSEP (scm_negative_p (denominator)))
350 {
351 numerator = scm_difference (numerator, SCM_UNDEFINED);
352 denominator = scm_difference (denominator, SCM_UNDEFINED);
353 }
354
355 /* Now consider for each of the four fixnum/bignum combinations
356 whether the rational number is really an integer.
357 */
f92e85f7
MV		 358 if (SCM_INUMP (numerator))
359 {
360 if (SCM_EQ_P (numerator, SCM_INUM0))
361 return SCM_INUM0;
362 if (SCM_INUMP (denominator))
363 {
364 long x, y;
365 x = SCM_INUM (numerator);
366 y = SCM_INUM (denominator);
367 if (x == y)
368 return SCM_MAKINUM(1);
369 if ((x % y) == 0)
370 return SCM_MAKINUM (x / y);
f92e85f7
MV		 371 }
372 }
c60e130c 373 else if (SCM_BIGP (numerator))
f92e85f7 374 {
c60e130c
MV		 375 if (SCM_INUMP (denominator))
376 {
377 long yy = SCM_INUM (denominator);
378 if (mpz_divisible_ui_p (SCM_I_BIG_MPZ (numerator), yy))
379 return scm_divide (numerator, denominator);
380 }
381 else
f92e85f7 382 {
c60e130c
MV		 383 if (SCM_EQ_P (numerator, denominator))
384 return SCM_MAKINUM(1);
385 if (mpz_divisible_p (SCM_I_BIG_MPZ (numerator),
386 SCM_I_BIG_MPZ (denominator)))
387 return scm_divide(numerator, denominator);
f92e85f7 388 }
f92e85f7 389 }
c60e130c
MV		 390
391 /* No, it's a proper fraction.
392 */
393 return scm_double_cell (scm_tc16_fraction,
394 SCM_UNPACK (numerator),
395 SCM_UNPACK (denominator), 0);
f92e85f7 396}
c60e130c 397#undef FUNC_NAME
f92e85f7
MV		 398
399static void scm_i_fraction_reduce (SCM z)
400{
401 if (!(SCM_FRACTION_REDUCED (z)))
402 {
403 SCM divisor;
404 divisor = scm_gcd (SCM_FRACTION_NUMERATOR (z), SCM_FRACTION_DENOMINATOR (z));
405 if (!(SCM_EQ_P (divisor, SCM_MAKINUM(1))))
406 {
407 /* is this safe? */
408 SCM_FRACTION_SET_NUMERATOR (z, scm_divide (SCM_FRACTION_NUMERATOR (z), divisor));
409 SCM_FRACTION_SET_DENOMINATOR (z, scm_divide (SCM_FRACTION_DENOMINATOR (z), divisor));
410 }
411 SCM_FRACTION_REDUCED_SET (z);
412 }
413}
414
415double
416scm_i_fraction2double (SCM z)
417{
418 return scm_num2dbl (scm_divide2real (SCM_FRACTION_NUMERATOR (z),
419 SCM_FRACTION_DENOMINATOR (z)),
420 "fraction2real");
421}
422
a1ec6916 423SCM_DEFINE (scm_exact_p, "exact?", 1, 0, 0,
1bbd0b84 424 (SCM x),
942e5b91
MG		 425 "Return @code{#t} if @var{x} is an exact number, @code{#f}\n"
426 "otherwise.")
1bbd0b84 427#define FUNC_NAME s_scm_exact_p
0f2d19dd 428{
0aacf84e
MD		 429 if (SCM_INUMP (x))
430 return SCM_BOOL_T;
431 if (SCM_BIGP (x))
432 return SCM_BOOL_T;
f92e85f7
MV		 433 if (SCM_FRACTIONP (x))
434 return SCM_BOOL_T;
eb927cb9
MV		 435 if (SCM_NUMBERP (x))
436 return SCM_BOOL_F;
437 SCM_WRONG_TYPE_ARG (1, x);
0f2d19dd 438}
1bbd0b84 439#undef FUNC_NAME
0f2d19dd 440
4219f20d 441
a1ec6916 442SCM_DEFINE (scm_odd_p, "odd?", 1, 0, 0,
1bbd0b84 443 (SCM n),
942e5b91
MG		 444 "Return @code{#t} if @var{n} is an odd number, @code{#f}\n"
445 "otherwise.")
1bbd0b84 446#define FUNC_NAME s_scm_odd_p
0f2d19dd 447{
0aacf84e
MD		 448 if (SCM_INUMP (n))
449 {
450 long val = SCM_INUM (n);
451 return SCM_BOOL ((val & 1L) != 0);
452 }
453 else if (SCM_BIGP (n))
454 {
455 int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
456 scm_remember_upto_here_1 (n);
457 return SCM_BOOL (odd_p);
458 }
459 else if (!SCM_FALSEP (scm_inf_p (n)))
7351e207 460 return SCM_BOOL_T;
f92e85f7
MV		 461 else if (SCM_REALP (n))
462 {
463 double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
464 if (rem == 1.0)
465 return SCM_BOOL_T;
466 else if (rem == 0.0)
467 return SCM_BOOL_F;
468 else
469 SCM_WRONG_TYPE_ARG (1, n);
470 }
0aacf84e 471 else
a1a33b0f 472 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 473}
1bbd0b84 474#undef FUNC_NAME
0f2d19dd 475
4219f20d 476
a1ec6916 477SCM_DEFINE (scm_even_p, "even?", 1, 0, 0,
1bbd0b84 478 (SCM n),
942e5b91
MG		 479 "Return @code{#t} if @var{n} is an even number, @code{#f}\n"
480 "otherwise.")
1bbd0b84 481#define FUNC_NAME s_scm_even_p
0f2d19dd 482{
0aacf84e
MD		 483 if (SCM_INUMP (n))
484 {
485 long val = SCM_INUM (n);
486 return SCM_BOOL ((val & 1L) == 0);
487 }
488 else if (SCM_BIGP (n))
489 {
490 int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
491 scm_remember_upto_here_1 (n);
492 return SCM_BOOL (even_p);
493 }
494 else if (!SCM_FALSEP (scm_inf_p (n)))
7351e207 495 return SCM_BOOL_T;
f92e85f7
MV		 496 else if (SCM_REALP (n))
497 {
498 double rem = fabs (fmod (SCM_REAL_VALUE(n), 2.0));
499 if (rem == 1.0)
500 return SCM_BOOL_F;
501 else if (rem == 0.0)
502 return SCM_BOOL_T;
503 else
504 SCM_WRONG_TYPE_ARG (1, n);
505 }
0aacf84e 506 else
a1a33b0f 507 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 508}
1bbd0b84 509#undef FUNC_NAME
0f2d19dd 510
7351e207
MV		 511SCM_DEFINE (scm_inf_p, "inf?", 1, 0, 0,
512 (SCM n),
513 "Return @code{#t} if @var{n} is infinite, @code{#f}\n"
514 "otherwise.")
515#define FUNC_NAME s_scm_inf_p
516{
0aacf84e 517 if (SCM_REALP (n))
7351e207 518 return SCM_BOOL (xisinf (SCM_REAL_VALUE (n)));
0aacf84e 519 else if (SCM_COMPLEXP (n))
7351e207
MV		 520 return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n))
521 || xisinf (SCM_COMPLEX_IMAG (n)));
0aacf84e 522 else
7351e207 523 return SCM_BOOL_F;
7351e207
MV		 524}
525#undef FUNC_NAME
526
527SCM_DEFINE (scm_nan_p, "nan?", 1, 0, 0,
528 (SCM n),
529 "Return @code{#t} if @var{n} is a NaN, @code{#f}\n"
530 "otherwise.")
531#define FUNC_NAME s_scm_nan_p
532{
0aacf84e 533 if (SCM_REALP (n))
7351e207 534 return SCM_BOOL (xisnan (SCM_REAL_VALUE (n)));
0aacf84e 535 else if (SCM_COMPLEXP (n))
7351e207
MV		 536 return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n))
537 || xisnan (SCM_COMPLEX_IMAG (n)));
0aacf84e 538 else
7351e207 539 return SCM_BOOL_F;
7351e207
MV		 540}
541#undef FUNC_NAME
542
543/* Guile's idea of infinity. */
544static double guile_Inf;
545
546/* Guile's idea of not a number. */
547static double guile_NaN;
548
549static void
550guile_ieee_init (void)
551{
552#if defined (HAVE_ISINF) || defined (HAVE_FINITE)
553
554/* Some version of gcc on some old version of Linux used to crash when
555 trying to make Inf and NaN. */
556
557#if defined (SCO)
558 double tmp = 1.0;
559 guile_Inf = 1.0 / (tmp - tmp);
560#elif defined (__alpha__) && ! defined (linux)
561 extern unsigned int DINFINITY[2];
562 guile_Inf = (*(X_CAST(double *, DINFINITY)));
563#else
564 double tmp = 1e+10;
565 guile_Inf = tmp;
566 for (;;)
567 {
568 guile_Inf *= 1e+10;
569 if (guile_Inf == tmp)
570 break;
571 tmp = guile_Inf;
572 }
573#endif
574
575#endif
576
577#if defined (HAVE_ISNAN)
578
579#if defined (__alpha__) && ! defined (linux)
580 extern unsigned int DQNAN[2];
581 guile_NaN = (*(X_CAST(double *, DQNAN)));
582#else
583 guile_NaN = guile_Inf / guile_Inf;
584#endif
585
586#endif
587}
588
589SCM_DEFINE (scm_inf, "inf", 0, 0, 0,
590 (void),
591 "Return Inf.")
592#define FUNC_NAME s_scm_inf
593{
594 static int initialized = 0;
595 if (! initialized)
596 {
597 guile_ieee_init ();
598 initialized = 1;
599 }
600 return scm_make_real (guile_Inf);
601}
602#undef FUNC_NAME
603
604SCM_DEFINE (scm_nan, "nan", 0, 0, 0,
605 (void),
606 "Return NaN.")
607#define FUNC_NAME s_scm_nan
608{
609 static int initialized = 0;
0aacf84e 610 if (!initialized)
7351e207
MV		 611 {
612 guile_ieee_init ();
613 initialized = 1;
614 }
615 return scm_make_real (guile_NaN);
616}
617#undef FUNC_NAME
618
4219f20d 619
a48d60b1
MD		 620SCM_PRIMITIVE_GENERIC (scm_abs, "abs", 1, 0, 0,
621 (SCM x),
622 "Return the absolute value of @var{x}.")
623#define FUNC_NAME
0f2d19dd 624{
0aacf84e
MD		 625 if (SCM_INUMP (x))
626 {
627 long int xx = SCM_INUM (x);
628 if (xx >= 0)
629 return x;
630 else if (SCM_POSFIXABLE (-xx))
631 return SCM_MAKINUM (-xx);
632 else
633 return scm_i_long2big (-xx);
4219f20d 634 }
0aacf84e
MD		 635 else if (SCM_BIGP (x))
636 {
637 const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
638 if (sgn < 0)
639 return scm_i_clonebig (x, 0);
640 else
641 return x;
4219f20d 642 }
0aacf84e 643 else if (SCM_REALP (x))
5986c47d 644 return scm_make_real (fabs (SCM_REAL_VALUE (x)));
f92e85f7
MV		 645 else if (SCM_FRACTIONP (x))
646 {
647 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (x))))
648 return x;
649 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
650 SCM_FRACTION_DENOMINATOR (x));
651 }
0aacf84e 652 else
a48d60b1 653 SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs);
0f2d19dd 654}
a48d60b1 655#undef FUNC_NAME
0f2d19dd 656
4219f20d 657
9de33deb 658SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
942e5b91
MG		 659/* "Return the quotient of the numbers @var{x} and @var{y}."
660 */
0f2d19dd 661SCM
6e8d25a6 662scm_quotient (SCM x, SCM y)
0f2d19dd 663{
0aacf84e
MD		 664 if (SCM_INUMP (x))
665 {
666 long xx = SCM_INUM (x);
667 if (SCM_INUMP (y))
668 {
669 long yy = SCM_INUM (y);
670 if (yy == 0)
671 scm_num_overflow (s_quotient);
672 else
673 {
674 long z = xx / yy;
675 if (SCM_FIXABLE (z))
676 return SCM_MAKINUM (z);
677 else
678 return scm_i_long2big (z);
679 }
828865c3 680 }
0aacf84e 681 else if (SCM_BIGP (y))
ac0c002c 682 {
0aacf84e
MD		 683 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
684 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
685 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
686 return SCM_MAKINUM (-1);
687 else
688 return SCM_MAKINUM (0);
ac0c002c
DH		 689 }
690 else
0aacf84e 691 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
828865c3 692 }
0aacf84e
MD		 693 else if (SCM_BIGP (x))
694 {
695 if (SCM_INUMP (y))
696 {
697 long yy = SCM_INUM (y);
698 if (yy == 0)
699 scm_num_overflow (s_quotient);
700 else if (yy == 1)
701 return x;
702 else
703 {
704 SCM result = scm_i_mkbig ();
705 if (yy < 0)
706 {
707 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result),
708 SCM_I_BIG_MPZ (x),
709 - yy);
710 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
711 }
712 else
713 mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
714 scm_remember_upto_here_1 (x);
715 return scm_i_normbig (result);
716 }
717 }
718 else if (SCM_BIGP (y))
719 {
720 SCM result = scm_i_mkbig ();
721 mpz_tdiv_q (SCM_I_BIG_MPZ (result),
722 SCM_I_BIG_MPZ (x),
723 SCM_I_BIG_MPZ (y));
724 scm_remember_upto_here_2 (x, y);
725 return scm_i_normbig (result);
726 }
727 else
728 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
f872b822 729 }
0aacf84e 730 else
89a7e495 731 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient);
0f2d19dd
JB		 732}
733
9de33deb 734SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
942e5b91
MG		 735/* "Return the remainder of the numbers @var{x} and @var{y}.\n"
736 * "@lisp\n"
737 * "(remainder 13 4) @result{} 1\n"
738 * "(remainder -13 4) @result{} -1\n"
739 * "@end lisp"
740 */
0f2d19dd 741SCM
6e8d25a6 742scm_remainder (SCM x, SCM y)
0f2d19dd 743{
0aacf84e
MD		 744 if (SCM_INUMP (x))
745 {
746 if (SCM_INUMP (y))
747 {
748 long yy = SCM_INUM (y);
749 if (yy == 0)
750 scm_num_overflow (s_remainder);
751 else
752 {
753 long z = SCM_INUM (x) % yy;
754 return SCM_MAKINUM (z);
755 }
756 }
757 else if (SCM_BIGP (y))
ac0c002c 758 {
0aacf84e
MD		 759 if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM)
760 && (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0))
761 /* Special case: x == fixnum-min && y == abs (fixnum-min) */
762 return SCM_MAKINUM (0);
763 else
764 return x;
ac0c002c
DH		 765 }
766 else
0aacf84e 767 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
89a7e495 768 }
0aacf84e
MD		 769 else if (SCM_BIGP (x))
770 {
771 if (SCM_INUMP (y))
772 {
773 long yy = SCM_INUM (y);
774 if (yy == 0)
775 scm_num_overflow (s_remainder);
776 else
777 {
778 SCM result = scm_i_mkbig ();
779 if (yy < 0)
780 yy = - yy;
781 mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy);
782 scm_remember_upto_here_1 (x);
783 return scm_i_normbig (result);
784 }
785 }
786 else if (SCM_BIGP (y))
787 {
788 SCM result = scm_i_mkbig ();
789 mpz_tdiv_r (SCM_I_BIG_MPZ (result),
790 SCM_I_BIG_MPZ (x),
791 SCM_I_BIG_MPZ (y));
792 scm_remember_upto_here_2 (x, y);
793 return scm_i_normbig (result);
794 }
795 else
796 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
f872b822 797 }
0aacf84e 798 else
89a7e495 799 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder);
0f2d19dd
JB		 800}
801
89a7e495 802
9de33deb 803SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
942e5b91
MG		 804/* "Return the modulo of the numbers @var{x} and @var{y}.\n"
805 * "@lisp\n"
806 * "(modulo 13 4) @result{} 1\n"
807 * "(modulo -13 4) @result{} 3\n"
808 * "@end lisp"
809 */
0f2d19dd 810SCM
6e8d25a6 811scm_modulo (SCM x, SCM y)
0f2d19dd 812{
0aacf84e
MD		 813 if (SCM_INUMP (x))
814 {
815 long xx = SCM_INUM (x);
816 if (SCM_INUMP (y))
817 {
818 long yy = SCM_INUM (y);
819 if (yy == 0)
820 scm_num_overflow (s_modulo);
821 else
822 {
823 /* FIXME: I think this may be a bug on some arches -- results
824 of % with negative second arg are undefined... */
825 long z = xx % yy;
826 long result;
827
828 if (yy < 0)
829 {
830 if (z > 0)
831 result = z + yy;
832 else
833 result = z;
834 }
835 else
836 {
837 if (z < 0)
838 result = z + yy;
839 else
840 result = z;
841 }
842 return SCM_MAKINUM (result);
843 }
844 }
845 else if (SCM_BIGP (y))
846 {
847 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
848
849 if (sgn_y == 0)
850 scm_num_overflow (s_modulo);
851 else
852 {
853 mpz_t z_x;
854 SCM result;
855
856 if (sgn_y < 0)
857 {
858 SCM pos_y = scm_i_clonebig (y, 0);
859 /* do this after the last scm_op */
860 mpz_init_set_si (z_x, xx);
861 result = pos_y; /* re-use this bignum */
862 mpz_mod (SCM_I_BIG_MPZ (result),
863 z_x,
864 SCM_I_BIG_MPZ (pos_y));
865 scm_remember_upto_here_1 (pos_y);
866 }
867 else
868 {
869 result = scm_i_mkbig ();
870 /* do this after the last scm_op */
871 mpz_init_set_si (z_x, xx);
872 mpz_mod (SCM_I_BIG_MPZ (result),
873 z_x,
874 SCM_I_BIG_MPZ (y));
875 scm_remember_upto_here_1 (y);
876 }
ca46fb90 877
0aacf84e
MD		 878 if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)
879 mpz_add (SCM_I_BIG_MPZ (result),
880 SCM_I_BIG_MPZ (y),
881 SCM_I_BIG_MPZ (result));
882 scm_remember_upto_here_1 (y);
883 /* and do this before the next one */
884 mpz_clear (z_x);
885 return scm_i_normbig (result);
886 }
887 }
888 else
889 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
f872b822 890 }
0aacf84e
MD		 891 else if (SCM_BIGP (x))
892 {
893 if (SCM_INUMP (y))
894 {
895 long yy = SCM_INUM (y);
896 if (yy == 0)
897 scm_num_overflow (s_modulo);
898 else
899 {
900 SCM result = scm_i_mkbig ();
901 mpz_mod_ui (SCM_I_BIG_MPZ (result),
902 SCM_I_BIG_MPZ (x),
903 (yy < 0) ? - yy : yy);
904 scm_remember_upto_here_1 (x);
905 if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
906 mpz_sub_ui (SCM_I_BIG_MPZ (result),
907 SCM_I_BIG_MPZ (result),
908 - yy);
909 return scm_i_normbig (result);
910 }
911 }
912 else if (SCM_BIGP (y))
913 {
914 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
915 if (sgn_y == 0)
916 scm_num_overflow (s_modulo);
917 else
918 {
919 SCM result = scm_i_mkbig ();
920 int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
921 SCM pos_y = scm_i_clonebig (y, y_sgn >= 0);
922 mpz_mod (SCM_I_BIG_MPZ (result),
923 SCM_I_BIG_MPZ (x),
924 SCM_I_BIG_MPZ (pos_y));
ca46fb90 925
0aacf84e
MD		 926 scm_remember_upto_here_1 (x);
927 if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0))
928 mpz_add (SCM_I_BIG_MPZ (result),
929 SCM_I_BIG_MPZ (y),
930 SCM_I_BIG_MPZ (result));
931 scm_remember_upto_here_2 (y, pos_y);
932 return scm_i_normbig (result);
933 }
934 }
935 else
936 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
828865c3 937 }
0aacf84e 938 else
09fb7599 939 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo);
0f2d19dd
JB		 940}
941
9de33deb 942SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
942e5b91
MG		 943/* "Return the greatest common divisor of all arguments.\n"
944 * "If called without arguments, 0 is returned."
945 */
0f2d19dd 946SCM
6e8d25a6 947scm_gcd (SCM x, SCM y)
0f2d19dd 948{
ca46fb90 949 if (SCM_UNBNDP (y))
0aacf84e 950 return SCM_UNBNDP (x) ? SCM_INUM0 : x;
ca46fb90
RB		 951
952 if (SCM_INUMP (x))
953 {
954 if (SCM_INUMP (y))
955 {
956 long xx = SCM_INUM (x);
957 long yy = SCM_INUM (y);
958 long u = xx < 0 ? -xx : xx;
959 long v = yy < 0 ? -yy : yy;
960 long result;
0aacf84e
MD		 961 if (xx == 0)
962 result = v;
963 else if (yy == 0)
964 result = u;
965 else
966 {
967 long k = 1;
968 long t;
969 /* Determine a common factor 2^k */
970 while (!(1 & (u | v)))
971 {
972 k <<= 1;
973 u >>= 1;
974 v >>= 1;
975 }
976 /* Now, any factor 2^n can be eliminated */
977 if (u & 1)
978 t = -v;
979 else
980 {
981 t = u;
982 b3:
983 t = SCM_SRS (t, 1);
984 }
985 if (!(1 & t))
986 goto b3;
987 if (t > 0)
988 u = t;
989 else
990 v = -t;
991 t = u - v;
992 if (t != 0)
993 goto b3;
994 result = u * k;
995 }
996 return (SCM_POSFIXABLE (result)
997 ? SCM_MAKINUM (result)
998 : scm_i_long2big (result));
ca46fb90
RB		 999 }
1000 else if (SCM_BIGP (y))
1001 {
1002 SCM result = scm_i_mkbig ();
1003 SCM mx = scm_i_mkbig ();
0aacf84e 1004 mpz_set_si (SCM_I_BIG_MPZ (mx), SCM_INUM (x));
ca46fb90 1005 scm_remember_upto_here_1 (x);
0aacf84e
MD		 1006 mpz_gcd (SCM_I_BIG_MPZ (result),
1007 SCM_I_BIG_MPZ (mx),
1008 SCM_I_BIG_MPZ (y));
1009 scm_remember_upto_here_2 (mx, y);
ca46fb90
RB		 1010 return scm_i_normbig (result);
1011 }
1012 else
1013 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
f872b822 1014 }
ca46fb90
RB		 1015 else if (SCM_BIGP (x))
1016 {
1017 if (SCM_INUMP (y))
1018 {
1019 unsigned long result;
1020 long yy = SCM_INUM (y);
8c5b0afc
KR		 1021 if (yy == 0)
1022 return scm_abs (x);
0aacf84e
MD		 1023 if (yy < 0)
1024 yy = -yy;
ca46fb90
RB		 1025 result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy);
1026 scm_remember_upto_here_1 (x);
0aacf84e
MD		 1027 return (SCM_POSFIXABLE (result)
1028 ? SCM_MAKINUM (result)
1029 : scm_ulong2num (result));
ca46fb90
RB		 1030 }
1031 else if (SCM_BIGP (y))
1032 {
1033 SCM result = scm_i_mkbig ();
0aacf84e
MD		 1034 mpz_gcd (SCM_I_BIG_MPZ (result),
1035 SCM_I_BIG_MPZ (x),
1036 SCM_I_BIG_MPZ (y));
1037 scm_remember_upto_here_2 (x, y);
ca46fb90
RB		 1038 return scm_i_normbig (result);
1039 }
1040 else
1041 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG2, s_gcd);
09fb7599 1042 }
ca46fb90 1043 else
09fb7599 1044 SCM_WTA_DISPATCH_2 (g_gcd, x, y, SCM_ARG1, s_gcd);
0f2d19dd
JB		 1045}
1046
9de33deb 1047SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
942e5b91
MG		 1048/* "Return the least common multiple of the arguments.\n"
1049 * "If called without arguments, 1 is returned."
1050 */
0f2d19dd 1051SCM
6e8d25a6 1052scm_lcm (SCM n1, SCM n2)
0f2d19dd 1053{
ca46fb90
RB		 1054 if (SCM_UNBNDP (n2))
1055 {
1056 if (SCM_UNBNDP (n1))
1057 return SCM_MAKINUM (1L);
09fb7599
DH		 1058 n2 = SCM_MAKINUM (1L);
1059 }
09fb7599 1060
09fb7599 1061 SCM_GASSERT2 (SCM_INUMP (n1) || SCM_BIGP (n1),
ca46fb90 1062 g_lcm, n1, n2, SCM_ARG1, s_lcm);
09fb7599 1063 SCM_GASSERT2 (SCM_INUMP (n2) || SCM_BIGP (n2),
ca46fb90 1064 g_lcm, n1, n2, SCM_ARGn, s_lcm);
09fb7599 1065
ca46fb90
RB		 1066 if (SCM_INUMP (n1))
1067 {
1068 if (SCM_INUMP (n2))
1069 {
1070 SCM d = scm_gcd (n1, n2);
1071 if (SCM_EQ_P (d, SCM_INUM0))
1072 return d;
1073 else
1074 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
1075 }
1076 else
1077 {
1078 /* inum n1, big n2 */
1079 inumbig:
1080 {
1081 SCM result = scm_i_mkbig ();
1082 long nn1 = SCM_INUM (n1);
1083 if (nn1 == 0) return SCM_INUM0;
1084 if (nn1 < 0) nn1 = - nn1;
1085 mpz_lcm_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n2), nn1);
1086 scm_remember_upto_here_1 (n2);
1087 return result;
1088 }
1089 }
1090 }
1091 else
1092 {
1093 /* big n1 */
1094 if (SCM_INUMP (n2))
1095 {
1096 SCM_SWAP (n1, n2);
1097 goto inumbig;
1098 }
1099 else
1100 {
1101 SCM result = scm_i_mkbig ();
1102 mpz_lcm(SCM_I_BIG_MPZ (result),
1103 SCM_I_BIG_MPZ (n1),
1104 SCM_I_BIG_MPZ (n2));
1105 scm_remember_upto_here_2(n1, n2);
1106 /* shouldn't need to normalize b/c lcm of 2 bigs should be big */
1107 return result;
1108 }
f872b822 1109 }
0f2d19dd
JB		 1110}
1111
0f2d19dd 1112#ifndef scm_long2num
c1bfcf60
GB		 1113#define SCM_LOGOP_RETURN(x) scm_ulong2num(x)
1114#else
1115#define SCM_LOGOP_RETURN(x) SCM_MAKINUM(x)
1116#endif
1117
8a525303
GB		 1118/* Emulating 2's complement bignums with sign magnitude arithmetic:
1119
1120 Logand:
1121 X Y Result Method:
1122 (len)
1123 + + + x (map digit:logand X Y)
1124 + - + x (map digit:logand X (lognot (+ -1 Y)))
1125 - + + y (map digit:logand (lognot (+ -1 X)) Y)
1126 - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
1127
1128 Logior:
1129 X Y Result Method:
1130
1131 + + + (map digit:logior X Y)
1132 + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
1133 - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
1134 - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
1135
1136 Logxor:
1137 X Y Result Method:
1138
1139 + + + (map digit:logxor X Y)
1140 + - - (+ 1 (map digit:logxor X (+ -1 Y)))
1141 - + - (+ 1 (map digit:logxor (+ -1 X) Y))
1142 - - + (map digit:logxor (+ -1 X) (+ -1 Y))
1143
1144 Logtest:
1145 X Y Result
1146
1147 + + (any digit:logand X Y)
1148 + - (any digit:logand X (lognot (+ -1 Y)))
1149 - + (any digit:logand (lognot (+ -1 X)) Y)
1150 - - #t
1151
1152*/
1153
c3ee7520 1154SCM_DEFINE1 (scm_logand, "logand", scm_tc7_asubr,
1bbd0b84 1155 (SCM n1, SCM n2),
3c3db128
GH		 1156 "Return the bitwise AND of the integer arguments.\n\n"
1157 "@lisp\n"
1158 "(logand) @result{} -1\n"
1159 "(logand 7) @result{} 7\n"
1160 "(logand #b111 #b011 #\b001) @result{} 1\n"
1161 "@end lisp")
1bbd0b84 1162#define FUNC_NAME s_scm_logand
0f2d19dd 1163{
9a00c9fc
DH		 1164 long int nn1;
1165
0aacf84e
MD		 1166 if (SCM_UNBNDP (n2))
1167 {
1168 if (SCM_UNBNDP (n1))
1169 return SCM_MAKINUM (-1);
1170 else if (!SCM_NUMBERP (n1))
1171 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
1172 else if (SCM_NUMBERP (n1))
1173 return n1;
1174 else
1175 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1176 }
09fb7599 1177
0aacf84e
MD		 1178 if (SCM_INUMP (n1))
1179 {
9a00c9fc 1180 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1181 if (SCM_INUMP (n2))
1182 {
1183 long nn2 = SCM_INUM (n2);
1184 return SCM_MAKINUM (nn1 & nn2);
1185 }
1186 else if SCM_BIGP (n2)
1187 {
1188 intbig:
1189 if (n1 == 0)
1190 return SCM_INUM0;
1191 {
1192 SCM result_z = scm_i_mkbig ();
1193 mpz_t nn1_z;
1194 mpz_init_set_si (nn1_z, nn1);
1195 mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1196 scm_remember_upto_here_1 (n2);
1197 mpz_clear (nn1_z);
1198 return scm_i_normbig (result_z);
1199 }
1200 }
1201 else
1202 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1203 }
1204 else if (SCM_BIGP (n1))
1205 {
1206 if (SCM_INUMP (n2))
1207 {
1208 SCM_SWAP (n1, n2);
1209 nn1 = SCM_INUM (n1);
1210 goto intbig;
1211 }
1212 else if (SCM_BIGP (n2))
1213 {
1214 SCM result_z = scm_i_mkbig ();
1215 mpz_and (SCM_I_BIG_MPZ (result_z),
1216 SCM_I_BIG_MPZ (n1),
1217 SCM_I_BIG_MPZ (n2));
1218 scm_remember_upto_here_2 (n1, n2);
1219 return scm_i_normbig (result_z);
1220 }
1221 else
1222 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1223 }
0aacf84e 1224 else
09fb7599 1225 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1226}
1bbd0b84 1227#undef FUNC_NAME
0f2d19dd 1228
09fb7599 1229
c3ee7520 1230SCM_DEFINE1 (scm_logior, "logior", scm_tc7_asubr,
1bbd0b84 1231 (SCM n1, SCM n2),
3c3db128
GH		 1232 "Return the bitwise OR of the integer arguments.\n\n"
1233 "@lisp\n"
1234 "(logior) @result{} 0\n"
1235 "(logior 7) @result{} 7\n"
1236 "(logior #b000 #b001 #b011) @result{} 3\n"
1e6808ea 1237 "@end lisp")
1bbd0b84 1238#define FUNC_NAME s_scm_logior
0f2d19dd 1239{
9a00c9fc
DH		 1240 long int nn1;
1241
0aacf84e
MD		 1242 if (SCM_UNBNDP (n2))
1243 {
1244 if (SCM_UNBNDP (n1))
1245 return SCM_INUM0;
1246 else if (SCM_NUMBERP (n1))
1247 return n1;
1248 else
1249 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1250 }
09fb7599 1251
0aacf84e
MD		 1252 if (SCM_INUMP (n1))
1253 {
9a00c9fc 1254 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1255 if (SCM_INUMP (n2))
1256 {
1257 long nn2 = SCM_INUM (n2);
1258 return SCM_MAKINUM (nn1 | nn2);
1259 }
1260 else if (SCM_BIGP (n2))
1261 {
1262 intbig:
1263 if (nn1 == 0)
1264 return n2;
1265 {
1266 SCM result_z = scm_i_mkbig ();
1267 mpz_t nn1_z;
1268 mpz_init_set_si (nn1_z, nn1);
1269 mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1270 scm_remember_upto_here_1 (n2);
1271 mpz_clear (nn1_z);
1272 return result_z;
1273 }
1274 }
1275 else
1276 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1277 }
1278 else if (SCM_BIGP (n1))
1279 {
1280 if (SCM_INUMP (n2))
1281 {
1282 SCM_SWAP (n1, n2);
1283 nn1 = SCM_INUM (n1);
1284 goto intbig;
1285 }
1286 else if (SCM_BIGP (n2))
1287 {
1288 SCM result_z = scm_i_mkbig ();
1289 mpz_ior (SCM_I_BIG_MPZ (result_z),
1290 SCM_I_BIG_MPZ (n1),
1291 SCM_I_BIG_MPZ (n2));
1292 scm_remember_upto_here_2 (n1, n2);
1293 return result_z;
1294 }
1295 else
1296 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1297 }
0aacf84e 1298 else
09fb7599 1299 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1300}
1bbd0b84 1301#undef FUNC_NAME
0f2d19dd 1302
09fb7599 1303
c3ee7520 1304SCM_DEFINE1 (scm_logxor, "logxor", scm_tc7_asubr,
1bbd0b84 1305 (SCM n1, SCM n2),
3c3db128
GH		 1306 "Return the bitwise XOR of the integer arguments. A bit is\n"
1307 "set in the result if it is set in an odd number of arguments.\n"
1308 "@lisp\n"
1309 "(logxor) @result{} 0\n"
1310 "(logxor 7) @result{} 7\n"
1311 "(logxor #b000 #b001 #b011) @result{} 2\n"
1312 "(logxor #b000 #b001 #b011 #b011) @result{} 1\n"
1e6808ea 1313 "@end lisp")
1bbd0b84 1314#define FUNC_NAME s_scm_logxor
0f2d19dd 1315{
9a00c9fc
DH		 1316 long int nn1;
1317
0aacf84e
MD		 1318 if (SCM_UNBNDP (n2))
1319 {
1320 if (SCM_UNBNDP (n1))
1321 return SCM_INUM0;
1322 else if (SCM_NUMBERP (n1))
1323 return n1;
1324 else
1325 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
d28da049 1326 }
09fb7599 1327
0aacf84e
MD		 1328 if (SCM_INUMP (n1))
1329 {
9a00c9fc 1330 nn1 = SCM_INUM (n1);
0aacf84e
MD		 1331 if (SCM_INUMP (n2))
1332 {
1333 long nn2 = SCM_INUM (n2);
1334 return SCM_MAKINUM (nn1 ^ nn2);
1335 }
1336 else if (SCM_BIGP (n2))
1337 {
1338 intbig:
1339 {
1340 SCM result_z = scm_i_mkbig ();
1341 mpz_t nn1_z;
1342 mpz_init_set_si (nn1_z, nn1);
1343 mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2));
1344 scm_remember_upto_here_1 (n2);
1345 mpz_clear (nn1_z);
1346 return scm_i_normbig (result_z);
1347 }
1348 }
1349 else
1350 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
1351 }
1352 else if (SCM_BIGP (n1))
1353 {
1354 if (SCM_INUMP (n2))
1355 {
1356 SCM_SWAP (n1, n2);
1357 nn1 = SCM_INUM (n1);
1358 goto intbig;
1359 }
1360 else if (SCM_BIGP (n2))
1361 {
1362 SCM result_z = scm_i_mkbig ();
1363 mpz_xor (SCM_I_BIG_MPZ (result_z),
1364 SCM_I_BIG_MPZ (n1),
1365 SCM_I_BIG_MPZ (n2));
1366 scm_remember_upto_here_2 (n1, n2);
1367 return scm_i_normbig (result_z);
1368 }
1369 else
1370 SCM_WRONG_TYPE_ARG (SCM_ARG2, n2);
09fb7599 1371 }
0aacf84e 1372 else
09fb7599 1373 SCM_WRONG_TYPE_ARG (SCM_ARG1, n1);
0f2d19dd 1374}
1bbd0b84 1375#undef FUNC_NAME
0f2d19dd 1376
09fb7599 1377
a1ec6916 1378SCM_DEFINE (scm_logtest, "logtest", 2, 0, 0,
1e6808ea
MG		 1379 (SCM j, SCM k),
1380 "@lisp\n"
b380b885
MD		 1381 "(logtest j k) @equiv{} (not (zero? (logand j k)))\n\n"
1382 "(logtest #b0100 #b1011) @result{} #f\n"
1383 "(logtest #b0100 #b0111) @result{} #t\n"
1e6808ea 1384 "@end lisp")
1bbd0b84 1385#define FUNC_NAME s_scm_logtest
0f2d19dd 1386{
1e6808ea 1387 long int nj;
9a00c9fc 1388
0aacf84e
MD		 1389 if (SCM_INUMP (j))
1390 {
1e6808ea 1391 nj = SCM_INUM (j);
0aacf84e
MD		 1392 if (SCM_INUMP (k))
1393 {
1394 long nk = SCM_INUM (k);
1395 return SCM_BOOL (nj & nk);
1396 }
1397 else if (SCM_BIGP (k))
1398 {
1399 intbig:
1400 if (nj == 0)
1401 return SCM_BOOL_F;
1402 {
1403 SCM result;
1404 mpz_t nj_z;
1405 mpz_init_set_si (nj_z, nj);
1406 mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k));
1407 scm_remember_upto_here_1 (k);
1408 result = SCM_BOOL (mpz_sgn (nj_z) != 0);
1409 mpz_clear (nj_z);
1410 return result;
1411 }
1412 }
1413 else
1414 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1415 }
1416 else if (SCM_BIGP (j))
1417 {
1418 if (SCM_INUMP (k))
1419 {
1420 SCM_SWAP (j, k);
1421 nj = SCM_INUM (j);
1422 goto intbig;
1423 }
1424 else if (SCM_BIGP (k))
1425 {
1426 SCM result;
1427 mpz_t result_z;
1428 mpz_init (result_z);
1429 mpz_and (result_z,
1430 SCM_I_BIG_MPZ (j),
1431 SCM_I_BIG_MPZ (k));
1432 scm_remember_upto_here_2 (j, k);
1433 result = SCM_BOOL (mpz_sgn (result_z) != 0);
1434 mpz_clear (result_z);
1435 return result;
1436 }
1437 else
1438 SCM_WRONG_TYPE_ARG (SCM_ARG2, k);
1439 }
1440 else
1441 SCM_WRONG_TYPE_ARG (SCM_ARG1, j);
0f2d19dd 1442}
1bbd0b84 1443#undef FUNC_NAME
0f2d19dd 1444
c1bfcf60 1445
a1ec6916 1446SCM_DEFINE (scm_logbit_p, "logbit?", 2, 0, 0,
2cd04b42 1447 (SCM index, SCM j),
1e6808ea 1448 "@lisp\n"
b380b885
MD		 1449 "(logbit? index j) @equiv{} (logtest (integer-expt 2 index) j)\n\n"
1450 "(logbit? 0 #b1101) @result{} #t\n"
1451 "(logbit? 1 #b1101) @result{} #f\n"
1452 "(logbit? 2 #b1101) @result{} #t\n"
1453 "(logbit? 3 #b1101) @result{} #t\n"
1454 "(logbit? 4 #b1101) @result{} #f\n"
1e6808ea 1455 "@end lisp")
1bbd0b84 1456#define FUNC_NAME s_scm_logbit_p
0f2d19dd 1457{
78166ad5
DH		 1458 unsigned long int iindex;
1459
1460 SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0);
1461 iindex = (unsigned long int) SCM_INUM (index);
1462
0aacf84e 1463 if (SCM_INUMP (j))
78166ad5 1464 return SCM_BOOL ((1L << iindex) & SCM_INUM (j));
0aacf84e
MD		 1465 else if (SCM_BIGP (j))
1466 {
1467 int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex);
1468 scm_remember_upto_here_1 (j);
1469 return SCM_BOOL (val);
1470 }
1471 else
78166ad5 1472 SCM_WRONG_TYPE_ARG (SCM_ARG2, j);
0f2d19dd 1473}
1bbd0b84 1474#undef FUNC_NAME
0f2d19dd 1475
78166ad5 1476
a1ec6916 1477SCM_DEFINE (scm_lognot, "lognot", 1, 0, 0,
1bbd0b84 1478 (SCM n),
4d814788 1479 "Return the integer which is the ones-complement of the integer\n"
1e6808ea
MG		 1480 "argument.\n"
1481 "\n"
b380b885
MD		 1482 "@lisp\n"
1483 "(number->string (lognot #b10000000) 2)\n"
1484 " @result{} \"-10000001\"\n"
1485 "(number->string (lognot #b0) 2)\n"
1486 " @result{} \"-1\"\n"
1e6808ea 1487 "@end lisp")
1bbd0b84 1488#define FUNC_NAME s_scm_lognot
0f2d19dd 1489{
f9811f9f
KR		 1490 if (SCM_INUMP (n)) {
1491 /* No overflow here, just need to toggle all the bits making up the inum.
1492 Enhancement: No need to strip the tag and add it back, could just xor
1493 a block of 1 bits, if that worked with the various debug versions of
1494 the SCM typedef. */
1495 return SCM_MAKINUM (~ SCM_INUM (n));
1496
1497 } else if (SCM_BIGP (n)) {
1498 SCM result = scm_i_mkbig ();
1499 mpz_com (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (n));
1500 scm_remember_upto_here_1 (n);
1501 return result;
1502
1503 } else {
1504 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
1505 }
0f2d19dd 1506}
1bbd0b84 1507#undef FUNC_NAME
0f2d19dd 1508
a1ec6916 1509SCM_DEFINE (scm_integer_expt, "integer-expt", 2, 0, 0,
2cd04b42 1510 (SCM n, SCM k),
1e6808ea
MG		 1511 "Return @var{n} raised to the non-negative integer exponent\n"
1512 "@var{k}.\n"
1513 "\n"
b380b885
MD		 1514 "@lisp\n"
1515 "(integer-expt 2 5)\n"
1516 " @result{} 32\n"
1517 "(integer-expt -3 3)\n"
1518 " @result{} -27\n"
1519 "@end lisp")
1bbd0b84 1520#define FUNC_NAME s_scm_integer_expt
0f2d19dd 1521{
1c35cb19
RB		 1522 long i2 = 0;
1523 SCM z_i2 = SCM_BOOL_F;
1524 int i2_is_big = 0;
f872b822 1525 SCM acc = SCM_MAKINUM (1L);
ca46fb90 1526
d57ed702 1527 /* 0^0 == 1 according to R5RS */
4260a7fc 1528 if (SCM_EQ_P (n, SCM_INUM0) || SCM_EQ_P (n, acc))
7b3381f4 1529 return SCM_FALSEP (scm_zero_p(k)) ? n : acc;
4260a7fc
DH		 1530 else if (SCM_EQ_P (n, SCM_MAKINUM (-1L)))
1531 return SCM_FALSEP (scm_even_p (k)) ? n : acc;
ca46fb90 1532
ca46fb90
RB		 1533 if (SCM_INUMP (k))
1534 i2 = SCM_INUM (k);
1535 else if (SCM_BIGP (k))
1536 {
1537 z_i2 = scm_i_clonebig (k, 1);
ca46fb90
RB		 1538 scm_remember_upto_here_1 (k);
1539 i2_is_big = 1;
1540 }
1541 else if (SCM_REALP (k))
2830fd91
MD		 1542 {
1543 double r = SCM_REAL_VALUE (k);
ca46fb90
RB		 1544 if (floor (r) != r)
1545 SCM_WRONG_TYPE_ARG (2, k);
1546 if ((r > SCM_MOST_POSITIVE_FIXNUM) || (r < SCM_MOST_NEGATIVE_FIXNUM))
1547 {
1548 z_i2 = scm_i_mkbig ();
753ac1e7 1549 mpz_set_d (SCM_I_BIG_MPZ (z_i2), r);
ca46fb90
RB		 1550 i2_is_big = 1;
1551 }
1552 else
1553 {
1554 i2 = r;
1555 }
2830fd91
MD		 1556 }
1557 else
ca46fb90
RB		 1558 SCM_WRONG_TYPE_ARG (2, k);
1559
1560 if (i2_is_big)
f872b822 1561 {
ca46fb90
RB		 1562 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == -1)
1563 {
1564 mpz_neg (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2));
1565 n = scm_divide (n, SCM_UNDEFINED);
1566 }
1567 while (1)
1568 {
1569 if (mpz_sgn(SCM_I_BIG_MPZ (z_i2)) == 0)
1570 {
ca46fb90
RB		 1571 return acc;
1572 }
1573 if (mpz_cmp_ui(SCM_I_BIG_MPZ (z_i2), 1) == 0)
1574 {
ca46fb90
RB		 1575 return scm_product (acc, n);
1576 }
1577 if (mpz_tstbit(SCM_I_BIG_MPZ (z_i2), 0))
1578 acc = scm_product (acc, n);
1579 n = scm_product (n, n);
1580 mpz_fdiv_q_2exp (SCM_I_BIG_MPZ (z_i2), SCM_I_BIG_MPZ (z_i2), 1);
1581 }
f872b822 1582 }
ca46fb90 1583 else
f872b822 1584 {
ca46fb90
RB		 1585 if (i2 < 0)
1586 {
1587 i2 = -i2;
1588 n = scm_divide (n, SCM_UNDEFINED);
1589 }
1590 while (1)
1591 {
1592 if (0 == i2)
1593 return acc;
1594 if (1 == i2)
1595 return scm_product (acc, n);
1596 if (i2 & 1)
1597 acc = scm_product (acc, n);
1598 n = scm_product (n, n);
1599 i2 >>= 1;
1600 }
f872b822 1601 }
0f2d19dd 1602}
1bbd0b84 1603#undef FUNC_NAME
0f2d19dd 1604
a1ec6916 1605SCM_DEFINE (scm_ash, "ash", 2, 0, 0,
1bbd0b84 1606 (SCM n, SCM cnt),
32f19569
KR		 1607 "Return @var{n} shifted left by @var{cnt} bits, or shifted right\n"
1608 "if @var{cnt} is negative. This is an ``arithmetic'' shift.\n"
1e6808ea 1609 "\n"
32f19569
KR		 1610 "This is effectively a multiplication by 2^@var{cnt}}, and when\n"
1611 "@var{cnt} is negative it's a division, rounded towards negative\n"
1612 "infinity. (Note that this is not the same rounding as\n"
1613 "@code{quotient} does.)\n"
1614 "\n"
1615 "With @var{n} viewed as an infinite precision twos complement,\n"
1616 "@code{ash} means a left shift introducing zero bits, or a right\n"
1617 "shift dropping bits.\n"
1e6808ea 1618 "\n"
b380b885 1619 "@lisp\n"
1e6808ea
MG		 1620 "(number->string (ash #b1 3) 2) @result{} \"1000\"\n"
1621 "(number->string (ash #b1010 -1) 2) @result{} \"101\"\n"
32f19569
KR		 1622 "\n"
1623 ";; -23 is bits ...11101001, -6 is bits ...111010\n"
1624 "(ash -23 -2) @result{} -6\n"
a3c8b9fc 1625 "@end lisp")
1bbd0b84 1626#define FUNC_NAME s_scm_ash
0f2d19dd 1627{
3ab9f56e
DH		 1628 long bits_to_shift;
1629
3ab9f56e
DH		 1630 SCM_VALIDATE_INUM (2, cnt);
1631
1632 bits_to_shift = SCM_INUM (cnt);
ca46fb90
RB		 1633
1634 if (bits_to_shift < 0)
1635 {
1636 /* Shift right by abs(cnt) bits. This is realized as a division
1637 by div:=2^abs(cnt). However, to guarantee the floor
1638 rounding, negative values require some special treatment.
1639 */
1640 SCM div = scm_integer_expt (SCM_MAKINUM (2),
1641 SCM_MAKINUM (-bits_to_shift));
f92e85f7
MV		 1642
1643 /* scm_quotient assumes its arguments are integers, but it's legal to (ash 1/2 -1) */
ca46fb90
RB		 1644 if (SCM_FALSEP (scm_negative_p (n)))
1645 return scm_quotient (n, div);
1646 else
1647 return scm_sum (SCM_MAKINUM (-1L),
1648 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), div));
1649 }
1650 else
3ab9f56e 1651 /* Shift left is done by multiplication with 2^CNT */
f872b822 1652 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 1653}
1bbd0b84 1654#undef FUNC_NAME
0f2d19dd 1655
3c9f20f8 1656
a1ec6916 1657SCM_DEFINE (scm_bit_extract, "bit-extract", 3, 0, 0,
1bbd0b84 1658 (SCM n, SCM start, SCM end),
1e6808ea
MG		 1659 "Return the integer composed of the @var{start} (inclusive)\n"
1660 "through @var{end} (exclusive) bits of @var{n}. The\n"
1661 "@var{start}th bit becomes the 0-th bit in the result.\n"
1662 "\n"
b380b885
MD		 1663 "@lisp\n"
1664 "(number->string (bit-extract #b1101101010 0 4) 2)\n"
1665 " @result{} \"1010\"\n"
1666 "(number->string (bit-extract #b1101101010 4 9) 2)\n"
1667 " @result{} \"10110\"\n"
1668 "@end lisp")
1bbd0b84 1669#define FUNC_NAME s_scm_bit_extract
0f2d19dd 1670{
ac0c002c 1671 unsigned long int istart, iend;
34d19ef6 1672 SCM_VALIDATE_INUM_MIN_COPY (2, start,0, istart);
c1bfcf60
GB		 1673 SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend);
1674 SCM_ASSERT_RANGE (3, end, (iend >= istart));
78166ad5 1675
0aacf84e
MD		 1676 if (SCM_INUMP (n))
1677 {
1678 long int in = SCM_INUM (n);
1679 unsigned long int bits = iend - istart;
ac0c002c 1680
0aacf84e
MD		 1681 if (in < 0 && bits >= SCM_I_FIXNUM_BIT)
1682 {
1683 /* Since we emulate two's complement encoded numbers, this
1684 * special case requires us to produce a result that has
1685 * more bits than can be stored in a fixnum. Thus, we fall
1686 * back to the more general algorithm that is used for
1687 * bignums.
1688 */
1689 goto generalcase;
1690 }
ac0c002c 1691
0aacf84e
MD		 1692 if (istart < SCM_I_FIXNUM_BIT)
1693 {
1694 in = in >> istart;
1695 if (bits < SCM_I_FIXNUM_BIT)
1696 return SCM_MAKINUM (in & ((1L << bits) - 1));
1697 else /* we know: in >= 0 */
1698 return SCM_MAKINUM (in);
1699 }
1700 else if (in < 0)
ac0c002c 1701 return SCM_MAKINUM (-1L & ((1L << bits) - 1));
0aacf84e 1702 else
ac0c002c 1703 return SCM_MAKINUM (0);
0aacf84e
MD		 1704 }
1705 else if (SCM_BIGP (n))
ac0c002c 1706 {
0aacf84e
MD		 1707 generalcase:
1708 {
1709 SCM num1 = SCM_MAKINUM (1L);
1710 SCM num2 = SCM_MAKINUM (2L);
1711 SCM bits = SCM_MAKINUM (iend - istart);
1712 SCM mask = scm_difference (scm_integer_expt (num2, bits), num1);
1713 return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart)));
1714 }
ac0c002c 1715 }
0aacf84e 1716 else
78166ad5 1717 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1718}
1bbd0b84 1719#undef FUNC_NAME
0f2d19dd 1720
e4755e5c
JB		 1721static const char scm_logtab[] = {
1722 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
1723};
1cc91f1b 1724
a1ec6916 1725SCM_DEFINE (scm_logcount, "logcount", 1, 0, 0,
1bbd0b84 1726 (SCM n),
1e6808ea
MG		 1727 "Return the number of bits in integer @var{n}. If integer is\n"
1728 "positive, the 1-bits in its binary representation are counted.\n"
1729 "If negative, the 0-bits in its two's-complement binary\n"
1730 "representation are counted. If 0, 0 is returned.\n"
1731 "\n"
b380b885
MD		 1732 "@lisp\n"
1733 "(logcount #b10101010)\n"
ca46fb90
RB		 1734 " @result{} 4\n"
1735 "(logcount 0)\n"
1736 " @result{} 0\n"
1737 "(logcount -2)\n"
1738 " @result{} 1\n"
1739 "@end lisp")
1740#define FUNC_NAME s_scm_logcount
1741{
1742 if (SCM_INUMP (n))
f872b822 1743 {
ca46fb90
RB		 1744 unsigned long int c = 0;
1745 long int nn = SCM_INUM (n);
1746 if (nn < 0)
1747 nn = -1 - nn;
1748 while (nn)
1749 {
1750 c += scm_logtab[15 & nn];
1751 nn >>= 4;
1752 }
1753 return SCM_MAKINUM (c);
f872b822 1754 }
ca46fb90 1755 else if (SCM_BIGP (n))
f872b822 1756 {
ca46fb90 1757 unsigned long count;
713a4259
KR		 1758 if (mpz_sgn (SCM_I_BIG_MPZ (n)) >= 0)
1759 count = mpz_popcount (SCM_I_BIG_MPZ (n));
ca46fb90 1760 else
713a4259
KR		 1761 count = mpz_hamdist (SCM_I_BIG_MPZ (n), z_negative_one);
1762 scm_remember_upto_here_1 (n);
ca46fb90 1763 return SCM_MAKINUM (count);
f872b822 1764 }
ca46fb90
RB		 1765 else
1766 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
0f2d19dd 1767}
ca46fb90 1768#undef FUNC_NAME
0f2d19dd
JB		 1769
1770
ca46fb90
RB		 1771static const char scm_ilentab[] = {
1772 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
1773};
1774
0f2d19dd 1775
ca46fb90
RB		 1776SCM_DEFINE (scm_integer_length, "integer-length", 1, 0, 0,
1777 (SCM n),
1778 "Return the number of bits necessary to represent @var{n}.\n"
1779 "\n"
1780 "@lisp\n"
1781 "(integer-length #b10101010)\n"
1782 " @result{} 8\n"
1783 "(integer-length 0)\n"
1784 " @result{} 0\n"
1785 "(integer-length #b1111)\n"
1786 " @result{} 4\n"
1787 "@end lisp")
1788#define FUNC_NAME s_scm_integer_length
1789{
0aacf84e
MD		 1790 if (SCM_INUMP (n))
1791 {
1792 unsigned long int c = 0;
1793 unsigned int l = 4;
1794 long int nn = SCM_INUM (n);
1795 if (nn < 0)
1796 nn = -1 - nn;
1797 while (nn)
1798 {
1799 c += 4;
1800 l = scm_ilentab [15 & nn];
1801 nn >>= 4;
1802 }
1803 return SCM_MAKINUM (c - 4 + l);
1804 }
1805 else if (SCM_BIGP (n))
1806 {
1807 /* mpz_sizeinbase looks at the absolute value of negatives, whereas we
1808 want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is
1809 1 too big, so check for that and adjust. */
1810 size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2);
1811 if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0
1812 && mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */
1813 mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX)
1814 size--;
1815 scm_remember_upto_here_1 (n);
1816 return SCM_MAKINUM (size);
1817 }
1818 else
ca46fb90 1819 SCM_WRONG_TYPE_ARG (SCM_ARG1, n);
ca46fb90
RB		 1820}
1821#undef FUNC_NAME
0f2d19dd
JB		 1822
1823/*** NUMBERS -> STRINGS ***/
0f2d19dd 1824int scm_dblprec;
e4755e5c 1825static const double fx[] =
f872b822
MD		 1826{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1827 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1828 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1829 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
0f2d19dd 1830
1be6b49c 1831static size_t
1bbd0b84 1832idbl2str (double f, char *a)
0f2d19dd
JB		 1833{
1834 int efmt, dpt, d, i, wp = scm_dblprec;
1be6b49c 1835 size_t ch = 0;
0f2d19dd
JB		 1836 int exp = 0;
1837
f872b822 1838 if (f == 0.0)
abb7e44d
MV		 1839 {
1840#ifdef HAVE_COPYSIGN
1841 double sgn = copysign (1.0, f);
1842
1843 if (sgn < 0.0)
1844 a[ch++] = '-';
1845#endif
1846
1847 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1848 }
7351e207
MV		 1849
1850 if (xisinf (f))
1851 {
1852 if (f < 0)
1853 strcpy (a, "-inf.0");
1854 else
1855 strcpy (a, "+inf.0");
1856 return ch+6;
1857 }
1858 else if (xisnan (f))
1859 {
1860 strcpy (a, "+nan.0");
1861 return ch+6;
1862 }
1863
f872b822
MD		 1864 if (f < 0.0)
1865 {
1866 f = -f;
1867 a[ch++] = '-';
1868 }
7351e207 1869
f872b822
MD		 1870#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1871 make-uniform-vector, from causing infinite loops. */
1872 while (f < 1.0)
1873 {
1874 f *= 10.0;
1875 if (exp-- < DBL_MIN_10_EXP)
7351e207
MV		 1876 {
1877 a[ch++] = '#';
1878 a[ch++] = '.';
1879 a[ch++] = '#';
1880 return ch;
1881 }
f872b822
MD		 1882 }
1883 while (f > 10.0)
1884 {
1885 f *= 0.10;
1886 if (exp++ > DBL_MAX_10_EXP)
7351e207
MV		 1887 {
1888 a[ch++] = '#';
1889 a[ch++] = '.';
1890 a[ch++] = '#';
1891 return ch;
1892 }
f872b822
MD		 1893 }
1894#else
1895 while (f < 1.0)
1896 {
1897 f *= 10.0;
1898 exp--;
1899 }
1900 while (f > 10.0)
1901 {
1902 f /= 10.0;
1903 exp++;
1904 }
1905#endif
1906 if (f + fx[wp] >= 10.0)
1907 {
1908 f = 1.0;
1909 exp++;
1910 }
0f2d19dd 1911 zero:
f872b822
MD		 1912#ifdef ENGNOT
1913 dpt = (exp + 9999) % 3;
0f2d19dd
JB		 1914 exp -= dpt++;
1915 efmt = 1;
f872b822
MD		 1916#else
1917 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 1918 if (!efmt)
cda139a7
MD		 1919 {
1920 if (exp < 0)
1921 {
1922 a[ch++] = '0';
1923 a[ch++] = '.';
1924 dpt = exp;
f872b822
MD		 1925 while (++dpt)
1926 a[ch++] = '0';
cda139a7
MD		 1927 }
1928 else
f872b822 1929 dpt = exp + 1;
cda139a7 1930 }
0f2d19dd
JB		 1931 else
1932 dpt = 1;
f872b822
MD		 1933#endif
1934
1935 do
1936 {
1937 d = f;
1938 f -= d;
1939 a[ch++] = d + '0';
1940 if (f < fx[wp])
1941 break;
1942 if (f + fx[wp] >= 1.0)
1943 {
1944 a[ch - 1]++;
1945 break;
1946 }
1947 f *= 10.0;
1948 if (!(--dpt))
1949 a[ch++] = '.';
0f2d19dd 1950 }
f872b822 1951 while (wp--);
0f2d19dd
JB		 1952
1953 if (dpt > 0)
cda139a7 1954 {
f872b822 1955#ifndef ENGNOT
cda139a7
MD		 1956 if ((dpt > 4) && (exp > 6))
1957 {
f872b822 1958 d = (a[0] == '-' ? 2 : 1);
cda139a7 1959 for (i = ch++; i > d; i--)
f872b822 1960 a[i] = a[i - 1];
cda139a7
MD		 1961 a[d] = '.';
1962 efmt = 1;
1963 }
1964 else
f872b822 1965#endif
cda139a7 1966 {
f872b822
MD		 1967 while (--dpt)
1968 a[ch++] = '0';
cda139a7
MD		 1969 a[ch++] = '.';
1970 }
1971 }
f872b822
MD		 1972 if (a[ch - 1] == '.')
1973 a[ch++] = '0'; /* trailing zero */
1974 if (efmt && exp)
1975 {
1976 a[ch++] = 'e';
1977 if (exp < 0)
1978 {
1979 exp = -exp;
1980 a[ch++] = '-';
1981 }
1982 for (i = 10; i <= exp; i *= 10);
1983 for (i /= 10; i; i /= 10)
1984 {
1985 a[ch++] = exp / i + '0';
1986 exp %= i;
1987 }
0f2d19dd 1988 }
0f2d19dd
JB		 1989 return ch;
1990}
1991
1cc91f1b 1992
1be6b49c 1993static size_t
1bbd0b84 1994iflo2str (SCM flt, char *str)
0f2d19dd 1995{
1be6b49c 1996 size_t i;
3c9a524f 1997 if (SCM_REALP (flt))
f3ae5d60 1998 i = idbl2str (SCM_REAL_VALUE (flt), str);
0f2d19dd 1999 else
f872b822 2000 {
f3ae5d60
MD		 2001 i = idbl2str (SCM_COMPLEX_REAL (flt), str);
2002 if (SCM_COMPLEX_IMAG (flt) != 0.0)
2003 {
7351e207
MV		 2004 double imag = SCM_COMPLEX_IMAG (flt);
2005 /* Don't output a '+' for negative numbers or for Inf and
2006 NaN. They will provide their own sign. */
2007 if (0 <= imag && !xisinf (imag) && !xisnan (imag))
f3ae5d60 2008 str[i++] = '+';
7351e207 2009 i += idbl2str (imag, &str[i]);
f3ae5d60
MD		 2010 str[i++] = 'i';
2011 }
f872b822 2012 }
0f2d19dd
JB		 2013 return i;
2014}
0f2d19dd 2015
5c11cc9d 2016/* convert a long to a string (unterminated). returns the number of
1bbd0b84
GB		 2017 characters in the result.
2018 rad is output base
2019 p is destination: worst case (base 2) is SCM_INTBUFLEN */
1be6b49c 2020size_t
1bbd0b84 2021scm_iint2str (long num, int rad, char *p)
0f2d19dd 2022{
1be6b49c
ML		 2023 size_t j = 1;
2024 size_t i;
5c11cc9d
GH		 2025 unsigned long n = (num < 0) ? -num : num;
2026
f872b822 2027 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 2028 j++;
2029
2030 i = j;
2031 if (num < 0)
f872b822 2032 {
f872b822 2033 *p++ = '-';
5c11cc9d
GH		 2034 j++;
2035 n = -num;
f872b822 2036 }
5c11cc9d
GH		 2037 else
2038 n = num;
f872b822
MD		 2039 while (i--)
2040 {
5c11cc9d
GH		 2041 int d = n % rad;
2042
f872b822
MD		 2043 n /= rad;
2044 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
2045 }
0f2d19dd
JB		 2046 return j;
2047}
2048
a1ec6916 2049SCM_DEFINE (scm_number_to_string, "number->string", 1, 1, 0,
bb628794
DH		 2050 (SCM n, SCM radix),
2051 "Return a string holding the external representation of the\n"
942e5b91
MG		 2052 "number @var{n} in the given @var{radix}. If @var{n} is\n"
2053 "inexact, a radix of 10 will be used.")
1bbd0b84 2054#define FUNC_NAME s_scm_number_to_string
0f2d19dd 2055{
1bbd0b84 2056 int base;
98cb6e75 2057
0aacf84e 2058 if (SCM_UNBNDP (radix))
98cb6e75 2059 base = 10;
0aacf84e
MD		 2060 else
2061 {
2062 SCM_VALIDATE_INUM (2, radix);
2063 base = SCM_INUM (radix);
2064 /* FIXME: ask if range limit was OK, and if so, document */
2065 SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36));
2066 }
98cb6e75 2067
0aacf84e
MD		 2068 if (SCM_INUMP (n))
2069 {
2070 char num_buf [SCM_INTBUFLEN];
2071 size_t length = scm_iint2str (SCM_INUM (n), base, num_buf);
2072 return scm_mem2string (num_buf, length);
2073 }
2074 else if (SCM_BIGP (n))
2075 {
2076 char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n));
2077 scm_remember_upto_here_1 (n);
2078 return scm_take0str (str);
2079 }
f92e85f7
MV		 2080 else if (SCM_FRACTIONP (n))
2081 {
2082 scm_i_fraction_reduce (n);
2083 return scm_string_append (scm_list_3 (scm_number_to_string (SCM_FRACTION_NUMERATOR (n), radix),
2084 scm_mem2string ("/", 1),
2085 scm_number_to_string (SCM_FRACTION_DENOMINATOR (n), radix)));
2086 }
0aacf84e
MD		 2087 else if (SCM_INEXACTP (n))
2088 {
2089 char num_buf [FLOBUFLEN];
2090 return scm_mem2string (num_buf, iflo2str (n, num_buf));
2091 }
2092 else
bb628794 2093 SCM_WRONG_TYPE_ARG (1, n);
0f2d19dd 2094}
1bbd0b84 2095#undef FUNC_NAME
0f2d19dd
JB		 2096
2097
ca46fb90
RB		 2098/* These print routines used to be stubbed here so that scm_repl.c
2099 wouldn't need SCM_BIGDIG conditionals (pre GMP) */
1cc91f1b 2100
0f2d19dd 2101int
e81d98ec 2102scm_print_real (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 2103{
56e55ac7 2104 char num_buf[FLOBUFLEN];
f872b822 2105 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
0f2d19dd
JB		 2106 return !0;
2107}
2108
f3ae5d60 2109int
e81d98ec 2110scm_print_complex (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
f92e85f7 2111
f3ae5d60 2112{
56e55ac7 2113 char num_buf[FLOBUFLEN];
f3ae5d60
MD		 2114 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
2115 return !0;
2116}
1cc91f1b 2117
f92e85f7
MV		 2118int
2119scm_i_print_fraction (SCM sexp, SCM port, scm_print_state *pstate SCM_UNUSED)
2120{
2121 SCM str;
2122 scm_i_fraction_reduce (sexp);
2123 str = scm_number_to_string (sexp, SCM_UNDEFINED);
2124 scm_lfwrite (SCM_STRING_CHARS (str), SCM_STRING_LENGTH (str), port);
2125 scm_remember_upto_here_1 (str);
2126 return !0;
2127}
2128
0f2d19dd 2129int
e81d98ec 2130scm_bigprint (SCM exp, SCM port, scm_print_state *pstate SCM_UNUSED)
0f2d19dd 2131{
ca46fb90
RB		 2132 char *str = mpz_get_str (NULL, 10, SCM_I_BIG_MPZ (exp));
2133 scm_remember_upto_here_1 (exp);
2134 scm_lfwrite (str, (size_t) strlen (str), port);
2135 free (str);
0f2d19dd
JB		 2136 return !0;
2137}
2138/*** END nums->strs ***/
2139
3c9a524f 2140
0f2d19dd 2141/*** STRINGS -> NUMBERS ***/
2a8fecee 2142
3c9a524f
DH		 2143/* The following functions implement the conversion from strings to numbers.
2144 * The implementation somehow follows the grammar for numbers as it is given
2145 * in R5RS. Thus, the functions resemble syntactic units (<ureal R>,
2146 * <uinteger R>, ...) that are used to build up numbers in the grammar. Some
2147 * points should be noted about the implementation:
2148 * * Each function keeps a local index variable 'idx' that points at the
2149 * current position within the parsed string. The global index is only
2150 * updated if the function could parse the corresponding syntactic unit
2151 * successfully.
2152 * * Similarly, the functions keep track of indicators of inexactness ('#',
2153 * '.' or exponents) using local variables ('hash_seen', 'x'). Again, the
2154 * global exactness information is only updated after each part has been
2155 * successfully parsed.
2156 * * Sequences of digits are parsed into temporary variables holding fixnums.
2157 * Only if these fixnums would overflow, the result variables are updated
2158 * using the standard functions scm_add, scm_product, scm_divide etc. Then,
2159 * the temporary variables holding the fixnums are cleared, and the process
2160 * starts over again. If for example fixnums were able to store five decimal
2161 * digits, a number 1234567890 would be parsed in two parts 12345 and 67890,
2162 * and the result was computed as 12345 * 100000 + 67890. In other words,
2163 * only every five digits two bignum operations were performed.
2164 */
2165
2166enum t_exactness {NO_EXACTNESS, INEXACT, EXACT};
2167
2168/* R5RS, section 7.1.1, lexical structure of numbers: <uinteger R>. */
2169
2170/* In non ASCII-style encodings the following macro might not work. */
2171#define XDIGIT2UINT(d) (isdigit (d) ? (d) - '0' : tolower (d) - 'a' + 10)
2172
2a8fecee 2173static SCM
3c9a524f
DH		 2174mem2uinteger (const char* mem, size_t len, unsigned int *p_idx,
2175 unsigned int radix, enum t_exactness *p_exactness)
2a8fecee 2176{
3c9a524f
DH		 2177 unsigned int idx = *p_idx;
2178 unsigned int hash_seen = 0;
2179 scm_t_bits shift = 1;
2180 scm_t_bits add = 0;
2181 unsigned int digit_value;
2182 SCM result;
2183 char c;
2184
2185 if (idx == len)
2186 return SCM_BOOL_F;
2a8fecee 2187
3c9a524f
DH		 2188 c = mem[idx];
2189 if (!isxdigit (c))
2190 return SCM_BOOL_F;
2191 digit_value = XDIGIT2UINT (c);
2192 if (digit_value >= radix)
2193 return SCM_BOOL_F;
2194
2195 idx++;
2196 result = SCM_MAKINUM (digit_value);
2197 while (idx != len)
f872b822 2198 {
3c9a524f
DH		 2199 char c = mem[idx];
2200 if (isxdigit (c))
f872b822 2201 {
3c9a524f 2202 if (hash_seen)
1fe5e088 2203 break;
3c9a524f
DH		 2204 digit_value = XDIGIT2UINT (c);
2205 if (digit_value >= radix)
1fe5e088 2206 break;
f872b822 2207 }
3c9a524f
DH		 2208 else if (c == '#')
2209 {
2210 hash_seen = 1;
2211 digit_value = 0;
2212 }
2213 else
2214 break;
2215
2216 idx++;
2217 if (SCM_MOST_POSITIVE_FIXNUM / radix < shift)
2218 {
2219 result = scm_product (result, SCM_MAKINUM (shift));
2220 if (add > 0)
2221 result = scm_sum (result, SCM_MAKINUM (add));
2222
2223 shift = radix;
2224 add = digit_value;
2225 }
2226 else
2227 {
2228 shift = shift * radix;
2229 add = add * radix + digit_value;
2230 }
2231 };
2232
2233 if (shift > 1)
2234 result = scm_product (result, SCM_MAKINUM (shift));
2235 if (add > 0)
2236 result = scm_sum (result, SCM_MAKINUM (add));
2237
2238 *p_idx = idx;
2239 if (hash_seen)
2240 *p_exactness = INEXACT;
2241
2242 return result;
2a8fecee
JB		 2243}
2244
2245
3c9a524f
DH		 2246/* R5RS, section 7.1.1, lexical structure of numbers: <decimal 10>. Only
2247 * covers the parts of the rules that start at a potential point. The value
2248 * of the digits up to the point have been parsed by the caller and are given
79d34f68
DH		 2249 * in variable result. The content of *p_exactness indicates, whether a hash
2250 * has already been seen in the digits before the point.
3c9a524f 2251 */
1cc91f1b 2252
3c9a524f
DH		 2253/* In non ASCII-style encodings the following macro might not work. */
2254#define DIGIT2UINT(d) ((d) - '0')
2255
2256static SCM
79d34f68 2257mem2decimal_from_point (SCM result, const char* mem, size_t len,
3c9a524f 2258 unsigned int *p_idx, enum t_exactness *p_exactness)
0f2d19dd 2259{
3c9a524f
DH		 2260 unsigned int idx = *p_idx;
2261 enum t_exactness x = *p_exactness;
3c9a524f
DH		 2262
2263 if (idx == len)
79d34f68 2264 return result;
3c9a524f
DH		 2265
2266 if (mem[idx] == '.')
2267 {
2268 scm_t_bits shift = 1;
2269 scm_t_bits add = 0;
2270 unsigned int digit_value;
79d34f68 2271 SCM big_shift = SCM_MAKINUM (1);
3c9a524f
DH		 2272
2273 idx++;
2274 while (idx != len)
2275 {
2276 char c = mem[idx];
2277 if (isdigit (c))
2278 {
2279 if (x == INEXACT)
2280 return SCM_BOOL_F;
2281 else
2282 digit_value = DIGIT2UINT (c);
2283 }
2284 else if (c == '#')
2285 {
2286 x = INEXACT;
2287 digit_value = 0;
2288 }
2289 else
2290 break;
2291
2292 idx++;
2293 if (SCM_MOST_POSITIVE_FIXNUM / 10 < shift)
2294 {
2295 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68 2296 result = scm_product (result, SCM_MAKINUM (shift));
3c9a524f 2297 if (add > 0)
79d34f68 2298 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2299
2300 shift = 10;
2301 add = digit_value;
2302 }
2303 else
2304 {
2305 shift = shift * 10;
2306 add = add * 10 + digit_value;
2307 }
2308 };
2309
2310 if (add > 0)
2311 {
2312 big_shift = scm_product (big_shift, SCM_MAKINUM (shift));
79d34f68
DH		 2313 result = scm_product (result, SCM_MAKINUM (shift));
2314 result = scm_sum (result, SCM_MAKINUM (add));
3c9a524f
DH		 2315 }
2316
d8592269 2317 result = scm_divide (result, big_shift);
79d34f68 2318
3c9a524f
DH		 2319 /* We've seen a decimal point, thus the value is implicitly inexact. */
2320 x = INEXACT;
f872b822 2321 }
3c9a524f 2322
3c9a524f 2323 if (idx != len)
f872b822 2324 {
3c9a524f
DH		 2325 int sign = 1;
2326 unsigned int start;
2327 char c;
2328 int exponent;
2329 SCM e;
2330
2331 /* R5RS, section 7.1.1, lexical structure of numbers: <suffix> */
2332
2333 switch (mem[idx])
f872b822 2334 {
3c9a524f
DH		 2335 case 'd': case 'D':
2336 case 'e': case 'E':
2337 case 'f': case 'F':
2338 case 'l': case 'L':
2339 case 's': case 'S':
2340 idx++;
2341 start = idx;
2342 c = mem[idx];
2343 if (c == '-')
2344 {
2345 idx++;
2346 sign = -1;
2347 c = mem[idx];
2348 }
2349 else if (c == '+')
2350 {
2351 idx++;
2352 sign = 1;
2353 c = mem[idx];
2354 }
2355 else
2356 sign = 1;
2357
2358 if (!isdigit (c))
2359 return SCM_BOOL_F;
2360
2361 idx++;
2362 exponent = DIGIT2UINT (c);
2363 while (idx != len)
f872b822 2364 {
3c9a524f
DH		 2365 char c = mem[idx];
2366 if (isdigit (c))
2367 {
2368 idx++;
2369 if (exponent <= SCM_MAXEXP)
2370 exponent = exponent * 10 + DIGIT2UINT (c);
2371 }
2372 else
2373 break;
f872b822 2374 }
3c9a524f
DH		 2375
2376 if (exponent > SCM_MAXEXP)
f872b822 2377 {
3c9a524f
DH		 2378 size_t exp_len = idx - start;
2379 SCM exp_string = scm_mem2string (&mem[start], exp_len);
2380 SCM exp_num = scm_string_to_number (exp_string, SCM_UNDEFINED);
2381 scm_out_of_range ("string->number", exp_num);
f872b822 2382 }
3c9a524f
DH		 2383
2384 e = scm_integer_expt (SCM_MAKINUM (10), SCM_MAKINUM (exponent));
2385 if (sign == 1)
2386 result = scm_product (result, e);
2387 else
f92e85f7 2388 result = scm_divide2real (result, e);
3c9a524f
DH		 2389
2390 /* We've seen an exponent, thus the value is implicitly inexact. */
2391 x = INEXACT;
2392
f872b822 2393 break;
3c9a524f 2394
f872b822 2395 default:
3c9a524f 2396 break;
f872b822 2397 }
0f2d19dd 2398 }
3c9a524f
DH		 2399
2400 *p_idx = idx;
2401 if (x == INEXACT)
2402 *p_exactness = x;
2403
2404 return result;
0f2d19dd 2405}
0f2d19dd 2406
3c9a524f
DH		 2407
2408/* R5RS, section 7.1.1, lexical structure of numbers: <ureal R> */
2409
2410static SCM
2411mem2ureal (const char* mem, size_t len, unsigned int *p_idx,
2412 unsigned int radix, enum t_exactness *p_exactness)
0f2d19dd 2413{
3c9a524f 2414 unsigned int idx = *p_idx;
164d2481 2415 SCM result;
3c9a524f
DH		 2416
2417 if (idx == len)
2418 return SCM_BOOL_F;
2419
7351e207
MV		 2420 if (idx+5 <= len && !strncmp (mem+idx, "inf.0", 5))
2421 {
2422 *p_idx = idx+5;
2423 return scm_inf ();
2424 }
2425
2426 if (idx+4 < len && !strncmp (mem+idx, "nan.", 4))
2427 {
2428 enum t_exactness x = EXACT;
2429
d8592269
MV		 2430 /* Cobble up the fractional part. We might want to set the
2431 NaN's mantissa from it. */
7351e207
MV		 2432 idx += 4;
2433 mem2uinteger (mem, len, &idx, 10, &x);
2434 *p_idx = idx;
2435 return scm_nan ();
2436 }
2437
3c9a524f
DH		 2438 if (mem[idx] == '.')
2439 {
2440 if (radix != 10)
2441 return SCM_BOOL_F;
2442 else if (idx + 1 == len)
2443 return SCM_BOOL_F;
2444 else if (!isdigit (mem[idx + 1]))
2445 return SCM_BOOL_F;
2446 else
164d2481
MV		 2447 result = mem2decimal_from_point (SCM_MAKINUM (0), mem, len,
2448 p_idx, p_exactness);
f872b822 2449 }
3c9a524f
DH		 2450 else
2451 {
2452 enum t_exactness x = EXACT;
2453 SCM uinteger;
3c9a524f
DH		 2454
2455 uinteger = mem2uinteger (mem, len, &idx, radix, &x);
2456 if (SCM_FALSEP (uinteger))
2457 return SCM_BOOL_F;
2458
2459 if (idx == len)
2460 result = uinteger;
2461 else if (mem[idx] == '/')
f872b822 2462 {
3c9a524f
DH		 2463 SCM divisor;
2464
2465 idx++;
2466
2467 divisor = mem2uinteger (mem, len, &idx, radix, &x);
2468 if (SCM_FALSEP (divisor))
2469 return SCM_BOOL_F;
2470
f92e85f7
MV		 2471 /* both are int/big here, I assume */
2472 result = scm_make_ratio (uinteger, divisor);
f872b822 2473 }
3c9a524f
DH		 2474 else if (radix == 10)
2475 {
2476 result = mem2decimal_from_point (uinteger, mem, len, &idx, &x);
2477 if (SCM_FALSEP (result))
2478 return SCM_BOOL_F;
2479 }
2480 else
2481 result = uinteger;
2482
2483 *p_idx = idx;
2484 if (x == INEXACT)
2485 *p_exactness = x;
f872b822 2486 }
164d2481
MV		 2487
2488 /* When returning an inexact zero, make sure it is represented as a
2489 floating point value so that we can change its sign.
2490 */
2491 if (SCM_EQ_P (result, SCM_MAKINUM(0)) && *p_exactness == INEXACT)
2492 result = scm_make_real (0.0);
2493
2494 return result;
3c9a524f 2495}
0f2d19dd 2496
0f2d19dd 2497
3c9a524f 2498/* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
0f2d19dd 2499
3c9a524f
DH		 2500static SCM
2501mem2complex (const char* mem, size_t len, unsigned int idx,
2502 unsigned int radix, enum t_exactness *p_exactness)
2503{
2504 char c;
2505 int sign = 0;
2506 SCM ureal;
2507
2508 if (idx == len)
2509 return SCM_BOOL_F;
2510
2511 c = mem[idx];
2512 if (c == '+')
2513 {
2514 idx++;
2515 sign = 1;
2516 }
2517 else if (c == '-')
2518 {
2519 idx++;
2520 sign = -1;
0f2d19dd 2521 }
0f2d19dd 2522
3c9a524f
DH		 2523 if (idx == len)
2524 return SCM_BOOL_F;
2525
2526 ureal = mem2ureal (mem, len, &idx, radix, p_exactness);
2527 if (SCM_FALSEP (ureal))
f872b822 2528 {
3c9a524f
DH		 2529 /* input must be either +i or -i */
2530
2531 if (sign == 0)
2532 return SCM_BOOL_F;
2533
2534 if (mem[idx] == 'i' || mem[idx] == 'I')
f872b822 2535 {
3c9a524f
DH		 2536 idx++;
2537 if (idx != len)
2538 return SCM_BOOL_F;
2539
2540 return scm_make_rectangular (SCM_MAKINUM (0), SCM_MAKINUM (sign));
f872b822 2541 }
3c9a524f
DH		 2542 else
2543 return SCM_BOOL_F;
0f2d19dd 2544 }
3c9a524f
DH		 2545 else
2546 {
fc194577 2547 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f 2548 ureal = scm_difference (ureal, SCM_UNDEFINED);
f872b822 2549
3c9a524f
DH		 2550 if (idx == len)
2551 return ureal;
2552
2553 c = mem[idx];
2554 switch (c)
f872b822 2555 {
3c9a524f
DH		 2556 case 'i': case 'I':
2557 /* either +<ureal>i or -<ureal>i */
2558
2559 idx++;
2560 if (sign == 0)
2561 return SCM_BOOL_F;
2562 if (idx != len)
2563 return SCM_BOOL_F;
2564 return scm_make_rectangular (SCM_MAKINUM (0), ureal);
2565
2566 case '@':
2567 /* polar input: <real>@<real>. */
2568
2569 idx++;
2570 if (idx == len)
2571 return SCM_BOOL_F;
2572 else
f872b822 2573 {
3c9a524f
DH		 2574 int sign;
2575 SCM angle;
2576 SCM result;
2577
2578 c = mem[idx];
2579 if (c == '+')
2580 {
2581 idx++;
2582 sign = 1;
2583 }
2584 else if (c == '-')
2585 {
2586 idx++;
2587 sign = -1;
2588 }
2589 else
2590 sign = 1;
2591
2592 angle = mem2ureal (mem, len, &idx, radix, p_exactness);
2593 if (SCM_FALSEP (angle))
2594 return SCM_BOOL_F;
2595 if (idx != len)
2596 return SCM_BOOL_F;
2597
fc194577 2598 if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
3c9a524f
DH		 2599 angle = scm_difference (angle, SCM_UNDEFINED);
2600
2601 result = scm_make_polar (ureal, angle);
2602 return result;
f872b822 2603 }
3c9a524f
DH		 2604 case '+':
2605 case '-':
2606 /* expecting input matching <real>[+-]<ureal>?i */
0f2d19dd 2607
3c9a524f
DH		 2608 idx++;
2609 if (idx == len)
2610 return SCM_BOOL_F;
2611 else
2612 {
2613 int sign = (c == '+') ? 1 : -1;
2614 SCM imag = mem2ureal (mem, len, &idx, radix, p_exactness);
0f2d19dd 2615
3c9a524f
DH		 2616 if (SCM_FALSEP (imag))
2617 imag = SCM_MAKINUM (sign);
fc194577 2618 else if (sign == -1 && SCM_FALSEP (scm_nan_p (ureal)))
1fe5e088 2619 imag = scm_difference (imag, SCM_UNDEFINED);
0f2d19dd 2620
3c9a524f
DH		 2621 if (idx == len)
2622 return SCM_BOOL_F;
2623 if (mem[idx] != 'i' && mem[idx] != 'I')
2624 return SCM_BOOL_F;
0f2d19dd 2625
3c9a524f
DH		 2626 idx++;
2627 if (idx != len)
2628 return SCM_BOOL_F;
0f2d19dd 2629
1fe5e088 2630 return scm_make_rectangular (ureal, imag);
3c9a524f
DH		 2631 }
2632 default:
2633 return SCM_BOOL_F;
2634 }
2635 }
0f2d19dd 2636}
0f2d19dd
JB		 2637
2638
3c9a524f
DH		 2639/* R5RS, section 7.1.1, lexical structure of numbers: <number> */
2640
2641enum t_radix {NO_RADIX=0, DUAL=2, OCT=8, DEC=10, HEX=16};
1cc91f1b 2642
0f2d19dd 2643SCM
3c9a524f 2644scm_i_mem2number (const char* mem, size_t len, unsigned int default_radix)
0f2d19dd 2645{
3c9a524f
DH		 2646 unsigned int idx = 0;
2647 unsigned int radix = NO_RADIX;
2648 enum t_exactness forced_x = NO_EXACTNESS;
2649 enum t_exactness implicit_x = EXACT;
2650 SCM result;
2651
2652 /* R5RS, section 7.1.1, lexical structure of numbers: <prefix R> */
2653 while (idx + 2 < len && mem[idx] == '#')
2654 {
2655 switch (mem[idx + 1])
2656 {
2657 case 'b': case 'B':
2658 if (radix != NO_RADIX)
2659 return SCM_BOOL_F;
2660 radix = DUAL;
2661 break;
2662 case 'd': case 'D':
2663 if (radix != NO_RADIX)
2664 return SCM_BOOL_F;
2665 radix = DEC;
2666 break;
2667 case 'i': case 'I':
2668 if (forced_x != NO_EXACTNESS)
2669 return SCM_BOOL_F;
2670 forced_x = INEXACT;
2671 break;
2672 case 'e': case 'E':
2673 if (forced_x != NO_EXACTNESS)
2674 return SCM_BOOL_F;
2675 forced_x = EXACT;
2676 break;
2677 case 'o': case 'O':
2678 if (radix != NO_RADIX)
2679 return SCM_BOOL_F;
2680 radix = OCT;
2681 break;
2682 case 'x': case 'X':
2683 if (radix != NO_RADIX)
2684 return SCM_BOOL_F;
2685 radix = HEX;
2686 break;
2687 default:
f872b822 2688 return SCM_BOOL_F;
3c9a524f
DH		 2689 }
2690 idx += 2;
2691 }
2692
2693 /* R5RS, section 7.1.1, lexical structure of numbers: <complex R> */
2694 if (radix == NO_RADIX)
2695 result = mem2complex (mem, len, idx, default_radix, &implicit_x);
2696 else
2697 result = mem2complex (mem, len, idx, (unsigned int) radix, &implicit_x);
2698
2699 if (SCM_FALSEP (result))
2700 return SCM_BOOL_F;
f872b822 2701
3c9a524f 2702 switch (forced_x)
f872b822 2703 {
3c9a524f
DH		 2704 case EXACT:
2705 if (SCM_INEXACTP (result))
3c9a524f
DH		 2706 return scm_inexact_to_exact (result);
2707 else
2708 return result;
2709 case INEXACT:
2710 if (SCM_INEXACTP (result))
2711 return result;
2712 else
2713 return scm_exact_to_inexact (result);
2714 case NO_EXACTNESS:
2715 default:
2716 if (implicit_x == INEXACT)
2717 {
2718 if (SCM_INEXACTP (result))
2719 return result;
2720 else
2721 return scm_exact_to_inexact (result);
2722 }
2723 else
2724 return result;
f872b822 2725 }
0f2d19dd
JB		 2726}
2727
2728
a1ec6916 2729SCM_DEFINE (scm_string_to_number, "string->number", 1, 1, 0,
bb628794 2730 (SCM string, SCM radix),
1e6808ea 2731 "Return a number of the maximally precise representation\n"
942e5b91 2732 "expressed by the given @var{string}. @var{radix} must be an\n"
5352393c
MG		 2733 "exact integer, either 2, 8, 10, or 16. If supplied, @var{radix}\n"
2734 "is a default radix that may be overridden by an explicit radix\n"
2735 "prefix in @var{string} (e.g. \"#o177\"). If @var{radix} is not\n"
2736 "supplied, then the default radix is 10. If string is not a\n"
2737 "syntactically valid notation for a number, then\n"
2738 "@code{string->number} returns @code{#f}.")
1bbd0b84 2739#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2740{
2741 SCM answer;
1bbd0b84 2742 int base;
a6d9e5ab 2743 SCM_VALIDATE_STRING (1, string);
34d19ef6 2744 SCM_VALIDATE_INUM_MIN_DEF_COPY (2, radix,2,10, base);
3c9a524f 2745 answer = scm_i_mem2number (SCM_STRING_CHARS (string),
d8592269
MV		 2746 SCM_STRING_LENGTH (string),
2747 base);
bb628794 2748 return scm_return_first (answer, string);
0f2d19dd 2749}
1bbd0b84 2750#undef FUNC_NAME
3c9a524f
DH		 2751
2752
0f2d19dd
JB		 2753/*** END strs->nums ***/
2754
5986c47d 2755
0f2d19dd 2756SCM
f3ae5d60 2757scm_make_real (double x)
0f2d19dd 2758{
3553e1d1
GH		 2759 SCM z = scm_double_cell (scm_tc16_real, 0, 0, 0);
2760
3a9809df 2761 SCM_REAL_VALUE (z) = x;
0f2d19dd
JB		 2762 return z;
2763}
0f2d19dd 2764
5986c47d 2765
f3ae5d60
MD		 2766SCM
2767scm_make_complex (double x, double y)
2768{
0aacf84e 2769 if (y == 0.0)
3a9809df 2770 return scm_make_real (x);
0aacf84e
MD		 2771 else
2772 {
2773 SCM z;
29c4382a 2774 SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (sizeof (scm_t_complex),
0aacf84e
MD		 2775 "complex"));
2776 SCM_COMPLEX_REAL (z) = x;
2777 SCM_COMPLEX_IMAG (z) = y;
2778 return z;
2779 }
f3ae5d60 2780}
1cc91f1b 2781
5986c47d 2782
0f2d19dd 2783SCM
1bbd0b84 2784scm_bigequal (SCM x, SCM y)
0f2d19dd 2785{
47ae1f0e 2786 int result = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
ca46fb90
RB		 2787 scm_remember_upto_here_2 (x, y);
2788 return SCM_BOOL (0 == result);
0f2d19dd
JB		 2789}
2790
0f2d19dd 2791SCM
f3ae5d60 2792scm_real_equalp (SCM x, SCM y)
0f2d19dd 2793{
f3ae5d60 2794 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
0f2d19dd
JB		 2795}
2796
f3ae5d60
MD		 2797SCM
2798scm_complex_equalp (SCM x, SCM y)
2799{
2800 return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
2801 && SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
2802}
0f2d19dd 2803
f92e85f7
MV		 2804SCM
2805scm_i_fraction_equalp (SCM x, SCM y)
2806{
2807 scm_i_fraction_reduce (x);
2808 scm_i_fraction_reduce (y);
02164269
MV		 2809 if (SCM_FALSEP (scm_equal_p (SCM_FRACTION_NUMERATOR (x),
2810 SCM_FRACTION_NUMERATOR (y)))
2811 || SCM_FALSEP (scm_equal_p (SCM_FRACTION_DENOMINATOR (x),
2812 SCM_FRACTION_DENOMINATOR (y))))
2813 return SCM_BOOL_F;
2814 else
2815 return SCM_BOOL_T;
f92e85f7 2816}
0f2d19dd
JB		 2817
2818
1bbd0b84 2819SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
942e5b91
MG		 2820/* "Return @code{#t} if @var{x} is a number, @code{#f}\n"
2821 * "else. Note that the sets of complex, real, rational and\n"
2822 * "integer values form subsets of the set of numbers, i. e. the\n"
2823 * "predicate will be fulfilled for any number."
2824 */
a1ec6916 2825SCM_DEFINE (scm_number_p, "complex?", 1, 0, 0,
1bbd0b84 2826 (SCM x),
942e5b91 2827 "Return @code{#t} if @var{x} is a complex number, @code{#f}\n"
bb2c02f2 2828 "otherwise. Note that the sets of real, rational and integer\n"
942e5b91
MG		 2829 "values form subsets of the set of complex numbers, i. e. the\n"
2830 "predicate will also be fulfilled if @var{x} is a real,\n"
2831 "rational or integer number.")
1bbd0b84 2832#define FUNC_NAME s_scm_number_p
0f2d19dd 2833{
bb628794 2834 return SCM_BOOL (SCM_NUMBERP (x));
0f2d19dd 2835}
1bbd0b84 2836#undef FUNC_NAME
0f2d19dd
JB		 2837
2838
f92e85f7
MV		 2839SCM_DEFINE (scm_real_p, "real?", 1, 0, 0,
2840 (SCM x),
2841 "Return @code{#t} if @var{x} is a real number, @code{#f}\n"
2842 "otherwise. Note that the set of integer values forms a subset of\n"
2843 "the set of real numbers, i. e. the predicate will also be\n"
2844 "fulfilled if @var{x} is an integer number.")
2845#define FUNC_NAME s_scm_real_p
2846{
2847 /* we can't represent irrational numbers. */
2848 return scm_rational_p (x);
2849}
2850#undef FUNC_NAME
2851
2852SCM_DEFINE (scm_rational_p, "rational?", 1, 0, 0,
1bbd0b84 2853 (SCM x),
942e5b91 2854 "Return @code{#t} if @var{x} is a rational number, @code{#f}\n"
bb2c02f2 2855 "otherwise. Note that the set of integer values forms a subset of\n"
942e5b91 2856 "the set of rational numbers, i. e. the predicate will also be\n"
f92e85f7
MV		 2857 "fulfilled if @var{x} is an integer number.")
2858#define FUNC_NAME s_scm_rational_p
0f2d19dd 2859{
0aacf84e 2860 if (SCM_INUMP (x))
0f2d19dd 2861 return SCM_BOOL_T;
0aacf84e 2862 else if (SCM_IMP (x))
0f2d19dd 2863 return SCM_BOOL_F;
0aacf84e 2864 else if (SCM_BIGP (x))
0f2d19dd 2865 return SCM_BOOL_T;
f92e85f7
MV		 2866 else if (SCM_FRACTIONP (x))
2867 return SCM_BOOL_T;
2868 else if (SCM_REALP (x))
2869 /* due to their limited precision, all floating point numbers are
2870 rational as well. */
2871 return SCM_BOOL_T;
0aacf84e 2872 else
bb628794 2873 return SCM_BOOL_F;
0f2d19dd 2874}
1bbd0b84 2875#undef FUNC_NAME
0f2d19dd
JB		 2876
2877
a1ec6916 2878SCM_DEFINE (scm_integer_p, "integer?", 1, 0, 0,
1bbd0b84 2879 (SCM x),
942e5b91
MG		 2880 "Return @code{#t} if @var{x} is an integer number, @code{#f}\n"
2881 "else.")
1bbd0b84 2882#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 2883{
2884 double r;
f872b822
MD		 2885 if (SCM_INUMP (x))
2886 return SCM_BOOL_T;
2887 if (SCM_IMP (x))
2888 return SCM_BOOL_F;
f872b822
MD		 2889 if (SCM_BIGP (x))
2890 return SCM_BOOL_T;
3c9a524f 2891 if (!SCM_INEXACTP (x))
f872b822 2892 return SCM_BOOL_F;
3c9a524f 2893 if (SCM_COMPLEXP (x))
f872b822 2894 return SCM_BOOL_F;
5986c47d 2895 r = SCM_REAL_VALUE (x);
f872b822
MD		 2896 if (r == floor (r))
2897 return SCM_BOOL_T;
0f2d19dd
JB		 2898 return SCM_BOOL_F;
2899}
1bbd0b84 2900#undef FUNC_NAME
0f2d19dd
JB		 2901
2902
a1ec6916 2903SCM_DEFINE (scm_inexact_p, "inexact?", 1, 0, 0,
1bbd0b84 2904 (SCM x),
942e5b91
MG		 2905 "Return @code{#t} if @var{x} is an inexact number, @code{#f}\n"
2906 "else.")
1bbd0b84 2907#define FUNC_NAME s_scm_inexact_p
0f2d19dd 2908{
eb927cb9
MV		 2909 if (SCM_INEXACTP (x))
2910 return SCM_BOOL_T;
2911 if (SCM_NUMBERP (x))
2912 return SCM_BOOL_F;
2913 SCM_WRONG_TYPE_ARG (1, x);
0f2d19dd 2914}
1bbd0b84 2915#undef FUNC_NAME
0f2d19dd
JB		 2916
2917
152f82bf 2918SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
942e5b91 2919/* "Return @code{#t} if all parameters are numerically equal." */
0f2d19dd 2920SCM
6e8d25a6 2921scm_num_eq_p (SCM x, SCM y)
0f2d19dd 2922{
0aacf84e
MD		 2923 if (SCM_INUMP (x))
2924 {
2925 long xx = SCM_INUM (x);
2926 if (SCM_INUMP (y))
2927 {
2928 long yy = SCM_INUM (y);
2929 return SCM_BOOL (xx == yy);
2930 }
2931 else if (SCM_BIGP (y))
2932 return SCM_BOOL_F;
2933 else if (SCM_REALP (y))
2934 return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y));
2935 else if (SCM_COMPLEXP (y))
2936 return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y))
2937 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 2938 else if (SCM_FRACTIONP (y))
2939 return SCM_BOOL_F;
0aacf84e
MD		 2940 else
2941 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2942 }
0aacf84e
MD		 2943 else if (SCM_BIGP (x))
2944 {
2945 if (SCM_INUMP (y))
2946 return SCM_BOOL_F;
2947 else if (SCM_BIGP (y))
2948 {
2949 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
2950 scm_remember_upto_here_2 (x, y);
2951 return SCM_BOOL (0 == cmp);
2952 }
2953 else if (SCM_REALP (y))
2954 {
2955 int cmp;
2956 if (xisnan (SCM_REAL_VALUE (y)))
2957 return SCM_BOOL_F;
2958 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
2959 scm_remember_upto_here_1 (x);
2960 return SCM_BOOL (0 == cmp);
2961 }
2962 else if (SCM_COMPLEXP (y))
2963 {
2964 int cmp;
2965 if (0.0 != SCM_COMPLEX_IMAG (y))
2966 return SCM_BOOL_F;
2967 if (xisnan (SCM_COMPLEX_REAL (y)))
2968 return SCM_BOOL_F;
2969 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y));
2970 scm_remember_upto_here_1 (x);
2971 return SCM_BOOL (0 == cmp);
2972 }
f92e85f7
MV		 2973 else if (SCM_FRACTIONP (y))
2974 return SCM_BOOL_F;
0aacf84e
MD		 2975 else
2976 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 2977 }
0aacf84e
MD		 2978 else if (SCM_REALP (x))
2979 {
2980 if (SCM_INUMP (y))
2981 return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y));
2982 else if (SCM_BIGP (y))
2983 {
2984 int cmp;
2985 if (xisnan (SCM_REAL_VALUE (x)))
2986 return SCM_BOOL_F;
2987 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
2988 scm_remember_upto_here_1 (y);
2989 return SCM_BOOL (0 == cmp);
2990 }
2991 else if (SCM_REALP (y))
2992 return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
2993 else if (SCM_COMPLEXP (y))
2994 return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y))
2995 && (0.0 == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 2996 else if (SCM_FRACTIONP (y))
2997 return SCM_BOOL (SCM_REAL_VALUE (x) == scm_i_fraction2double (y));
0aacf84e
MD		 2998 else
2999 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 3000 }
0aacf84e
MD		 3001 else if (SCM_COMPLEXP (x))
3002 {
3003 if (SCM_INUMP (y))
3004 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y))
3005 && (SCM_COMPLEX_IMAG (x) == 0.0));
3006 else if (SCM_BIGP (y))
3007 {
3008 int cmp;
3009 if (0.0 != SCM_COMPLEX_IMAG (x))
3010 return SCM_BOOL_F;
3011 if (xisnan (SCM_COMPLEX_REAL (x)))
3012 return SCM_BOOL_F;
3013 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x));
3014 scm_remember_upto_here_1 (y);
3015 return SCM_BOOL (0 == cmp);
3016 }
3017 else if (SCM_REALP (y))
3018 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y))
3019 && (SCM_COMPLEX_IMAG (x) == 0.0));
3020 else if (SCM_COMPLEXP (y))
3021 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y))
3022 && (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y)));
f92e85f7
MV		 3023 else if (SCM_FRACTIONP (y))
3024 return SCM_BOOL ((SCM_COMPLEX_REAL (x) == scm_i_fraction2double (y))
3025 && (SCM_COMPLEX_IMAG (x) == 0.0));
3026 else
3027 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
3028 }
3029 else if (SCM_FRACTIONP (x))
3030 {
3031 if (SCM_INUMP (y))
3032 return SCM_BOOL_F;
3033 else if (SCM_BIGP (y))
3034 return SCM_BOOL_F;
3035 else if (SCM_REALP (y))
3036 return SCM_BOOL (scm_i_fraction2double (x) == SCM_REAL_VALUE (y));
3037 else if (SCM_COMPLEXP (y))
3038 return SCM_BOOL ((scm_i_fraction2double (x) == SCM_COMPLEX_REAL (y))
3039 && (0.0 == SCM_COMPLEX_IMAG (y)));
3040 else if (SCM_FRACTIONP (y))
3041 return scm_i_fraction_equalp (x, y);
0aacf84e
MD		 3042 else
3043 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f4c627b3 3044 }
0aacf84e 3045 else
f4c627b3 3046 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
0f2d19dd
JB		 3047}
3048
3049
152f82bf 3050SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
942e5b91
MG		 3051/* "Return @code{#t} if the list of parameters is monotonically\n"
3052 * "increasing."
3053 */
0f2d19dd 3054SCM
6e8d25a6 3055scm_less_p (SCM x, SCM y)
0f2d19dd 3056{
0aacf84e
MD		 3057 if (SCM_INUMP (x))
3058 {
3059 long xx = SCM_INUM (x);
3060 if (SCM_INUMP (y))
3061 {
3062 long yy = SCM_INUM (y);
3063 return SCM_BOOL (xx < yy);
3064 }
3065 else if (SCM_BIGP (y))
3066 {
3067 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3068 scm_remember_upto_here_1 (y);
3069 return SCM_BOOL (sgn > 0);
3070 }
3071 else if (SCM_REALP (y))
3072 return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y));
f92e85f7
MV		 3073 else if (SCM_FRACTIONP (y))
3074 return SCM_BOOL ((double) xx < scm_i_fraction2double (y));
0aacf84e
MD		 3075 else
3076 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3077 }
0aacf84e
MD		 3078 else if (SCM_BIGP (x))
3079 {
3080 if (SCM_INUMP (y))
3081 {
3082 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3083 scm_remember_upto_here_1 (x);
3084 return SCM_BOOL (sgn < 0);
3085 }
3086 else if (SCM_BIGP (y))
3087 {
3088 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3089 scm_remember_upto_here_2 (x, y);
3090 return SCM_BOOL (cmp < 0);
3091 }
3092 else if (SCM_REALP (y))
3093 {
3094 int cmp;
3095 if (xisnan (SCM_REAL_VALUE (y)))
3096 return SCM_BOOL_F;
3097 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y));
3098 scm_remember_upto_here_1 (x);
3099 return SCM_BOOL (cmp < 0);
3100 }
f92e85f7
MV		 3101 else if (SCM_FRACTIONP (y))
3102 {
3103 int cmp;
3104 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), scm_i_fraction2double (y));
3105 scm_remember_upto_here_1 (x);
3106 return SCM_BOOL (cmp < 0);
3107 }
0aacf84e
MD		 3108 else
3109 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f4c627b3 3110 }
0aacf84e
MD		 3111 else if (SCM_REALP (x))
3112 {
3113 if (SCM_INUMP (y))
3114 return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y));
3115 else if (SCM_BIGP (y))
3116 {
3117 int cmp;
3118 if (xisnan (SCM_REAL_VALUE (x)))
3119 return SCM_BOOL_F;
3120 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x));
3121 scm_remember_upto_here_1 (y);
3122 return SCM_BOOL (cmp > 0);
3123 }
3124 else if (SCM_REALP (y))
3125 return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y));
f92e85f7
MV		 3126 else if (SCM_FRACTIONP (y))
3127 return SCM_BOOL (SCM_REAL_VALUE (x) < scm_i_fraction2double (y));
3128 else
3129 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
3130 }
3131 else if (SCM_FRACTIONP (x))
3132 {
3133 if (SCM_INUMP (y))
3134 return SCM_BOOL (scm_i_fraction2double (x) < (double) SCM_INUM (y));
3135 else if (SCM_BIGP (y))
3136 {
3137 int cmp;
3138 if (xisnan (SCM_REAL_VALUE (x)))
3139 return SCM_BOOL_F;
3140 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), scm_i_fraction2double (x));
3141 scm_remember_upto_here_1 (y);
3142 return SCM_BOOL (cmp > 0);
3143 }
3144 else if (SCM_REALP (y))
3145 return SCM_BOOL (scm_i_fraction2double (x) < SCM_REAL_VALUE (y));
3146 else if (SCM_FRACTIONP (y))
3147 return SCM_BOOL (scm_i_fraction2double (x) < scm_i_fraction2double (y));
0aacf84e
MD		 3148 else
3149 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 3150 }
0aacf84e 3151 else
f4c627b3 3152 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
0f2d19dd
JB		 3153}
3154
3155
c76b1eaf 3156SCM_GPROC1 (s_scm_gr_p, ">", scm_tc7_rpsubr, scm_gr_p, g_gr_p);
942e5b91
MG		 3157/* "Return @code{#t} if the list of parameters is monotonically\n"
3158 * "decreasing."
c76b1eaf 3159 */
1bbd0b84 3160#define FUNC_NAME s_scm_gr_p
c76b1eaf
MD		 3161SCM
3162scm_gr_p (SCM x, SCM y)
0f2d19dd 3163{
c76b1eaf
MD		 3164 if (!SCM_NUMBERP (x))
3165 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG1, FUNC_NAME);
3166 else if (!SCM_NUMBERP (y))
3167 SCM_WTA_DISPATCH_2 (g_gr_p, x, y, SCM_ARG2, FUNC_NAME);
3168 else
3169 return scm_less_p (y, x);
0f2d19dd 3170}
1bbd0b84 3171#undef FUNC_NAME
0f2d19dd
JB		 3172
3173
c76b1eaf 3174SCM_GPROC1 (s_scm_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p, g_leq_p);
942e5b91 3175/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3176 * "non-decreasing."
3177 */
1bbd0b84 3178#define FUNC_NAME s_scm_leq_p
c76b1eaf
MD		 3179SCM
3180scm_leq_p (SCM x, SCM y)
0f2d19dd 3181{
c76b1eaf
MD		 3182 if (!SCM_NUMBERP (x))
3183 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG1, FUNC_NAME);
3184 else if (!SCM_NUMBERP (y))
3185 SCM_WTA_DISPATCH_2 (g_leq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3186 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3187 return SCM_BOOL_F;
c76b1eaf
MD		 3188 else
3189 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 3190}
1bbd0b84 3191#undef FUNC_NAME
0f2d19dd
JB		 3192
3193
c76b1eaf 3194SCM_GPROC1 (s_scm_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p, g_geq_p);
942e5b91 3195/* "Return @code{#t} if the list of parameters is monotonically\n"
c76b1eaf
MD		 3196 * "non-increasing."
3197 */
1bbd0b84 3198#define FUNC_NAME s_scm_geq_p
c76b1eaf
MD		 3199SCM
3200scm_geq_p (SCM x, SCM y)
0f2d19dd 3201{
c76b1eaf
MD		 3202 if (!SCM_NUMBERP (x))
3203 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG1, FUNC_NAME);
3204 else if (!SCM_NUMBERP (y))
3205 SCM_WTA_DISPATCH_2 (g_geq_p, x, y, SCM_ARG2, FUNC_NAME);
fc194577
MV		 3206 else if (SCM_NFALSEP (scm_nan_p (x)) || SCM_NFALSEP (scm_nan_p (y)))
3207 return SCM_BOOL_F;
c76b1eaf 3208 else
fc194577 3209 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 3210}
1bbd0b84 3211#undef FUNC_NAME
0f2d19dd
JB		 3212
3213
152f82bf 3214SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
942e5b91
MG		 3215/* "Return @code{#t} if @var{z} is an exact or inexact number equal to\n"
3216 * "zero."
3217 */
0f2d19dd 3218SCM
6e8d25a6 3219scm_zero_p (SCM z)
0f2d19dd 3220{
0aacf84e 3221 if (SCM_INUMP (z))
c2ff8ab0 3222 return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0));
0aacf84e 3223 else if (SCM_BIGP (z))
c2ff8ab0 3224 return SCM_BOOL_F;
0aacf84e 3225 else if (SCM_REALP (z))
c2ff8ab0 3226 return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0);
0aacf84e 3227 else if (SCM_COMPLEXP (z))
c2ff8ab0
DH		 3228 return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0
3229 && SCM_COMPLEX_IMAG (z) == 0.0);
f92e85f7
MV		 3230 else if (SCM_FRACTIONP (z))
3231 return SCM_BOOL_F;
0aacf84e 3232 else
c2ff8ab0 3233 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
0f2d19dd
JB		 3234}
3235
3236
152f82bf 3237SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
942e5b91
MG		 3238/* "Return @code{#t} if @var{x} is an exact or inexact number greater than\n"
3239 * "zero."
3240 */
0f2d19dd 3241SCM
6e8d25a6 3242scm_positive_p (SCM x)
0f2d19dd 3243{
0aacf84e 3244 if (SCM_INUMP (x))
c2ff8ab0 3245 return SCM_BOOL (SCM_INUM (x) > 0);
0aacf84e
MD		 3246 else if (SCM_BIGP (x))
3247 {
3248 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3249 scm_remember_upto_here_1 (x);
3250 return SCM_BOOL (sgn > 0);
3251 }
3252 else if (SCM_REALP (x))
c2ff8ab0 3253 return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0);
f92e85f7
MV		 3254 else if (SCM_FRACTIONP (x))
3255 return scm_positive_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3256 else
c2ff8ab0 3257 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
0f2d19dd
JB		 3258}
3259
3260
152f82bf 3261SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
942e5b91
MG		 3262/* "Return @code{#t} if @var{x} is an exact or inexact number less than\n"
3263 * "zero."
3264 */
0f2d19dd 3265SCM
6e8d25a6 3266scm_negative_p (SCM x)
0f2d19dd 3267{
0aacf84e 3268 if (SCM_INUMP (x))
c2ff8ab0 3269 return SCM_BOOL (SCM_INUM (x) < 0);
0aacf84e
MD		 3270 else if (SCM_BIGP (x))
3271 {
3272 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3273 scm_remember_upto_here_1 (x);
3274 return SCM_BOOL (sgn < 0);
3275 }
3276 else if (SCM_REALP (x))
c2ff8ab0 3277 return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0);
f92e85f7
MV		 3278 else if (SCM_FRACTIONP (x))
3279 return scm_negative_p (SCM_FRACTION_NUMERATOR (x));
0aacf84e 3280 else
c2ff8ab0 3281 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
0f2d19dd
JB		 3282}
3283
3284
9de33deb 3285SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
942e5b91
MG		 3286/* "Return the maximum of all parameter values."
3287 */
0f2d19dd 3288SCM
6e8d25a6 3289scm_max (SCM x, SCM y)
0f2d19dd 3290{
0aacf84e
MD		 3291 if (SCM_UNBNDP (y))
3292 {
3293 if (SCM_UNBNDP (x))
3294 SCM_WTA_DISPATCH_0 (g_max, s_max);
3295 else if (SCM_NUMBERP (x))
3296 return x;
3297 else
3298 SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max);
f872b822 3299 }
f4c627b3 3300
0aacf84e
MD		 3301 if (SCM_INUMP (x))
3302 {
3303 long xx = SCM_INUM (x);
3304 if (SCM_INUMP (y))
3305 {
3306 long yy = SCM_INUM (y);
3307 return (xx < yy) ? y : x;
3308 }
3309 else if (SCM_BIGP (y))
3310 {
3311 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3312 scm_remember_upto_here_1 (y);
3313 return (sgn < 0) ? x : y;
3314 }
3315 else if (SCM_REALP (y))
3316 {
3317 double z = xx;
3318 /* if y==NaN then ">" is false and we return NaN */
3319 return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3320 }
f92e85f7
MV		 3321 else if (SCM_FRACTIONP (y))
3322 {
3323 double z = xx;
3324 return (z > scm_i_fraction2double (y)) ? x : y;
3325 }
0aacf84e
MD		 3326 else
3327 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3328 }
0aacf84e
MD		 3329 else if (SCM_BIGP (x))
3330 {
3331 if (SCM_INUMP (y))
3332 {
3333 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3334 scm_remember_upto_here_1 (x);
3335 return (sgn < 0) ? y : x;
3336 }
3337 else if (SCM_BIGP (y))
3338 {
3339 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3340 scm_remember_upto_here_2 (x, y);
3341 return (cmp > 0) ? x : y;
3342 }
3343 else if (SCM_REALP (y))
3344 {
3345 double yy = SCM_REAL_VALUE (y);
3346 int cmp;
3347 if (xisnan (yy))
3348 return y;
3349 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3350 scm_remember_upto_here_1 (x);
3351 return (cmp > 0) ? x : y;
3352 }
f92e85f7
MV		 3353 else if (SCM_FRACTIONP (y))
3354 {
3355 double yy = scm_i_fraction2double (y);
3356 int cmp;
3357 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3358 scm_remember_upto_here_1 (x);
3359 return (cmp > 0) ? x : y;
3360 }
0aacf84e
MD		 3361 else
3362 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f4c627b3 3363 }
0aacf84e
MD		 3364 else if (SCM_REALP (x))
3365 {
3366 if (SCM_INUMP (y))
3367 {
3368 double z = SCM_INUM (y);
3369 /* if x==NaN then "<" is false and we return NaN */
3370 return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x;
3371 }
3372 else if (SCM_BIGP (y))
3373 {
3374 double xx = SCM_REAL_VALUE (x);
3375 int cmp;
3376 if (xisnan (xx))
3377 return x;
3378 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3379 scm_remember_upto_here_1 (y);
3380 return (cmp < 0) ? x : y;
3381 }
3382 else if (SCM_REALP (y))
3383 {
3384 /* if x==NaN then our explicit check means we return NaN
3385 if y==NaN then ">" is false and we return NaN
3386 calling isnan is unavoidable, since it's the only way to know
3387 which of x or y causes any compares to be false */
3388 double xx = SCM_REAL_VALUE (x);
3389 return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y;
3390 }
f92e85f7
MV		 3391 else if (SCM_FRACTIONP (y))
3392 {
3393 double yy = scm_i_fraction2double (y);
3394 double xx = SCM_REAL_VALUE (x);
3395 return (xx < yy) ? scm_make_real (yy) : x;
3396 }
3397 else
3398 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3399 }
3400 else if (SCM_FRACTIONP (x))
3401 {
3402 if (SCM_INUMP (y))
3403 {
3404 double z = SCM_INUM (y);
3405 return (scm_i_fraction2double (x) < z) ? y : x;
3406 }
3407 else if (SCM_BIGP (y))
3408 {
3409 double xx = scm_i_fraction2double (x);
3410 int cmp;
3411 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3412 scm_remember_upto_here_1 (y);
3413 return (cmp < 0) ? x : y;
3414 }
3415 else if (SCM_REALP (y))
3416 {
3417 double xx = scm_i_fraction2double (x);
3418 return (xx < SCM_REAL_VALUE (y)) ? y : scm_make_real (xx);
3419 }
3420 else if (SCM_FRACTIONP (y))
3421 {
3422 double yy = scm_i_fraction2double (y);
3423 double xx = scm_i_fraction2double (x);
3424 return (xx < yy) ? y : x;
3425 }
0aacf84e
MD		 3426 else
3427 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3428 }
0aacf84e 3429 else
f4c627b3 3430 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
0f2d19dd
JB		 3431}
3432
3433
9de33deb 3434SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
942e5b91
MG		 3435/* "Return the minium of all parameter values."
3436 */
0f2d19dd 3437SCM
6e8d25a6 3438scm_min (SCM x, SCM y)
0f2d19dd 3439{
0aacf84e
MD		 3440 if (SCM_UNBNDP (y))
3441 {
3442 if (SCM_UNBNDP (x))
3443 SCM_WTA_DISPATCH_0 (g_min, s_min);
3444 else if (SCM_NUMBERP (x))
3445 return x;
3446 else
3447 SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min);
f872b822 3448 }
f4c627b3 3449
0aacf84e
MD		 3450 if (SCM_INUMP (x))
3451 {
3452 long xx = SCM_INUM (x);
3453 if (SCM_INUMP (y))
3454 {
3455 long yy = SCM_INUM (y);
3456 return (xx < yy) ? x : y;
3457 }
3458 else if (SCM_BIGP (y))
3459 {
3460 int sgn = mpz_sgn (SCM_I_BIG_MPZ (y));
3461 scm_remember_upto_here_1 (y);
3462 return (sgn < 0) ? y : x;
3463 }
3464 else if (SCM_REALP (y))
3465 {
3466 double z = xx;
3467 /* if y==NaN then "<" is false and we return NaN */
3468 return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y;
3469 }
f92e85f7
MV		 3470 else if (SCM_FRACTIONP (y))
3471 {
3472 double z = xx;
3473 return (z < scm_i_fraction2double (y)) ? x : y;
3474 }
0aacf84e
MD		 3475 else
3476 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3477 }
0aacf84e
MD		 3478 else if (SCM_BIGP (x))
3479 {
3480 if (SCM_INUMP (y))
3481 {
3482 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3483 scm_remember_upto_here_1 (x);
3484 return (sgn < 0) ? x : y;
3485 }
3486 else if (SCM_BIGP (y))
3487 {
3488 int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y));
3489 scm_remember_upto_here_2 (x, y);
3490 return (cmp > 0) ? y : x;
3491 }
3492 else if (SCM_REALP (y))
3493 {
3494 double yy = SCM_REAL_VALUE (y);
3495 int cmp;
3496 if (xisnan (yy))
3497 return y;
3498 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3499 scm_remember_upto_here_1 (x);
3500 return (cmp > 0) ? y : x;
3501 }
f92e85f7
MV		 3502 else if (SCM_FRACTIONP (y))
3503 {
3504 double yy = scm_i_fraction2double (y);
3505 int cmp;
3506 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy);
3507 scm_remember_upto_here_1 (x);
3508 return (cmp > 0) ? y : x;
3509 }
0aacf84e
MD		 3510 else
3511 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f4c627b3 3512 }
0aacf84e
MD		 3513 else if (SCM_REALP (x))
3514 {
3515 if (SCM_INUMP (y))
3516 {
3517 double z = SCM_INUM (y);
3518 /* if x==NaN then "<" is false and we return NaN */
3519 return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x;
3520 }
3521 else if (SCM_BIGP (y))
3522 {
3523 double xx = SCM_REAL_VALUE (x);
3524 int cmp;
3525 if (xisnan (xx))
3526 return x;
3527 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3528 scm_remember_upto_here_1 (y);
3529 return (cmp < 0) ? y : x;
3530 }
3531 else if (SCM_REALP (y))
3532 {
3533 /* if x==NaN then our explicit check means we return NaN
3534 if y==NaN then "<" is false and we return NaN
3535 calling isnan is unavoidable, since it's the only way to know
3536 which of x or y causes any compares to be false */
3537 double xx = SCM_REAL_VALUE (x);
3538 return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y;
3539 }
f92e85f7
MV		 3540 else if (SCM_FRACTIONP (y))
3541 {
3542 double yy = scm_i_fraction2double (y);
3543 double xx = SCM_REAL_VALUE (x);
3544 return (yy < xx) ? scm_make_real (yy) : x;
3545 }
0aacf84e
MD		 3546 else
3547 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3548 }
f92e85f7
MV		 3549 else if (SCM_FRACTIONP (x))
3550 {
3551 if (SCM_INUMP (y))
3552 {
3553 double z = SCM_INUM (y);
3554 return (scm_i_fraction2double (x) < z) ? x : y;
3555 }
3556 else if (SCM_BIGP (y))
3557 {
3558 double xx = scm_i_fraction2double (x);
3559 int cmp;
3560 cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx);
3561 scm_remember_upto_here_1 (y);
3562 return (cmp < 0) ? y : x;
3563 }
3564 else if (SCM_REALP (y))
3565 {
3566 double xx = scm_i_fraction2double (x);
3567 return (SCM_REAL_VALUE (y) < xx) ? y : scm_make_real (xx);
3568 }
3569 else if (SCM_FRACTIONP (y))
3570 {
3571 double yy = scm_i_fraction2double (y);
3572 double xx = scm_i_fraction2double (x);
3573 return (xx < yy) ? x : y;
3574 }
3575 else
3576 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
3577 }
0aacf84e 3578 else
f4c627b3 3579 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
0f2d19dd
JB		 3580}
3581
3582
9de33deb 3583SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
942e5b91
MG		 3584/* "Return the sum of all parameter values. Return 0 if called without\n"
3585 * "any parameters."
3586 */
0f2d19dd 3587SCM
6e8d25a6 3588scm_sum (SCM x, SCM y)
0f2d19dd 3589{
ca46fb90
RB		 3590 if (SCM_UNBNDP (y))
3591 {
3592 if (SCM_NUMBERP (x)) return x;
3593 if (SCM_UNBNDP (x)) return SCM_INUM0;
98cb6e75 3594 SCM_WTA_DISPATCH_1 (g_sum, x, SCM_ARG1, s_sum);
f872b822 3595 }
c209c88e 3596
ca46fb90
RB		 3597 if (SCM_INUMP (x))
3598 {
3599 if (SCM_INUMP (y))
3600 {
3601 long xx = SCM_INUM (x);
3602 long yy = SCM_INUM (y);
3603 long int z = xx + yy;
3604 return SCM_FIXABLE (z) ? SCM_MAKINUM (z) : scm_i_long2big (z);
3605 }
3606 else if (SCM_BIGP (y))
3607 {
3608 SCM_SWAP (x, y);
3609 goto add_big_inum;
3610 }
3611 else if (SCM_REALP (y))
3612 {
3613 long int xx = SCM_INUM (x);
3614 return scm_make_real (xx + SCM_REAL_VALUE (y));
3615 }
3616 else if (SCM_COMPLEXP (y))
3617 {
3618 long int xx = SCM_INUM (x);
3619 return scm_make_complex (xx + SCM_COMPLEX_REAL (y),
3620 SCM_COMPLEX_IMAG (y));
3621 }
f92e85f7
MV		 3622 else if (SCM_FRACTIONP (y))
3623 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3624 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3625 SCM_FRACTION_DENOMINATOR (y));
ca46fb90
RB		 3626 else
3627 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0aacf84e
MD		 3628 } else if (SCM_BIGP (x))
3629 {
3630 if (SCM_INUMP (y))
3631 {
3632 long int inum;
3633 int bigsgn;
3634 add_big_inum:
3635 inum = SCM_INUM (y);
3636 if (inum == 0)
3637 return x;
3638 bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x));
3639 if (inum < 0)
3640 {
3641 SCM result = scm_i_mkbig ();
3642 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum);
3643 scm_remember_upto_here_1 (x);
3644 /* we know the result will have to be a bignum */
3645 if (bigsgn == -1)
3646 return result;
3647 return scm_i_normbig (result);
3648 }
3649 else
3650 {
3651 SCM result = scm_i_mkbig ();
3652 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum);
3653 scm_remember_upto_here_1 (x);
3654 /* we know the result will have to be a bignum */
3655 if (bigsgn == 1)
3656 return result;
3657 return scm_i_normbig (result);
3658 }
3659 }
3660 else if (SCM_BIGP (y))
3661 {
3662 SCM result = scm_i_mkbig ();
3663 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3664 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3665 mpz_add (SCM_I_BIG_MPZ (result),
3666 SCM_I_BIG_MPZ (x),
3667 SCM_I_BIG_MPZ (y));
3668 scm_remember_upto_here_2 (x, y);
3669 /* we know the result will have to be a bignum */
3670 if (sgn_x == sgn_y)
3671 return result;
3672 return scm_i_normbig (result);
3673 }
3674 else if (SCM_REALP (y))
3675 {
3676 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y);
3677 scm_remember_upto_here_1 (x);
3678 return scm_make_real (result);
3679 }
3680 else if (SCM_COMPLEXP (y))
3681 {
3682 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3683 + SCM_COMPLEX_REAL (y));
3684 scm_remember_upto_here_1 (x);
3685 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3686 }
f92e85f7
MV		 3687 else if (SCM_FRACTIONP (y))
3688 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (y),
3689 scm_product (x, SCM_FRACTION_DENOMINATOR (y))),
3690 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 3691 else
3692 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
0f2d19dd 3693 }
0aacf84e
MD		 3694 else if (SCM_REALP (x))
3695 {
3696 if (SCM_INUMP (y))
3697 return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y));
3698 else if (SCM_BIGP (y))
3699 {
3700 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x);
3701 scm_remember_upto_here_1 (y);
3702 return scm_make_real (result);
3703 }
3704 else if (SCM_REALP (y))
3705 return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y));
3706 else if (SCM_COMPLEXP (y))
3707 return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y),
3708 SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3709 else if (SCM_FRACTIONP (y))
3710 return scm_make_real (SCM_REAL_VALUE (x) + scm_i_fraction2double (y));
0aacf84e
MD		 3711 else
3712 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3713 }
0aacf84e
MD		 3714 else if (SCM_COMPLEXP (x))
3715 {
3716 if (SCM_INUMP (y))
3717 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y),
3718 SCM_COMPLEX_IMAG (x));
3719 else if (SCM_BIGP (y))
3720 {
3721 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y))
3722 + SCM_COMPLEX_REAL (x));
3723 scm_remember_upto_here_1 (y);
3724 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x));
3725 }
3726 else if (SCM_REALP (y))
3727 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y),
3728 SCM_COMPLEX_IMAG (x));
3729 else if (SCM_COMPLEXP (y))
3730 return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y),
3731 SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3732 else if (SCM_FRACTIONP (y))
3733 return scm_make_complex (SCM_COMPLEX_REAL (x) + scm_i_fraction2double (y),
3734 SCM_COMPLEX_IMAG (x));
3735 else
3736 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
3737 }
3738 else if (SCM_FRACTIONP (x))
3739 {
3740 if (SCM_INUMP (y))
3741 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3742 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3743 SCM_FRACTION_DENOMINATOR (x));
3744 else if (SCM_BIGP (y))
3745 return scm_make_ratio (scm_sum (SCM_FRACTION_NUMERATOR (x),
3746 scm_product (y, SCM_FRACTION_DENOMINATOR (x))),
3747 SCM_FRACTION_DENOMINATOR (x));
3748 else if (SCM_REALP (y))
3749 return scm_make_real (SCM_REAL_VALUE (y) + scm_i_fraction2double (x));
3750 else if (SCM_COMPLEXP (y))
3751 return scm_make_complex (SCM_COMPLEX_REAL (y) + scm_i_fraction2double (x),
3752 SCM_COMPLEX_IMAG (y));
3753 else if (SCM_FRACTIONP (y))
3754 /* a/b + c/d = (ad + bc) / bd */
3755 return scm_make_ratio (scm_sum (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
3756 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
3757 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 3758 else
3759 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
98cb6e75 3760 }
0aacf84e 3761 else
98cb6e75 3762 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
0f2d19dd
JB		 3763}
3764
3765
9de33deb 3766SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
609c3d30
MG		 3767/* If called with one argument @var{z1}, -@var{z1} returned. Otherwise
3768 * the sum of all but the first argument are subtracted from the first
3769 * argument. */
c05e97b7 3770#define FUNC_NAME s_difference
0f2d19dd 3771SCM
6e8d25a6 3772scm_difference (SCM x, SCM y)
0f2d19dd 3773{
ca46fb90
RB		 3774 if (SCM_UNBNDP (y))
3775 {
3776 if (SCM_UNBNDP (x))
3777 SCM_WTA_DISPATCH_0 (g_difference, s_difference);
3778 else
3779 if (SCM_INUMP (x))
3780 {
3781 long xx = -SCM_INUM (x);
3782 if (SCM_FIXABLE (xx))
3783 return SCM_MAKINUM (xx);
3784 else
3785 return scm_i_long2big (xx);
3786 }
3787 else if (SCM_BIGP (x))
3788 /* FIXME: do we really need to normalize here? */
3789 return scm_i_normbig (scm_i_clonebig (x, 0));
3790 else if (SCM_REALP (x))
3791 return scm_make_real (-SCM_REAL_VALUE (x));
3792 else if (SCM_COMPLEXP (x))
3793 return scm_make_complex (-SCM_COMPLEX_REAL (x),
3794 -SCM_COMPLEX_IMAG (x));
f92e85f7
MV		 3795 else if (SCM_FRACTIONP (x))
3796 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x), SCM_UNDEFINED),
3797 SCM_FRACTION_DENOMINATOR (x));
ca46fb90
RB		 3798 else
3799 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
f872b822 3800 }
ca46fb90 3801
0aacf84e
MD		 3802 if (SCM_INUMP (x))
3803 {
3804 if (SCM_INUMP (y))
3805 {
3806 long int xx = SCM_INUM (x);
3807 long int yy = SCM_INUM (y);
3808 long int z = xx - yy;
3809 if (SCM_FIXABLE (z))
3810 return SCM_MAKINUM (z);
3811 else
3812 return scm_i_long2big (z);
3813 }
3814 else if (SCM_BIGP (y))
3815 {
3816 /* inum-x - big-y */
3817 long xx = SCM_INUM (x);
ca46fb90 3818
0aacf84e
MD		 3819 if (xx == 0)
3820 return scm_i_clonebig (y, 0);
3821 else
3822 {
3823 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3824 SCM result = scm_i_mkbig ();
ca46fb90 3825
0aacf84e
MD		 3826 if (xx >= 0)
3827 mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y));
3828 else
3829 {
3830 /* x - y == -(y + -x) */
3831 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx);
3832 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
3833 }
3834 scm_remember_upto_here_1 (y);
ca46fb90 3835
0aacf84e
MD		 3836 if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0))
3837 /* we know the result will have to be a bignum */
3838 return result;
3839 else
3840 return scm_i_normbig (result);
3841 }
3842 }
3843 else if (SCM_REALP (y))
3844 {
3845 long int xx = SCM_INUM (x);
3846 return scm_make_real (xx - SCM_REAL_VALUE (y));
3847 }
3848 else if (SCM_COMPLEXP (y))
3849 {
3850 long int xx = SCM_INUM (x);
3851 return scm_make_complex (xx - SCM_COMPLEX_REAL (y),
3852 - SCM_COMPLEX_IMAG (y));
3853 }
f92e85f7
MV		 3854 else if (SCM_FRACTIONP (y))
3855 /* a - b/c = (ac - b) / c */
3856 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
3857 SCM_FRACTION_NUMERATOR (y)),
3858 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 3859 else
3860 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3861 }
0aacf84e
MD		 3862 else if (SCM_BIGP (x))
3863 {
3864 if (SCM_INUMP (y))
3865 {
3866 /* big-x - inum-y */
3867 long yy = SCM_INUM (y);
3868 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
ca46fb90 3869
0aacf84e
MD		 3870 scm_remember_upto_here_1 (x);
3871 if (sgn_x == 0)
3872 return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy);
3873 else
3874 {
3875 SCM result = scm_i_mkbig ();
ca46fb90 3876
708f22c6
KR		 3877 if (yy >= 0)
3878 mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy);
3879 else
3880 mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), -yy);
0aacf84e 3881 scm_remember_upto_here_1 (x);
ca46fb90 3882
0aacf84e
MD		 3883 if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0))
3884 /* we know the result will have to be a bignum */
3885 return result;
3886 else
3887 return scm_i_normbig (result);
3888 }
3889 }
3890 else if (SCM_BIGP (y))
3891 {
3892 int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x));
3893 int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y));
3894 SCM result = scm_i_mkbig ();
3895 mpz_sub (SCM_I_BIG_MPZ (result),
3896 SCM_I_BIG_MPZ (x),
3897 SCM_I_BIG_MPZ (y));
3898 scm_remember_upto_here_2 (x, y);
3899 /* we know the result will have to be a bignum */
3900 if ((sgn_x == 1) && (sgn_y == -1))
3901 return result;
3902 if ((sgn_x == -1) && (sgn_y == 1))
3903 return result;
3904 return scm_i_normbig (result);
3905 }
3906 else if (SCM_REALP (y))
3907 {
3908 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y);
3909 scm_remember_upto_here_1 (x);
3910 return scm_make_real (result);
3911 }
3912 else if (SCM_COMPLEXP (y))
3913 {
3914 double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x))
3915 - SCM_COMPLEX_REAL (y));
3916 scm_remember_upto_here_1 (x);
3917 return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y));
3918 }
f92e85f7
MV		 3919 else if (SCM_FRACTIONP (y))
3920 return scm_make_ratio (scm_difference (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
3921 SCM_FRACTION_NUMERATOR (y)),
3922 SCM_FRACTION_DENOMINATOR (y));
0aacf84e 3923 else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
ca46fb90 3924 }
0aacf84e
MD		 3925 else if (SCM_REALP (x))
3926 {
3927 if (SCM_INUMP (y))
3928 return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y));
3929 else if (SCM_BIGP (y))
3930 {
3931 double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y));
3932 scm_remember_upto_here_1 (x);
3933 return scm_make_real (result);
3934 }
3935 else if (SCM_REALP (y))
3936 return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y));
3937 else if (SCM_COMPLEXP (y))
3938 return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y),
3939 -SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3940 else if (SCM_FRACTIONP (y))
3941 return scm_make_real (SCM_REAL_VALUE (x) - scm_i_fraction2double (y));
0aacf84e
MD		 3942 else
3943 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3944 }
0aacf84e
MD		 3945 else if (SCM_COMPLEXP (x))
3946 {
3947 if (SCM_INUMP (y))
3948 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y),
3949 SCM_COMPLEX_IMAG (x));
3950 else if (SCM_BIGP (y))
3951 {
3952 double real_part = (SCM_COMPLEX_REAL (x)
3953 - mpz_get_d (SCM_I_BIG_MPZ (y)));
3954 scm_remember_upto_here_1 (x);
3955 return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y));
3956 }
3957 else if (SCM_REALP (y))
3958 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y),
3959 SCM_COMPLEX_IMAG (x));
3960 else if (SCM_COMPLEXP (y))
3961 return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y),
3962 SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 3963 else if (SCM_FRACTIONP (y))
3964 return scm_make_complex (SCM_COMPLEX_REAL (x) - scm_i_fraction2double (y),
3965 SCM_COMPLEX_IMAG (x));
3966 else
3967 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
3968 }
3969 else if (SCM_FRACTIONP (x))
3970 {
3971 if (SCM_INUMP (y))
3972 /* a/b - c = (a - cb) / b */
3973 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
3974 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
3975 SCM_FRACTION_DENOMINATOR (x));
3976 else if (SCM_BIGP (y))
3977 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (x),
3978 scm_product(y, SCM_FRACTION_DENOMINATOR (x))),
3979 SCM_FRACTION_DENOMINATOR (x));
3980 else if (SCM_REALP (y))
3981 return scm_make_real (scm_i_fraction2double (x) - SCM_REAL_VALUE (y));
3982 else if (SCM_COMPLEXP (y))
3983 return scm_make_complex (scm_i_fraction2double (x) - SCM_COMPLEX_REAL (y),
3984 -SCM_COMPLEX_IMAG (y));
3985 else if (SCM_FRACTIONP (y))
3986 /* a/b - c/d = (ad - bc) / bd */
3987 return scm_make_ratio (scm_difference (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
3988 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x))),
3989 scm_product (SCM_FRACTION_DENOMINATOR (x), SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 3990 else
3991 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
98cb6e75 3992 }
0aacf84e 3993 else
98cb6e75 3994 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
0f2d19dd 3995}
c05e97b7 3996#undef FUNC_NAME
0f2d19dd 3997
ca46fb90 3998
9de33deb 3999SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
942e5b91
MG		 4000/* "Return the product of all arguments. If called without arguments,\n"
4001 * "1 is returned."
4002 */
0f2d19dd 4003SCM
6e8d25a6 4004scm_product (SCM x, SCM y)
0f2d19dd 4005{
0aacf84e
MD		 4006 if (SCM_UNBNDP (y))
4007 {
4008 if (SCM_UNBNDP (x))
4009 return SCM_MAKINUM (1L);
4010 else if (SCM_NUMBERP (x))
4011 return x;
4012 else
4013 SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product);
f872b822 4014 }
ca46fb90 4015
0aacf84e
MD		 4016 if (SCM_INUMP (x))
4017 {
4018 long xx;
f4c627b3 4019
0aacf84e
MD		 4020 intbig:
4021 xx = SCM_INUM (x);
f4c627b3 4022
0aacf84e
MD		 4023 switch (xx)
4024 {
ca46fb90
RB		 4025 case 0: return x; break;
4026 case 1: return y; break;
0aacf84e 4027 }
f4c627b3 4028
0aacf84e
MD		 4029 if (SCM_INUMP (y))
4030 {
4031 long yy = SCM_INUM (y);
4032 long kk = xx * yy;
4033 SCM k = SCM_MAKINUM (kk);
4034 if ((kk == SCM_INUM (k)) && (kk / xx == yy))
4035 return k;
4036 else
4037 {
4038 SCM result = scm_i_long2big (xx);
4039 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy);
4040 return scm_i_normbig (result);
4041 }
4042 }
4043 else if (SCM_BIGP (y))
4044 {
4045 SCM result = scm_i_mkbig ();
4046 mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx);
4047 scm_remember_upto_here_1 (y);
4048 return result;
4049 }
4050 else if (SCM_REALP (y))
4051 return scm_make_real (xx * SCM_REAL_VALUE (y));
4052 else if (SCM_COMPLEXP (y))
4053 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4054 xx * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4055 else if (SCM_FRACTIONP (y))
4056 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4057 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4058 else
4059 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4060 }
0aacf84e
MD		 4061 else if (SCM_BIGP (x))
4062 {
4063 if (SCM_INUMP (y))
4064 {
4065 SCM_SWAP (x, y);
4066 goto intbig;
4067 }
4068 else if (SCM_BIGP (y))
4069 {
4070 SCM result = scm_i_mkbig ();
4071 mpz_mul (SCM_I_BIG_MPZ (result),
4072 SCM_I_BIG_MPZ (x),
4073 SCM_I_BIG_MPZ (y));
4074 scm_remember_upto_here_2 (x, y);
4075 return result;
4076 }
4077 else if (SCM_REALP (y))
4078 {
4079 double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y);
4080 scm_remember_upto_here_1 (x);
4081 return scm_make_real (result);
4082 }
4083 else if (SCM_COMPLEXP (y))
4084 {
4085 double z = mpz_get_d (SCM_I_BIG_MPZ (x));
4086 scm_remember_upto_here_1 (x);
4087 return scm_make_complex (z * SCM_COMPLEX_REAL (y),
4088 z * SCM_COMPLEX_IMAG (y));
4089 }
f92e85f7
MV		 4090 else if (SCM_FRACTIONP (y))
4091 return scm_make_ratio (scm_product (x, SCM_FRACTION_NUMERATOR (y)),
4092 SCM_FRACTION_DENOMINATOR (y));
0aacf84e
MD		 4093 else
4094 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4095 }
0aacf84e
MD		 4096 else if (SCM_REALP (x))
4097 {
4098 if (SCM_INUMP (y))
4099 return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x));
4100 else if (SCM_BIGP (y))
4101 {
4102 double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x);
4103 scm_remember_upto_here_1 (y);
4104 return scm_make_real (result);
4105 }
4106 else if (SCM_REALP (y))
4107 return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y));
4108 else if (SCM_COMPLEXP (y))
4109 return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y),
4110 SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y));
f92e85f7
MV		 4111 else if (SCM_FRACTIONP (y))
4112 return scm_make_real (SCM_REAL_VALUE (x) * scm_i_fraction2double (y));
0aacf84e
MD		 4113 else
4114 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4115 }
0aacf84e
MD		 4116 else if (SCM_COMPLEXP (x))
4117 {
4118 if (SCM_INUMP (y))
4119 return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x),
4120 SCM_INUM (y) * SCM_COMPLEX_IMAG (x));
4121 else if (SCM_BIGP (y))
4122 {
4123 double z = mpz_get_d (SCM_I_BIG_MPZ (y));
4124 scm_remember_upto_here_1 (y);
76506335
KR		 4125 return scm_make_complex (z * SCM_COMPLEX_REAL (x),
4126 z * SCM_COMPLEX_IMAG (x));
0aacf84e
MD		 4127 }
4128 else if (SCM_REALP (y))
4129 return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x),
4130 SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x));
4131 else if (SCM_COMPLEXP (y))
4132 {
4133 return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y)
4134 - SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y),
4135 SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y)
4136 + SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y));
4137 }
f92e85f7
MV		 4138 else if (SCM_FRACTIONP (y))
4139 {
4140 double yy = scm_i_fraction2double (y);
4141 return scm_make_complex (yy * SCM_COMPLEX_REAL (x),
4142 yy * SCM_COMPLEX_IMAG (x));
4143 }
4144 else
4145 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
4146 }
4147 else if (SCM_FRACTIONP (x))
4148 {
4149 if (SCM_INUMP (y))
4150 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4151 SCM_FRACTION_DENOMINATOR (x));
4152 else if (SCM_BIGP (y))
4153 return scm_make_ratio (scm_product (y, SCM_FRACTION_NUMERATOR (x)),
4154 SCM_FRACTION_DENOMINATOR (x));
4155 else if (SCM_REALP (y))
4156 return scm_make_real (scm_i_fraction2double (x) * SCM_REAL_VALUE (y));
4157 else if (SCM_COMPLEXP (y))
4158 {
4159 double xx = scm_i_fraction2double (x);
4160 return scm_make_complex (xx * SCM_COMPLEX_REAL (y),
4161 xx * SCM_COMPLEX_IMAG (y));
4162 }
4163 else if (SCM_FRACTIONP (y))
4164 /* a/b * c/d = ac / bd */
4165 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x),
4166 SCM_FRACTION_NUMERATOR (y)),
4167 scm_product (SCM_FRACTION_DENOMINATOR (x),
4168 SCM_FRACTION_DENOMINATOR (y)));
0aacf84e
MD		 4169 else
4170 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f4c627b3 4171 }
0aacf84e 4172 else
f4c627b3 4173 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
0f2d19dd
JB		 4174}
4175
0f2d19dd 4176double
6e8d25a6 4177scm_num2dbl (SCM a, const char *why)
f4c627b3 4178#define FUNC_NAME why
0f2d19dd 4179{
0aacf84e 4180 if (SCM_INUMP (a))
0f2d19dd 4181 return (double) SCM_INUM (a);
0aacf84e
MD		 4182 else if (SCM_BIGP (a))
4183 {
4184 double result = mpz_get_d (SCM_I_BIG_MPZ (a));
4185 scm_remember_upto_here_1 (a);
4186 return result;
4187 }
4188 else if (SCM_REALP (a))
f4c627b3 4189 return (SCM_REAL_VALUE (a));
f92e85f7
MV		 4190 else if (SCM_FRACTIONP (a))
4191 return scm_i_fraction2double (a);
0aacf84e 4192 else
f4c627b3 4193 SCM_WRONG_TYPE_ARG (SCM_ARGn, a);
0f2d19dd 4194}
f4c627b3 4195#undef FUNC_NAME
0f2d19dd 4196
7351e207
MV		 4197#if ((defined (HAVE_ISINF) && defined (HAVE_ISNAN)) \
4198 || (defined (HAVE_FINITE) && defined (HAVE_ISNAN)))
4199#define ALLOW_DIVIDE_BY_ZERO
4200/* #define ALLOW_DIVIDE_BY_EXACT_ZERO */
4201#endif
0f2d19dd 4202
ba74ef4e
MV		 4203/* The code below for complex division is adapted from the GNU
4204 libstdc++, which adapted it from f2c's libF77, and is subject to
4205 this copyright: */
4206
4207/****************************************************************
4208Copyright 1990, 1991, 1992, 1993 by AT&T Bell Laboratories and Bellcore.
4209
4210Permission to use, copy, modify, and distribute this software
4211and its documentation for any purpose and without fee is hereby
4212granted, provided that the above copyright notice appear in all
4213copies and that both that the copyright notice and this
4214permission notice and warranty disclaimer appear in supporting
4215documentation, and that the names of AT&T Bell Laboratories or
4216Bellcore or any of their entities not be used in advertising or
4217publicity pertaining to distribution of the software without
4218specific, written prior permission.
4219
4220AT&T and Bellcore disclaim all warranties with regard to this
4221software, including all implied warranties of merchantability
4222and fitness. In no event shall AT&T or Bellcore be liable for
4223any special, indirect or consequential damages or any damages
4224whatsoever resulting from loss of use, data or profits, whether
4225in an action of contract, negligence or other tortious action,
4226arising out of or in connection with the use or performance of
4227this software.
4228****************************************************************/
4229
9de33deb 4230SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
609c3d30
MG		 4231/* Divide the first argument by the product of the remaining
4232 arguments. If called with one argument @var{z1}, 1/@var{z1} is
4233 returned. */
c05e97b7 4234#define FUNC_NAME s_divide
f92e85f7
MV		 4235static SCM
4236scm_i_divide (SCM x, SCM y, int inexact)
0f2d19dd 4237{
f8de44c1
DH		 4238 double a;
4239
0aacf84e
MD		 4240 if (SCM_UNBNDP (y))
4241 {
4242 if (SCM_UNBNDP (x))
4243 SCM_WTA_DISPATCH_0 (g_divide, s_divide);
4244 else if (SCM_INUMP (x))
4245 {
4246 long xx = SCM_INUM (x);
4247 if (xx == 1 || xx == -1)
4248 return x;
7351e207 4249#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4250 else if (xx == 0)
4251 scm_num_overflow (s_divide);
7351e207 4252#endif
0aacf84e 4253 else
f92e85f7
MV		 4254 {
4255 if (inexact)
4256 return scm_make_real (1.0 / (double) xx);
4257 else return scm_make_ratio (SCM_MAKINUM(1), x);
4258 }
0aacf84e
MD		 4259 }
4260 else if (SCM_BIGP (x))
f92e85f7
MV		 4261 {
4262 if (inexact)
4263 return scm_make_real (1.0 / scm_i_big2dbl (x));
4264 else return scm_make_ratio (SCM_MAKINUM(1), x);
4265 }
0aacf84e
MD		 4266 else if (SCM_REALP (x))
4267 {
4268 double xx = SCM_REAL_VALUE (x);
7351e207 4269#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4270 if (xx == 0.0)
4271 scm_num_overflow (s_divide);
4272 else
7351e207 4273#endif
0aacf84e
MD		 4274 return scm_make_real (1.0 / xx);
4275 }
4276 else if (SCM_COMPLEXP (x))
4277 {
4278 double r = SCM_COMPLEX_REAL (x);
4279 double i = SCM_COMPLEX_IMAG (x);
4280 if (r <= i)
4281 {
4282 double t = r / i;
4283 double d = i * (1.0 + t * t);
4284 return scm_make_complex (t / d, -1.0 / d);
4285 }
4286 else
4287 {
4288 double t = i / r;
4289 double d = r * (1.0 + t * t);
4290 return scm_make_complex (1.0 / d, -t / d);
4291 }
4292 }
f92e85f7
MV		 4293 else if (SCM_FRACTIONP (x))
4294 return scm_make_ratio (SCM_FRACTION_DENOMINATOR (x),
4295 SCM_FRACTION_NUMERATOR (x));
0aacf84e
MD		 4296 else
4297 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
f8de44c1 4298 }
f8de44c1 4299
0aacf84e
MD		 4300 if (SCM_INUMP (x))
4301 {
4302 long xx = SCM_INUM (x);
4303 if (SCM_INUMP (y))
4304 {
4305 long yy = SCM_INUM (y);
4306 if (yy == 0)
4307 {
7351e207 4308#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4309 scm_num_overflow (s_divide);
7351e207 4310#else
0aacf84e 4311 return scm_make_real ((double) xx / (double) yy);
7351e207 4312#endif
0aacf84e
MD		 4313 }
4314 else if (xx % yy != 0)
f92e85f7
MV		 4315 {
4316 if (inexact)
4317 return scm_make_real ((double) xx / (double) yy);
4318 else return scm_make_ratio (x, y);
4319 }
0aacf84e
MD		 4320 else
4321 {
4322 long z = xx / yy;
4323 if (SCM_FIXABLE (z))
4324 return SCM_MAKINUM (z);
4325 else
4326 return scm_i_long2big (z);
4327 }
f872b822 4328 }
0aacf84e 4329 else if (SCM_BIGP (y))
f92e85f7
MV		 4330 {
4331 if (inexact)
4332 return scm_make_real ((double) xx / scm_i_big2dbl (y));
4333 else return scm_make_ratio (x, y);
4334 }
0aacf84e
MD		 4335 else if (SCM_REALP (y))
4336 {
4337 double yy = SCM_REAL_VALUE (y);
7351e207 4338#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4339 if (yy == 0.0)
4340 scm_num_overflow (s_divide);
4341 else
7351e207 4342#endif
0aacf84e 4343 return scm_make_real ((double) xx / yy);
ba74ef4e 4344 }
0aacf84e
MD		 4345 else if (SCM_COMPLEXP (y))
4346 {
4347 a = xx;
4348 complex_div: /* y _must_ be a complex number */
4349 {
4350 double r = SCM_COMPLEX_REAL (y);
4351 double i = SCM_COMPLEX_IMAG (y);
4352 if (r <= i)
4353 {
4354 double t = r / i;
4355 double d = i * (1.0 + t * t);
4356 return scm_make_complex ((a * t) / d, -a / d);
4357 }
4358 else
4359 {
4360 double t = i / r;
4361 double d = r * (1.0 + t * t);
4362 return scm_make_complex (a / d, -(a * t) / d);
4363 }
4364 }
4365 }
f92e85f7
MV		 4366 else if (SCM_FRACTIONP (y))
4367 /* a / b/c = ac / b */
4368 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4369 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4370 else
4371 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4372 }
0aacf84e
MD		 4373 else if (SCM_BIGP (x))
4374 {
4375 if (SCM_INUMP (y))
4376 {
4377 long int yy = SCM_INUM (y);
4378 if (yy == 0)
4379 {
7351e207 4380#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4381 scm_num_overflow (s_divide);
7351e207 4382#else
0aacf84e
MD		 4383 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4384 scm_remember_upto_here_1 (x);
4385 return (sgn == 0) ? scm_nan () : scm_inf ();
7351e207 4386#endif
0aacf84e
MD		 4387 }
4388 else if (yy == 1)
4389 return x;
4390 else
4391 {
4392 /* FIXME: HMM, what are the relative performance issues here?
4393 We need to test. Is it faster on average to test
4394 divisible_p, then perform whichever operation, or is it
4395 faster to perform the integer div opportunistically and
4396 switch to real if there's a remainder? For now we take the
4397 middle ground: test, then if divisible, use the faster div
4398 func. */
4399
4400 long abs_yy = yy < 0 ? -yy : yy;
4401 int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy);
4402
4403 if (divisible_p)
4404 {
4405 SCM result = scm_i_mkbig ();
4406 mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy);
4407 scm_remember_upto_here_1 (x);
4408 if (yy < 0)
4409 mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result));
4410 return scm_i_normbig (result);
4411 }
4412 else
f92e85f7
MV		 4413 {
4414 if (inexact)
4415 return scm_make_real (scm_i_big2dbl (x) / (double) yy);
4416 else return scm_make_ratio (x, y);
4417 }
0aacf84e
MD		 4418 }
4419 }
4420 else if (SCM_BIGP (y))
4421 {
4422 int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0);
4423 if (y_is_zero)
4424 {
ca46fb90 4425#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e 4426 scm_num_overflow (s_divide);
f872b822 4427#else
0aacf84e
MD		 4428 int sgn = mpz_sgn (SCM_I_BIG_MPZ (x));
4429 scm_remember_upto_here_1 (x);
4430 return (sgn == 0) ? scm_nan () : scm_inf ();
f872b822 4431#endif
0aacf84e
MD		 4432 }
4433 else
4434 {
4435 /* big_x / big_y */
4436 int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x),
4437 SCM_I_BIG_MPZ (y));
4438 if (divisible_p)
4439 {
4440 SCM result = scm_i_mkbig ();
4441 mpz_divexact (SCM_I_BIG_MPZ (result),
4442 SCM_I_BIG_MPZ (x),
4443 SCM_I_BIG_MPZ (y));
4444 scm_remember_upto_here_2 (x, y);
4445 return scm_i_normbig (result);
4446 }
4447 else
4448 {
f92e85f7
MV		 4449 if (inexact)
4450 {
4451 double dbx = mpz_get_d (SCM_I_BIG_MPZ (x));
4452 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4453 scm_remember_upto_here_2 (x, y);
4454 return scm_make_real (dbx / dby);
4455 }
4456 else return scm_make_ratio (x, y);
0aacf84e
MD		 4457 }
4458 }
4459 }
4460 else if (SCM_REALP (y))
4461 {
4462 double yy = SCM_REAL_VALUE (y);
7351e207 4463#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4464 if (yy == 0.0)
4465 scm_num_overflow (s_divide);
4466 else
7351e207 4467#endif
0aacf84e
MD		 4468 return scm_make_real (scm_i_big2dbl (x) / yy);
4469 }
4470 else if (SCM_COMPLEXP (y))
4471 {
4472 a = scm_i_big2dbl (x);
4473 goto complex_div;
4474 }
f92e85f7
MV		 4475 else if (SCM_FRACTIONP (y))
4476 return scm_make_ratio (scm_product (x, SCM_FRACTION_DENOMINATOR (y)),
4477 SCM_FRACTION_NUMERATOR (y));
0aacf84e
MD		 4478 else
4479 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4480 }
0aacf84e
MD		 4481 else if (SCM_REALP (x))
4482 {
4483 double rx = SCM_REAL_VALUE (x);
4484 if (SCM_INUMP (y))
4485 {
4486 long int yy = SCM_INUM (y);
7351e207 4487#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4488 if (yy == 0)
4489 scm_num_overflow (s_divide);
4490 else
7351e207 4491#endif
0aacf84e
MD		 4492 return scm_make_real (rx / (double) yy);
4493 }
4494 else if (SCM_BIGP (y))
4495 {
4496 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4497 scm_remember_upto_here_1 (y);
4498 return scm_make_real (rx / dby);
4499 }
4500 else if (SCM_REALP (y))
4501 {
4502 double yy = SCM_REAL_VALUE (y);
7351e207 4503#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4504 if (yy == 0.0)
4505 scm_num_overflow (s_divide);
4506 else
7351e207 4507#endif
0aacf84e
MD		 4508 return scm_make_real (rx / yy);
4509 }
4510 else if (SCM_COMPLEXP (y))
4511 {
4512 a = rx;
4513 goto complex_div;
4514 }
f92e85f7
MV		 4515 else if (SCM_FRACTIONP (y))
4516 return scm_make_real (rx / scm_i_fraction2double (y));
0aacf84e
MD		 4517 else
4518 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 4519 }
0aacf84e
MD		 4520 else if (SCM_COMPLEXP (x))
4521 {
4522 double rx = SCM_COMPLEX_REAL (x);
4523 double ix = SCM_COMPLEX_IMAG (x);
4524 if (SCM_INUMP (y))
4525 {
4526 long int yy = SCM_INUM (y);
7351e207 4527#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
0aacf84e
MD		 4528 if (yy == 0)
4529 scm_num_overflow (s_divide);
4530 else
7351e207 4531#endif
0aacf84e
MD		 4532 {
4533 double d = yy;
4534 return scm_make_complex (rx / d, ix / d);
4535 }
4536 }
4537 else if (SCM_BIGP (y))
4538 {
4539 double dby = mpz_get_d (SCM_I_BIG_MPZ (y));
4540 scm_remember_upto_here_1 (y);
4541 return scm_make_complex (rx / dby, ix / dby);
4542 }
4543 else if (SCM_REALP (y))
4544 {
4545 double yy = SCM_REAL_VALUE (y);
7351e207 4546#ifndef ALLOW_DIVIDE_BY_ZERO
0aacf84e
MD		 4547 if (yy == 0.0)
4548 scm_num_overflow (s_divide);
4549 else
7351e207 4550#endif
0aacf84e
MD		 4551 return scm_make_complex (rx / yy, ix / yy);
4552 }
4553 else if (SCM_COMPLEXP (y))
4554 {
4555 double ry = SCM_COMPLEX_REAL (y);
4556 double iy = SCM_COMPLEX_IMAG (y);
4557 if (ry <= iy)
4558 {
4559 double t = ry / iy;
4560 double d = iy * (1.0 + t * t);
4561 return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d);
4562 }
4563 else
4564 {
4565 double t = iy / ry;
4566 double d = ry * (1.0 + t * t);
4567 return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d);
4568 }
4569 }
f92e85f7
MV		 4570 else if (SCM_FRACTIONP (y))
4571 {
4572 double yy = scm_i_fraction2double (y);
4573 return scm_make_complex (rx / yy, ix / yy);
4574 }
0aacf84e
MD		 4575 else
4576 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f8de44c1 4577 }
f92e85f7
MV		 4578 else if (SCM_FRACTIONP (x))
4579 {
4580 if (SCM_INUMP (y))
4581 {
4582 long int yy = SCM_INUM (y);
4583#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO
4584 if (yy == 0)
4585 scm_num_overflow (s_divide);
4586 else
4587#endif
4588 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4589 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4590 }
4591 else if (SCM_BIGP (y))
4592 {
4593 return scm_make_ratio (SCM_FRACTION_NUMERATOR (x),
4594 scm_product (SCM_FRACTION_DENOMINATOR (x), y));
4595 }
4596 else if (SCM_REALP (y))
4597 {
4598 double yy = SCM_REAL_VALUE (y);
4599#ifndef ALLOW_DIVIDE_BY_ZERO
4600 if (yy == 0.0)
4601 scm_num_overflow (s_divide);
4602 else
4603#endif
4604 return scm_make_real (scm_i_fraction2double (x) / yy);
4605 }
4606 else if (SCM_COMPLEXP (y))
4607 {
4608 a = scm_i_fraction2double (x);
4609 goto complex_div;
4610 }
4611 else if (SCM_FRACTIONP (y))
4612 return scm_make_ratio (scm_product (SCM_FRACTION_NUMERATOR (x), SCM_FRACTION_DENOMINATOR (y)),
4613 scm_product (SCM_FRACTION_NUMERATOR (y), SCM_FRACTION_DENOMINATOR (x)));
4614 else
4615 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
4616 }
0aacf84e 4617 else
f8de44c1 4618 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
0f2d19dd 4619}
f92e85f7
MV		 4620
4621SCM
4622scm_divide (SCM x, SCM y)
4623{
4624 return scm_i_divide (x, y, 0);
4625}
4626
4627static SCM scm_divide2real (SCM x, SCM y)
4628{
4629 return scm_i_divide (x, y, 1);
4630}
c05e97b7 4631#undef FUNC_NAME
0f2d19dd 4632
fa605590 4633
0f2d19dd 4634double
6e8d25a6 4635scm_asinh (double x)
0f2d19dd 4636{
fa605590
KR		 4637#if HAVE_ASINH
4638 return asinh (x);
4639#else
4640#define asinh scm_asinh
f872b822 4641 return log (x + sqrt (x * x + 1));
fa605590 4642#endif
0f2d19dd 4643}
fa605590
KR		 4644SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_dsubr, (SCM (*)()) asinh, g_asinh);
4645/* "Return the inverse hyperbolic sine of @var{x}."
4646 */
0f2d19dd
JB		 4647
4648
0f2d19dd 4649double
6e8d25a6 4650scm_acosh (double x)
0f2d19dd 4651{
fa605590
KR		 4652#if HAVE_ACOSH
4653 return acosh (x);
4654#else
4655#define acosh scm_acosh
f872b822 4656 return log (x + sqrt (x * x - 1));
fa605590 4657#endif
0f2d19dd 4658}
fa605590
KR		 4659SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_dsubr, (SCM (*)()) acosh, g_acosh);
4660/* "Return the inverse hyperbolic cosine of @var{x}."
4661 */
0f2d19dd
JB		 4662
4663
0f2d19dd 4664double
6e8d25a6 4665scm_atanh (double x)
0f2d19dd 4666{
fa605590
KR		 4667#if HAVE_ATANH
4668 return atanh (x);
4669#else
4670#define atanh scm_atanh
f872b822 4671 return 0.5 * log ((1 + x) / (1 - x));
fa605590 4672#endif
0f2d19dd 4673}
fa605590
KR		 4674SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_dsubr, (SCM (*)()) atanh, g_atanh);
4675/* "Return the inverse hyperbolic tangent of @var{x}."
4676 */
0f2d19dd
JB		 4677
4678
f92e85f7
MV		 4679/* XXX - eventually, we should remove this definition of scm_round and
4680 rename scm_round_number to scm_round. Likewise for scm_truncate
4681 and scm_truncate_number.
4682 */
4683
0f2d19dd 4684double
6e8d25a6 4685scm_truncate (double x)
0f2d19dd 4686{
fa605590
KR		 4687#if HAVE_TRUNC
4688 return trunc (x);
4689#else
4690#define trunc scm_truncate
f872b822
MD		 4691 if (x < 0.0)
4692 return -floor (-x);
4693 return floor (x);
fa605590 4694#endif
0f2d19dd 4695}
0f2d19dd 4696
0f2d19dd 4697double
6e8d25a6 4698scm_round (double x)
0f2d19dd
JB		 4699{
4700 double plus_half = x + 0.5;
f872b822 4701 double result = floor (plus_half);
0f2d19dd 4702 /* Adjust so that the scm_round is towards even. */
0aacf84e
MD		 4703 return ((plus_half == result && plus_half / 2 != floor (plus_half / 2))
4704 ? result - 1
4705 : result);
0f2d19dd
JB		 4706}
4707
f92e85f7
MV		 4708SCM_DEFINE (scm_truncate_number, "truncate", 1, 0, 0,
4709 (SCM x),
4710 "Round the number @var{x} towards zero.")
4711#define FUNC_NAME s_scm_truncate_number
4712{
4713 if (SCM_FALSEP (scm_negative_p (x)))
4714 return scm_floor (x);
4715 else
4716 return scm_ceiling (x);
4717}
4718#undef FUNC_NAME
4719
4720static SCM exactly_one_half;
4721
4722SCM_DEFINE (scm_round_number, "round", 1, 0, 0,
4723 (SCM x),
4724 "Round the number @var{x} towards the nearest integer. "
4725 "When it is exactly halfway between two integers, "
4726 "round towards the even one.")
4727#define FUNC_NAME s_scm_round_number
4728{
4729 SCM plus_half = scm_sum (x, exactly_one_half);
4730 SCM result = scm_floor (plus_half);
4731 /* Adjust so that the scm_round is towards even. */
4732 if (!SCM_FALSEP (scm_num_eq_p (plus_half, result))
4733 && !SCM_FALSEP (scm_odd_p (result)))
4734 return scm_difference (result, SCM_MAKINUM (1));
4735 else
4736 return result;
4737}
4738#undef FUNC_NAME
4739
4740SCM_PRIMITIVE_GENERIC (scm_floor, "floor", 1, 0, 0,
4741 (SCM x),
4742 "Round the number @var{x} towards minus infinity.")
4743#define FUNC_NAME s_scm_floor
4744{
4745 if (SCM_INUMP (x) || SCM_BIGP (x))
4746 return x;
4747 else if (SCM_REALP (x))
4748 return scm_make_real (floor (SCM_REAL_VALUE (x)));
4749 else if (SCM_FRACTIONP (x))
4750 {
4751 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
4752 SCM_FRACTION_DENOMINATOR (x));
4753 if (SCM_FALSEP (scm_negative_p (x)))
4754 {
4755 /* For positive x, rounding towards zero is correct. */
4756 return q;
4757 }
4758 else
4759 {
4760 /* For negative x, we need to return q-1 unless x is an
4761 integer. But fractions are never integer, per our
4762 assumptions. */
4763 return scm_difference (q, SCM_MAKINUM (1));
4764 }
4765 }
4766 else
4767 SCM_WTA_DISPATCH_1 (g_scm_floor, x, 1, s_scm_floor);
4768}
4769#undef FUNC_NAME
4770
4771SCM_PRIMITIVE_GENERIC (scm_ceiling, "ceiling", 1, 0, 0,
4772 (SCM x),
4773 "Round the number @var{x} towards infinity.")
4774#define FUNC_NAME s_scm_ceiling
4775{
4776 if (SCM_INUMP (x) || SCM_BIGP (x))
4777 return x;
4778 else if (SCM_REALP (x))
4779 return scm_make_real (ceil (SCM_REAL_VALUE (x)));
4780 else if (SCM_FRACTIONP (x))
4781 {
4782 SCM q = scm_quotient (SCM_FRACTION_NUMERATOR (x),
4783 SCM_FRACTION_DENOMINATOR (x));
4784 if (SCM_FALSEP (scm_positive_p (x)))
4785 {
4786 /* For negative x, rounding towards zero is correct. */
4787 return q;
4788 }
4789 else
4790 {
4791 /* For positive x, we need to return q+1 unless x is an
4792 integer. But fractions are never integer, per our
4793 assumptions. */
4794 return scm_sum (q, SCM_MAKINUM (1));
4795 }
4796 }
4797 else
4798 SCM_WTA_DISPATCH_1 (g_scm_ceiling, x, 1, s_scm_ceiling);
4799}
4800#undef FUNC_NAME
0f2d19dd 4801
14b18ed6 4802SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_dsubr, (SCM (*)()) sqrt, g_i_sqrt);
942e5b91
MG		 4803/* "Return the square root of the real number @var{x}."
4804 */
14b18ed6 4805SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_dsubr, (SCM (*)()) fabs, g_i_abs);
942e5b91
MG		 4806/* "Return the absolute value of the real number @var{x}."
4807 */
14b18ed6 4808SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_dsubr, (SCM (*)()) exp, g_i_exp);
942e5b91
MG		 4809/* "Return the @var{x}th power of e."
4810 */
14b18ed6 4811SCM_GPROC1 (s_i_log, "$log", scm_tc7_dsubr, (SCM (*)()) log, g_i_log);
b3fcac34 4812/* "Return the natural logarithm of the real number @var{x}."
942e5b91 4813 */
14b18ed6 4814SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_dsubr, (SCM (*)()) sin, g_i_sin);
942e5b91
MG		 4815/* "Return the sine of the real number @var{x}."
4816 */
14b18ed6 4817SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_dsubr, (SCM (*)()) cos, g_i_cos);
942e5b91
MG		 4818/* "Return the cosine of the real number @var{x}."
4819 */
14b18ed6 4820SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_dsubr, (SCM (*)()) tan, g_i_tan);
942e5b91
MG		 4821/* "Return the tangent of the real number @var{x}."
4822 */
14b18ed6 4823SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_dsubr, (SCM (*)()) asin, g_i_asin);
942e5b91
MG		 4824/* "Return the arc sine of the real number @var{x}."
4825 */
14b18ed6 4826SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_dsubr, (SCM (*)()) acos, g_i_acos);
942e5b91
MG		 4827/* "Return the arc cosine of the real number @var{x}."
4828 */
14b18ed6 4829SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_dsubr, (SCM (*)()) atan, g_i_atan);
942e5b91
MG		 4830/* "Return the arc tangent of the real number @var{x}."
4831 */
14b18ed6 4832SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_dsubr, (SCM (*)()) sinh, g_i_sinh);
942e5b91
MG		 4833/* "Return the hyperbolic sine of the real number @var{x}."
4834 */
14b18ed6 4835SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_dsubr, (SCM (*)()) cosh, g_i_cosh);
942e5b91
MG		 4836/* "Return the hyperbolic cosine of the real number @var{x}."
4837 */
14b18ed6 4838SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_dsubr, (SCM (*)()) tanh, g_i_tanh);
942e5b91
MG		 4839/* "Return the hyperbolic tangent of the real number @var{x}."
4840 */
f872b822
MD		 4841
4842struct dpair
4843{
4844 double x, y;
4845};
4846
27c37006
NJ		 4847static void scm_two_doubles (SCM x,
4848 SCM y,
3eeba8d4
JB		 4849 const char *sstring,
4850 struct dpair * xy);
f872b822
MD		 4851
4852static void
27c37006
NJ		 4853scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy)
4854{
0aacf84e 4855 if (SCM_INUMP (x))
27c37006 4856 xy->x = SCM_INUM (x);
0aacf84e 4857 else if (SCM_BIGP (x))
1be6b49c 4858 xy->x = scm_i_big2dbl (x);
0aacf84e 4859 else if (SCM_REALP (x))
27c37006 4860 xy->x = SCM_REAL_VALUE (x);
f92e85f7
MV		 4861 else if (SCM_FRACTIONP (x))
4862 xy->x = scm_i_fraction2double (x);
0aacf84e 4863 else
27c37006 4864 scm_wrong_type_arg (sstring, SCM_ARG1, x);
98cb6e75 4865
0aacf84e 4866 if (SCM_INUMP (y))
27c37006 4867 xy->y = SCM_INUM (y);
0aacf84e 4868 else if (SCM_BIGP (y))
1be6b49c 4869 xy->y = scm_i_big2dbl (y);
0aacf84e 4870 else if (SCM_REALP (y))
27c37006 4871 xy->y = SCM_REAL_VALUE (y);
f92e85f7
MV		 4872 else if (SCM_FRACTIONP (y))
4873 xy->y = scm_i_fraction2double (y);
0aacf84e 4874 else
27c37006 4875 scm_wrong_type_arg (sstring, SCM_ARG2, y);
0f2d19dd
JB		 4876}
4877
4878
a1ec6916 4879SCM_DEFINE (scm_sys_expt, "$expt", 2, 0, 0,
27c37006
NJ		 4880 (SCM x, SCM y),
4881 "Return @var{x} raised to the power of @var{y}. This\n"
0137a31b 4882 "procedure does not accept complex arguments.")
1bbd0b84 4883#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 4884{
4885 struct dpair xy;
27c37006 4886 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4887 return scm_make_real (pow (xy.x, xy.y));
0f2d19dd 4888}
1bbd0b84 4889#undef FUNC_NAME
0f2d19dd
JB		 4890
4891
a1ec6916 4892SCM_DEFINE (scm_sys_atan2, "$atan2", 2, 0, 0,
27c37006
NJ		 4893 (SCM x, SCM y),
4894 "Return the arc tangent of the two arguments @var{x} and\n"
4895 "@var{y}. This is similar to calculating the arc tangent of\n"
4896 "@var{x} / @var{y}, except that the signs of both arguments\n"
0137a31b
MG		 4897 "are used to determine the quadrant of the result. This\n"
4898 "procedure does not accept complex arguments.")
1bbd0b84 4899#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 4900{
4901 struct dpair xy;
27c37006 4902 scm_two_doubles (x, y, FUNC_NAME, &xy);
f8de44c1 4903 return scm_make_real (atan2 (xy.x, xy.y));
0f2d19dd 4904}
1bbd0b84 4905#undef FUNC_NAME
0f2d19dd
JB		 4906
4907
a1ec6916 4908SCM_DEFINE (scm_make_rectangular, "make-rectangular", 2, 0, 0,
bb628794 4909 (SCM real, SCM imaginary),
942e5b91
MG		 4910 "Return a complex number constructed of the given @var{real} and\n"
4911 "@var{imaginary} parts.")
1bbd0b84 4912#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 4913{
4914 struct dpair xy;
bb628794 4915 scm_two_doubles (real, imaginary, FUNC_NAME, &xy);
f8de44c1 4916 return scm_make_complex (xy.x, xy.y);
0f2d19dd 4917}
1bbd0b84 4918#undef FUNC_NAME
0f2d19dd
JB		 4919
4920
4921
a1ec6916 4922SCM_DEFINE (scm_make_polar, "make-polar", 2, 0, 0,
27c37006 4923 (SCM x, SCM y),
942e5b91 4924 "Return the complex number @var{x} * e^(i * @var{y}).")
1bbd0b84 4925#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 4926{
4927 struct dpair xy;
6efadd7c 4928 double s, c;
27c37006 4929 scm_two_doubles (x, y, FUNC_NAME, &xy);
6efadd7c
KR		 4930#if HAVE_SINCOS
4931 sincos (xy.y, &s, &c);
4932#else
4933 s = sin (xy.y);
4934 c = cos (xy.y);
4935#endif
4936 return scm_make_complex (xy.x * c, xy.x * s);
0f2d19dd 4937}
1bbd0b84 4938#undef FUNC_NAME
0f2d19dd
JB		 4939
4940
152f82bf 4941SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
942e5b91
MG		 4942/* "Return the real part of the number @var{z}."
4943 */
0f2d19dd 4944SCM
6e8d25a6 4945scm_real_part (SCM z)
0f2d19dd 4946{
0aacf84e 4947 if (SCM_INUMP (z))
c2ff8ab0 4948 return z;
0aacf84e 4949 else if (SCM_BIGP (z))
c2ff8ab0 4950 return z;
0aacf84e 4951 else if (SCM_REALP (z))
c2ff8ab0 4952 return z;
0aacf84e 4953 else if (SCM_COMPLEXP (z))
c2ff8ab0 4954 return scm_make_real (SCM_COMPLEX_REAL (z));
f92e85f7
MV		 4955 else if (SCM_FRACTIONP (z))
4956 return scm_make_real (scm_i_fraction2double (z));
0aacf84e 4957 else
c2ff8ab0 4958 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
0f2d19dd
JB		 4959}
4960
4961
152f82bf 4962SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
942e5b91
MG		 4963/* "Return the imaginary part of the number @var{z}."
4964 */
0f2d19dd 4965SCM
6e8d25a6 4966scm_imag_part (SCM z)
0f2d19dd 4967{
0aacf84e 4968 if (SCM_INUMP (z))
f872b822 4969 return SCM_INUM0;
0aacf84e 4970 else if (SCM_BIGP (z))
f872b822 4971 return SCM_INUM0;
0aacf84e 4972 else if (SCM_REALP (z))
c2ff8ab0 4973 return scm_flo0;
0aacf84e 4974 else if (SCM_COMPLEXP (z))
c2ff8ab0 4975 return scm_make_real (SCM_COMPLEX_IMAG (z));
f92e85f7
MV		 4976 else if (SCM_FRACTIONP (z))
4977 return SCM_INUM0;
0aacf84e 4978 else
c2ff8ab0 4979 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
0f2d19dd
JB		 4980}
4981
f92e85f7
MV		 4982SCM_GPROC (s_numerator, "numerator", 1, 0, 0, scm_numerator, g_numerator);
4983/* "Return the numerator of the number @var{z}."
4984 */
4985SCM
4986scm_numerator (SCM z)
4987{
4988 if (SCM_INUMP (z))
4989 return z;
4990 else if (SCM_BIGP (z))
4991 return z;
4992 else if (SCM_FRACTIONP (z))
4993 {
4994 scm_i_fraction_reduce (z);
4995 return SCM_FRACTION_NUMERATOR (z);
4996 }
4997 else if (SCM_REALP (z))
4998 return scm_exact_to_inexact (scm_numerator (scm_inexact_to_exact (z)));
4999 else
5000 SCM_WTA_DISPATCH_1 (g_numerator, z, SCM_ARG1, s_numerator);
5001}
5002
5003
5004SCM_GPROC (s_denominator, "denominator", 1, 0, 0, scm_denominator, g_denominator);
5005/* "Return the denominator of the number @var{z}."
5006 */
5007SCM
5008scm_denominator (SCM z)
5009{
5010 if (SCM_INUMP (z))
5011 return SCM_MAKINUM (1);
5012 else if (SCM_BIGP (z))
5013 return SCM_MAKINUM (1);
5014 else if (SCM_FRACTIONP (z))
5015 {
5016 scm_i_fraction_reduce (z);
5017 return SCM_FRACTION_DENOMINATOR (z);
5018 }
5019 else if (SCM_REALP (z))
5020 return scm_exact_to_inexact (scm_denominator (scm_inexact_to_exact (z)));
5021 else
5022 SCM_WTA_DISPATCH_1 (g_denominator, z, SCM_ARG1, s_denominator);
5023}
0f2d19dd 5024
9de33deb 5025SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
942e5b91
MG		 5026/* "Return the magnitude of the number @var{z}. This is the same as\n"
5027 * "@code{abs} for real arguments, but also allows complex numbers."
5028 */
0f2d19dd 5029SCM
6e8d25a6 5030scm_magnitude (SCM z)
0f2d19dd 5031{
0aacf84e
MD		 5032 if (SCM_INUMP (z))
5033 {
5034 long int zz = SCM_INUM (z);
5035 if (zz >= 0)
5036 return z;
5037 else if (SCM_POSFIXABLE (-zz))
5038 return SCM_MAKINUM (-zz);
5039 else
5040 return scm_i_long2big (-zz);
5986c47d 5041 }
0aacf84e
MD		 5042 else if (SCM_BIGP (z))
5043 {
5044 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5045 scm_remember_upto_here_1 (z);
5046 if (sgn < 0)
5047 return scm_i_clonebig (z, 0);
5048 else
5049 return z;
5986c47d 5050 }
0aacf84e 5051 else if (SCM_REALP (z))
c2ff8ab0 5052 return scm_make_real (fabs (SCM_REAL_VALUE (z)));
0aacf84e 5053 else if (SCM_COMPLEXP (z))
6efadd7c 5054 return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z)));
f92e85f7
MV		 5055 else if (SCM_FRACTIONP (z))
5056 {
5057 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5058 return z;
5059 return scm_make_ratio (scm_difference (SCM_FRACTION_NUMERATOR (z), SCM_UNDEFINED),
5060 SCM_FRACTION_DENOMINATOR (z));
5061 }
0aacf84e 5062 else
c2ff8ab0 5063 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
0f2d19dd
JB		 5064}
5065
5066
9de33deb 5067SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
942e5b91
MG		 5068/* "Return the angle of the complex number @var{z}."
5069 */
0f2d19dd 5070SCM
6e8d25a6 5071scm_angle (SCM z)
0f2d19dd 5072{
c8ae173e
KR		 5073 /* atan(0,-1) is pi and it'd be possible to have that as a constant like
5074 scm_flo0 to save allocating a new flonum with scm_make_real each time.
5075 But if atan2 follows the floating point rounding mode, then the value
5076 is not a constant. Maybe it'd be close enough though. */
0aacf84e
MD		 5077 if (SCM_INUMP (z))
5078 {
5079 if (SCM_INUM (z) >= 0)
c8ae173e 5080 return scm_flo0;
0aacf84e
MD		 5081 else
5082 return scm_make_real (atan2 (0.0, -1.0));
f872b822 5083 }
0aacf84e
MD		 5084 else if (SCM_BIGP (z))
5085 {
5086 int sgn = mpz_sgn (SCM_I_BIG_MPZ (z));
5087 scm_remember_upto_here_1 (z);
5088 if (sgn < 0)
5089 return scm_make_real (atan2 (0.0, -1.0));
5090 else
c8ae173e 5091 return scm_flo0;
0f2d19dd 5092 }
0aacf84e 5093 else if (SCM_REALP (z))
c8ae173e
KR		 5094 {
5095 if (SCM_REAL_VALUE (z) >= 0)
5096 return scm_flo0;
5097 else
5098 return scm_make_real (atan2 (0.0, -1.0));
5099 }
0aacf84e 5100 else if (SCM_COMPLEXP (z))
f4c627b3 5101 return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z)));
f92e85f7
MV		 5102 else if (SCM_FRACTIONP (z))
5103 {
5104 if (SCM_FALSEP (scm_negative_p (SCM_FRACTION_NUMERATOR (z))))
5105 return scm_flo0;
5106 else return scm_make_real (atan2 (0.0, -1.0));
5107 }
0aacf84e 5108 else
f4c627b3 5109 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
0f2d19dd
JB		 5110}
5111
5112
3c9a524f
DH		 5113SCM_GPROC (s_exact_to_inexact, "exact->inexact", 1, 0, 0, scm_exact_to_inexact, g_exact_to_inexact);
5114/* Convert the number @var{x} to its inexact representation.\n"
5115 */
5116SCM
5117scm_exact_to_inexact (SCM z)
5118{
5119 if (SCM_INUMP (z))
5120 return scm_make_real ((double) SCM_INUM (z));
5121 else if (SCM_BIGP (z))
5122 return scm_make_real (scm_i_big2dbl (z));
f92e85f7
MV		 5123 else if (SCM_FRACTIONP (z))
5124 return scm_make_real (scm_i_fraction2double (z));
3c9a524f
DH		 5125 else if (SCM_INEXACTP (z))
5126 return z;
5127 else
5128 SCM_WTA_DISPATCH_1 (g_exact_to_inexact, z, 1, s_exact_to_inexact);
5129}
5130
5131
a1ec6916 5132SCM_DEFINE (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
1bbd0b84 5133 (SCM z),
1e6808ea 5134 "Return an exact number that is numerically closest to @var{z}.")
1bbd0b84 5135#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 5136{
0aacf84e 5137 if (SCM_INUMP (z))
f872b822 5138 return z;
0aacf84e 5139 else if (SCM_BIGP (z))
f872b822 5140 return z;
0aacf84e
MD		 5141 else if (SCM_REALP (z))
5142 {
f92e85f7
MV		 5143 if (xisinf (SCM_REAL_VALUE (z)) || xisnan (SCM_REAL_VALUE (z)))
5144 SCM_OUT_OF_RANGE (1, z);
2be24db4 5145 else
f92e85f7
MV		 5146 {
5147 mpq_t frac;
5148 SCM q;
5149
5150 mpq_init (frac);
5151 mpq_set_d (frac, SCM_REAL_VALUE (z));
5152 q = scm_make_ratio (scm_i_mpz2num (mpq_numref (frac)),
5153 scm_i_mpz2num (mpq_denref (frac)));
5154
5155 /* When scm_make_ratio throws, we leak the memory allocated
5156 for frac...
5157 */
5158 mpq_clear (frac);
5159 return q;
5160 }
c2ff8ab0 5161 }
f92e85f7
MV		 5162 else if (SCM_FRACTIONP (z))
5163 return z;
0aacf84e 5164 else
c2ff8ab0 5165 SCM_WRONG_TYPE_ARG (1, z);
0f2d19dd 5166}
1bbd0b84 5167#undef FUNC_NAME
0f2d19dd 5168
f92e85f7
MV		 5169SCM_DEFINE (scm_rationalize, "rationalize", 2, 0, 0,
5170 (SCM x, SCM err),
5171 "Return an exact number that is within @var{err} of @var{x}.")
5172#define FUNC_NAME s_scm_rationalize
5173{
5174 if (SCM_INUMP (x))
5175 return x;
5176 else if (SCM_BIGP (x))
5177 return x;
5178 else if ((SCM_REALP (x)) || SCM_FRACTIONP (x))
5179 {
5180 /* Use continued fractions to find closest ratio. All
5181 arithmetic is done with exact numbers.
5182 */
5183
5184 SCM ex = scm_inexact_to_exact (x);
5185 SCM int_part = scm_floor (ex);
5186 SCM tt = SCM_MAKINUM (1);
5187 SCM a1 = SCM_MAKINUM (0), a2 = SCM_MAKINUM (1), a = SCM_MAKINUM (0);
5188 SCM b1 = SCM_MAKINUM (1), b2 = SCM_MAKINUM (0), b = SCM_MAKINUM (0);
5189 SCM rx;
5190 int i = 0;
5191
5192 if (!SCM_FALSEP (scm_num_eq_p (ex, int_part)))
5193 return ex;
5194
5195 ex = scm_difference (ex, int_part); /* x = x-int_part */
5196 rx = scm_divide (ex, SCM_UNDEFINED); /* rx = 1/x */
5197
5198 /* We stop after a million iterations just to be absolutely sure
5199 that we don't go into an infinite loop. The process normally
5200 converges after less than a dozen iterations.
5201 */
5202
5203 err = scm_abs (err);
5204 while (++i < 1000000)
5205 {
5206 a = scm_sum (scm_product (a1, tt), a2); /* a = a1*tt + a2 */
5207 b = scm_sum (scm_product (b1, tt), b2); /* b = b1*tt + b2 */
5208 if (SCM_FALSEP (scm_zero_p (b)) && /* b != 0 */
5209 SCM_FALSEP
5210 (scm_gr_p (scm_abs (scm_difference (ex, scm_divide (a, b))),
5211 err))) /* abs(x-a/b) <= err */
02164269
MV		 5212 {
5213 SCM res = scm_sum (int_part, scm_divide (a, b));
5214 if (SCM_FALSEP (scm_exact_p (x))
5215 || SCM_FALSEP (scm_exact_p (err)))
5216 return scm_exact_to_inexact (res);
5217 else
5218 return res;
5219 }
f92e85f7
MV		 5220 rx = scm_divide (scm_difference (rx, tt), /* rx = 1/(rx - tt) */
5221 SCM_UNDEFINED);
5222 tt = scm_floor (rx); /* tt = floor (rx) */
5223 a2 = a1;
5224 b2 = b1;
5225 a1 = a;
5226 b1 = b;
5227 }
5228 scm_num_overflow (s_scm_rationalize);
5229 }
5230 else
5231 SCM_WRONG_TYPE_ARG (1, x);
5232}
5233#undef FUNC_NAME
5234
87617347 5235/* if you need to change this, change test-num2integral.c as well */
ee33d62a 5236#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5237# ifndef LLONG_MAX
5238# define ULLONG_MAX ((unsigned long long) (-1))
5239# define LLONG_MAX ((long long) (ULLONG_MAX >> 1))
5240# define LLONG_MIN (~LLONG_MAX)
5241# endif
f872b822 5242#endif
0f2d19dd 5243
3d2e8ceb
MV		 5244/* Parameters for creating integer conversion routines.
5245
5246 Define the following preprocessor macros before including
5247 "libguile/num2integral.i.c":
5248
5249 NUM2INTEGRAL - the name of the function for converting from a
ca46fb90
RB		 5250 Scheme object to the integral type. This function will be
5251 defined when including "num2integral.i.c".
3d2e8ceb
MV		 5252
5253 INTEGRAL2NUM - the name of the function for converting from the
ca46fb90 5254 integral type to a Scheme object. This function will be defined.
3d2e8ceb
MV		 5255
5256 INTEGRAL2BIG - the name of an internal function that createas a
ca46fb90
RB		 5257 bignum from the integral type. This function will be defined.
5258 The name should start with "scm_i_".
5259
5260 ITYPE - the name of the integral type.
5261
9dd023e1
MV		 5262 UNSIGNED - Define this to 1 when ITYPE is an unsigned type. Define
5263 it to 0 otherwise.
ca46fb90
RB		 5264
5265 UNSIGNED_ITYPE - the name of the the unsigned variant of the
5266 integral type. If you don't define this, it defaults to
5267 "unsigned ITYPE" for signed types and simply "ITYPE" for unsigned
5268 ones.
5269
5270 SIZEOF_ITYPE - an expression giving the size of the integral type
5271 in bytes. This expression must be computable by the
5272 preprocessor. (SIZEOF_FOO values are calculated by configure.in
5273 for common types).
5274
3d2e8ceb
MV		 5275*/
5276
1be6b49c
ML		 5277#define NUM2INTEGRAL scm_num2short
5278#define INTEGRAL2NUM scm_short2num
5279#define INTEGRAL2BIG scm_i_short2big
ca46fb90 5280#define UNSIGNED 0
1be6b49c 5281#define ITYPE short
3d2e8ceb 5282#define SIZEOF_ITYPE SIZEOF_SHORT
1be6b49c
ML		 5283#include "libguile/num2integral.i.c"
5284
5285#define NUM2INTEGRAL scm_num2ushort
5286#define INTEGRAL2NUM scm_ushort2num
5287#define INTEGRAL2BIG scm_i_ushort2big
ca46fb90 5288#define UNSIGNED 1
1be6b49c 5289#define ITYPE unsigned short
ca46fb90 5290#define SIZEOF_ITYPE SIZEOF_UNSIGNED_SHORT
1be6b49c
ML		 5291#include "libguile/num2integral.i.c"
5292
5293#define NUM2INTEGRAL scm_num2int
5294#define INTEGRAL2NUM scm_int2num
5295#define INTEGRAL2BIG scm_i_int2big
ca46fb90 5296#define UNSIGNED 0
1be6b49c 5297#define ITYPE int
3d2e8ceb 5298#define SIZEOF_ITYPE SIZEOF_INT
1be6b49c
ML		 5299#include "libguile/num2integral.i.c"
5300
5301#define NUM2INTEGRAL scm_num2uint
5302#define INTEGRAL2NUM scm_uint2num
5303#define INTEGRAL2BIG scm_i_uint2big
ca46fb90 5304#define UNSIGNED 1
1be6b49c 5305#define ITYPE unsigned int
ca46fb90 5306#define SIZEOF_ITYPE SIZEOF_UNSIGNED_INT
1be6b49c
ML		 5307#include "libguile/num2integral.i.c"
5308
5309#define NUM2INTEGRAL scm_num2long
5310#define INTEGRAL2NUM scm_long2num
5311#define INTEGRAL2BIG scm_i_long2big
ca46fb90 5312#define UNSIGNED 0
1be6b49c 5313#define ITYPE long
3d2e8ceb 5314#define SIZEOF_ITYPE SIZEOF_LONG
1be6b49c
ML		 5315#include "libguile/num2integral.i.c"
5316
5317#define NUM2INTEGRAL scm_num2ulong
5318#define INTEGRAL2NUM scm_ulong2num
5319#define INTEGRAL2BIG scm_i_ulong2big
ca46fb90 5320#define UNSIGNED 1
1be6b49c 5321#define ITYPE unsigned long
ca46fb90 5322#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG
1be6b49c
ML		 5323#include "libguile/num2integral.i.c"
5324
1be6b49c
ML		 5325#define NUM2INTEGRAL scm_num2ptrdiff
5326#define INTEGRAL2NUM scm_ptrdiff2num
5327#define INTEGRAL2BIG scm_i_ptrdiff2big
ca46fb90 5328#define UNSIGNED 0
ee33d62a 5329#define ITYPE scm_t_ptrdiff
3d2e8ceb 5330#define UNSIGNED_ITYPE size_t
ee33d62a 5331#define SIZEOF_ITYPE SCM_SIZEOF_SCM_T_PTRDIFF
1be6b49c
ML		 5332#include "libguile/num2integral.i.c"
5333
5334#define NUM2INTEGRAL scm_num2size
5335#define INTEGRAL2NUM scm_size2num
5336#define INTEGRAL2BIG scm_i_size2big
ca46fb90 5337#define UNSIGNED 1
1be6b49c 5338#define ITYPE size_t
3d2e8ceb 5339#define SIZEOF_ITYPE SIZEOF_SIZE_T
1be6b49c 5340#include "libguile/num2integral.i.c"
0f2d19dd 5341
ee33d62a 5342#if SCM_SIZEOF_LONG_LONG != 0
1cc91f1b 5343
caf08e65
MV		 5344#ifndef ULONG_LONG_MAX
5345#define ULONG_LONG_MAX (~0ULL)
5346#endif
5347
1be6b49c
ML		 5348#define NUM2INTEGRAL scm_num2long_long
5349#define INTEGRAL2NUM scm_long_long2num
5350#define INTEGRAL2BIG scm_i_long_long2big
ca46fb90 5351#define UNSIGNED 0
1be6b49c 5352#define ITYPE long long
3d2e8ceb 5353#define SIZEOF_ITYPE SIZEOF_LONG_LONG
1be6b49c
ML		 5354#include "libguile/num2integral.i.c"
5355
5356#define NUM2INTEGRAL scm_num2ulong_long
5357#define INTEGRAL2NUM scm_ulong_long2num
5358#define INTEGRAL2BIG scm_i_ulong_long2big
ca46fb90 5359#define UNSIGNED 1
1be6b49c 5360#define ITYPE unsigned long long
ca46fb90 5361#define SIZEOF_ITYPE SIZEOF_UNSIGNED_LONG_LONG
1be6b49c 5362#include "libguile/num2integral.i.c"
0f2d19dd 5363
ee33d62a 5364#endif /* SCM_SIZEOF_LONG_LONG != 0 */
caf08e65 5365
5437598b
MD		 5366#define NUM2FLOAT scm_num2float
5367#define FLOAT2NUM scm_float2num
5368#define FTYPE float
5369#include "libguile/num2float.i.c"
5370
5371#define NUM2FLOAT scm_num2double
5372#define FLOAT2NUM scm_double2num
5373#define FTYPE double
5374#include "libguile/num2float.i.c"
5375
1be6b49c 5376#ifdef GUILE_DEBUG
caf08e65 5377
6063dc1d
SJ		 5378#ifndef SIZE_MAX
5379#define SIZE_MAX ((size_t) (-1))
5380#endif
5381#ifndef PTRDIFF_MIN
5382#define PTRDIFF_MIN \
b4fb7de8
RB		 5383 ((scm_t_ptrdiff) ((scm_t_ptrdiff) 1 \
5384 << ((sizeof (scm_t_ptrdiff) * SCM_CHAR_BIT) - 1)))
6063dc1d
SJ		 5385#endif
5386#ifndef PTRDIFF_MAX
5387#define PTRDIFF_MAX (~ PTRDIFF_MIN)
5388#endif
5389
0aacf84e
MD		 5390#define CHECK(type, v) \
5391 do \
5392 { \
5393 if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \
5394 abort (); \
5395 } \
5396 while (0)
caf08e65 5397
1be6b49c
ML		 5398static void
5399check_sanity ()
5400{
5401 CHECK (short, 0);
5402 CHECK (ushort, 0U);
5403 CHECK (int, 0);
5404 CHECK (uint, 0U);
5405 CHECK (long, 0L);
5406 CHECK (ulong, 0UL);
5407 CHECK (size, 0);
5408 CHECK (ptrdiff, 0);
5409
5410 CHECK (short, -1);
5411 CHECK (int, -1);
5412 CHECK (long, -1L);
5413 CHECK (ptrdiff, -1);
5414
5415 CHECK (short, SHRT_MAX);
5416 CHECK (short, SHRT_MIN);
5417 CHECK (ushort, USHRT_MAX);
5418 CHECK (int, INT_MAX);
5419 CHECK (int, INT_MIN);
5420 CHECK (uint, UINT_MAX);
5421 CHECK (long, LONG_MAX);
5422 CHECK (long, LONG_MIN);
5423 CHECK (ulong, ULONG_MAX);
5424 CHECK (size, SIZE_MAX);
5425 CHECK (ptrdiff, PTRDIFF_MAX);
5426 CHECK (ptrdiff, PTRDIFF_MIN);
0f2d19dd 5427
ee33d62a 5428#if SCM_SIZEOF_LONG_LONG != 0
1be6b49c
ML		 5429 CHECK (long_long, 0LL);
5430 CHECK (ulong_long, 0ULL);
1be6b49c 5431 CHECK (long_long, -1LL);
1be6b49c
ML		 5432 CHECK (long_long, LLONG_MAX);
5433 CHECK (long_long, LLONG_MIN);
5434 CHECK (ulong_long, ULLONG_MAX);
5435#endif
0f2d19dd
JB		 5436}
5437
b10586f0
ML		 5438#undef CHECK
5439
5440#define CHECK \
5441 scm_internal_catch (SCM_BOOL_T, check_body, &data, check_handler, &data); \
5442 if (!SCM_FALSEP (data)) abort();
5443
5444static SCM
5445check_body (void *data)
5446{
5447 SCM num = *(SCM *) data;
5448 scm_num2ulong (num, 1, NULL);
5449
5450 return SCM_UNSPECIFIED;
5451}
5452
5453static SCM
5454check_handler (void *data, SCM tag, SCM throw_args)
5455{
5456 SCM *num = (SCM *) data;
5457 *num = SCM_BOOL_F;
5458
5459 return SCM_UNSPECIFIED;
5460}
5461
5462SCM_DEFINE (scm_sys_check_number_conversions, "%check-number-conversions", 0, 0, 0,
b4e15479 5463 (void),
b10586f0
ML		 5464 "Number conversion sanity checking.")
5465#define FUNC_NAME s_scm_sys_check_number_conversions
5466{
5467 SCM data = SCM_MAKINUM (-1);
5468 CHECK;
5469 data = scm_int2num (INT_MIN);
5470 CHECK;
5471 data = scm_ulong2num (ULONG_MAX);
5472 data = scm_difference (SCM_INUM0, data);
5473 CHECK;
5474 data = scm_ulong2num (ULONG_MAX);
5475 data = scm_sum (SCM_MAKINUM (1), data); data = scm_difference (SCM_INUM0, data);
5476 CHECK;
5477 data = scm_int2num (-10000); data = scm_product (data, data); data = scm_product (data, data);
5478 CHECK;
5479
5480 return SCM_UNSPECIFIED;
5481}
5482#undef FUNC_NAME
5483
1be6b49c 5484#endif
0f2d19dd 5485
0f2d19dd
JB		 5486void
5487scm_init_numbers ()
0f2d19dd 5488{
1be6b49c 5489 abs_most_negative_fixnum = scm_i_long2big (- SCM_MOST_NEGATIVE_FIXNUM);
ac0c002c
DH		 5490 scm_permanent_object (abs_most_negative_fixnum);
5491
713a4259
KR		 5492 mpz_init_set_si (z_negative_one, -1);
5493
a261c0e9
DH		 5494 /* It may be possible to tune the performance of some algorithms by using
5495 * the following constants to avoid the creation of bignums. Please, before
5496 * using these values, remember the two rules of program optimization:
5497 * 1st Rule: Don't do it. 2nd Rule (experts only): Don't do it yet. */
86d31dfe
MV		 5498 scm_c_define ("most-positive-fixnum",
5499 SCM_MAKINUM (SCM_MOST_POSITIVE_FIXNUM));
5500 scm_c_define ("most-negative-fixnum",
5501 SCM_MAKINUM (SCM_MOST_NEGATIVE_FIXNUM));
a261c0e9 5502
f3ae5d60
MD		 5503 scm_add_feature ("complex");
5504 scm_add_feature ("inexact");
5986c47d 5505 scm_flo0 = scm_make_real (0.0);
f872b822 5506#ifdef DBL_DIG
0f2d19dd 5507 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 5508#else
0f2d19dd
JB		 5509 { /* determine floating point precision */
5510 double f = 0.1;
f872b822 5511 double fsum = 1.0 + f;
0aacf84e
MD		 5512 while (fsum != 1.0)
5513 {
5514 if (++scm_dblprec > 20)
5515 fsum = 1.0;
5516 else
5517 {
5518 f /= 10.0;
5519 fsum = f + 1.0;
5520 }
f872b822
MD		 5521 }
5522 scm_dblprec = scm_dblprec - 1;
0f2d19dd 5523 }
f872b822 5524#endif /* DBL_DIG */
1be6b49c
ML		 5525
5526#ifdef GUILE_DEBUG
5527 check_sanity ();
5528#endif
f92e85f7
MV		 5529
5530 exactly_one_half = scm_permanent_object (scm_divide (SCM_MAKINUM (1),
5531 SCM_MAKINUM (2)));
a0599745 5532#include "libguile/numbers.x"
0f2d19dd 5533}
89e00824
ML		 5534
5535/*
5536 Local Variables:
5537 c-file-style: "gnu"
5538 End:
5539*/
Unnamed repository; edit this file 'description' to name the repository.