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