HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* Makefile.am, doc.scm: Added doc.scm.
[bpt/guile.git] / libguile / numbers.c
CommitLineData
b4a204af 1/* Copyright (C) 1995,1996,1997,1998, 1999 Free Software Foundation, Inc.
f872b822 2
0f2d19dd
JB		 3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
1bbd0b84
GB		 41
42/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
43 gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
44
0f2d19dd
JB		 45\f
46
47#include <stdio.h>
48#include <math.h>
49#include "_scm.h"
20e6290e
JB		 50#include "genio.h"
51#include "unif.h"
dd856e23 52#include "feature.h"
23a62151 53#include "smob.h"
0f2d19dd 54
1bbd0b84 55#include "scm_validate.h"
20e6290e 56#include "numbers.h"
0f2d19dd
JB		 57\f
58#define DIGITS '0':case '1':case '2':case '3':case '4':\
59 case '5':case '6':case '7':case '8':case '9'
60
61
62/* IS_INF tests its floating point number for infiniteness
63 */
64#ifndef IS_INF
f872b822 65#define IS_INF(x) ((x) == (x) / 2)
0f2d19dd
JB		 66#endif
67
e6f3ef58
MD		 68/* Return true if X is not infinite and is not a NaN
69 */
70#ifndef isfinite
71#define isfinite(x) (!IS_INF (x) && (x) == (x))
72#endif
73
0f2d19dd
JB		 74/* MAXEXP is the maximum double precision expontent
75 * FLTMAX is less than or scm_equal the largest single precision float
76 */
77
78#ifdef SCM_FLOATS
f872b822
MD		 79#ifdef STDC_HEADERS
80#ifndef GO32
81#include <float.h>
82#endif /* ndef GO32 */
83#endif /* def STDC_HEADERS */
84#ifdef DBL_MAX_10_EXP
85#define MAXEXP DBL_MAX_10_EXP
86#else
87#define MAXEXP 308 /* IEEE doubles */
88#endif /* def DBL_MAX_10_EXP */
89#ifdef FLT_MAX
90#define FLTMAX FLT_MAX
91#else
92#define FLTMAX 1e+23
93#endif /* def FLT_MAX */
0f2d19dd 94#endif /* def SCM_FLOATS */
0f2d19dd
JB		 95\f
96
f872b822 97
1bbd0b84
GB		 98GUILE_PROC (scm_exact_p, "exact?", 1, 0, 0,
99 (SCM x),
100"")
101#define FUNC_NAME s_scm_exact_p
0f2d19dd 102{
f872b822
MD		 103 if (SCM_INUMP (x))
104 return SCM_BOOL_T;
0f2d19dd 105#ifdef SCM_BIGDIG
f872b822
MD		 106 if (SCM_NIMP (x) && SCM_BIGP (x))
107 return SCM_BOOL_T;
0f2d19dd
JB		 108#endif
109 return SCM_BOOL_F;
110}
1bbd0b84 111#undef FUNC_NAME
0f2d19dd 112
1bbd0b84
GB		 113GUILE_PROC (scm_odd_p, "odd?", 1, 0, 0,
114 (SCM n),
115"")
116#define FUNC_NAME s_scm_odd_p
0f2d19dd
JB		 117{
118#ifdef SCM_BIGDIG
f872b822
MD		 119 if (SCM_NINUMP (n))
120 {
1bbd0b84
GB		 121 SCM_VALIDATE_BIGINT(1,n);
122 return SCM_BOOL(1 & SCM_BDIGITS (n)[0]);
f872b822 123 }
0f2d19dd 124#else
1bbd0b84 125 SCM_VALIDATE_INT(1,n);
0f2d19dd 126#endif
1bbd0b84 127 return SCM_BOOL(4 & (int) n);
0f2d19dd 128}
1bbd0b84 129#undef FUNC_NAME
0f2d19dd 130
1bbd0b84
GB		 131GUILE_PROC (scm_even_p, "even?", 1, 0, 0,
132 (SCM n),
133"")
134#define FUNC_NAME s_scm_even_p
0f2d19dd
JB		 135{
136#ifdef SCM_BIGDIG
f872b822
MD		 137 if (SCM_NINUMP (n))
138 {
1bbd0b84
GB		 139 SCM_VALIDATE_BIGINT(1,n);
140 return SCM_NEGATE_BOOL(1 & SCM_BDIGITS (n)[0]);
f872b822 141 }
0f2d19dd 142#else
1bbd0b84 143 SCM_VALIDATE_INT(1,n);
0f2d19dd 144#endif
1bbd0b84 145 return SCM_NEGATE_BOOL(4 & (int) n);
0f2d19dd 146}
1bbd0b84 147#undef FUNC_NAME
0f2d19dd 148
9de33deb 149SCM_GPROC (s_abs, "abs", 1, 0, 0, scm_abs, g_abs);
1cc91f1b 150
0f2d19dd 151SCM
6e8d25a6 152scm_abs (SCM x)
0f2d19dd
JB		 153{
154#ifdef SCM_BIGDIG
f872b822
MD		 155 if (SCM_NINUMP (x))
156 {
9de33deb 157 SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x), g_abs, x, SCM_ARG1, s_abs);
f872b822
MD		 158 if (SCM_TYP16 (x) == scm_tc16_bigpos)
159 return x;
160 return scm_copybig (x, 0);
161 }
0f2d19dd 162#else
9de33deb 163 SCM_GASSERT1 (SCM_INUMP (x), g_abs, x, SCM_ARG1, s_abs);
0f2d19dd 164#endif
f872b822
MD		 165 if (SCM_INUM (x) >= 0)
166 return x;
167 x = - SCM_INUM (x);
168 if (!SCM_POSFIXABLE (x))
0f2d19dd 169#ifdef SCM_BIGDIG
f872b822 170 return scm_long2big (x);
0f2d19dd 171#else
52859adf 172 scm_num_overflow (s_abs);
0f2d19dd 173#endif
f872b822 174 return SCM_MAKINUM (x);
0f2d19dd
JB		 175}
176
9de33deb 177SCM_GPROC (s_quotient, "quotient", 2, 0, 0, scm_quotient, g_quotient);
1cc91f1b 178
0f2d19dd 179SCM
6e8d25a6 180scm_quotient (SCM x, SCM y)
0f2d19dd
JB		 181{
182 register long z;
183#ifdef SCM_BIGDIG
f872b822
MD		 184 if (SCM_NINUMP (x))
185 {
186 long w;
9de33deb
MD		 187 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
188 g_quotient, x, y, SCM_ARG1, s_quotient);
f872b822
MD		 189 if (SCM_NINUMP (y))
190 {
191 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
192 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
193 SCM_BDIGITS (y), SCM_NUMDIGS (y),
194 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 2);
195 }
196 z = SCM_INUM (y);
197 SCM_ASRTGO (z, ov);
198 if (1 == z)
199 return x;
200 if (z < 0)
201 z = -z;
202 if (z < SCM_BIGRAD)
203 {
204 w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
205 scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w), (SCM_BIGDIG) z);
206 return scm_normbig (w);
207 }
0f2d19dd 208#ifndef SCM_DIGSTOOBIG
f872b822
MD		 209 w = scm_pseudolong (z);
210 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
211 (SCM_BIGDIG *) & w, SCM_DIGSPERLONG,
212 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
0f2d19dd 213#else
f872b822
MD		 214 {
215 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
216 scm_longdigs (z, zdigs);
217 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
218 zdigs, SCM_DIGSPERLONG,
219 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 2);
220 }
221#endif
0f2d19dd 222 }
f872b822
MD		 223 if (SCM_NINUMP (y))
224 {
f872b822
MD		 225 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
226 {
227 bady:
9de33deb 228 SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient);
f872b822 229 }
f872b822
MD		 230 return SCM_INUM0;
231 }
0f2d19dd 232#else
9de33deb
MD		 233 SCM_GASSERT2 (SCM_INUMP (x), g_quotient, x, y, SCM_ARG1, s_quotient);
234 SCM_GASSERT2 (SCM_INUMP (y), g_quotient, x, y, SCM_ARG2, s_quotient);
0f2d19dd 235#endif
f872b822
MD		 236 if ((z = SCM_INUM (y)) == 0)
237 {
238 ov:
239 scm_num_overflow (s_quotient);
240 }
241 z = SCM_INUM (x) / z;
0f2d19dd
JB		 242#ifdef BADIVSGNS
243 {
f872b822
MD		 244#if (__TURBOC__ == 1)
245 long t = ((y < 0) ? -SCM_INUM (x) : SCM_INUM (x)) % SCM_INUM (y);
0f2d19dd 246#else
f872b822 247 long t = SCM_INUM (x) % SCM_INUM (y);
0f2d19dd 248#endif
f872b822 249 if (t == 0);
0f2d19dd 250 else if (t < 0)
f872b822
MD		 251 if (x < 0);
252 else
253 z--;
254 else if (x < 0)
255 z++;
0f2d19dd
JB		 256 }
257#endif
f872b822 258 if (!SCM_FIXABLE (z))
0f2d19dd 259#ifdef SCM_BIGDIG
f872b822 260 return scm_long2big (z);
0f2d19dd 261#else
52859adf 262 scm_num_overflow (s_quotient);
0f2d19dd 263#endif
f872b822 264 return SCM_MAKINUM (z);
0f2d19dd
JB		 265}
266
9de33deb 267SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder);
1cc91f1b 268
0f2d19dd 269SCM
6e8d25a6 270scm_remainder (SCM x, SCM y)
0f2d19dd
JB		 271{
272 register long z;
273#ifdef SCM_BIGDIG
f872b822
MD		 274 if (SCM_NINUMP (x))
275 {
9de33deb
MD		 276 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
277 g_remainder, x, y, SCM_ARG1, s_remainder);
f872b822
MD		 278 if (SCM_NINUMP (y))
279 {
280 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
281 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
282 SCM_BDIGITS (y), SCM_NUMDIGS (y),
283 SCM_BIGSIGN (x), 0);
284 }
285 if (!(z = SCM_INUM (y)))
286 goto ov;
287 return scm_divbigint (x, z, SCM_BIGSIGN (x), 0);
288 }
289 if (SCM_NINUMP (y))
290 {
f872b822
MD		 291 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
292 {
293 bady:
9de33deb 294 SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder);
f872b822 295 }
f872b822 296 return x;
0f2d19dd 297 }
0f2d19dd 298#else
9de33deb
MD		 299 SCM_GASSERT2 (SCM_INUMP (x), g_remainder, x, y, SCM_ARG1, s_remainder);
300 SCM_GASSERT2 (SCM_INUMP (y), g_remainder, x, y, SCM_ARG2, s_remainder);
0f2d19dd 301#endif
f872b822
MD		 302 if (!(z = SCM_INUM (y)))
303 {
304 ov:
305 scm_num_overflow (s_remainder);
306 }
307#if (__TURBOC__ == 1)
308 if (z < 0)
309 z = -z;
0f2d19dd 310#endif
f872b822 311 z = SCM_INUM (x) % z;
0f2d19dd 312#ifdef BADIVSGNS
f872b822 313 if (!z);
0f2d19dd 314 else if (z < 0)
f872b822
MD		 315 if (x < 0);
316 else
317 z += SCM_INUM (y);
318 else if (x < 0)
319 z -= SCM_INUM (y);
0f2d19dd 320#endif
f872b822 321 return SCM_MAKINUM (z);
0f2d19dd
JB		 322}
323
9de33deb 324SCM_GPROC (s_modulo, "modulo", 2, 0, 0, scm_modulo, g_modulo);
1cc91f1b 325
0f2d19dd 326SCM
6e8d25a6 327scm_modulo (SCM x, SCM y)
0f2d19dd
JB		 328{
329 register long yy, z;
330#ifdef SCM_BIGDIG
f872b822
MD		 331 if (SCM_NINUMP (x))
332 {
9de33deb
MD		 333 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
334 g_modulo, x, y, SCM_ARG1, s_modulo);
f872b822
MD		 335 if (SCM_NINUMP (y))
336 {
337 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
338 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
339 SCM_BDIGITS (y), SCM_NUMDIGS (y),
340 SCM_BIGSIGN (y),
341 (SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y)) ? 1 : 0);
342 }
343 if (!(z = SCM_INUM (y)))
344 goto ov;
345 return scm_divbigint (x, z, y < 0,
346 (SCM_BIGSIGN (x) ? (y > 0) : (y < 0)) ? 1 : 0);
347 }
348 if (SCM_NINUMP (y))
349 {
f872b822
MD		 350 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
351 {
352 bady:
9de33deb 353 SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo);
f872b822 354 }
f872b822 355 return (SCM_BIGSIGN (y) ? (x > 0) : (x < 0)) ? scm_sum (x, y) : x;
0f2d19dd 356 }
0f2d19dd 357#else
9de33deb
MD		 358 SCM_GASSERT1 (SCM_INUMP (x), g_modulo, x, y, SCM_ARG1, s_modulo);
359 SCM_GASSERT2 (SCM_INUMP (y), g_modulo, x, y, SCM_ARG2, s_modulo);
0f2d19dd 360#endif
f872b822
MD		 361 if (!(yy = SCM_INUM (y)))
362 {
363 ov:
364 scm_num_overflow (s_modulo);
365 }
0f2d19dd 366#if (__TURBOC__==1)
f872b822
MD		 367 z = SCM_INUM (x);
368 z = ((yy < 0) ? -z : z) % yy;
0f2d19dd 369#else
f872b822 370 z = SCM_INUM (x) % yy;
0f2d19dd 371#endif
f872b822 372 return SCM_MAKINUM (((yy < 0) ? (z > 0) : (z < 0)) ? z + yy : z);
0f2d19dd
JB		 373}
374
9de33deb 375SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd);
1cc91f1b 376
0f2d19dd 377SCM
6e8d25a6 378scm_gcd (SCM x, SCM y)
0f2d19dd
JB		 379{
380 register long u, v, k, t;
f872b822
MD		 381 if (SCM_UNBNDP (y))
382 return SCM_UNBNDP (x) ? SCM_INUM0 : x;
0f2d19dd
JB		 383 tailrec:
384#ifdef SCM_BIGDIG
f872b822
MD		 385 if (SCM_NINUMP (x))
386 {
387 big_gcd:
9de33deb
MD		 388 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
389 g_gcd, x, y, SCM_ARG1, s_gcd);
f872b822
MD		 390 if (SCM_BIGSIGN (x))
391 x = scm_copybig (x, 0);
392 newy:
393 if (SCM_NINUMP (y))
394 {
9de33deb
MD		 395 SCM_GASSERT2 (SCM_NIMP (y) && SCM_BIGP (y),
396 g_gcd, x, y, SCM_ARGn, s_gcd);
f872b822
MD		 397 if (SCM_BIGSIGN (y))
398 y = scm_copybig (y, 0);
399 switch (scm_bigcomp (x, y))
400 {
401 case -1:
402 swaprec:
403 t = scm_remainder (x, y);
404 x = y;
405 y = t;
406 goto tailrec;
407 case 0:
408 return x;
409 case 1:
410 y = scm_remainder (y, x);
411 goto newy;
412 }
413 /* instead of the switch, we could just
414 return scm_gcd (y, scm_modulo (x, y)); */
415 }
416 if (SCM_INUM0 == y)
417 return x;
418 goto swaprec;
0f2d19dd 419 }
f872b822
MD		 420 if (SCM_NINUMP (y))
421 {
422 t = x;
423 x = y;
424 y = t;
425 goto big_gcd;
426 }
427#else
9de33deb
MD		 428 SCM_GASSERT2 (SCM_INUMP (x), g_gcd, x, y, SCM_ARG1, s_gcd);
429 SCM_GASSERT2 (SCM_INUMP (y), g_gcd, x, y, SCM_ARGn, s_gcd);
f872b822
MD		 430#endif
431 u = SCM_INUM (x);
432 if (u < 0)
433 u = -u;
434 v = SCM_INUM (y);
435 if (v < 0)
436 v = -v;
437 else if (0 == v)
438 goto getout;
439 if (0 == u)
440 {
441 u = v;
442 goto getout;
443 }
444 for (k = 1; !(1 & ((int) u | (int) v)); k <<= 1, u >>= 1, v >>= 1);
445 if (1 & (int) u)
446 t = -v;
447 else
448 {
449 t = u;
450 b3:
451 t = SCM_SRS (t, 1);
452 }
453 if (!(1 & (int) t))
454 goto b3;
455 if (t > 0)
456 u = t;
457 else
458 v = -t;
459 if ((t = u - v))
460 goto b3;
461 u = u * k;
0f2d19dd 462 getout:
f872b822 463 if (!SCM_POSFIXABLE (u))
0f2d19dd 464#ifdef SCM_BIGDIG
f872b822 465 return scm_long2big (u);
0f2d19dd 466#else
52859adf 467 scm_num_overflow (s_gcd);
0f2d19dd 468#endif
f872b822 469 return SCM_MAKINUM (u);
0f2d19dd
JB		 470}
471
9de33deb 472SCM_GPROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm, g_lcm);
1cc91f1b 473
0f2d19dd 474SCM
6e8d25a6 475scm_lcm (SCM n1, SCM n2)
0f2d19dd
JB		 476{
477 SCM d;
02a3305a 478#ifndef SCM_BIGDIG
87fbf1be
MD		 479 SCM_GASSERT2 (SCM_INUMP (n1) || SCM_UNBNDP (n1),
480 g_lcm, n1, n2, SCM_ARG1, s_lcm);
02a3305a
MD		 481 SCM_GASSERT2 (SCM_INUMP (n2) || SCM_UNBNDP (n2),
482 g_lcm, n1, n2, SCM_ARGn, s_lcm);
9de33deb 483#else
87fbf1be
MD		 484 SCM_GASSERT2 (SCM_INUMP (n1)
485 || SCM_UNBNDP (n1)
486 || (SCM_NIMP (n1) && SCM_BIGP (n1)),
9de33deb 487 g_lcm, n1, n2, SCM_ARG1, s_lcm);
02a3305a
MD		 488 SCM_GASSERT2 (SCM_INUMP (n2)
489 || SCM_UNBNDP (n2)
490 || (SCM_NIMP (n2) && SCM_BIGP (n2)),
9de33deb
MD		 491 g_lcm, n1, n2, SCM_ARGn, s_lcm);
492#endif
f872b822
MD		 493 if (SCM_UNBNDP (n2))
494 {
495 n2 = SCM_MAKINUM (1L);
496 if (SCM_UNBNDP (n1))
497 return n2;
498 }
9de33deb 499
f872b822
MD		 500 d = scm_gcd (n1, n2);
501 if (SCM_INUM0 == d)
502 return d;
503 return scm_abs (scm_product (n1, scm_quotient (n2, d)));
0f2d19dd
JB		 504}
505
506#ifndef SCM_BIGDIG
f872b822
MD		 507#ifndef SCM_FLOATS
508#define scm_long2num SCM_MAKINUM
509#endif
0f2d19dd
JB		 510#endif
511
512#ifndef scm_long2num
1bbd0b84
GB		 513GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr,
514 (SCM n1, SCM n2),
515"")
516#define FUNC_NAME s_scm_logand
0f2d19dd 517{
1bbd0b84 518 int i1, i2;
f872b822 519 if (SCM_UNBNDP (n2))
d28da049
MD		 520 {
521 if (SCM_UNBNDP (n1))
522 return SCM_MAKINUM (-1);
523 return n1;
524 }
1bbd0b84
GB		 525 SCM_VALIDATE_INT_COPY(1,n1,i1);
526 SCM_VALIDATE_INT_COPY(2,n2,i2);
527 return scm_ulong2num (i1 & i2);
0f2d19dd 528}
1bbd0b84 529#undef FUNC_NAME
0f2d19dd 530
1bbd0b84
GB		 531GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr,
532 (SCM n1, SCM n2),
533"")
534#define FUNC_NAME s_scm_logior
0f2d19dd 535{
1bbd0b84 536 int i1, i2;
f872b822 537 if (SCM_UNBNDP (n2))
d28da049
MD		 538 {
539 if (SCM_UNBNDP (n1))
540 return SCM_INUM0;
541 return n1;
542 }
1bbd0b84
GB		 543 SCM_VALIDATE_INT_COPY(1,n1,i1);
544 SCM_VALIDATE_INT_COPY(2,n2,i2);
545 return scm_ulong2num (i1 | i2);
0f2d19dd 546}
1bbd0b84 547#undef FUNC_NAME
0f2d19dd 548
1bbd0b84
GB		 549GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr,
550 (SCM n1, SCM n2),
551"")
552#define FUNC_NAME s_scm_logxor
0f2d19dd 553{
1bbd0b84 554 int i1, i2;
f872b822 555 if (SCM_UNBNDP (n2))
d28da049
MD		 556 {
557 if (SCM_UNBNDP (n1))
558 return SCM_INUM0;
559 return n1;
560 }
1bbd0b84
GB		 561 SCM_VALIDATE_INT_COPY(1,n1,i1);
562 SCM_VALIDATE_INT_COPY(2,n2,i2);
563 return scm_ulong2num (i1 ^ i2);
0f2d19dd 564}
1bbd0b84 565#undef FUNC_NAME
0f2d19dd 566
1bbd0b84
GB		 567GUILE_PROC (scm_logtest, "logtest", 2, 0, 0,
568 (SCM n1, SCM n2),
569"")
570#define FUNC_NAME s_scm_logtest
0f2d19dd 571{
1bbd0b84
GB		 572 int i1, i2;
573 SCM_VALIDATE_INT_COPY(1,n1,i1);
574 SCM_VALIDATE_INT_COPY(2,n2,i2);
575 return SCM_BOOL(i1 & i2);
0f2d19dd 576}
1bbd0b84 577#undef FUNC_NAME
0f2d19dd
JB		 578
579
1bbd0b84
GB		 580GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0,
581 (SCM n1, SCM n2),
582"")
583#define FUNC_NAME s_scm_logbit_p
0f2d19dd 584{
1bbd0b84
GB		 585 int i1, i2;
586 SCM_VALIDATE_INT_COPY(1,n1,i1);
587 SCM_VALIDATE_INT_COPY(2,n2,i2);
588 return SCM_BOOL((1 << i1) & i2);
0f2d19dd 589}
1bbd0b84 590#undef FUNC_NAME
0f2d19dd
JB		 591
592#else
593
1bbd0b84
GB		 594GUILE_PROC1 (scm_logand, "logand", scm_tc7_asubr,
595 (SCM n1, SCM n2),
596"")
597#define FUNC_NAME s_scm_logand
0f2d19dd 598{
1bbd0b84 599 int i1, i2;
f872b822 600 if (SCM_UNBNDP (n2))
d28da049
MD		 601 {
602 if (SCM_UNBNDP (n1))
603 return SCM_MAKINUM (-1);
604 return n1;
605 }
1bbd0b84
GB		 606 SCM_VALIDATE_INT_COPY(1,n1,i1);
607 SCM_VALIDATE_INT_COPY(2,n2,i2);
608 return SCM_MAKINUM (i1 & i2);
0f2d19dd 609}
1bbd0b84 610#undef FUNC_NAME
0f2d19dd 611
1bbd0b84
GB		 612GUILE_PROC1 (scm_logior, "logior", scm_tc7_asubr,
613 (SCM n1, SCM n2),
614"")
615#define FUNC_NAME s_scm_logior
0f2d19dd 616{
1bbd0b84 617 int i1, i2;
f872b822 618 if (SCM_UNBNDP (n2))
d28da049
MD		 619 {
620 if (SCM_UNBNDP (n1))
621 return SCM_INUM0;
622 return n1;
623 }
1bbd0b84
GB		 624 SCM_VALIDATE_INT_COPY(1,n1,i1);
625 SCM_VALIDATE_INT_COPY(2,n2,i2);
626 return SCM_MAKINUM (i1 | i2);
0f2d19dd 627}
1bbd0b84 628#undef FUNC_NAME
0f2d19dd 629
1bbd0b84
GB		 630GUILE_PROC1 (scm_logxor, "logxor", scm_tc7_asubr,
631 (SCM n1, SCM n2),
632"")
633#define FUNC_NAME s_scm_logxor
0f2d19dd 634{
1bbd0b84 635 int i1, i2;
f872b822 636 if (SCM_UNBNDP (n2))
d28da049
MD		 637 {
638 if (SCM_UNBNDP (n1))
639 return SCM_INUM0;
640 return n1;
641 }
1bbd0b84
GB		 642 SCM_VALIDATE_INT_COPY(1,n1,i1);
643 SCM_VALIDATE_INT_COPY(2,n2,i2);
644 return SCM_MAKINUM (i1 ^ i2);
0f2d19dd 645}
1bbd0b84 646#undef FUNC_NAME
0f2d19dd 647
1bbd0b84
GB		 648GUILE_PROC (scm_logtest, "logtest", 2, 0, 0,
649 (SCM n1, SCM n2),
650"")
651#define FUNC_NAME s_scm_logtest
0f2d19dd 652{
1bbd0b84
GB		 653 int i1, i2;
654 SCM_VALIDATE_INT_COPY(1,n1,i1);
655 SCM_VALIDATE_INT_COPY(2,n2,i2);
656 return SCM_BOOL(i1 & i2);
0f2d19dd 657}
1bbd0b84 658#undef FUNC_NAME
0f2d19dd 659
1bbd0b84
GB		 660GUILE_PROC (scm_logbit_p, "logbit?", 2, 0, 0,
661 (SCM n1, SCM n2),
662"")
663#define FUNC_NAME s_scm_logbit_p
0f2d19dd 664{
1bbd0b84
GB		 665 int i1, i2;
666 SCM_VALIDATE_INT_MIN_COPY(1,n1,0,i1);
667 SCM_VALIDATE_INT_COPY(2,n2,i2);
668 return SCM_BOOL((1 << i1) & i2);
0f2d19dd 669}
1bbd0b84 670#undef FUNC_NAME
0f2d19dd
JB		 671#endif
672
1bbd0b84
GB		 673GUILE_PROC (scm_lognot, "lognot", 1, 0, 0,
674 (SCM n),
675"")
676#define FUNC_NAME s_scm_lognot
0f2d19dd 677{
1bbd0b84 678 SCM_VALIDATE_INT(1,n);
f872b822 679 return scm_difference (SCM_MAKINUM (-1L), n);
0f2d19dd 680}
1bbd0b84 681#undef FUNC_NAME
0f2d19dd 682
1bbd0b84
GB		 683GUILE_PROC (scm_integer_expt, "integer-expt", 2, 0, 0,
684 (SCM z1, SCM z2),
685"")
686#define FUNC_NAME s_scm_integer_expt
0f2d19dd 687{
f872b822 688 SCM acc = SCM_MAKINUM (1L);
1bbd0b84 689 int i2;
0f2d19dd 690#ifdef SCM_BIGDIG
f872b822
MD		 691 if (SCM_INUM0 == z1 || acc == z1)
692 return z1;
693 else if (SCM_MAKINUM (-1L) == z1)
694 return SCM_BOOL_F == scm_even_p (z2) ? z1 : acc;
0f2d19dd 695#endif
1bbd0b84
GB		 696 SCM_VALIDATE_INT_COPY(2,z2,i2);
697 if (i2 < 0)
f872b822 698 {
1bbd0b84 699 i2 = -i2;
f872b822
MD		 700 z1 = scm_divide (z1, SCM_UNDEFINED);
701 }
702 while (1)
703 {
1bbd0b84 704 if (0 == i2)
f872b822 705 return acc;
1bbd0b84 706 if (1 == i2)
f872b822 707 return scm_product (acc, z1);
1bbd0b84 708 if (i2 & 1)
f872b822
MD		 709 acc = scm_product (acc, z1);
710 z1 = scm_product (z1, z1);
1bbd0b84 711 i2 >>= 1;
f872b822 712 }
0f2d19dd 713}
1bbd0b84 714#undef FUNC_NAME
0f2d19dd 715
1bbd0b84
GB		 716GUILE_PROC (scm_ash, "ash", 2, 0, 0,
717 (SCM n, SCM cnt),
718"")
719#define FUNC_NAME s_scm_ash
0f2d19dd 720{
1bbd0b84 721 /* GJB:FIXME:: what is going on here? */
f872b822 722 SCM res = SCM_INUM (n);
1bbd0b84 723 SCM_VALIDATE_INT(2,cnt);
0f2d19dd 724#ifdef SCM_BIGDIG
f872b822
MD		 725 if (cnt < 0)
726 {
727 res = scm_integer_expt (SCM_MAKINUM (2), SCM_MAKINUM (-SCM_INUM (cnt)));
728 if (SCM_NFALSEP (scm_negative_p (n)))
729 return scm_sum (SCM_MAKINUM (-1L),
730 scm_quotient (scm_sum (SCM_MAKINUM (1L), n), res));
731 else
732 return scm_quotient (n, res);
733 }
734 else
735 return scm_product (n, scm_integer_expt (SCM_MAKINUM (2), cnt));
0f2d19dd 736#else
1bbd0b84 737 SCM_VALIDATE_INT(1,n)
f872b822
MD		 738 cnt = SCM_INUM (cnt);
739 if (cnt < 0)
740 return SCM_MAKINUM (SCM_SRS (res, -cnt));
741 res = SCM_MAKINUM (res << cnt);
742 if (SCM_INUM (res) >> cnt != SCM_INUM (n))
1bbd0b84 743 scm_num_overflow (FUNC_NAME);
0f2d19dd
JB		 744 return res;
745#endif
746}
1bbd0b84 747#undef FUNC_NAME
0f2d19dd 748
1bbd0b84
GB		 749/* GJB:FIXME: do not use SCMs as integers! */
750GUILE_PROC (scm_bit_extract, "bit-extract", 3, 0, 0,
751 (SCM n, SCM start, SCM end),
752"")
753#define FUNC_NAME s_scm_bit_extract
0f2d19dd 754{
1bbd0b84
GB		 755 SCM_VALIDATE_INT(1,n);
756 SCM_VALIDATE_INT_MIN(2,start,0);
757 SCM_VALIDATE_INT_MIN(3,end,0);
f872b822
MD		 758 start = SCM_INUM (start);
759 end = SCM_INUM (end);
1bbd0b84 760 SCM_ASSERT (end >= start, SCM_MAKINUM (end), SCM_OUTOFRANGE, FUNC_NAME);
0f2d19dd 761#ifdef SCM_BIGDIG
f872b822 762 if (SCM_NINUMP (n))
0f2d19dd 763 return
f872b822
MD		 764 scm_logand (scm_difference (scm_integer_expt (SCM_MAKINUM (2),
765 SCM_MAKINUM (end - start)),
766 SCM_MAKINUM (1L)),
767 scm_ash (n, SCM_MAKINUM (-start)));
0f2d19dd 768#else
1bbd0b84 769 SCM_VALIDATE_INT(1,n);
0f2d19dd 770#endif
f872b822 771 return SCM_MAKINUM ((SCM_INUM (n) >> start) & ((1L << (end - start)) - 1));
0f2d19dd 772}
1bbd0b84 773#undef FUNC_NAME
0f2d19dd 774
e4755e5c
JB		 775static const char scm_logtab[] = {
776 0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4
777};
1cc91f1b 778
1bbd0b84
GB		 779GUILE_PROC (scm_logcount, "logcount", 1, 0, 0,
780 (SCM n),
781"")
782#define FUNC_NAME s_scm_logcount
0f2d19dd
JB		 783{
784 register unsigned long c = 0;
785 register long nn;
786#ifdef SCM_BIGDIG
f872b822
MD		 787 if (SCM_NINUMP (n))
788 {
789 scm_sizet i;
790 SCM_BIGDIG *ds, d;
1bbd0b84 791 SCM_VALIDATE_BIGINT(1,n);
f872b822
MD		 792 if (SCM_BIGSIGN (n))
793 return scm_logcount (scm_difference (SCM_MAKINUM (-1L), n));
794 ds = SCM_BDIGITS (n);
795 for (i = SCM_NUMDIGS (n); i--;)
796 for (d = ds[i]; d; d >>= 4)
797 c += scm_logtab[15 & d];
798 return SCM_MAKINUM (c);
799 }
0f2d19dd 800#else
1bbd0b84 801 SCM_VALIDATE_INT(1,n);
0f2d19dd 802#endif
f872b822
MD		 803 if ((nn = SCM_INUM (n)) < 0)
804 nn = -1 - nn;
805 for (; nn; nn >>= 4)
806 c += scm_logtab[15 & nn];
807 return SCM_MAKINUM (c);
0f2d19dd 808}
1bbd0b84
GB		 809#undef FUNC_NAME
810
0f2d19dd 811
e4755e5c
JB		 812static const char scm_ilentab[] = {
813 0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4
814};
1cc91f1b 815
1bbd0b84
GB		 816GUILE_PROC (scm_integer_length, "integer-length", 1, 0, 0,
817 (SCM n),
818"")
819#define FUNC_NAME s_scm_integer_length
0f2d19dd
JB		 820{
821 register unsigned long c = 0;
822 register long nn;
823 unsigned int l = 4;
824#ifdef SCM_BIGDIG
f872b822
MD		 825 if (SCM_NINUMP (n))
826 {
827 SCM_BIGDIG *ds, d;
1bbd0b84 828 SCM_VALIDATE_BIGINT(1,n);
f872b822
MD		 829 if (SCM_BIGSIGN (n))
830 return scm_integer_length (scm_difference (SCM_MAKINUM (-1L), n));
831 ds = SCM_BDIGITS (n);
832 d = ds[c = SCM_NUMDIGS (n) - 1];
833 for (c *= SCM_BITSPERDIG; d; d >>= 4)
834 {
835 c += 4;
836 l = scm_ilentab[15 & d];
837 }
838 return SCM_MAKINUM (c - 4 + l);
839 }
0f2d19dd 840#else
1bbd0b84 841 SCM_VALIDATE_INT(1,n);
0f2d19dd 842#endif
f872b822
MD		 843 if ((nn = SCM_INUM (n)) < 0)
844 nn = -1 - nn;
845 for (; nn; nn >>= 4)
846 {
847 c += 4;
848 l = scm_ilentab[15 & nn];
849 }
850 return SCM_MAKINUM (c - 4 + l);
0f2d19dd 851}
1bbd0b84 852#undef FUNC_NAME
0f2d19dd
JB		 853
854
855#ifdef SCM_BIGDIG
e4755e5c 856static const char s_bignum[] = "bignum";
1cc91f1b 857
0f2d19dd 858SCM
1bbd0b84 859scm_mkbig (scm_sizet nlen, int sign)
0f2d19dd
JB		 860{
861 SCM v = nlen;
2bf746cc
JB		 862 /* Cast to SCM to avoid signed/unsigned comparison warnings. */
863 if (((v << 16) >> 16) != (SCM) nlen)
e4755e5c 864 scm_wta (SCM_MAKINUM (nlen), (char *) SCM_NALLOC, s_bignum);
f872b822 865 SCM_NEWCELL (v);
0f2d19dd 866 SCM_DEFER_INTS;
f872b822 867 SCM_SETCHARS (v, scm_must_malloc ((long) (nlen * sizeof (SCM_BIGDIG)),
e4755e5c 868 s_bignum));
f872b822 869 SCM_SETNUMDIGS (v, nlen, sign ? scm_tc16_bigneg : scm_tc16_bigpos);
0f2d19dd
JB		 870 SCM_ALLOW_INTS;
871 return v;
872}
873
1cc91f1b 874
0f2d19dd 875SCM
1bbd0b84 876scm_big2inum (SCM b, scm_sizet l)
0f2d19dd
JB		 877{
878 unsigned long num = 0;
f872b822
MD		 879 SCM_BIGDIG *tmp = SCM_BDIGITS (b);
880 while (l--)
881 num = SCM_BIGUP (num) + tmp[l];
882 if (SCM_TYP16 (b) == scm_tc16_bigpos)
883 {
884 if (SCM_POSFIXABLE (num))
885 return SCM_MAKINUM (num);
886 }
887 else if (SCM_UNEGFIXABLE (num))
888 return SCM_MAKINUM (-num);
0f2d19dd
JB		 889 return b;
890}
891
892
e4755e5c 893static const char s_adjbig[] = "scm_adjbig";
1cc91f1b 894
0f2d19dd 895SCM
1bbd0b84 896scm_adjbig (SCM b, scm_sizet nlen)
0f2d19dd 897{
2bf746cc
JB		 898 scm_sizet nsiz = nlen;
899 if (((nsiz << 16) >> 16) != nlen)
f872b822 900 scm_wta (scm_ulong2num (nsiz), (char *) SCM_NALLOC, s_adjbig);
2bf746cc 901
0f2d19dd 902 SCM_DEFER_INTS;
2bf746cc
JB		 903 {
904 SCM_BIGDIG *digits
905 = ((SCM_BIGDIG *)
f872b822
MD		 906 scm_must_realloc ((char *) SCM_CHARS (b),
907 (long) (SCM_NUMDIGS (b) * sizeof (SCM_BIGDIG)),
908 (long) (nsiz * sizeof (SCM_BIGDIG)), s_adjbig));
2bf746cc
JB		 909
910 SCM_SETCHARS (b, digits);
f872b822 911 SCM_SETNUMDIGS (b, nsiz, SCM_TYP16 (b));
2bf746cc 912 }
0f2d19dd
JB		 913 SCM_ALLOW_INTS;
914 return b;
915}
916
917
1cc91f1b 918
0f2d19dd 919SCM
1bbd0b84 920scm_normbig (SCM b)
0f2d19dd 921{
f872b822
MD		 922#ifndef _UNICOS
923 scm_sizet nlen = SCM_NUMDIGS (b);
0f2d19dd 924#else
f872b822 925 int nlen = SCM_NUMDIGS (b); /* unsigned nlen breaks on Cray when nlen => 0 */
0f2d19dd 926#endif
f872b822
MD		 927 SCM_BIGDIG *zds = SCM_BDIGITS (b);
928 while (nlen-- && !zds[nlen]);
929 nlen++;
930 if (nlen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM))
931 if (SCM_INUMP (b = scm_big2inum (b, (scm_sizet) nlen)))
932 return b;
933 if (SCM_NUMDIGS (b) == nlen)
934 return b;
935 return scm_adjbig (b, (scm_sizet) nlen);
0f2d19dd
JB		 936}
937
938
1cc91f1b 939
0f2d19dd 940SCM
1bbd0b84 941scm_copybig (SCM b, int sign)
0f2d19dd 942{
f872b822
MD		 943 scm_sizet i = SCM_NUMDIGS (b);
944 SCM ans = scm_mkbig (i, sign);
945 SCM_BIGDIG *src = SCM_BDIGITS (b), *dst = SCM_BDIGITS (ans);
946 while (i--)
947 dst[i] = src[i];
0f2d19dd
JB		 948 return ans;
949}
950
951
1cc91f1b 952
0f2d19dd 953SCM
1bbd0b84 954scm_long2big (long n)
0f2d19dd
JB		 955{
956 scm_sizet i = 0;
957 SCM_BIGDIG *digits;
f872b822
MD		 958 SCM ans = scm_mkbig (SCM_DIGSPERLONG, n < 0);
959 digits = SCM_BDIGITS (ans);
960 if (n < 0)
961 n = -n;
962 while (i < SCM_DIGSPERLONG)
963 {
964 digits[i++] = SCM_BIGLO (n);
965 n = SCM_BIGDN ((unsigned long) n);
966 }
0f2d19dd
JB		 967 return ans;
968}
969
5c11cc9d 970#ifdef HAVE_LONG_LONGS
1cc91f1b 971
0f2d19dd 972SCM
1bbd0b84 973scm_long_long2big (long_long n)
0f2d19dd
JB		 974{
975 scm_sizet i;
976 SCM_BIGDIG *digits;
977 SCM ans;
978 int n_digits;
979
980 {
981 long tn;
982 tn = (long) n;
f872b822 983 if ((long long) tn == n)
0f2d19dd
JB		 984 return scm_long2big (tn);
985 }
986
987 {
988 long_long tn;
989
990 for (tn = n, n_digits = 0;
991 tn;
f872b822 992 ++n_digits, tn = SCM_BIGDN ((ulong_long) tn))
0f2d19dd
JB		 993 ;
994 }
995
996 i = 0;
f872b822
MD		 997 ans = scm_mkbig (n_digits, n < 0);
998 digits = SCM_BDIGITS (ans);
0f2d19dd
JB		 999 if (n < 0)
1000 n = -n;
f872b822
MD		 1001 while (i < n_digits)
1002 {
1003 digits[i++] = SCM_BIGLO (n);
1004 n = SCM_BIGDN ((ulong_long) n);
1005 }
0f2d19dd
JB		 1006 return ans;
1007}
1008#endif
1009
1cc91f1b 1010
0f2d19dd 1011SCM
1bbd0b84 1012scm_2ulong2big (unsigned long *np)
0f2d19dd
JB		 1013{
1014 unsigned long n;
1015 scm_sizet i;
1016 SCM_BIGDIG *digits;
1017 SCM ans;
1018
f872b822
MD		 1019 ans = scm_mkbig (2 * SCM_DIGSPERLONG, 0);
1020 digits = SCM_BDIGITS (ans);
0f2d19dd
JB		 1021
1022 n = np[0];
1023 for (i = 0; i < SCM_DIGSPERLONG; ++i)
1024 {
f872b822
MD		 1025 digits[i] = SCM_BIGLO (n);
1026 n = SCM_BIGDN ((unsigned long) n);
0f2d19dd
JB		 1027 }
1028 n = np[1];
1029 for (i = 0; i < SCM_DIGSPERLONG; ++i)
1030 {
f872b822
MD		 1031 digits[i + SCM_DIGSPERLONG] = SCM_BIGLO (n);
1032 n = SCM_BIGDN ((unsigned long) n);
0f2d19dd
JB		 1033 }
1034 return ans;
1035}
1036
1037
1cc91f1b 1038
0f2d19dd 1039SCM
1bbd0b84 1040scm_ulong2big (unsigned long n)
0f2d19dd
JB		 1041{
1042 scm_sizet i = 0;
1043 SCM_BIGDIG *digits;
f872b822
MD		 1044 SCM ans = scm_mkbig (SCM_DIGSPERLONG, 0);
1045 digits = SCM_BDIGITS (ans);
1046 while (i < SCM_DIGSPERLONG)
1047 {
1048 digits[i++] = SCM_BIGLO (n);
1049 n = SCM_BIGDN (n);
1050 }
0f2d19dd
JB		 1051 return ans;
1052}
1053
1054
1cc91f1b 1055
0f2d19dd 1056int
1bbd0b84 1057scm_bigcomp (SCM x, SCM y)
0f2d19dd 1058{
f872b822
MD		 1059 int xsign = SCM_BIGSIGN (x);
1060 int ysign = SCM_BIGSIGN (y);
0f2d19dd 1061 scm_sizet xlen, ylen;
2bf746cc
JB		 1062
1063 /* Look at the signs, first. */
f872b822
MD		 1064 if (ysign < xsign)
1065 return 1;
1066 if (ysign > xsign)
1067 return -1;
2bf746cc
JB		 1068
1069 /* They're the same sign, so see which one has more digits. Note
1070 that, if they are negative, the longer number is the lesser. */
f872b822
MD		 1071 ylen = SCM_NUMDIGS (y);
1072 xlen = SCM_NUMDIGS (x);
2bf746cc
JB		 1073 if (ylen > xlen)
1074 return (xsign) ? -1 : 1;
f872b822
MD		 1075 if (ylen < xlen)
1076 return (xsign) ? 1 : -1;
2bf746cc
JB		 1077
1078 /* They have the same number of digits, so find the most significant
1079 digit where they differ. */
1080 while (xlen)
1081 {
1082 --xlen;
1083 if (SCM_BDIGITS (y)[xlen] != SCM_BDIGITS (x)[xlen])
1084 /* Make the discrimination based on the digit that differs. */
f872b822
MD		 1085 return ((SCM_BDIGITS (y)[xlen] > SCM_BDIGITS (x)[xlen])
1086 ? (xsign ? -1 : 1)
1087 : (xsign ? 1 : -1));
2bf746cc
JB		 1088 }
1089
1090 /* The numbers are identical. */
1091 return 0;
0f2d19dd
JB		 1092}
1093
1094#ifndef SCM_DIGSTOOBIG
1095
1cc91f1b 1096
0f2d19dd 1097long
1bbd0b84 1098scm_pseudolong (long x)
0f2d19dd 1099{
f872b822
MD		 1100 union
1101 {
0f2d19dd
JB		 1102 long l;
1103 SCM_BIGDIG bd[SCM_DIGSPERLONG];
f872b822
MD		 1104 }
1105 p;
0f2d19dd 1106 scm_sizet i = 0;
f872b822
MD		 1107 if (x < 0)
1108 x = -x;
1109 while (i < SCM_DIGSPERLONG)
1110 {
1111 p.bd[i++] = SCM_BIGLO (x);
1112 x = SCM_BIGDN (x);
1113 }
0f2d19dd
JB		 1114 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
1115 return p.l;
1116}
1117
1118#else
1119
1cc91f1b 1120
0f2d19dd 1121void
1bbd0b84 1122scm_longdigs (long x, SCM_BIGDIG digs[])
0f2d19dd
JB		 1123{
1124 scm_sizet i = 0;
f872b822
MD		 1125 if (x < 0)
1126 x = -x;
1127 while (i < SCM_DIGSPERLONG)
1128 {
1129 digs[i++] = SCM_BIGLO (x);
1130 x = SCM_BIGDN (x);
1131 }
0f2d19dd
JB		 1132}
1133#endif
1134
1135
1cc91f1b 1136
0f2d19dd 1137SCM
1bbd0b84 1138scm_addbig (SCM_BIGDIG *x, scm_sizet nx, int xsgn, SCM bigy, int sgny)
0f2d19dd
JB		 1139{
1140 /* Assumes nx <= SCM_NUMDIGS(bigy) */
1141 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
1142 long num = 0;
f872b822
MD		 1143 scm_sizet i = 0, ny = SCM_NUMDIGS (bigy);
1144 SCM z = scm_copybig (bigy, SCM_BIGSIGN (bigy) ^ sgny);
1145 SCM_BIGDIG *zds = SCM_BDIGITS (z);
1146 if (xsgn ^ SCM_BIGSIGN (z))
1147 {
1148 do
1149 {
1150 num += (long) zds[i] - x[i];
1151 if (num < 0)
1152 {
1153 zds[i] = num + SCM_BIGRAD;
1154 num = -1;
1155 }
1156 else
1157 {
1158 zds[i] = SCM_BIGLO (num);
1159 num = 0;
1160 }
1161 }
1162 while (++i < nx);
1163 if (num && nx == ny)
1164 {
1165 num = 1;
1166 i = 0;
1167 SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
1168 do
1169 {
1170 num += (SCM_BIGRAD - 1) - zds[i];
1171 zds[i++] = SCM_BIGLO (num);
1172 num = SCM_BIGDN (num);
1173 }
1174 while (i < ny);
1175 }
1176 else
1177 while (i < ny)
1178 {
1179 num += zds[i];
1180 if (num < 0)
1181 {
1182 zds[i++] = num + SCM_BIGRAD;
1183 num = -1;
1184 }
1185 else
1186 {
1187 zds[i++] = SCM_BIGLO (num);
1188 num = 0;
1189 }
1190 }
1191 }
1192 else
1193 {
1194 do
1195 {
1196 num += (long) zds[i] + x[i];
1197 zds[i++] = SCM_BIGLO (num);
1198 num = SCM_BIGDN (num);
1199 }
1200 while (i < nx);
1201 if (!num)
1202 return z;
1203 while (i < ny)
1204 {
1205 num += zds[i];
1206 zds[i++] = SCM_BIGLO (num);
1207 num = SCM_BIGDN (num);
1208 if (!num)
1209 return z;
1210 }
1211 if (num)
1212 {
1213 z = scm_adjbig (z, ny + 1);
1214 SCM_BDIGITS (z)[ny] = num;
1215 return z;
1216 }
1217 }
1218 return scm_normbig (z);
0f2d19dd
JB		 1219}
1220
1cc91f1b 1221
0f2d19dd 1222SCM
1bbd0b84 1223scm_mulbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn)
0f2d19dd
JB		 1224{
1225 scm_sizet i = 0, j = nx + ny;
1226 unsigned long n = 0;
f872b822
MD		 1227 SCM z = scm_mkbig (j, sgn);
1228 SCM_BIGDIG *zds = SCM_BDIGITS (z);
1229 while (j--)
1230 zds[j] = 0;
1231 do
1232 {
1233 j = 0;
1234 if (x[i])
1235 {
1236 do
1237 {
1238 n += zds[i + j] + ((unsigned long) x[i] * y[j]);
1239 zds[i + j++] = SCM_BIGLO (n);
1240 n = SCM_BIGDN (n);
1241 }
1242 while (j < ny);
1243 if (n)
1244 {
1245 zds[i + j] = n;
1246 n = 0;
1247 }
1248 }
0f2d19dd 1249 }
f872b822
MD		 1250 while (++i < nx);
1251 return scm_normbig (z);
0f2d19dd
JB		 1252}
1253
1cc91f1b 1254
805df3e8
JB		 1255/* Sun's compiler complains about the fact that this function has an
1256 ANSI prototype in numbers.h, but a K&R declaration here, and the
1257 two specify different promotions for the third argument. I'm going
1258 to turn this into an ANSI declaration, and see if anyone complains
1259 about it not being K&R. */
1260
0f2d19dd 1261unsigned int
f872b822
MD		 1262scm_divbigdig (SCM_BIGDIG * ds,
1263 scm_sizet h,
1264 SCM_BIGDIG div)
0f2d19dd
JB		 1265{
1266 register unsigned long t2 = 0;
f872b822
MD		 1267 while (h--)
1268 {
1269 t2 = SCM_BIGUP (t2) + ds[h];
1270 ds[h] = t2 / div;
1271 t2 %= div;
1272 }
0f2d19dd
JB		 1273 return t2;
1274}
1275
1276
1cc91f1b 1277
0f2d19dd 1278SCM
1bbd0b84 1279scm_divbigint (SCM x, long z, int sgn, int mode)
0f2d19dd 1280{
f872b822
MD		 1281 if (z < 0)
1282 z = -z;
1283 if (z < SCM_BIGRAD)
1284 {
1285 register unsigned long t2 = 0;
1286 register SCM_BIGDIG *ds = SCM_BDIGITS (x);
1287 scm_sizet nd = SCM_NUMDIGS (x);
1288 while (nd--)
1289 t2 = (SCM_BIGUP (t2) + ds[nd]) % z;
1290 if (mode && t2)
1291 t2 = z - t2;
1292 return SCM_MAKINUM (sgn ? -t2 : t2);
1293 }
0f2d19dd
JB		 1294 {
1295#ifndef SCM_DIGSTOOBIG
f872b822
MD		 1296 unsigned long t2 = scm_pseudolong (z);
1297 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
1298 (SCM_BIGDIG *) & t2, SCM_DIGSPERLONG,
1299 sgn, mode);
0f2d19dd
JB		 1300#else
1301 SCM_BIGDIG t2[SCM_DIGSPERLONG];
f872b822
MD		 1302 scm_longdigs (z, t2);
1303 return scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
1304 t2, SCM_DIGSPERLONG,
1305 sgn, mode);
0f2d19dd
JB		 1306#endif
1307 }
1308}
1309
1cc91f1b 1310
0f2d19dd 1311SCM
1bbd0b84 1312scm_divbigbig (SCM_BIGDIG *x, scm_sizet nx, SCM_BIGDIG *y, scm_sizet ny, int sgn, int modes)
0f2d19dd
JB		 1313{
1314 /* modes description
f872b822
MD		 1315 0 remainder
1316 1 scm_modulo
1317 2 quotient
1318 3 quotient but returns 0 if division is not exact. */
0f2d19dd
JB		 1319 scm_sizet i = 0, j = 0;
1320 long num = 0;
1321 unsigned long t2 = 0;
1322 SCM z, newy;
f872b822 1323 SCM_BIGDIG d = 0, qhat, *zds, *yds;
0f2d19dd
JB		 1324 /* algorithm requires nx >= ny */
1325 if (nx < ny)
f872b822
MD		 1326 switch (modes)
1327 {
1328 case 0: /* remainder -- just return x */
1329 z = scm_mkbig (nx, sgn);
1330 zds = SCM_BDIGITS (z);
1331 do
1332 {
1333 zds[i] = x[i];
1334 }
1335 while (++i < nx);
1336 return z;
1337 case 1: /* scm_modulo -- return y-x */
1338 z = scm_mkbig (ny, sgn);
1339 zds = SCM_BDIGITS (z);
1340 do
1341 {
1342 num += (long) y[i] - x[i];
1343 if (num < 0)
1344 {
1345 zds[i] = num + SCM_BIGRAD;
1346 num = -1;
1347 }
1348 else
1349 {
1350 zds[i] = num;
1351 num = 0;
1352 }
1353 }
1354 while (++i < nx);
1355 while (i < ny)
1356 {
1357 num += y[i];
1358 if (num < 0)
1359 {
1360 zds[i++] = num + SCM_BIGRAD;
1361 num = -1;
1362 }
1363 else
1364 {
1365 zds[i++] = num;
1366 num = 0;
1367 }
1368 }
1369 goto doadj;
1370 case 2:
1371 return SCM_INUM0; /* quotient is zero */
1372 case 3:
1373 return 0; /* the division is not exact */
0f2d19dd 1374 }
f872b822
MD		 1375
1376 z = scm_mkbig (nx == ny ? nx + 2 : nx + 1, sgn);
1377 zds = SCM_BDIGITS (z);
1378 if (nx == ny)
1379 zds[nx + 1] = 0;
1380 while (!y[ny - 1])
1381 ny--; /* in case y came in as a psuedolong */
1382 if (y[ny - 1] < (SCM_BIGRAD >> 1))
1383 { /* normalize operands */
1384 d = SCM_BIGRAD / (y[ny - 1] + 1);
1385 newy = scm_mkbig (ny, 0);
1386 yds = SCM_BDIGITS (newy);
1387 while (j < ny)
1388 {
1389 t2 += (unsigned long) y[j] * d;
1390 yds[j++] = SCM_BIGLO (t2);
1391 t2 = SCM_BIGDN (t2);
1392 }
1393 y = yds;
1394 j = 0;
1395 t2 = 0;
1396 while (j < nx)
1397 {
1398 t2 += (unsigned long) x[j] * d;
1399 zds[j++] = SCM_BIGLO (t2);
1400 t2 = SCM_BIGDN (t2);
1401 }
1402 zds[j] = t2;
1403 }
1404 else
1405 {
1406 zds[j = nx] = 0;
1407 while (j--)
1408 zds[j] = x[j];
1409 }
1410 j = nx == ny ? nx + 1 : nx; /* dividend needs more digits than divisor */
1411 do
1412 { /* loop over digits of quotient */
1413 if (zds[j] == y[ny - 1])
1414 qhat = SCM_BIGRAD - 1;
1415 else
1416 qhat = (SCM_BIGUP (zds[j]) + zds[j - 1]) / y[ny - 1];
1417 if (!qhat)
1418 continue;
1419 i = 0;
1420 num = 0;
1421 t2 = 0;
1422 do
1423 { /* multiply and subtract */
1424 t2 += (unsigned long) y[i] * qhat;
1425 num += zds[j - ny + i] - SCM_BIGLO (t2);
1426 if (num < 0)
1427 {
1428 zds[j - ny + i] = num + SCM_BIGRAD;
1429 num = -1;
1430 }
1431 else
1432 {
1433 zds[j - ny + i] = num;
1434 num = 0;
1435 }
1436 t2 = SCM_BIGDN (t2);
1437 }
1438 while (++i < ny);
1439 num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
1440 while (num)
1441 { /* "add back" required */
1442 i = 0;
1443 num = 0;
1444 qhat--;
1445 do
1446 {
1447 num += (long) zds[j - ny + i] + y[i];
1448 zds[j - ny + i] = SCM_BIGLO (num);
1449 num = SCM_BIGDN (num);
1450 }
1451 while (++i < ny);
1452 num--;
1453 }
1454 if (modes & 2)
1455 zds[j] = qhat;
1456 }
1457 while (--j >= ny);
1458 switch (modes)
1459 {
1460 case 3: /* check that remainder==0 */
1461 for (j = ny; j && !zds[j - 1]; --j);
1462 if (j)
1463 return 0;
1464 case 2: /* move quotient down in z */
1465 j = (nx == ny ? nx + 2 : nx + 1) - ny;
1466 for (i = 0; i < j; i++)
1467 zds[i] = zds[i + ny];
1468 ny = i;
1469 break;
1470 case 1: /* subtract for scm_modulo */
1471 i = 0;
1472 num = 0;
1473 j = 0;
1474 do
1475 {
1476 num += y[i] - zds[i];
1477 j = j | zds[i];
1478 if (num < 0)
1479 {
1480 zds[i] = num + SCM_BIGRAD;
1481 num = -1;
1482 }
1483 else
1484 {
1485 zds[i] = num;
1486 num = 0;
1487 }
1488 }
1489 while (++i < ny);
1490 if (!j)
1491 return SCM_INUM0;
1492 case 0: /* just normalize remainder */
1493 if (d)
1494 scm_divbigdig (zds, ny, d);
1495 }
0f2d19dd 1496 doadj:
f872b822
MD		 1497 for (j = ny; j && !zds[j - 1]; --j);
1498 if (j * SCM_BITSPERDIG <= sizeof (SCM) * SCM_CHAR_BIT)
1499 if (SCM_INUMP (z = scm_big2inum (z, j)))
1500 return z;
1501 return scm_adjbig (z, j);
0f2d19dd
JB		 1502}
1503#endif
f872b822 1504\f
0f2d19dd
JB		 1505
1506
1507
0f2d19dd
JB		 1508
1509/*** NUMBERS -> STRINGS ***/
1510#ifdef SCM_FLOATS
1511int scm_dblprec;
e4755e5c 1512static const double fx[] =
f872b822
MD		 1513{ 0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1514 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1515 5e-11, 5e-12, 5e-13, 5e-14, 5e-15,
1516 5e-16, 5e-17, 5e-18, 5e-19, 5e-20};
0f2d19dd
JB		 1517
1518
1519
1cc91f1b 1520
0f2d19dd 1521static scm_sizet
1bbd0b84 1522idbl2str (double f, char *a)
0f2d19dd
JB		 1523{
1524 int efmt, dpt, d, i, wp = scm_dblprec;
1525 scm_sizet ch = 0;
1526 int exp = 0;
1527
f872b822
MD		 1528 if (f == 0.0)
1529 goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;} */
1530 if (f < 0.0)
1531 {
1532 f = -f;
1533 a[ch++] = '-';
1534 }
1535 else if (f > 0.0);
1536 else
1537 goto funny;
1538 if (IS_INF (f))
1539 {
1540 if (ch == 0)
1541 a[ch++] = '+';
1542 funny:
1543 a[ch++] = '#';
1544 a[ch++] = '.';
1545 a[ch++] = '#';
1546 return ch;
1547 }
1548#ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1549 make-uniform-vector, from causing infinite loops. */
1550 while (f < 1.0)
1551 {
1552 f *= 10.0;
1553 if (exp-- < DBL_MIN_10_EXP)
1554 goto funny;
1555 }
1556 while (f > 10.0)
1557 {
1558 f *= 0.10;
1559 if (exp++ > DBL_MAX_10_EXP)
1560 goto funny;
1561 }
1562#else
1563 while (f < 1.0)
1564 {
1565 f *= 10.0;
1566 exp--;
1567 }
1568 while (f > 10.0)
1569 {
1570 f /= 10.0;
1571 exp++;
1572 }
1573#endif
1574 if (f + fx[wp] >= 10.0)
1575 {
1576 f = 1.0;
1577 exp++;
1578 }
0f2d19dd 1579 zero:
f872b822
MD		 1580#ifdef ENGNOT
1581 dpt = (exp + 9999) % 3;
0f2d19dd
JB		 1582 exp -= dpt++;
1583 efmt = 1;
f872b822
MD		 1584#else
1585 efmt = (exp < -3) || (exp > wp + 2);
0f2d19dd 1586 if (!efmt)
cda139a7
MD		 1587 {
1588 if (exp < 0)
1589 {
1590 a[ch++] = '0';
1591 a[ch++] = '.';
1592 dpt = exp;
f872b822
MD		 1593 while (++dpt)
1594 a[ch++] = '0';
cda139a7
MD		 1595 }
1596 else
f872b822 1597 dpt = exp + 1;
cda139a7 1598 }
0f2d19dd
JB		 1599 else
1600 dpt = 1;
f872b822
MD		 1601#endif
1602
1603 do
1604 {
1605 d = f;
1606 f -= d;
1607 a[ch++] = d + '0';
1608 if (f < fx[wp])
1609 break;
1610 if (f + fx[wp] >= 1.0)
1611 {
1612 a[ch - 1]++;
1613 break;
1614 }
1615 f *= 10.0;
1616 if (!(--dpt))
1617 a[ch++] = '.';
0f2d19dd 1618 }
f872b822 1619 while (wp--);
0f2d19dd
JB		 1620
1621 if (dpt > 0)
cda139a7 1622 {
f872b822 1623#ifndef ENGNOT
cda139a7
MD		 1624 if ((dpt > 4) && (exp > 6))
1625 {
f872b822 1626 d = (a[0] == '-' ? 2 : 1);
cda139a7 1627 for (i = ch++; i > d; i--)
f872b822 1628 a[i] = a[i - 1];
cda139a7
MD		 1629 a[d] = '.';
1630 efmt = 1;
1631 }
1632 else
f872b822 1633#endif
cda139a7 1634 {
f872b822
MD		 1635 while (--dpt)
1636 a[ch++] = '0';
cda139a7
MD		 1637 a[ch++] = '.';
1638 }
1639 }
f872b822
MD		 1640 if (a[ch - 1] == '.')
1641 a[ch++] = '0'; /* trailing zero */
1642 if (efmt && exp)
1643 {
1644 a[ch++] = 'e';
1645 if (exp < 0)
1646 {
1647 exp = -exp;
1648 a[ch++] = '-';
1649 }
1650 for (i = 10; i <= exp; i *= 10);
1651 for (i /= 10; i; i /= 10)
1652 {
1653 a[ch++] = exp / i + '0';
1654 exp %= i;
1655 }
0f2d19dd 1656 }
0f2d19dd
JB		 1657 return ch;
1658}
1659
1cc91f1b 1660
0f2d19dd 1661static scm_sizet
1bbd0b84 1662iflo2str (SCM flt, char *str)
0f2d19dd
JB		 1663{
1664 scm_sizet i;
f872b822
MD		 1665#ifdef SCM_SINGLES
1666 if (SCM_SINGP (flt))
1667 i = idbl2str (SCM_FLO (flt), str);
0f2d19dd 1668 else
f872b822
MD		 1669#endif
1670 i = idbl2str (SCM_REAL (flt), str);
1671 if (SCM_CPLXP (flt))
1672 {
1673 if (0 <= SCM_IMAG (flt)) /* jeh */
1674 str[i++] = '+'; /* jeh */
1675 i += idbl2str (SCM_IMAG (flt), &str[i]);
1676 str[i++] = 'i';
1677 }
0f2d19dd
JB		 1678 return i;
1679}
f872b822 1680#endif /* SCM_FLOATS */
0f2d19dd 1681
5c11cc9d 1682/* convert a long to a string (unterminated). returns the number of
1bbd0b84
GB		 1683 characters in the result.
1684 rad is output base
1685 p is destination: worst case (base 2) is SCM_INTBUFLEN */
0f2d19dd 1686scm_sizet
1bbd0b84 1687scm_iint2str (long num, int rad, char *p)
0f2d19dd 1688{
5c11cc9d
GH		 1689 scm_sizet j = 1;
1690 scm_sizet i;
1691 unsigned long n = (num < 0) ? -num : num;
1692
f872b822 1693 for (n /= rad; n > 0; n /= rad)
5c11cc9d
GH		 1694 j++;
1695
1696 i = j;
1697 if (num < 0)
f872b822 1698 {
f872b822 1699 *p++ = '-';
5c11cc9d
GH		 1700 j++;
1701 n = -num;
f872b822 1702 }
5c11cc9d
GH		 1703 else
1704 n = num;
f872b822
MD		 1705 while (i--)
1706 {
5c11cc9d
GH		 1707 int d = n % rad;
1708
f872b822
MD		 1709 n /= rad;
1710 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1711 }
0f2d19dd
JB		 1712 return j;
1713}
1714
1715
1716#ifdef SCM_BIGDIG
1cc91f1b 1717
0f2d19dd 1718static SCM
1bbd0b84 1719big2str (SCM b, unsigned int radix)
0f2d19dd 1720{
f872b822
MD		 1721 SCM t = scm_copybig (b, 0); /* sign of temp doesn't matter */
1722 register SCM_BIGDIG *ds = SCM_BDIGITS (t);
1723 scm_sizet i = SCM_NUMDIGS (t);
1724 scm_sizet j = radix == 16 ? (SCM_BITSPERDIG * i) / 4 + 2
1725 : radix >= 10 ? (SCM_BITSPERDIG * i * 241L) / 800 + 2
1726 : (SCM_BITSPERDIG * i) + 2;
0f2d19dd
JB		 1727 scm_sizet k = 0;
1728 scm_sizet radct = 0;
1729 scm_sizet ch; /* jeh */
1730 SCM_BIGDIG radpow = 1, radmod = 0;
f872b822
MD		 1731 SCM ss = scm_makstr ((long) j, 0);
1732 char *s = SCM_CHARS (ss), c;
1733 while ((long) radpow * radix < SCM_BIGRAD)
1734 {
1735 radpow *= radix;
1736 radct++;
1737 }
1738 s[0] = scm_tc16_bigneg == SCM_TYP16 (b) ? '-' : '+';
1739 while ((i || radmod) && j)
1740 {
1741 if (k == 0)
1742 {
1743 radmod = (SCM_BIGDIG) scm_divbigdig (ds, i, radpow);
1744 k = radct;
1745 if (!ds[i - 1])
1746 i--;
1747 }
1748 c = radmod % radix;
1749 radmod /= radix;
1750 k--;
1751 s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
1752 }
0f2d19dd 1753 ch = s[0] == '-' ? 1 : 0; /* jeh */
f872b822
MD		 1754 if (ch < j)
1755 { /* jeh */
1756 for (i = j; j < SCM_LENGTH (ss); j++)
1757 s[ch + j - i] = s[j]; /* jeh */
1758 scm_vector_set_length_x (ss, /* jeh */
1759 (SCM) SCM_MAKINUM (ch + SCM_LENGTH (ss) - i));
1760 }
b098016b
JB		 1761
1762 return scm_return_first (ss, t);
0f2d19dd
JB		 1763}
1764#endif
1765
1766
1bbd0b84
GB		 1767GUILE_PROC (scm_number_to_string, "number->string", 1, 1, 0,
1768 (SCM x, SCM radix),
1769"")
1770#define FUNC_NAME s_scm_number_to_string
0f2d19dd 1771{
1bbd0b84
GB		 1772 int base;
1773 SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base);
0f2d19dd 1774#ifdef SCM_FLOATS
f872b822
MD		 1775 if (SCM_NINUMP (x))
1776 {
1777 char num_buf[SCM_FLOBUFLEN];
1778#ifdef SCM_BIGDIG
1779 SCM_ASRTGO (SCM_NIMP (x), badx);
1780 if (SCM_BIGP (x))
1bbd0b84 1781 return big2str (x, (unsigned int) base);
f872b822
MD		 1782#ifndef SCM_RECKLESS
1783 if (!(SCM_INEXP (x)))
1784 {
1785 badx:
1bbd0b84 1786 scm_wta (x, (char *) SCM_ARG1, FUNC_NAME);
f872b822
MD		 1787 }
1788#endif
0f2d19dd 1789#else
f872b822
MD		 1790 SCM_ASSERT (SCM_NIMP (x) && SCM_INEXP (x),
1791 x, SCM_ARG1, s_number_to_string);
0f2d19dd 1792#endif
f872b822
MD		 1793 return scm_makfromstr (num_buf, iflo2str (x, num_buf), 0);
1794 }
1795#else
1796#ifdef SCM_BIGDIG
1797 if (SCM_NINUMP (x))
1798 {
1799 SCM_ASSERT (SCM_NIMP (x) && SCM_BIGP (x),
1800 x, SCM_ARG1, s_number_to_string);
1bbd0b84 1801 return big2str (x, (unsigned int) base);
f872b822
MD		 1802 }
1803#else
1804 SCM_ASSERT (SCM_INUMP (x), x, SCM_ARG1, s_number_to_string);
1805#endif
1806#endif
1807 {
1808 char num_buf[SCM_INTBUFLEN];
1809 return scm_makfromstr (num_buf,
1810 scm_iint2str (SCM_INUM (x),
1bbd0b84 1811 base,
f872b822
MD		 1812 num_buf),
1813 0);
0f2d19dd
JB		 1814 }
1815}
1bbd0b84 1816#undef FUNC_NAME
0f2d19dd
JB		 1817
1818
1819/* These print routines are stubbed here so that scm_repl.c doesn't need
1820 SCM_FLOATS or SCM_BIGDIGs conditionals */
1cc91f1b 1821
0f2d19dd 1822int
1bbd0b84 1823scm_floprint (SCM sexp, SCM port, scm_print_state *pstate)
0f2d19dd
JB		 1824{
1825#ifdef SCM_FLOATS
1826 char num_buf[SCM_FLOBUFLEN];
f872b822 1827 scm_lfwrite (num_buf, iflo2str (sexp, num_buf), port);
0f2d19dd 1828#else
f872b822 1829 scm_ipruk ("float", sexp, port);
0f2d19dd
JB		 1830#endif
1831 return !0;
1832}
1833
1834
1cc91f1b 1835
0f2d19dd 1836int
1bbd0b84 1837scm_bigprint (SCM exp, SCM port, scm_print_state *pstate)
0f2d19dd
JB		 1838{
1839#ifdef SCM_BIGDIG
f872b822
MD		 1840 exp = big2str (exp, (unsigned int) 10);
1841 scm_lfwrite (SCM_CHARS (exp), (scm_sizet) SCM_LENGTH (exp), port);
0f2d19dd 1842#else
f872b822 1843 scm_ipruk ("bignum", exp, port);
0f2d19dd
JB		 1844#endif
1845 return !0;
1846}
1847/*** END nums->strs ***/
1848
1849/*** STRINGS -> NUMBERS ***/
2a8fecee
JB		 1850
1851static SCM
1bbd0b84 1852scm_small_istr2int (char *str, long len, long radix)
2a8fecee
JB		 1853{
1854 register long n = 0, ln;
1855 register int c;
1856 register int i = 0;
1857 int lead_neg = 0;
f872b822
MD		 1858 if (0 >= len)
1859 return SCM_BOOL_F; /* zero scm_length */
1860 switch (*str)
1861 { /* leading sign */
1862 case '-':
1863 lead_neg = 1;
1864 case '+':
1865 if (++i == len)
1866 return SCM_BOOL_F; /* bad if lone `+' or `-' */
1867 }
2a8fecee 1868
f872b822
MD		 1869 do
1870 {
1871 switch (c = str[i++])
1872 {
1873 case DIGITS:
1874 c = c - '0';
1875 goto accumulate;
1876 case 'A':
1877 case 'B':
1878 case 'C':
1879 case 'D':
1880 case 'E':
1881 case 'F':
1882 c = c - 'A' + 10;
1883 goto accumulate;
1884 case 'a':
1885 case 'b':
1886 case 'c':
1887 case 'd':
1888 case 'e':
1889 case 'f':
1890 c = c - 'a' + 10;
1891 accumulate:
1892 if (c >= radix)
1893 return SCM_BOOL_F; /* bad digit for radix */
1894 ln = n;
1895 n = n * radix - c;
1896 /* Negation is a workaround for HP700 cc bug */
1897 if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM))
1898 goto ovfl;
1899 break;
1900 default:
1901 return SCM_BOOL_F; /* not a digit */
1902 }
2a8fecee 1903 }
f872b822
MD		 1904 while (i < len);
1905 if (!lead_neg)
1906 if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM)
1907 goto ovfl;
1908 return SCM_MAKINUM (n);
2a8fecee
JB		 1909 ovfl: /* overflow scheme integer */
1910 return SCM_BOOL_F;
1911}
1912
1913
1cc91f1b 1914
0f2d19dd 1915SCM
1bbd0b84 1916scm_istr2int (char *str, long len, long radix)
0f2d19dd
JB		 1917{
1918 scm_sizet j;
1919 register scm_sizet k, blen = 1;
1920 scm_sizet i = 0;
1921 int c;
1922 SCM res;
1923 register SCM_BIGDIG *ds;
1924 register unsigned long t2;
1925
f872b822
MD		 1926 if (0 >= len)
1927 return SCM_BOOL_F; /* zero scm_length */
2a8fecee
JB		 1928
1929 /* Short numbers we parse directly into an int, to avoid the overhead
1930 of creating a bignum. */
1931 if (len < 6)
1932 return scm_small_istr2int (str, len, radix);
1933
f872b822
MD		 1934 if (16 == radix)
1935 j = 1 + (4 * len * sizeof (char)) / (SCM_BITSPERDIG);
0f2d19dd 1936 else if (10 <= radix)
f872b822
MD		 1937 j = 1 + (84 * len * sizeof (char)) / (SCM_BITSPERDIG * 25);
1938 else
1939 j = 1 + (len * sizeof (char)) / (SCM_BITSPERDIG);
1940 switch (str[0])
1941 { /* leading sign */
1942 case '-':
1943 case '+':
1944 if (++i == (unsigned) len)
1945 return SCM_BOOL_F; /* bad if lone `+' or `-' */
1946 }
1947 res = scm_mkbig (j, '-' == str[0]);
1948 ds = SCM_BDIGITS (res);
1949 for (k = j; k--;)
1950 ds[k] = 0;
1951 do
1952 {
1953 switch (c = str[i++])
1954 {
1955 case DIGITS:
1956 c = c - '0';
1957 goto accumulate;
1958 case 'A':
1959 case 'B':
1960 case 'C':
1961 case 'D':
1962 case 'E':
1963 case 'F':
1964 c = c - 'A' + 10;
1965 goto accumulate;
1966 case 'a':
1967 case 'b':
1968 case 'c':
1969 case 'd':
1970 case 'e':
1971 case 'f':
1972 c = c - 'a' + 10;
1973 accumulate:
1974 if (c >= radix)
1975 return SCM_BOOL_F; /* bad digit for radix */
1976 k = 0;
1977 t2 = c;
1978 moretodo:
1979 while (k < blen)
1980 {
1981/* printf ("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]); */
1982 t2 += ds[k] * radix;
1983 ds[k++] = SCM_BIGLO (t2);
1984 t2 = SCM_BIGDN (t2);
1985 }
1986 if (blen > j)
1987 scm_num_overflow ("bignum");
1988 if (t2)
1989 {
1990 blen++;
1991 goto moretodo;
1992 }
1993 break;
1994 default:
1995 return SCM_BOOL_F; /* not a digit */
1996 }
0f2d19dd 1997 }
f872b822
MD		 1998 while (i < (unsigned) len);
1999 if (blen * SCM_BITSPERDIG / SCM_CHAR_BIT <= sizeof (SCM))
2000 if (SCM_INUMP (res = scm_big2inum (res, blen)))
2001 return res;
2002 if (j == blen)
2003 return res;
2004 return scm_adjbig (res, blen);
0f2d19dd 2005}
0f2d19dd
JB		 2006
2007#ifdef SCM_FLOATS
1cc91f1b 2008
0f2d19dd 2009SCM
1bbd0b84 2010scm_istr2flo (char *str, long len, long radix)
0f2d19dd
JB		 2011{
2012 register int c, i = 0;
2013 double lead_sgn;
2014 double res = 0.0, tmp = 0.0;
2015 int flg = 0;
2016 int point = 0;
2017 SCM second;
2018
f872b822
MD		 2019 if (i >= len)
2020 return SCM_BOOL_F; /* zero scm_length */
0f2d19dd 2021
f872b822
MD		 2022 switch (*str)
2023 { /* leading sign */
2024 case '-':
2025 lead_sgn = -1.0;
2026 i++;
2027 break;
2028 case '+':
2029 lead_sgn = 1.0;
2030 i++;
0f2d19dd
JB		 2031 break;
2032 default:
f872b822 2033 lead_sgn = 0.0;
0f2d19dd 2034 }
f872b822
MD		 2035 if (i == len)
2036 return SCM_BOOL_F; /* bad if lone `+' or `-' */
2037
2038 if (str[i] == 'i' || str[i] == 'I')
2039 { /* handle `+i' and `-i' */
2040 if (lead_sgn == 0.0)
2041 return SCM_BOOL_F; /* must have leading sign */
2042 if (++i < len)
2043 return SCM_BOOL_F; /* `i' not last character */
2044 return scm_makdbl (0.0, lead_sgn);
2045 }
2046 do
2047 { /* check initial digits */
2048 switch (c = str[i])
2049 {
2050 case DIGITS:
2051 c = c - '0';
2052 goto accum1;
2053 case 'D':
2054 case 'E':
2055 case 'F':
2056 if (radix == 10)
2057 goto out1; /* must be exponent */
2058 case 'A':
2059 case 'B':
2060 case 'C':
2061 c = c - 'A' + 10;
2062 goto accum1;
2063 case 'd':
2064 case 'e':
2065 case 'f':
2066 if (radix == 10)
2067 goto out1;
2068 case 'a':
2069 case 'b':
2070 case 'c':
2071 c = c - 'a' + 10;
2072 accum1:
2073 if (c >= radix)
2074 return SCM_BOOL_F; /* bad digit for radix */
2075 res = res * radix + c;
2076 flg = 1; /* res is valid */
2077 break;
2078 default:
2079 goto out1;
2080 }
2081 }
2082 while (++i < len);
0f2d19dd
JB		 2083 out1:
2084
2085 /* if true, then we did see a digit above, and res is valid */
f872b822
MD		 2086 if (i == len)
2087 goto done;
0f2d19dd
JB		 2088
2089 /* By here, must have seen a digit,
2090 or must have next char be a `.' with radix==10 */
2091 if (!flg)
f872b822 2092 if (!(str[i] == '.' && radix == 10))
0f2d19dd
JB		 2093 return SCM_BOOL_F;
2094
f872b822
MD		 2095 while (str[i] == '#')
2096 { /* optional sharps */
2097 res *= radix;
2098 if (++i == len)
2099 goto done;
0f2d19dd 2100 }
0f2d19dd 2101
f872b822
MD		 2102 if (str[i] == '/')
2103 {
2104 while (++i < len)
2105 {
2106 switch (c = str[i])
2107 {
2108 case DIGITS:
2109 c = c - '0';
2110 goto accum2;
2111 case 'A':
2112 case 'B':
2113 case 'C':
2114 case 'D':
2115 case 'E':
2116 case 'F':
2117 c = c - 'A' + 10;
2118 goto accum2;
2119 case 'a':
2120 case 'b':
2121 case 'c':
2122 case 'd':
2123 case 'e':
2124 case 'f':
2125 c = c - 'a' + 10;
2126 accum2:
2127 if (c >= radix)
2128 return SCM_BOOL_F;
2129 tmp = tmp * radix + c;
2130 break;
2131 default:
2132 goto out2;
2133 }
2134 }
2135 out2:
2136 if (tmp == 0.0)
2137 return SCM_BOOL_F; /* `slash zero' not allowed */
2138 if (i < len)
2139 while (str[i] == '#')
2140 { /* optional sharps */
2141 tmp *= radix;
2142 if (++i == len)
2143 break;
2144 }
2145 res /= tmp;
2146 goto done;
0f2d19dd 2147 }
f872b822
MD		 2148
2149 if (str[i] == '.')
2150 { /* decimal point notation */
2151 if (radix != 10)
2152 return SCM_BOOL_F; /* must be radix 10 */
2153 while (++i < len)
2154 {
2155 switch (c = str[i])
2156 {
2157 case DIGITS:
2158 point--;
2159 res = res * 10.0 + c - '0';
2160 flg = 1;
2161 break;
2162 default:
2163 goto out3;
2164 }
2165 }
2166 out3:
2167 if (!flg)
2168 return SCM_BOOL_F; /* no digits before or after decimal point */
2169 if (i == len)
2170 goto adjust;
2171 while (str[i] == '#')
2172 { /* ignore remaining sharps */
2173 if (++i == len)
2174 goto adjust;
2175 }
0f2d19dd 2176 }
0f2d19dd 2177
f872b822
MD		 2178 switch (str[i])
2179 { /* exponent */
2180 case 'd':
2181 case 'D':
2182 case 'e':
2183 case 'E':
2184 case 'f':
2185 case 'F':
2186 case 'l':
2187 case 'L':
2188 case 's':
2189 case 'S':
2190 {
2191 int expsgn = 1, expon = 0;
2192 if (radix != 10)
2193 return SCM_BOOL_F; /* only in radix 10 */
2194 if (++i == len)
2195 return SCM_BOOL_F; /* bad exponent */
2196 switch (str[i])
2197 {
2198 case '-':
2199 expsgn = (-1);
2200 case '+':
2201 if (++i == len)
2202 return SCM_BOOL_F; /* bad exponent */
2203 }
2204 if (str[i] < '0' || str[i] > '9')
2205 return SCM_BOOL_F; /* bad exponent */
2206 do
2207 {
2208 switch (c = str[i])
2209 {
2210 case DIGITS:
2211 expon = expon * 10 + c - '0';
2212 if (expon > MAXEXP)
2213 return SCM_BOOL_F; /* exponent too large */
2214 break;
2215 default:
2216 goto out4;
2217 }
2218 }
2219 while (++i < len);
2220 out4:
2221 point += expsgn * expon;
0f2d19dd 2222 }
f872b822 2223 }
0f2d19dd
JB		 2224
2225 adjust:
2226 if (point >= 0)
f872b822
MD		 2227 while (point--)
2228 res *= 10.0;
0f2d19dd 2229 else
f872b822
MD		 2230#ifdef _UNICOS
2231 while (point++)
2232 res *= 0.1;
2233#else
2234 while (point++)
2235 res /= 10.0;
2236#endif
0f2d19dd
JB		 2237
2238 done:
2239 /* at this point, we have a legitimate floating point result */
f872b822
MD		 2240 if (lead_sgn == -1.0)
2241 res = -res;
2242 if (i == len)
2243 return scm_makdbl (res, 0.0);
2244
2245 if (str[i] == 'i' || str[i] == 'I')
2246 { /* pure imaginary number */
2247 if (lead_sgn == 0.0)
2248 return SCM_BOOL_F; /* must have leading sign */
2249 if (++i < len)
2250 return SCM_BOOL_F; /* `i' not last character */
2251 return scm_makdbl (0.0, res);
2252 }
0f2d19dd 2253
f872b822
MD		 2254 switch (str[i++])
2255 {
2256 case '-':
2257 lead_sgn = -1.0;
2258 break;
2259 case '+':
2260 lead_sgn = 1.0;
2261 break;
2262 case '@':
2263 { /* polar input for complex number */
2264 /* get a `real' for scm_angle */
2265 second = scm_istr2flo (&str[i], (long) (len - i), radix);
b4a204af 2266 if (!(SCM_NIMP (second) && SCM_INEXP (second)))
f872b822
MD		 2267 return SCM_BOOL_F; /* not `real' */
2268 if (SCM_CPLXP (second))
2269 return SCM_BOOL_F; /* not `real' */
2270 tmp = SCM_REALPART (second);
2271 return scm_makdbl (res * cos (tmp), res * sin (tmp));
2272 }
2273 default:
2274 return SCM_BOOL_F;
2275 }
0f2d19dd
JB		 2276
2277 /* at this point, last char must be `i' */
f872b822
MD		 2278 if (str[len - 1] != 'i' && str[len - 1] != 'I')
2279 return SCM_BOOL_F;
0f2d19dd 2280 /* handles `x+i' and `x-i' */
f872b822
MD		 2281 if (i == (len - 1))
2282 return scm_makdbl (res, lead_sgn);
0f2d19dd 2283 /* get a `ureal' for complex part */
f872b822 2284 second = scm_istr2flo (&str[i], (long) ((len - i) - 1), radix);
b4a204af 2285 if (! (SCM_NIMP (second) && SCM_INEXP (second)))
f872b822
MD		 2286 return SCM_BOOL_F; /* not `ureal' */
2287 if (SCM_CPLXP (second))
2288 return SCM_BOOL_F; /* not `ureal' */
2289 tmp = SCM_REALPART (second);
2290 if (tmp < 0.0)
2291 return SCM_BOOL_F; /* not `ureal' */
2292 return scm_makdbl (res, (lead_sgn * tmp));
0f2d19dd 2293}
f872b822 2294#endif /* SCM_FLOATS */
0f2d19dd
JB		 2295
2296
1cc91f1b 2297
0f2d19dd 2298SCM
1bbd0b84 2299scm_istring2number (char *str, long len, long radix)
0f2d19dd
JB		 2300{
2301 int i = 0;
2302 char ex = 0;
2303 char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
2304 SCM res;
f872b822
MD		 2305 if (len == 1)
2306 if (*str == '+' || *str == '-') /* Catches lone `+' and `-' for speed */
0f2d19dd
JB		 2307 return SCM_BOOL_F;
2308
f872b822
MD		 2309 while ((len - i) >= 2 && str[i] == '#' && ++i)
2310 switch (str[i++])
2311 {
2312 case 'b':
2313 case 'B':
2314 if (rx_p++)
2315 return SCM_BOOL_F;
2316 radix = 2;
2317 break;
2318 case 'o':
2319 case 'O':
2320 if (rx_p++)
2321 return SCM_BOOL_F;
2322 radix = 8;
2323 break;
2324 case 'd':
2325 case 'D':
2326 if (rx_p++)
2327 return SCM_BOOL_F;
2328 radix = 10;
2329 break;
2330 case 'x':
2331 case 'X':
2332 if (rx_p++)
2333 return SCM_BOOL_F;
2334 radix = 16;
2335 break;
2336 case 'i':
2337 case 'I':
2338 if (ex_p++)
2339 return SCM_BOOL_F;
2340 ex = 2;
2341 break;
2342 case 'e':
2343 case 'E':
2344 if (ex_p++)
2345 return SCM_BOOL_F;
2346 ex = 1;
2347 break;
2348 default:
2349 return SCM_BOOL_F;
2350 }
2351
2352 switch (ex)
2353 {
2354 case 1:
2355 return scm_istr2int (&str[i], len - i, radix);
2356 case 0:
2357 res = scm_istr2int (&str[i], len - i, radix);
2358 if (SCM_NFALSEP (res))
2359 return res;
0f2d19dd 2360#ifdef SCM_FLOATS
f872b822
MD		 2361 case 2:
2362 return scm_istr2flo (&str[i], len - i, radix);
0f2d19dd 2363#endif
f872b822 2364 }
0f2d19dd
JB		 2365 return SCM_BOOL_F;
2366}
2367
2368
1bbd0b84
GB		 2369GUILE_PROC (scm_string_to_number, "string->number", 1, 1, 0,
2370 (SCM str, SCM radix),
2371"")
2372#define FUNC_NAME s_scm_string_to_number
0f2d19dd
JB		 2373{
2374 SCM answer;
1bbd0b84
GB		 2375 int base;
2376 SCM_VALIDATE_ROSTRING(1,str);
2377 SCM_VALIDATE_INT_MIN_DEF_COPY(2,radix,2,10,base);
f872b822
MD		 2378 answer = scm_istring2number (SCM_ROCHARS (str),
2379 SCM_ROLENGTH (str),
1bbd0b84 2380 base);
0f2d19dd
JB		 2381 return scm_return_first (answer, str);
2382}
1bbd0b84 2383#undef FUNC_NAME
0f2d19dd
JB		 2384/*** END strs->nums ***/
2385
2386#ifdef SCM_FLOATS
1cc91f1b 2387
0f2d19dd 2388SCM
1bbd0b84 2389scm_makdbl (double x, double y)
0f2d19dd
JB		 2390{
2391 SCM z;
f872b822
MD		 2392 if ((y == 0.0) && (x == 0.0))
2393 return scm_flo0;
0f2d19dd 2394 SCM_DEFER_INTS;
f872b822
MD		 2395 if (y == 0.0)
2396 {
2397#ifdef SCM_SINGLES
2398 float fx = x;
2399#ifndef SCM_SINGLESONLY
2400 if ((-FLTMAX < x) && (x < FLTMAX) && (fx == x))
2401#endif
2402 {
23a62151 2403 SCM_NEWSMOB(z,scm_tc_flo,NULL);
f872b822
MD		 2404 SCM_FLO (z) = x;
2405 SCM_ALLOW_INTS;
2406 return z;
2407 }
2408#endif /* def SCM_SINGLES */
23a62151 2409 SCM_NEWSMOB(z,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
f872b822
MD		 2410 }
2411 else
2412 {
23a62151 2413 SCM_NEWSMOB(z,scm_tc_dblc,scm_must_malloc (2L * sizeof (double), "comkplex"));
a7c930f1 2414 SCM_IMAG (z) = y;
f872b822
MD		 2415 }
2416 SCM_REAL (z) = x;
0f2d19dd
JB		 2417 SCM_ALLOW_INTS;
2418 return z;
2419}
2420#endif
2421
2422
1cc91f1b 2423
0f2d19dd 2424SCM
1bbd0b84 2425scm_bigequal (SCM x, SCM y)
0f2d19dd
JB		 2426{
2427#ifdef SCM_BIGDIG
f872b822
MD		 2428 if (0 == scm_bigcomp (x, y))
2429 return SCM_BOOL_T;
0f2d19dd
JB		 2430#endif
2431 return SCM_BOOL_F;
2432}
2433
2434
1cc91f1b 2435
0f2d19dd 2436SCM
1bbd0b84 2437scm_floequal (SCM x, SCM y)
0f2d19dd
JB		 2438{
2439#ifdef SCM_FLOATS
f872b822
MD		 2440 if (SCM_REALPART (x) != SCM_REALPART (y))
2441 return SCM_BOOL_F;
2442 if (!(SCM_CPLXP (x) && (SCM_IMAG (x) != SCM_IMAG (y))))
2443 return SCM_BOOL_T;
0f2d19dd
JB		 2444#endif
2445 return SCM_BOOL_F;
2446}
2447
2448
2449
2450
1bbd0b84 2451SCM_REGISTER_PROC (s_number_p, "number?", 1, 0, 0, scm_number_p);
1cc91f1b 2452
1bbd0b84
GB		 2453GUILE_PROC (scm_number_p, "complex?", 1, 0, 0,
2454 (SCM x),
2455"")
2456#define FUNC_NAME s_scm_number_p
0f2d19dd 2457{
f872b822
MD		 2458 if (SCM_INUMP (x))
2459 return SCM_BOOL_T;
0f2d19dd 2460#ifdef SCM_FLOATS
f872b822
MD		 2461 if (SCM_NIMP (x) && SCM_NUMP (x))
2462 return SCM_BOOL_T;
0f2d19dd 2463#else
f872b822
MD		 2464#ifdef SCM_BIGDIG
2465 if (SCM_NIMP (x) && SCM_NUMP (x))
2466 return SCM_BOOL_T;
2467#endif
0f2d19dd
JB		 2468#endif
2469 return SCM_BOOL_F;
2470}
1bbd0b84 2471#undef FUNC_NAME
0f2d19dd
JB		 2472
2473
2474
2475#ifdef SCM_FLOATS
1bbd0b84 2476SCM_REGISTER_PROC (s_real_p, "real?", 1, 0, 0, scm_real_p);
1cc91f1b 2477
1bbd0b84
GB		 2478
2479GUILE_PROC (scm_real_p, "rational?", 1, 0, 0,
2480 (SCM x),
2481"")
2482#define FUNC_NAME s_scm_real_p
0f2d19dd 2483{
f872b822 2484 if (SCM_INUMP (x))
0f2d19dd 2485 return SCM_BOOL_T;
f872b822 2486 if (SCM_IMP (x))
0f2d19dd 2487 return SCM_BOOL_F;
f872b822 2488 if (SCM_REALP (x))
0f2d19dd 2489 return SCM_BOOL_T;
f872b822
MD		 2490#ifdef SCM_BIGDIG
2491 if (SCM_BIGP (x))
0f2d19dd 2492 return SCM_BOOL_T;
f872b822 2493#endif
0f2d19dd
JB		 2494 return SCM_BOOL_F;
2495}
1bbd0b84 2496#undef FUNC_NAME
0f2d19dd
JB		 2497
2498
2499
1bbd0b84
GB		 2500GUILE_PROC (scm_integer_p, "integer?", 1, 0, 0,
2501 (SCM x),
2502"")
2503#define FUNC_NAME s_scm_integer_p
0f2d19dd
JB		 2504{
2505 double r;
f872b822
MD		 2506 if (SCM_INUMP (x))
2507 return SCM_BOOL_T;
2508 if (SCM_IMP (x))
2509 return SCM_BOOL_F;
2510#ifdef SCM_BIGDIG
2511 if (SCM_BIGP (x))
2512 return SCM_BOOL_T;
2513#endif
2514 if (!SCM_INEXP (x))
2515 return SCM_BOOL_F;
2516 if (SCM_CPLXP (x))
2517 return SCM_BOOL_F;
2518 r = SCM_REALPART (x);
2519 if (r == floor (r))
2520 return SCM_BOOL_T;
0f2d19dd
JB		 2521 return SCM_BOOL_F;
2522}
1bbd0b84 2523#undef FUNC_NAME
0f2d19dd
JB		 2524
2525
2526
f872b822 2527#endif /* SCM_FLOATS */
0f2d19dd 2528
1bbd0b84
GB		 2529GUILE_PROC (scm_inexact_p, "inexact?", 1, 0, 0,
2530 (SCM x),
2531"")
2532#define FUNC_NAME s_scm_inexact_p
0f2d19dd
JB		 2533{
2534#ifdef SCM_FLOATS
f872b822
MD		 2535 if (SCM_NIMP (x) && SCM_INEXP (x))
2536 return SCM_BOOL_T;
0f2d19dd
JB		 2537#endif
2538 return SCM_BOOL_F;
2539}
1bbd0b84 2540#undef FUNC_NAME
0f2d19dd
JB		 2541
2542
2543
2544
152f82bf 2545SCM_GPROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p, g_eq_p);
1cc91f1b 2546
0f2d19dd 2547SCM
6e8d25a6 2548scm_num_eq_p (SCM x, SCM y)
0f2d19dd
JB		 2549{
2550#ifdef SCM_FLOATS
2551 SCM t;
f872b822
MD		 2552 if (SCM_NINUMP (x))
2553 {
2554#ifdef SCM_BIGDIG
f872b822
MD		 2555 if (!(SCM_NIMP (x)))
2556 {
2557 badx:
152f82bf 2558 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p);
f872b822 2559 }
f872b822
MD		 2560 if (SCM_BIGP (x))
2561 {
2562 if (SCM_INUMP (y))
2563 return SCM_BOOL_F;
2564 SCM_ASRTGO (SCM_NIMP (y), bady);
2565 if (SCM_BIGP (y))
156dcb09 2566 return SCM_BOOL(0 == scm_bigcomp (x, y));
f872b822
MD		 2567 SCM_ASRTGO (SCM_INEXP (y), bady);
2568 bigreal:
2569 return ((SCM_REALP (y) && (scm_big2dbl (x) == SCM_REALPART (y)))
2570 ? SCM_BOOL_T
2571 : SCM_BOOL_F);
2572 }
2573 SCM_ASRTGO (SCM_INEXP (x), badx);
0f2d19dd 2574#else
152f82bf
MD		 2575 SCM_GASSERT2 (SCM_NIMP (x) && SCM_INEXP (x),
2576 g_eq_p, x, y, SCM_ARG1, s_eq_p);
f872b822
MD		 2577#endif
2578 if (SCM_INUMP (y))
2579 {
2580 t = x;
2581 x = y;
2582 y = t;
2583 goto realint;
2584 }
2585#ifdef SCM_BIGDIG
2586 SCM_ASRTGO (SCM_NIMP (y), bady);
2587 if (SCM_BIGP (y))
2588 {
2589 t = x;
2590 x = y;
2591 y = t;
2592 goto bigreal;
2593 }
2594 SCM_ASRTGO (SCM_INEXP (y), bady);
2595#else
2596 SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
2597#endif
2598 if (SCM_REALPART (x) != SCM_REALPART (y))
2599 return SCM_BOOL_F;
2600 if (SCM_CPLXP (x))
2601 return ((SCM_CPLXP (y) && (SCM_IMAG (x) == SCM_IMAG (y)))
2602 ? SCM_BOOL_T
2603 : SCM_BOOL_F);
156dcb09 2604 return SCM_NEGATE_BOOL(SCM_CPLXP (y));
f872b822
MD		 2605 }
2606 if (SCM_NINUMP (y))
2607 {
2608#ifdef SCM_BIGDIG
2609 SCM_ASRTGO (SCM_NIMP (y), bady);
2610 if (SCM_BIGP (y))
2611 return SCM_BOOL_F;
f872b822
MD		 2612 if (!(SCM_INEXP (y)))
2613 {
2614 bady:
152f82bf 2615 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2616 }
f872b822 2617#else
f872b822
MD		 2618 if (!(SCM_NIMP (y) && SCM_INEXP (y)))
2619 {
2620 bady:
152f82bf 2621 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2622 }
f872b822
MD		 2623#endif
2624 realint:
2625 return ((SCM_REALP (y) && (((double) SCM_INUM (x)) == SCM_REALPART (y)))
2626 ? SCM_BOOL_T
2627 : SCM_BOOL_F);
2628 }
2629#else
2630#ifdef SCM_BIGDIG
2631 if (SCM_NINUMP (x))
2632 {
152f82bf
MD		 2633 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
2634 g_eq_p, x, y, SCM_ARG1, s_eq_p);
f872b822
MD		 2635 if (SCM_INUMP (y))
2636 return SCM_BOOL_F;
2637 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
156dcb09 2638 return SCM_BOOL(0 == scm_bigcomp (x, y));
f872b822
MD		 2639 }
2640 if (SCM_NINUMP (y))
2641 {
f872b822
MD		 2642 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
2643 {
2644 bady:
152f82bf 2645 SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p);
f872b822 2646 }
f872b822
MD		 2647 return SCM_BOOL_F;
2648 }
2649#else
152f82bf
MD		 2650 SCM_GASSERT2 (SCM_INUMP (x), g_eq_p, x, y, SCM_ARG1, s_eq_p);
2651 SCM_GASSERT2 (SCM_INUMP (y), g_eq_p, x, y, SCM_ARGn, s_eq_p);
0f2d19dd 2652#endif
f872b822 2653#endif
156dcb09 2654 return SCM_BOOL((long) x == (long) y);
0f2d19dd
JB		 2655}
2656
2657
2658
152f82bf 2659SCM_GPROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p, g_less_p);
1cc91f1b 2660
0f2d19dd 2661SCM
6e8d25a6 2662scm_less_p (SCM x, SCM y)
0f2d19dd
JB		 2663{
2664#ifdef SCM_FLOATS
f872b822
MD		 2665 if (SCM_NINUMP (x))
2666 {
2667#ifdef SCM_BIGDIG
f872b822
MD		 2668 if (!(SCM_NIMP (x)))
2669 {
2670 badx:
152f82bf 2671 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p);
f872b822 2672 }
f872b822
MD		 2673 if (SCM_BIGP (x))
2674 {
2675 if (SCM_INUMP (y))
156dcb09 2676 return SCM_BOOL(SCM_BIGSIGN (x));
f872b822
MD		 2677 SCM_ASRTGO (SCM_NIMP (y), bady);
2678 if (SCM_BIGP (y))
156dcb09 2679 return SCM_BOOL(1 == scm_bigcomp (x, y));
f872b822
MD		 2680 SCM_ASRTGO (SCM_REALP (y), bady);
2681 return ((scm_big2dbl (x) < SCM_REALPART (y))
2682 ? SCM_BOOL_T
2683 : SCM_BOOL_F);
2684 }
2685 SCM_ASRTGO (SCM_REALP (x), badx);
0f2d19dd 2686#else
152f82bf
MD		 2687 SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
2688 g_less_p, x, y, SCM_ARG1, s_less_p);
f872b822
MD		 2689#endif
2690 if (SCM_INUMP (y))
2691 return ((SCM_REALPART (x) < ((double) SCM_INUM (y)))
2692 ? SCM_BOOL_T
2693 : SCM_BOOL_F);
2694#ifdef SCM_BIGDIG
2695 SCM_ASRTGO (SCM_NIMP (y), bady);
2696 if (SCM_BIGP (y))
156dcb09 2697 return SCM_BOOL(SCM_REALPART (x) < scm_big2dbl (y));
f872b822
MD		 2698 SCM_ASRTGO (SCM_REALP (y), bady);
2699#else
2700 SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
2701#endif
156dcb09 2702 return SCM_BOOL(SCM_REALPART (x) < SCM_REALPART (y));
f872b822
MD		 2703 }
2704 if (SCM_NINUMP (y))
2705 {
2706#ifdef SCM_BIGDIG
2707 SCM_ASRTGO (SCM_NIMP (y), bady);
2708 if (SCM_BIGP (y))
156dcb09 2709 return SCM_NEGATE_BOOL(SCM_BIGSIGN (y));
f872b822
MD		 2710 if (!(SCM_REALP (y)))
2711 {
2712 bady:
152f82bf 2713 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2714 }
f872b822 2715#else
f872b822
MD		 2716 if (!(SCM_NIMP (y) && SCM_REALP (y)))
2717 {
2718 bady:
152f82bf 2719 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2720 }
f872b822
MD		 2721#endif
2722 return ((((double) SCM_INUM (x)) < SCM_REALPART (y))
2723 ? SCM_BOOL_T
2724 : SCM_BOOL_F);
2725 }
2726#else
2727#ifdef SCM_BIGDIG
2728 if (SCM_NINUMP (x))
2729 {
152f82bf
MD		 2730 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
2731 g_less_p, x, y, SCM_ARG1, s_less_p);
f872b822 2732 if (SCM_INUMP (y))
156dcb09 2733 return SCM_BOOL(SCM_BIGSIGN (x));
f872b822 2734 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
156dcb09 2735 return SCM_BOOL(1 == scm_bigcomp (x, y));
f872b822
MD		 2736 }
2737 if (SCM_NINUMP (y))
2738 {
f872b822
MD		 2739 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
2740 {
2741 bady:
152f82bf 2742 SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p);
f872b822 2743 }
156dcb09 2744 return SCM_NEGATE_BOOL(SCM_BIGSIGN (y));
f872b822
MD		 2745 }
2746#else
152f82bf
MD		 2747 SCM_GASSERT2 (SCM_INUMP (x), g_less_p, x, y, SCM_ARG1, s_less_p);
2748 SCM_GASSERT2 (SCM_INUMP (y), g_less_p, x, y, SCM_ARGn, s_less_p);
0f2d19dd 2749#endif
f872b822 2750#endif
156dcb09 2751 return SCM_BOOL((long) x < (long) y);
0f2d19dd
JB		 2752}
2753
2754
1bbd0b84
GB		 2755GUILE_PROC1 (scm_gr_p, ">", scm_tc7_rpsubr,
2756 (SCM x, SCM y),
2757"")
2758#define FUNC_NAME s_scm_gr_p
0f2d19dd 2759{
f872b822 2760 return scm_less_p (y, x);
0f2d19dd 2761}
1bbd0b84 2762#undef FUNC_NAME
0f2d19dd
JB		 2763
2764
2765
1bbd0b84
GB		 2766GUILE_PROC1 (scm_leq_p, "<=", scm_tc7_rpsubr,
2767 (SCM x, SCM y),
2768"")
2769#define FUNC_NAME s_scm_leq_p
0f2d19dd 2770{
f872b822 2771 return SCM_BOOL_NOT (scm_less_p (y, x));
0f2d19dd 2772}
1bbd0b84 2773#undef FUNC_NAME
0f2d19dd
JB		 2774
2775
2776
1bbd0b84
GB		 2777GUILE_PROC1 (scm_geq_p, ">=", scm_tc7_rpsubr,
2778 (SCM x, SCM y),
2779"")
2780#define FUNC_NAME s_scm_geq_p
0f2d19dd 2781{
f872b822 2782 return SCM_BOOL_NOT (scm_less_p (x, y));
0f2d19dd 2783}
1bbd0b84 2784#undef FUNC_NAME
0f2d19dd
JB		 2785
2786
2787
152f82bf 2788SCM_GPROC (s_zero_p, "zero?", 1, 0, 0, scm_zero_p, g_zero_p);
1cc91f1b 2789
0f2d19dd 2790SCM
6e8d25a6 2791scm_zero_p (SCM z)
0f2d19dd
JB		 2792{
2793#ifdef SCM_FLOATS
f872b822
MD		 2794 if (SCM_NINUMP (z))
2795 {
2796#ifdef SCM_BIGDIG
2797 SCM_ASRTGO (SCM_NIMP (z), badz);
2798 if (SCM_BIGP (z))
2799 return SCM_BOOL_F;
f872b822
MD		 2800 if (!(SCM_INEXP (z)))
2801 {
2802 badz:
152f82bf 2803 SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p);
f872b822 2804 }
0f2d19dd 2805#else
152f82bf
MD		 2806 SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
2807 g_zero_p, z, SCM_ARG1, s_zero_p);
f872b822 2808#endif
156dcb09 2809 return SCM_BOOL(z == scm_flo0);
f872b822
MD		 2810 }
2811#else
2812#ifdef SCM_BIGDIG
2813 if (SCM_NINUMP (z))
2814 {
152f82bf
MD		 2815 SCM_GASSERT1 (SCM_NIMP (z) && SCM_BIGP (z),
2816 g_zero_p, z, SCM_ARG1, s_zero_p);
f872b822
MD		 2817 return SCM_BOOL_F;
2818 }
2819#else
152f82bf 2820 SCM_GASSERT1 (SCM_INUMP (z), g_zero_p, z, SCM_ARG1, s_zero_p);
0f2d19dd 2821#endif
f872b822 2822#endif
156dcb09 2823 return SCM_BOOL(z == SCM_INUM0);
0f2d19dd
JB		 2824}
2825
2826
2827
152f82bf 2828SCM_GPROC (s_positive_p, "positive?", 1, 0, 0, scm_positive_p, g_positive_p);
1cc91f1b 2829
0f2d19dd 2830SCM
6e8d25a6 2831scm_positive_p (SCM x)
0f2d19dd
JB		 2832{
2833#ifdef SCM_FLOATS
f872b822
MD		 2834 if (SCM_NINUMP (x))
2835 {
2836#ifdef SCM_BIGDIG
2837 SCM_ASRTGO (SCM_NIMP (x), badx);
2838 if (SCM_BIGP (x))
156dcb09 2839 return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
f872b822
MD		 2840 if (!(SCM_REALP (x)))
2841 {
2842 badx:
152f82bf 2843 SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p);
f872b822 2844 }
0f2d19dd 2845#else
152f82bf
MD		 2846 SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
2847 g_positive_p, x, SCM_ARG1, s_positive_p);
f872b822 2848#endif
156dcb09 2849 return SCM_BOOL(SCM_REALPART (x) > 0.0);
f872b822
MD		 2850 }
2851#else
2852#ifdef SCM_BIGDIG
2853 if (SCM_NINUMP (x))
2854 {
152f82bf
MD		 2855 SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
2856 g_positive_p, x, SCM_ARG1, s_positive_p);
156dcb09 2857 return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
f872b822
MD		 2858 }
2859#else
152f82bf 2860 SCM_GASSERT1 (SCM_INUMP (x), g_positive_p, x, SCM_ARG1, s_positive_p);
f872b822 2861#endif
0f2d19dd 2862#endif
156dcb09 2863 return SCM_BOOL(x > SCM_INUM0);
0f2d19dd
JB		 2864}
2865
2866
2867
152f82bf 2868SCM_GPROC (s_negative_p, "negative?", 1, 0, 0, scm_negative_p, g_negative_p);
1cc91f1b 2869
0f2d19dd 2870SCM
6e8d25a6 2871scm_negative_p (SCM x)
0f2d19dd
JB		 2872{
2873#ifdef SCM_FLOATS
f872b822
MD		 2874 if (SCM_NINUMP (x))
2875 {
2876#ifdef SCM_BIGDIG
2877 SCM_ASRTGO (SCM_NIMP (x), badx);
2878 if (SCM_BIGP (x))
156dcb09 2879 return SCM_NEGATE_BOOL(SCM_TYP16 (x) == scm_tc16_bigpos);
f872b822
MD		 2880 if (!(SCM_REALP (x)))
2881 {
2882 badx:
152f82bf 2883 SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p);
f872b822 2884 }
0f2d19dd 2885#else
152f82bf
MD		 2886 SCM_GASSERT1 (SCM_NIMP (x) && SCM_REALP (x),
2887 g_negative_p, x, SCM_ARG1, s_negative_p);
0f2d19dd 2888#endif
156dcb09 2889 return SCM_BOOL(SCM_REALPART (x) < 0.0);
f872b822
MD		 2890 }
2891#else
2892#ifdef SCM_BIGDIG
2893 if (SCM_NINUMP (x))
2894 {
152f82bf
MD		 2895 SCM_GASSERT1 (SCM_NIMP (x) && SCM_BIGP (x),
2896 g_negative_p, x, SCM_ARG1, s_negative_p);
156dcb09 2897 return SCM_BOOL(SCM_TYP16 (x) == scm_tc16_bigneg);
f872b822
MD		 2898 }
2899#else
152f82bf 2900 SCM_GASSERT1 (SCM_INUMP (x), g_negative_p, x, SCM_ARG1, s_negative_p);
f872b822
MD		 2901#endif
2902#endif
156dcb09 2903 return SCM_BOOL(x < SCM_INUM0);
0f2d19dd
JB		 2904}
2905
2906
9de33deb 2907SCM_GPROC1 (s_max, "max", scm_tc7_asubr, scm_max, g_max);
1cc91f1b 2908
0f2d19dd 2909SCM
6e8d25a6 2910scm_max (SCM x, SCM y)
0f2d19dd
JB		 2911{
2912#ifdef SCM_FLOATS
2913 double z;
2914#endif
f872b822
MD		 2915 if (SCM_UNBNDP (y))
2916 {
73ef98d6
MD		 2917 SCM_GASSERT0 (!SCM_UNBNDP (x),
2918 g_max, scm_makfrom0str (s_max), SCM_WNA, 0);
0e3aa89f 2919 SCM_GASSERT1 (SCM_NUMBERP (x), g_max, x, SCM_ARG1, s_max);
f872b822
MD		 2920 return x;
2921 }
0f2d19dd 2922#ifdef SCM_FLOATS
f872b822
MD		 2923 if (SCM_NINUMP (x))
2924 {
2925#ifdef SCM_BIGDIG
0e3aa89f
MD		 2926 if (!SCM_NIMP (x))
2927 {
2928 badx2:
2929 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max);
2930 }
f872b822
MD		 2931 if (SCM_BIGP (x))
2932 {
2933 if (SCM_INUMP (y))
2934 return SCM_BIGSIGN (x) ? y : x;
2935 SCM_ASRTGO (SCM_NIMP (y), bady);
2936 if (SCM_BIGP (y))
2937 return (1 == scm_bigcomp (x, y)) ? y : x;
2938 SCM_ASRTGO (SCM_REALP (y), bady);
2939 z = scm_big2dbl (x);
2940 return (z < SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
2941 }
0e3aa89f 2942 SCM_ASRTGO (SCM_REALP (x), badx2);
0f2d19dd 2943#else
9de33deb
MD		 2944 SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
2945 g_max, x, y, SCM_ARG1, s_max);
f872b822
MD		 2946#endif
2947 if (SCM_INUMP (y))
2948 return ((SCM_REALPART (x) < (z = SCM_INUM (y)))
2949 ? scm_makdbl (z, 0.0)
2950 : x);
2951#ifdef SCM_BIGDIG
2952 SCM_ASRTGO (SCM_NIMP (y), bady);
2953 if (SCM_BIGP (y))
2954 return ((SCM_REALPART (x) < (z = scm_big2dbl (y)))
2955 ? scm_makdbl (z, 0.0)
2956 : x);
2957 SCM_ASRTGO (SCM_REALP (y), bady);
2958#else
2959 SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
2960#endif
2961 return (SCM_REALPART (x) < SCM_REALPART (y)) ? y : x;
2962 }
2963 if (SCM_NINUMP (y))
2964 {
2965#ifdef SCM_BIGDIG
2966 SCM_ASRTGO (SCM_NIMP (y), bady);
2967 if (SCM_BIGP (y))
2968 return SCM_BIGSIGN (y) ? x : y;
f872b822
MD		 2969 if (!(SCM_REALP (y)))
2970 {
2971 bady:
9de33deb 2972 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 2973 }
f872b822 2974#else
f872b822
MD		 2975 if (!(SCM_NIMP (y) && SCM_REALP (y)))
2976 {
2977 bady:
9de33deb 2978 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 2979 }
f872b822
MD		 2980#endif
2981 return (((z = SCM_INUM (x)) < SCM_REALPART (y))
2982 ? y
2983 : scm_makdbl (z, 0.0));
2984 }
2985#else
2986#ifdef SCM_BIGDIG
2987 if (SCM_NINUMP (x))
2988 {
9de33deb
MD		 2989 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
2990 g_max, x, y, SCM_ARG1, s_max);
f872b822
MD		 2991 if (SCM_INUMP (y))
2992 return SCM_BIGSIGN (x) ? y : x;
2993 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
2994 return (1 == scm_bigcomp (x, y)) ? y : x;
2995 }
2996 if (SCM_NINUMP (y))
2997 {
f872b822
MD		 2998 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
2999 {
3000 bady:
9de33deb 3001 SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max);
f872b822 3002 }
f872b822
MD		 3003 return SCM_BIGSIGN (y) ? x : y;
3004 }
3005#else
9de33deb
MD		 3006 SCM_GASSERT2 (SCM_INUMP (x), g_max, x, y, SCM_ARG1, s_max);
3007 SCM_GASSERT2 (SCM_INUMP (y), g_max, x, y, SCM_ARGn, s_max);
f872b822
MD		 3008#endif
3009#endif
3010 return ((long) x < (long) y) ? y : x;
0f2d19dd
JB		 3011}
3012
3013
3014
3015
9de33deb 3016SCM_GPROC1 (s_min, "min", scm_tc7_asubr, scm_min, g_min);
1cc91f1b 3017
0f2d19dd 3018SCM
6e8d25a6 3019scm_min (SCM x, SCM y)
0f2d19dd
JB		 3020{
3021#ifdef SCM_FLOATS
3022 double z;
3023#endif
f872b822
MD		 3024 if (SCM_UNBNDP (y))
3025 {
73ef98d6
MD		 3026 SCM_GASSERT0 (!SCM_UNBNDP (x),
3027 g_min, scm_makfrom0str (s_min), SCM_WNA, 0);
0e3aa89f 3028 SCM_GASSERT1 (SCM_NUMBERP (x), g_min, x, SCM_ARG1, s_min);
f872b822
MD		 3029 return x;
3030 }
0f2d19dd 3031#ifdef SCM_FLOATS
f872b822
MD		 3032 if (SCM_NINUMP (x))
3033 {
3034#ifdef SCM_BIGDIG
0e3aa89f
MD		 3035 if (!(SCM_NIMP (x)))
3036 {
3037 badx2:
3038 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min);
3039 }
f872b822
MD		 3040 if (SCM_BIGP (x))
3041 {
3042 if (SCM_INUMP (y))
3043 return SCM_BIGSIGN (x) ? x : y;
3044 SCM_ASRTGO (SCM_NIMP (y), bady);
3045 if (SCM_BIGP (y))
3046 return (-1 == scm_bigcomp (x, y)) ? y : x;
3047 SCM_ASRTGO (SCM_REALP (y), bady);
3048 z = scm_big2dbl (x);
3049 return (z > SCM_REALPART (y)) ? y : scm_makdbl (z, 0.0);
3050 }
0e3aa89f 3051 SCM_ASRTGO (SCM_REALP (x), badx2);
0f2d19dd 3052#else
9de33deb
MD		 3053 SCM_GASSERT2 (SCM_NIMP (x) && SCM_REALP (x),
3054 g_min, x, y, SCM_ARG1, s_min);
f872b822
MD		 3055#endif
3056 if (SCM_INUMP (y))
3057 return ((SCM_REALPART (x) > (z = SCM_INUM (y)))
3058 ? scm_makdbl (z, 0.0)
3059 : x);
3060#ifdef SCM_BIGDIG
3061 SCM_ASRTGO (SCM_NIMP (y), bady);
3062 if (SCM_BIGP (y))
3063 return ((SCM_REALPART (x) > (z = scm_big2dbl (y)))
3064 ? scm_makdbl (z, 0.0)
3065 : x);
3066 SCM_ASRTGO (SCM_REALP (y), bady);
3067#else
3068 SCM_ASRTGO (SCM_NIMP (y) && SCM_REALP (y), bady);
3069#endif
3070 return (SCM_REALPART (x) > SCM_REALPART (y)) ? y : x;
3071 }
3072 if (SCM_NINUMP (y))
3073 {
3074#ifdef SCM_BIGDIG
3075 SCM_ASRTGO (SCM_NIMP (y), bady);
3076 if (SCM_BIGP (y))
3077 return SCM_BIGSIGN (y) ? y : x;
f872b822
MD		 3078 if (!(SCM_REALP (y)))
3079 {
3080 bady:
9de33deb 3081 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3082 }
f872b822 3083#else
f872b822
MD		 3084 if (!(SCM_NIMP (y) && SCM_REALP (y)))
3085 {
3086 bady:
9de33deb 3087 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3088 }
0f2d19dd 3089#endif
f872b822
MD		 3090 return (((z = SCM_INUM (x)) > SCM_REALPART (y))
3091 ? y
3092 : scm_makdbl (z, 0.0));
3093 }
3094#else
3095#ifdef SCM_BIGDIG
3096 if (SCM_NINUMP (x))
3097 {
9de33deb
MD		 3098 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3099 g_min, x, y, SCM_ARG1, s_min);
f872b822
MD		 3100 if (SCM_INUMP (y))
3101 return SCM_BIGSIGN (x) ? x : y;
3102 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3103 return (-1 == scm_bigcomp (x, y)) ? y : x;
3104 }
3105 if (SCM_NINUMP (y))
3106 {
f872b822
MD		 3107 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3108 {
3109 bady:
9de33deb 3110 SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min);
f872b822 3111 }
f872b822
MD		 3112 return SCM_BIGSIGN (y) ? y : x;
3113 }
3114#else
9de33deb
MD		 3115 SCM_GASSERT2 (SCM_INUMP (x), g_min, x, y, SCM_ARG1, s_min);
3116 SCM_GASSERT2 (SCM_INUMP (y), g_min, x, y, SCM_ARGn, s_min);
f872b822
MD		 3117#endif
3118#endif
3119 return ((long) x > (long) y) ? y : x;
0f2d19dd
JB		 3120}
3121
3122
3123
3124
9de33deb 3125SCM_GPROC1 (s_sum, "+", scm_tc7_asubr, scm_sum, g_sum);
1cc91f1b 3126
0f2d19dd 3127SCM
6e8d25a6 3128scm_sum (SCM x, SCM y)
0f2d19dd 3129{
f872b822
MD		 3130 if (SCM_UNBNDP (y))
3131 {
3132 if (SCM_UNBNDP (x))
3133 return SCM_INUM0;
0e3aa89f 3134 SCM_GASSERT1 (SCM_NUMBERP (x), g_sum, x, SCM_ARG1, s_sum);
f872b822
MD		 3135 return x;
3136 }
0f2d19dd 3137#ifdef SCM_FLOATS
f872b822
MD		 3138 if (SCM_NINUMP (x))
3139 {
3140 SCM t;
3141#ifdef SCM_BIGDIG
0e3aa89f
MD		 3142 if (!SCM_NIMP (x))
3143 {
3144 badx2:
3145 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum);
3146 }
f872b822
MD		 3147 if (SCM_BIGP (x))
3148 {
3149 if (SCM_INUMP (y))
3150 {
3151 t = x;
3152 x = y;
3153 y = t;
3154 goto intbig;
3155 }
3156 SCM_ASRTGO (SCM_NIMP (y), bady);
3157 if (SCM_BIGP (y))
3158 {
3159 if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3160 {
3161 t = x;
3162 x = y;
3163 y = t;
3164 }
3165 return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3166 SCM_BIGSIGN (x),
3167 y, 0);
3168 }
3169 SCM_ASRTGO (SCM_INEXP (y), bady);
3170 bigreal:
3171 return scm_makdbl (scm_big2dbl (x) + SCM_REALPART (y),
3172 SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3173 }
0e3aa89f 3174 SCM_ASRTGO (SCM_INEXP (x), badx2);
f872b822 3175#else
0e3aa89f 3176 SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
f872b822
MD		 3177#endif
3178 if (SCM_INUMP (y))
3179 {
3180 t = x;
3181 x = y;
3182 y = t;
3183 goto intreal;
3184 }
3185#ifdef SCM_BIGDIG
3186 SCM_ASRTGO (SCM_NIMP (y), bady);
3187 if (SCM_BIGP (y))
3188 {
3189 t = x;
3190 x = y;
3191 y = t;
3192 goto bigreal;
3193 }
f872b822
MD		 3194 else if (!(SCM_INEXP (y)))
3195 {
3196 bady:
9de33deb 3197 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3198 }
f872b822 3199#else
f872b822
MD		 3200 if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3201 {
3202 bady:
9de33deb 3203 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3204 }
f872b822
MD		 3205#endif
3206 {
3207 double i = 0.0;
3208 if (SCM_CPLXP (x))
3209 i = SCM_IMAG (x);
3210 if (SCM_CPLXP (y))
3211 i += SCM_IMAG (y);
3212 return scm_makdbl (SCM_REALPART (x) + SCM_REALPART (y), i);
0f2d19dd 3213 }
f872b822
MD		 3214 }
3215 if (SCM_NINUMP (y))
3216 {
3217#ifdef SCM_BIGDIG
3218 SCM_ASRTGO (SCM_NIMP (y), bady);
3219 if (SCM_BIGP (y))
3220 {
3221 intbig:
3222 {
3223#ifndef SCM_DIGSTOOBIG
3224 long z = scm_pseudolong (SCM_INUM (x));
3225 return scm_addbig ((SCM_BIGDIG *) & z,
3226 SCM_DIGSPERLONG,
3227 (x < 0) ? 0x0100 : 0,
3228 y, 0);
0f2d19dd 3229#else
f872b822
MD		 3230 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3231 scm_longdigs (SCM_INUM (x), zdigs);
3232 return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3233 y, 0);
3234#endif
3235 }
3236 }
3237 SCM_ASRTGO (SCM_INEXP (y), bady);
3238#else
3239 SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3240#endif
3241 intreal:
3242 return scm_makdbl (SCM_INUM (x) + SCM_REALPART (y),
3243 SCM_CPLXP (y) ? SCM_IMAG (y) : 0.0);
3244 }
3245#else
3246#ifdef SCM_BIGDIG
3247 if (SCM_NINUMP (x))
3248 {
3249 SCM t;
0e3aa89f 3250 SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
f872b822
MD		 3251 if (SCM_INUMP (y))
3252 {
3253 t = x;
3254 x = y;
3255 y = t;
3256 goto intbig;
3257 }
3258 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3259 if (SCM_NUMDIGS (x) > SCM_NUMDIGS (y))
3260 {
3261 t = x;
3262 x = y;
3263 y = t;
3264 }
3265 return scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3266 y, 0);
3267 }
3268 if (SCM_NINUMP (y))
3269 {
f872b822
MD		 3270 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3271 {
3272 bady:
9de33deb 3273 SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum);
f872b822 3274 }
f872b822
MD		 3275 intbig:
3276 {
3277#ifndef SCM_DIGSTOOBIG
3278 long z = scm_pseudolong (SCM_INUM (x));
3279 return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3280#else
3281 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3282 scm_longdigs (SCM_INUM (x), zdigs);
3283 return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
3284#endif
3285 }
3286 }
3287#else
0e3aa89f 3288 SCM_ASRTGO (SCM_INUMP (x), badx2);
9de33deb 3289 SCM_GASSERT2 (SCM_INUMP (y), g_sum, x, y, SCM_ARGn, s_sum);
f872b822
MD		 3290#endif
3291#endif
3292 x = SCM_INUM (x) + SCM_INUM (y);
3293 if (SCM_FIXABLE (x))
3294 return SCM_MAKINUM (x);
0f2d19dd 3295#ifdef SCM_BIGDIG
f872b822
MD		 3296 return scm_long2big (x);
3297#else
3298#ifdef SCM_FLOATS
3299 return scm_makdbl ((double) x, 0.0);
0f2d19dd 3300#else
52859adf 3301 scm_num_overflow (s_sum);
0f2d19dd 3302 return SCM_UNSPECIFIED;
f872b822 3303#endif
0f2d19dd
JB		 3304#endif
3305}
3306
3307
3308
3309
9de33deb 3310SCM_GPROC1 (s_difference, "-", scm_tc7_asubr, scm_difference, g_difference);
1cc91f1b 3311
0f2d19dd 3312SCM
6e8d25a6 3313scm_difference (SCM x, SCM y)
0f2d19dd
JB		 3314{
3315#ifdef SCM_FLOATS
f872b822
MD		 3316 if (SCM_NINUMP (x))
3317 {
f872b822
MD		 3318 if (!(SCM_NIMP (x)))
3319 {
0e3aa89f
MD		 3320 if (SCM_UNBNDP (y))
3321 {
73ef98d6
MD		 3322 SCM_GASSERT0 (!SCM_UNBNDP (x), g_difference,
3323 scm_makfrom0str (s_difference), SCM_WNA, 0);
0e3aa89f
MD		 3324 badx:
3325 SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference);
3326 }
3327 else
3328 {
3329 badx2:
3330 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference);
3331 }
f872b822 3332 }
f872b822
MD		 3333 if (SCM_UNBNDP (y))
3334 {
3335#ifdef SCM_BIGDIG
3336 if (SCM_BIGP (x))
3337 {
3338 x = scm_copybig (x, !SCM_BIGSIGN (x));
3339 return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3340 <= sizeof (SCM)
3341 ? scm_big2inum (x, SCM_NUMDIGS (x))
3342 : x);
3343 }
3344#endif
3345 SCM_ASRTGO (SCM_INEXP (x), badx);
3346 return scm_makdbl (- SCM_REALPART (x),
3347 SCM_CPLXP (x) ? -SCM_IMAG (x) : 0.0);
3348 }
3349 if (SCM_INUMP (y))
3350 return scm_sum (x, SCM_MAKINUM (- SCM_INUM (y)));
3351#ifdef SCM_BIGDIG
3352 SCM_ASRTGO (SCM_NIMP (y), bady);
3353 if (SCM_BIGP (x))
3354 {
3355 if (SCM_BIGP (y))
3356 return ((SCM_NUMDIGS (x) < SCM_NUMDIGS (y))
3357 ? scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3358 SCM_BIGSIGN (x),
3359 y, 0x0100)
3360 : scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y),
3361 SCM_BIGSIGN (y) ^ 0x0100,
3362 x, 0));
3363 SCM_ASRTGO (SCM_INEXP (y), bady);
3364 return scm_makdbl (scm_big2dbl (x) - SCM_REALPART (y),
3365 SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3366 }
0e3aa89f 3367 SCM_ASRTGO (SCM_INEXP (x), badx2);
f872b822
MD		 3368 if (SCM_BIGP (y))
3369 return scm_makdbl (SCM_REALPART (x) - scm_big2dbl (y),
3370 SCM_CPLXP (x) ? SCM_IMAG (x) : 0.0);
3371 SCM_ASRTGO (SCM_INEXP (y), bady);
3372#else
0e3aa89f 3373 SCM_ASRTGO (SCM_INEXP (x), badx2);
f872b822
MD		 3374 SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3375#endif
3376 if (SCM_CPLXP (x))
3377 {
3378 if (SCM_CPLXP (y))
3379 return scm_makdbl (SCM_REAL (x) - SCM_REAL (y),
3380 SCM_IMAG (x) - SCM_IMAG (y));
3381 else
3382 return scm_makdbl (SCM_REAL (x) - SCM_REALPART (y), SCM_IMAG (x));
3383 }
3384 return scm_makdbl (SCM_REALPART (x) - SCM_REALPART (y),
3385 SCM_CPLXP (y) ? - SCM_IMAG (y) : 0.0);
3386 }
3387 if (SCM_UNBNDP (y))
3388 {
3389 x = -SCM_INUM (x);
3390 goto checkx;
3391 }
3392 if (SCM_NINUMP (y))
3393 {
3394#ifdef SCM_BIGDIG
3395 SCM_ASRTGO (SCM_NIMP (y), bady);
3396 if (SCM_BIGP (y))
3397 {
3398#ifndef SCM_DIGSTOOBIG
3399 long z = scm_pseudolong (SCM_INUM (x));
3400 return scm_addbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3401 (x < 0) ? 0x0100 : 0,
3402 y, 0x0100);
3403#else
3404 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3405 scm_longdigs (SCM_INUM (x), zdigs);
3406 return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3407 y, 0x0100);
3408#endif
3409 }
f872b822
MD		 3410 if (!(SCM_INEXP (y)))
3411 {
3412 bady:
9de33deb 3413 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3414 }
f872b822 3415#else
f872b822
MD		 3416 if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3417 {
3418 bady:
9de33deb 3419 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3420 }
f872b822
MD		 3421#endif
3422 return scm_makdbl (SCM_INUM (x) - SCM_REALPART (y),
3423 SCM_CPLXP (y) ? -SCM_IMAG (y) : 0.0);
3424 }
3425#else
3426#ifdef SCM_BIGDIG
3427 if (SCM_NINUMP (x))
3428 {
9de33deb
MD		 3429 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3430 g_difference, x, y, SCM_ARG1, s_difference);
f872b822
MD		 3431 if (SCM_UNBNDP (y))
3432 {
3433 x = scm_copybig (x, !SCM_BIGSIGN (x));
3434 return (SCM_NUMDIGS (x) * SCM_BITSPERDIG / SCM_CHAR_BIT
3435 <= sizeof (SCM)
3436 ? scm_big2inum (x, SCM_NUMDIGS (x))
3437 : x);
3438 }
3439 if (SCM_INUMP (y))
3440 {
3441#ifndef SCM_DIGSTOOBIG
3442 long z = scm_pseudolong (SCM_INUM (y));
3443 return scm_addbig (&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
3444#else
3445 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3446 scm_longdigs (SCM_INUM (x), zdigs);
3447 return scm_addbig (zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100,
3448 x, 0);
3449#endif
3450 }
3451 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3452 return (SCM_NUMDIGS (x) < SCM_NUMDIGS (y)) ?
3453 scm_addbig (SCM_BDIGITS (x), SCM_NUMDIGS (x), SCM_BIGSIGN (x),
3454 y, 0x0100) :
3455 scm_addbig (SCM_BDIGITS (y), SCM_NUMDIGS (y), SCM_BIGSIGN (y) ^ 0x0100,
3456 x, 0);
3457 }
3458 if (SCM_UNBNDP (y))
3459 {
3460 x = -SCM_INUM (x);
3461 goto checkx;
3462 }
3463 if (SCM_NINUMP (y))
3464 {
f872b822
MD		 3465 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3466 {
3467 bady:
9de33deb 3468 SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference);
f872b822 3469 }
cda139a7 3470 {
f872b822
MD		 3471#ifndef SCM_DIGSTOOBIG
3472 long z = scm_pseudolong (SCM_INUM (x));
3473 return scm_addbig (&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3474 y, 0x0100);
3475#else
3476 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3477 scm_longdigs (SCM_INUM (x), zdigs);
3478 return scm_addbig (zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0,
3479 y, 0x0100);
3480#endif
cda139a7 3481 }
f872b822 3482 }
0f2d19dd 3483#else
9de33deb 3484 SCM_GASSERT2 (SCM_INUMP (x), g_difference, x, y, SCM_ARG1, s_difference);
f872b822
MD		 3485 if (SCM_UNBNDP (y))
3486 {
3487 x = -SCM_INUM (x);
3488 goto checkx;
0f2d19dd 3489 }
9de33deb 3490 SCM_GASSERT2 (SCM_INUMP (y), g_difference, x, y, SCM_ARGn, s_difference);
0f2d19dd 3491#endif
f872b822
MD		 3492#endif
3493 x = SCM_INUM (x) - SCM_INUM (y);
0f2d19dd 3494 checkx:
f872b822
MD		 3495 if (SCM_FIXABLE (x))
3496 return SCM_MAKINUM (x);
0f2d19dd 3497#ifdef SCM_BIGDIG
f872b822
MD		 3498 return scm_long2big (x);
3499#else
3500#ifdef SCM_FLOATS
3501 return scm_makdbl ((double) x, 0.0);
0f2d19dd 3502#else
52859adf 3503 scm_num_overflow (s_difference);
0f2d19dd 3504 return SCM_UNSPECIFIED;
f872b822 3505#endif
0f2d19dd
JB		 3506#endif
3507}
3508
3509
3510
3511
9de33deb 3512SCM_GPROC1 (s_product, "*", scm_tc7_asubr, scm_product, g_product);
1cc91f1b 3513
0f2d19dd 3514SCM
6e8d25a6 3515scm_product (SCM x, SCM y)
0f2d19dd 3516{
f872b822
MD		 3517 if (SCM_UNBNDP (y))
3518 {
3519 if (SCM_UNBNDP (x))
3520 return SCM_MAKINUM (1L);
0e3aa89f 3521 SCM_GASSERT1 (SCM_NUMBERP (x), g_product, x, SCM_ARG1, s_product);
f872b822
MD		 3522 return x;
3523 }
0f2d19dd 3524#ifdef SCM_FLOATS
f872b822
MD		 3525 if (SCM_NINUMP (x))
3526 {
3527 SCM t;
3528#ifdef SCM_BIGDIG
0e3aa89f
MD		 3529 if (!SCM_NIMP (x))
3530 {
3531 badx2:
3532 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product);
3533 }
f872b822
MD		 3534 if (SCM_BIGP (x))
3535 {
3536 if (SCM_INUMP (y))
3537 {
3538 t = x;
3539 x = y;
3540 y = t;
3541 goto intbig;
3542 }
3543 SCM_ASRTGO (SCM_NIMP (y), bady);
3544 if (SCM_BIGP (y))
3545 return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3546 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3547 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3548 SCM_ASRTGO (SCM_INEXP (y), bady);
3549 bigreal:
3550 {
3551 double bg = scm_big2dbl (x);
3552 return scm_makdbl (bg * SCM_REALPART (y),
3553 SCM_CPLXP (y) ? bg * SCM_IMAG (y) : 0.0);
3554 }
3555 }
0e3aa89f 3556 SCM_ASRTGO (SCM_INEXP (x), badx2);
f872b822 3557#else
0e3aa89f 3558 SCM_ASRTGO (SCM_NIMP (x) && SCM_INEXP (x), badx2);
f872b822
MD		 3559#endif
3560 if (SCM_INUMP (y))
3561 {
3562 t = x;
3563 x = y;
3564 y = t;
3565 goto intreal;
3566 }
3567#ifdef SCM_BIGDIG
3568 SCM_ASRTGO (SCM_NIMP (y), bady);
3569 if (SCM_BIGP (y))
3570 {
3571 t = x;
3572 x = y;
3573 y = t;
3574 goto bigreal;
3575 }
f872b822
MD		 3576 else if (!(SCM_INEXP (y)))
3577 {
3578 bady:
9de33deb 3579 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f872b822 3580 }
f872b822 3581#else
f872b822
MD		 3582 if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3583 {
3584 bady:
9de33deb 3585 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f872b822 3586 }
f872b822
MD		 3587#endif
3588 if (SCM_CPLXP (x))
3589 {
3590 if (SCM_CPLXP (y))
3591 return scm_makdbl (SCM_REAL (x) * SCM_REAL (y)
3592 - SCM_IMAG (x) * SCM_IMAG (y),
3593 SCM_REAL (x) * SCM_IMAG (y)
3594 + SCM_IMAG (x) * SCM_REAL (y));
3595 else
3596 return scm_makdbl (SCM_REAL (x) * SCM_REALPART (y),
3597 SCM_IMAG (x) * SCM_REALPART (y));
3598 }
3599 return scm_makdbl (SCM_REALPART (x) * SCM_REALPART (y),
3600 SCM_CPLXP (y)
3601 ? SCM_REALPART (x) * SCM_IMAG (y)
3602 : 0.0);
3603 }
3604 if (SCM_NINUMP (y))
3605 {
3606#ifdef SCM_BIGDIG
3607 SCM_ASRTGO (SCM_NIMP (y), bady);
3608 if (SCM_BIGP (y))
3609 {
3610 intbig:
3611 if (SCM_INUM0 == x)
3612 return x;
3613 if (SCM_MAKINUM (1L) == x)
3614 return y;
3615 {
3616#ifndef SCM_DIGSTOOBIG
3617 long z = scm_pseudolong (SCM_INUM (x));
3618 return scm_mulbig ((SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3619 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3620 SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3621#else
3622 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3623 scm_longdigs (SCM_INUM (x), zdigs);
3624 return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3625 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3626 SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3627#endif
3628 }
3629 }
3630 SCM_ASRTGO (SCM_INEXP (y), bady);
3631#else
3632 SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3633#endif
3634 intreal:
3635 return scm_makdbl (SCM_INUM (x) * SCM_REALPART (y),
3636 SCM_CPLXP (y) ? SCM_INUM (x) * SCM_IMAG (y) : 0.0);
3637 }
3638#else
3639#ifdef SCM_BIGDIG
3640 if (SCM_NINUMP (x))
3641 {
0e3aa89f 3642 SCM_ASRTGO (SCM_NIMP (x) && SCM_BIGP (x), badx2);
f872b822
MD		 3643 if (SCM_INUMP (y))
3644 {
3645 SCM t = x;
3646 x = y;
3647 y = t;
3648 goto intbig;
3649 }
3650 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3651 return scm_mulbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3652 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3653 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y));
3654 }
3655 if (SCM_NINUMP (y))
3656 {
f872b822
MD		 3657 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3658 {
3659 bady:
9de33deb 3660 SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product);
f872b822 3661 }
f872b822
MD		 3662 intbig:
3663 if (SCM_INUM0 == x)
3664 return x;
3665 if (SCM_MAKINUM (1L) == x)
3666 return y;
0f2d19dd 3667 {
f872b822
MD		 3668#ifndef SCM_DIGSTOOBIG
3669 long z = scm_pseudolong (SCM_INUM (x));
3670 return scm_mulbig (&z, SCM_DIGSPERLONG,
3671 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3672 SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3673#else
0f2d19dd 3674 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
f872b822
MD		 3675 scm_longdigs (SCM_INUM (x), zdigs);
3676 return scm_mulbig (zdigs, SCM_DIGSPERLONG,
3677 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3678 SCM_BIGSIGN (y) ? (x > 0) : (x < 0));
3679#endif
0f2d19dd
JB		 3680 }
3681 }
0f2d19dd 3682#else
0e3aa89f 3683 SCM_ASRTGO (SCM_INUMP (x), badx2);
9de33deb 3684 SCM_GASSERT (SCM_INUMP (y), g_product, x, y, SCM_ARGn, s_product);
f872b822 3685#endif
0f2d19dd
JB		 3686#endif
3687 {
3688 long i, j, k;
f872b822
MD		 3689 i = SCM_INUM (x);
3690 if (0 == i)
3691 return x;
3692 j = SCM_INUM (y);
0f2d19dd 3693 k = i * j;
f872b822
MD		 3694 y = SCM_MAKINUM (k);
3695 if (k != SCM_INUM (y) || k / i != j)
3696#ifdef SCM_BIGDIG
3697 {
3698 int sgn = (i < 0) ^ (j < 0);
3699#ifndef SCM_DIGSTOOBIG
3700 i = scm_pseudolong (i);
3701 j = scm_pseudolong (j);
3702 return scm_mulbig ((SCM_BIGDIG *) & i, SCM_DIGSPERLONG,
3703 (SCM_BIGDIG *) & j, SCM_DIGSPERLONG, sgn);
3704#else /* SCM_DIGSTOOBIG */
0f2d19dd
JB		 3705 SCM_BIGDIG idigs[SCM_DIGSPERLONG];
3706 SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
f872b822
MD		 3707 scm_longdigs (i, idigs);
3708 scm_longdigs (j, jdigs);
3709 return scm_mulbig (idigs, SCM_DIGSPERLONG,
3710 jdigs, SCM_DIGSPERLONG,
3711 sgn);
3712#endif
0f2d19dd
JB		 3713 }
3714#else
f872b822
MD		 3715#ifdef SCM_FLOATS
3716 return scm_makdbl (((double) i) * ((double) j), 0.0);
3717#else
52859adf 3718 scm_num_overflow (s_product);
f872b822 3719#endif
0f2d19dd
JB		 3720#endif
3721 return y;
3722 }
3723}
3724
3725
1cc91f1b 3726
0f2d19dd 3727double
6e8d25a6 3728scm_num2dbl (SCM a, const char *why)
0f2d19dd
JB		 3729{
3730 if (SCM_INUMP (a))
3731 return (double) SCM_INUM (a);
3732#ifdef SCM_FLOATS
3733 SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
3734 if (SCM_REALP (a))
3735 return (SCM_REALPART (a));
3736#endif
3737#ifdef SCM_BIGDIG
3738 return scm_big2dbl (a);
3739#endif
3740 SCM_ASSERT (0, a, "wrong type argument", why);
3741 return SCM_UNSPECIFIED;
3742}
3743
3744
9de33deb 3745SCM_GPROC1 (s_divide, "/", scm_tc7_asubr, scm_divide, g_divide);
1cc91f1b 3746
0f2d19dd 3747SCM
6e8d25a6 3748scm_divide (SCM x, SCM y)
0f2d19dd
JB		 3749{
3750#ifdef SCM_FLOATS
3751 double d, r, i, a;
f872b822
MD		 3752 if (SCM_NINUMP (x))
3753 {
f872b822
MD		 3754 if (!(SCM_NIMP (x)))
3755 {
0e3aa89f
MD		 3756 if (SCM_UNBNDP (y))
3757 {
73ef98d6
MD		 3758 SCM_GASSERT0 (!SCM_UNBNDP (x),
3759 g_divide, scm_makfrom0str (s_divide), SCM_WNA, 0);
0e3aa89f
MD		 3760 badx:
3761 SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide);
3762 }
3763 else
3764 {
3765 badx2:
3766 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide);
3767 }
f872b822 3768 }
f872b822
MD		 3769 if (SCM_UNBNDP (y))
3770 {
3771#ifdef SCM_BIGDIG
3772 if (SCM_BIGP (x))
3773 return scm_makdbl (1.0 / scm_big2dbl (x), 0.0);
3774#endif
3775 SCM_ASRTGO (SCM_INEXP (x), badx);
3776 if (SCM_REALP (x))
3777 return scm_makdbl (1.0 / SCM_REALPART (x), 0.0);
3778 r = SCM_REAL (x);
3779 i = SCM_IMAG (x);
3780 d = r * r + i * i;
3781 return scm_makdbl (r / d, -i / d);
3782 }
3783#ifdef SCM_BIGDIG
3784 if (SCM_BIGP (x))
3785 {
3786 SCM z;
3787 if (SCM_INUMP (y))
3788 {
3789 z = SCM_INUM (y);
3790#ifndef SCM_RECKLESS
3791 if (!z)
3792 scm_num_overflow (s_divide);
3793#endif
3794 if (1 == z)
3795 return x;
3796 if (z < 0)
3797 z = -z;
3798 if (z < SCM_BIGRAD)
3799 {
3800 SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
3801 return (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
3802 (SCM_BIGDIG) z)
3803 ? scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0)
3804 : scm_normbig (w));
3805 }
3806#ifndef SCM_DIGSTOOBIG
3807 z = scm_pseudolong (z);
3808 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3809 (SCM_BIGDIG *) & z, SCM_DIGSPERLONG,
3810 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3811#else
3812 {
3813 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3814 scm_longdigs (z, zdigs);
3815 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3816 zdigs, SCM_DIGSPERLONG,
3817 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3818 }
3819#endif
3820 return z ? z : scm_makdbl (scm_big2dbl (x) / SCM_INUM (y), 0.0);
3821 }
3822 SCM_ASRTGO (SCM_NIMP (y), bady);
3823 if (SCM_BIGP (y))
3824 {
3825 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3826 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3827 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
3828 return z ? z : scm_makdbl (scm_big2dbl (x) / scm_big2dbl (y),
3829 0.0);
3830 }
3831 SCM_ASRTGO (SCM_INEXP (y), bady);
3832 if (SCM_REALP (y))
3833 return scm_makdbl (scm_big2dbl (x) / SCM_REALPART (y), 0.0);
3834 a = scm_big2dbl (x);
3835 goto complex_div;
3836 }
3837#endif
0e3aa89f 3838 SCM_ASRTGO (SCM_INEXP (x), badx2);
f872b822
MD		 3839 if (SCM_INUMP (y))
3840 {
3841 d = SCM_INUM (y);
3842 goto basic_div;
3843 }
3844#ifdef SCM_BIGDIG
3845 SCM_ASRTGO (SCM_NIMP (y), bady);
3846 if (SCM_BIGP (y))
3847 {
3848 d = scm_big2dbl (y);
3849 goto basic_div;
3850 }
3851 SCM_ASRTGO (SCM_INEXP (y), bady);
3852#else
3853 SCM_ASRTGO (SCM_NIMP (y) && SCM_INEXP (y), bady);
3854#endif
3855 if (SCM_REALP (y))
3856 {
3857 d = SCM_REALPART (y);
3858 basic_div:
3859 return scm_makdbl (SCM_REALPART (x) / d,
3860 SCM_CPLXP (x) ? SCM_IMAG (x) / d : 0.0);
3861 }
3862 a = SCM_REALPART (x);
3863 if (SCM_REALP (x))
3864 goto complex_div;
3865 r = SCM_REAL (y);
3866 i = SCM_IMAG (y);
3867 d = r * r + i * i;
3868 return scm_makdbl ((a * r + SCM_IMAG (x) * i) / d,
3869 (SCM_IMAG (x) * r - a * i) / d);
3870 }
3871 if (SCM_UNBNDP (y))
3872 {
3873 if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
3874 return x;
3875 return scm_makdbl (1.0 / ((double) SCM_INUM (x)), 0.0);
3876 }
3877 if (SCM_NINUMP (y))
3878 {
3879#ifdef SCM_BIGDIG
3880 SCM_ASRTGO (SCM_NIMP (y), bady);
3881 if (SCM_BIGP (y))
3882 return scm_makdbl (SCM_INUM (x) / scm_big2dbl (y), 0.0);
f872b822
MD		 3883 if (!(SCM_INEXP (y)))
3884 {
3885 bady:
9de33deb 3886 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3887 }
f872b822 3888#else
f872b822
MD		 3889 if (!(SCM_NIMP (y) && SCM_INEXP (y)))
3890 {
3891 bady:
9de33deb 3892 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3893 }
f872b822
MD		 3894#endif
3895 if (SCM_REALP (y))
3896 return scm_makdbl (SCM_INUM (x) / SCM_REALPART (y), 0.0);
3897 a = SCM_INUM (x);
3898 complex_div:
3899 r = SCM_REAL (y);
3900 i = SCM_IMAG (y);
3901 d = r * r + i * i;
3902 return scm_makdbl ((a * r) / d, (-a * i) / d);
3903 }
3904#else
3905#ifdef SCM_BIGDIG
3906 if (SCM_NINUMP (x))
3907 {
0f2d19dd 3908 SCM z;
9de33deb
MD		 3909 SCM_GASSERT2 (SCM_NIMP (x) && SCM_BIGP (x),
3910 g_divide, x, y, SCM_ARG1, s_divide);
f872b822
MD		 3911 if (SCM_UNBNDP (y))
3912 goto ov;
3913 if (SCM_INUMP (y))
3914 {
3915 z = SCM_INUM (y);
3916 if (!z)
3917 goto ov;
3918 if (1 == z)
3919 return x;
3920 if (z < 0)
3921 z = -z;
3922 if (z < SCM_BIGRAD)
3923 {
3924 SCM w = scm_copybig (x, SCM_BIGSIGN (x) ? (y > 0) : (y < 0));
3925 if (scm_divbigdig (SCM_BDIGITS (w), SCM_NUMDIGS (w),
3926 (SCM_BIGDIG) z))
3927 goto ov;
3928 return w;
3929 }
3930#ifndef SCM_DIGSTOOBIG
3931 z = scm_pseudolong (z);
3932 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3933 &z, SCM_DIGSPERLONG,
3934 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3935#else
3936 {
3937 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
3938 scm_longdigs (z, zdigs);
3939 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3940 zdigs, SCM_DIGSPERLONG,
3941 SCM_BIGSIGN (x) ? (y > 0) : (y < 0), 3);
3942 }
3943#endif
3944 }
3945 else
3946 {
3947 SCM_ASRTGO (SCM_NIMP (y) && SCM_BIGP (y), bady);
3948 z = scm_divbigbig (SCM_BDIGITS (x), SCM_NUMDIGS (x),
3949 SCM_BDIGITS (y), SCM_NUMDIGS (y),
3950 SCM_BIGSIGN (x) ^ SCM_BIGSIGN (y), 3);
3951 }
3952 if (!z)
3953 goto ov;
3954 return z;
3955 }
3956 if (SCM_UNBNDP (y))
3957 {
3958 if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
3959 return x;
3960 goto ov;
3961 }
3962 if (SCM_NINUMP (y))
3963 {
f872b822
MD		 3964 if (!(SCM_NIMP (y) && SCM_BIGP (y)))
3965 {
3966 bady:
9de33deb 3967 SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3968 }
f872b822
MD		 3969 goto ov;
3970 }
0f2d19dd 3971#else
9de33deb 3972 SCM_GASSERT2 (SCM_INUMP (x), g_divide, x, y, SCM_ARG1, s_divide);
f872b822
MD		 3973 if (SCM_UNBNDP (y))
3974 {
3975 if ((SCM_MAKINUM (1L) == x) || (SCM_MAKINUM (-1L) == x))
3976 return x;
3977 goto ov;
3978 }
9de33deb 3979 SCM_GASSERT2 (SCM_INUMP (y), g_divide, x, y, SCM_ARGn, s_divide);
f872b822 3980#endif
0f2d19dd
JB		 3981#endif
3982 {
f872b822
MD		 3983 long z = SCM_INUM (y);
3984 if ((0 == z) || SCM_INUM (x) % z)
3985 goto ov;
3986 z = SCM_INUM (x) / z;
3987 if (SCM_FIXABLE (z))
3988 return SCM_MAKINUM (z);
0f2d19dd 3989#ifdef SCM_BIGDIG
f872b822 3990 return scm_long2big (z);
0f2d19dd
JB		 3991#endif
3992#ifdef SCM_FLOATS
f872b822
MD		 3993 ov:
3994 return scm_makdbl (((double) SCM_INUM (x)) / ((double) SCM_INUM (y)), 0.0);
0f2d19dd 3995#else
f872b822
MD		 3996 ov:
3997 scm_num_overflow (s_divide);
0f2d19dd
JB		 3998 return SCM_UNSPECIFIED;
3999#endif
4000 }
4001}
4002
4003
4004
4005
4006#ifdef SCM_FLOATS
9de33deb 4007SCM_GPROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh, g_asinh);
1cc91f1b 4008
0f2d19dd 4009double
6e8d25a6 4010scm_asinh (double x)
0f2d19dd 4011{
f872b822 4012 return log (x + sqrt (x * x + 1));
0f2d19dd
JB		 4013}
4014
4015
4016
4017
9de33deb 4018SCM_GPROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh, g_acosh);
1cc91f1b 4019
0f2d19dd 4020double
6e8d25a6 4021scm_acosh (double x)
0f2d19dd 4022{
f872b822 4023 return log (x + sqrt (x * x - 1));
0f2d19dd
JB		 4024}
4025
4026
4027
4028
9de33deb 4029SCM_GPROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh, g_atanh);
1cc91f1b 4030
0f2d19dd 4031double
6e8d25a6 4032scm_atanh (double x)
0f2d19dd 4033{
f872b822 4034 return 0.5 * log ((1 + x) / (1 - x));
0f2d19dd
JB		 4035}
4036
4037
4038
4039
9de33deb 4040SCM_GPROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate, g_truncate);
1cc91f1b 4041
0f2d19dd 4042double
6e8d25a6 4043scm_truncate (double x)
0f2d19dd 4044{
f872b822
MD		 4045 if (x < 0.0)
4046 return -floor (-x);
4047 return floor (x);
0f2d19dd
JB		 4048}
4049
4050
4051
9de33deb 4052SCM_GPROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round, g_round);
1cc91f1b 4053
0f2d19dd 4054double
6e8d25a6 4055scm_round (double x)
0f2d19dd
JB		 4056{
4057 double plus_half = x + 0.5;
f872b822 4058 double result = floor (plus_half);
0f2d19dd 4059 /* Adjust so that the scm_round is towards even. */
f872b822 4060 return (plus_half == result && plus_half / 2 != floor (plus_half / 2))
0f2d19dd
JB		 4061 ? result - 1 : result;
4062}
4063
4064
4065
9de33deb 4066SCM_GPROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact, g_exact_to_inexact);
1cc91f1b 4067
0f2d19dd 4068double
6e8d25a6 4069scm_exact_to_inexact (double z)
0f2d19dd
JB		 4070{
4071 return z;
4072}
4073
4074
9de33deb
MD		 4075SCM_GPROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor, g_i_floor);
4076SCM_GPROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil, g_i_ceil);
4077SCM_GPROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)()) sqrt, g_i_sqrt);
4078SCM_GPROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)()) fabs, g_i_abs);
4079SCM_GPROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)()) exp, g_i_exp);
4080SCM_GPROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)()) log, g_i_log);
4081SCM_GPROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)()) sin, g_i_sin);
4082SCM_GPROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)()) cos, g_i_cos);
4083SCM_GPROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)()) tan, g_i_tan);
4084SCM_GPROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)()) asin, g_i_asin);
4085SCM_GPROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)()) acos, g_i_acos);
4086SCM_GPROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)()) atan, g_i_atan);
4087SCM_GPROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)()) sinh, g_i_sinh);
4088SCM_GPROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)()) cosh, g_i_cosh);
4089SCM_GPROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)()) tanh, g_i_tanh);
f872b822
MD		 4090
4091struct dpair
4092{
4093 double x, y;
4094};
4095
3eeba8d4
JB		 4096static void scm_two_doubles (SCM z1,
4097 SCM z2,
4098 const char *sstring,
4099 struct dpair * xy);
f872b822
MD		 4100
4101static void
6e8d25a6 4102scm_two_doubles (SCM z1, SCM z2, const char *sstring, struct dpair *xy)
0f2d19dd 4103{
f872b822
MD		 4104 if (SCM_INUMP (z1))
4105 xy->x = SCM_INUM (z1);
4106 else
4107 {
4108#ifdef SCM_BIGDIG
4109 SCM_ASRTGO (SCM_NIMP (z1), badz1);
4110 if (SCM_BIGP (z1))
4111 xy->x = scm_big2dbl (z1);
4112 else
4113 {
4114#ifndef SCM_RECKLESS
4115 if (!(SCM_REALP (z1)))
4116 badz1:scm_wta (z1, (char *) SCM_ARG1, sstring);
4117#endif
4118 xy->x = SCM_REALPART (z1);
4119 }
4120#else
4121 {
4122 SCM_ASSERT (SCM_NIMP (z1) && SCM_REALP (z1), z1, SCM_ARG1, sstring);
4123 xy->x = SCM_REALPART (z1);
4124 }
4125#endif
4126 }
4127 if (SCM_INUMP (z2))
4128 xy->y = SCM_INUM (z2);
4129 else
4130 {
4131#ifdef SCM_BIGDIG
4132 SCM_ASRTGO (SCM_NIMP (z2), badz2);
4133 if (SCM_BIGP (z2))
4134 xy->y = scm_big2dbl (z2);
4135 else
4136 {
4137#ifndef SCM_RECKLESS
4138 if (!(SCM_REALP (z2)))
4139 badz2:scm_wta (z2, (char *) SCM_ARG2, sstring);
4140#endif
4141 xy->y = SCM_REALPART (z2);
4142 }
4143#else
4144 {
4145 SCM_ASSERT (SCM_NIMP (z2) && SCM_REALP (z2), z2, SCM_ARG2, sstring);
4146 xy->y = SCM_REALPART (z2);
4147 }
4148#endif
4149 }
0f2d19dd
JB		 4150}
4151
4152
4153
4154
1bbd0b84
GB		 4155GUILE_PROC (scm_sys_expt, "$expt", 2, 0, 0,
4156 (SCM z1, SCM z2),
4157"")
4158#define FUNC_NAME s_scm_sys_expt
0f2d19dd
JB		 4159{
4160 struct dpair xy;
1bbd0b84 4161 scm_two_doubles (z1, z2, FUNC_NAME, &xy);
f872b822 4162 return scm_makdbl (pow (xy.x, xy.y), 0.0);
0f2d19dd 4163}
1bbd0b84 4164#undef FUNC_NAME
0f2d19dd
JB		 4165
4166
4167
1bbd0b84
GB		 4168GUILE_PROC (scm_sys_atan2, "$atan2", 2, 0, 0,
4169 (SCM z1, SCM z2),
4170"")
4171#define FUNC_NAME s_scm_sys_atan2
0f2d19dd
JB		 4172{
4173 struct dpair xy;
1bbd0b84 4174 scm_two_doubles (z1, z2, FUNC_NAME, &xy);
f872b822 4175 return scm_makdbl (atan2 (xy.x, xy.y), 0.0);
0f2d19dd 4176}
1bbd0b84 4177#undef FUNC_NAME
0f2d19dd
JB		 4178
4179
4180
1bbd0b84
GB		 4181GUILE_PROC (scm_make_rectangular, "make-rectangular", 2, 0, 0,
4182 (SCM z1, SCM z2),
4183"")
4184#define FUNC_NAME s_scm_make_rectangular
0f2d19dd
JB		 4185{
4186 struct dpair xy;
1bbd0b84 4187 scm_two_doubles (z1, z2, FUNC_NAME, &xy);
f872b822 4188 return scm_makdbl (xy.x, xy.y);
0f2d19dd 4189}
1bbd0b84 4190#undef FUNC_NAME
0f2d19dd
JB		 4191
4192
4193
1bbd0b84
GB		 4194GUILE_PROC (scm_make_polar, "make-polar", 2, 0, 0,
4195 (SCM z1, SCM z2),
4196"")
4197#define FUNC_NAME s_scm_make_polar
0f2d19dd
JB		 4198{
4199 struct dpair xy;
1bbd0b84 4200 scm_two_doubles (z1, z2, FUNC_NAME, &xy);
f872b822 4201 return scm_makdbl (xy.x * cos (xy.y), xy.x * sin (xy.y));
0f2d19dd 4202}
1bbd0b84 4203#undef FUNC_NAME
0f2d19dd
JB		 4204
4205
4206
4207
152f82bf 4208SCM_GPROC (s_real_part, "real-part", 1, 0, 0, scm_real_part, g_real_part);
1cc91f1b 4209
0f2d19dd 4210SCM
6e8d25a6 4211scm_real_part (SCM z)
0f2d19dd 4212{
f872b822
MD		 4213 if (SCM_NINUMP (z))
4214 {
4215#ifdef SCM_BIGDIG
4216 SCM_ASRTGO (SCM_NIMP (z), badz);
4217 if (SCM_BIGP (z))
4218 return z;
f872b822
MD		 4219 if (!(SCM_INEXP (z)))
4220 {
4221 badz:
152f82bf 4222 SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part);
f872b822 4223 }
f872b822 4224#else
152f82bf
MD		 4225 SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4226 g_real_part, z, SCM_ARG1, s_real_part);
f872b822
MD		 4227#endif
4228 if (SCM_CPLXP (z))
4229 return scm_makdbl (SCM_REAL (z), 0.0);
4230 }
0f2d19dd
JB		 4231 return z;
4232}
4233
4234
4235
152f82bf 4236SCM_GPROC (s_imag_part, "imag-part", 1, 0, 0, scm_imag_part, g_imag_part);
1cc91f1b 4237
0f2d19dd 4238SCM
6e8d25a6 4239scm_imag_part (SCM z)
0f2d19dd 4240{
f872b822
MD		 4241 if (SCM_INUMP (z))
4242 return SCM_INUM0;
4243#ifdef SCM_BIGDIG
4244 SCM_ASRTGO (SCM_NIMP (z), badz);
4245 if (SCM_BIGP (z))
4246 return SCM_INUM0;
f872b822
MD		 4247 if (!(SCM_INEXP (z)))
4248 {
4249 badz:
152f82bf 4250 SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part);
f872b822 4251 }
f872b822 4252#else
152f82bf
MD		 4253 SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4254 g_imag_part, z, SCM_ARG1, s_imag_part);
f872b822
MD		 4255#endif
4256 if (SCM_CPLXP (z))
4257 return scm_makdbl (SCM_IMAG (z), 0.0);
0f2d19dd
JB		 4258 return scm_flo0;
4259}
4260
4261
4262
9de33deb 4263SCM_GPROC (s_magnitude, "magnitude", 1, 0, 0, scm_magnitude, g_magnitude);
1cc91f1b 4264
0f2d19dd 4265SCM
6e8d25a6 4266scm_magnitude (SCM z)
0f2d19dd 4267{
f872b822
MD		 4268 if (SCM_INUMP (z))
4269 return scm_abs (z);
4270#ifdef SCM_BIGDIG
4271 SCM_ASRTGO (SCM_NIMP (z), badz);
4272 if (SCM_BIGP (z))
4273 return scm_abs (z);
f872b822
MD		 4274 if (!(SCM_INEXP (z)))
4275 {
4276 badz:
9de33deb 4277 SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude);
f872b822 4278 }
f872b822 4279#else
9de33deb
MD		 4280 SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z),
4281 g_magnitude, z, SCM_ARG1, s_magnitude);
f872b822
MD		 4282#endif
4283 if (SCM_CPLXP (z))
0f2d19dd 4284 {
f872b822
MD		 4285 double i = SCM_IMAG (z), r = SCM_REAL (z);
4286 return scm_makdbl (sqrt (i * i + r * r), 0.0);
0f2d19dd 4287 }
f872b822 4288 return scm_makdbl (fabs (SCM_REALPART (z)), 0.0);
0f2d19dd
JB		 4289}
4290
4291
4292
4293
9de33deb 4294SCM_GPROC (s_angle, "angle", 1, 0, 0, scm_angle, g_angle);
1cc91f1b 4295
0f2d19dd 4296SCM
6e8d25a6 4297scm_angle (SCM z)
0f2d19dd
JB		 4298{
4299 double x, y = 0.0;
f872b822
MD		 4300 if (SCM_INUMP (z))
4301 {
4302 x = (z >= SCM_INUM0) ? 1.0 : -1.0;
4303 goto do_angle;
4304 }
4305#ifdef SCM_BIGDIG
4306 SCM_ASRTGO (SCM_NIMP (z), badz);
4307 if (SCM_BIGP (z))
4308 {
4309 x = (SCM_TYP16 (z) == scm_tc16_bigpos) ? 1.0 : -1.0;
4310 goto do_angle;
4311 }
f872b822
MD		 4312 if (!(SCM_INEXP (z)))
4313 {
4314 badz:
9de33deb 4315 SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle);
f872b822 4316 }
f872b822 4317#else
9de33deb 4318 SCM_GASSERT1 (SCM_NIMP (z) && SCM_INEXP (z), g_angle, z, SCM_ARG1, s_angle);
f872b822
MD		 4319#endif
4320 if (SCM_REALP (z))
4321 {
4322 x = SCM_REALPART (z);
0f2d19dd
JB		 4323 goto do_angle;
4324 }
f872b822
MD		 4325 x = SCM_REAL (z);
4326 y = SCM_IMAG (z);
0f2d19dd 4327 do_angle:
f872b822 4328 return scm_makdbl (atan2 (y, x), 0.0);
0f2d19dd
JB		 4329}
4330
4331
1bbd0b84
GB		 4332GUILE_PROC (scm_inexact_to_exact, "inexact->exact", 1, 0, 0,
4333 (SCM z),
4334"")
4335#define FUNC_NAME s_scm_inexact_to_exact
0f2d19dd 4336{
f872b822
MD		 4337 if (SCM_INUMP (z))
4338 return z;
4339#ifdef SCM_BIGDIG
4340 SCM_ASRTGO (SCM_NIMP (z), badz);
4341 if (SCM_BIGP (z))
4342 return z;
4343#ifndef SCM_RECKLESS
4344 if (!(SCM_REALP (z)))
4345 {
4346 badz:
1bbd0b84 4347 scm_wta (z, (char *) SCM_ARG1, FUNC_NAME);
f872b822
MD		 4348 }
4349#endif
4350#else
1bbd0b84 4351 SCM_VALIDATE_REAL(1,z);
f872b822
MD		 4352#endif
4353#ifdef SCM_BIGDIG
0f2d19dd 4354 {
f872b822
MD		 4355 double u = floor (SCM_REALPART (z) + 0.5);
4356 if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM))
4357 {
4358 /* Negation is a workaround for HP700 cc bug */
4359 SCM ans = SCM_MAKINUM ((long) u);
4360 if (SCM_INUM (ans) == (long) u)
4361 return ans;
4362 }
e6f3ef58 4363 SCM_ASRTGO (isfinite (u), badz); /* problem? */
f872b822 4364 return scm_dbl2big (u);
0f2d19dd 4365 }
f872b822
MD		 4366#else
4367 return SCM_MAKINUM ((long) floor (SCM_REALPART (z) + 0.5));
4368#endif
0f2d19dd 4369}
1bbd0b84 4370#undef FUNC_NAME
0f2d19dd
JB		 4371
4372
4373
f872b822 4374#else /* ~SCM_FLOATS */
9de33deb 4375SCM_GPROC (s_trunc, "truncate", 1, 0, 0, scm_trunc, g_trunc);
1cc91f1b 4376
0f2d19dd 4377SCM
6e8d25a6 4378scm_trunc (SCM x)
0f2d19dd 4379{
9de33deb 4380 SCM_GASSERT2 (SCM_INUMP (x), g_trunc, x, y, SCM_ARG1, s_truncate);
0f2d19dd
JB		 4381 return x;
4382}
4383
4384
4385
f872b822 4386#endif /* SCM_FLOATS */
0f2d19dd
JB		 4387
4388#ifdef SCM_BIGDIG
f872b822 4389#ifdef SCM_FLOATS
0f2d19dd 4390/* d must be integer */
1cc91f1b 4391
0f2d19dd 4392SCM
6e8d25a6 4393scm_dbl2big (double d)
0f2d19dd
JB		 4394{
4395 scm_sizet i = 0;
4396 long c;
4397 SCM_BIGDIG *digits;
4398 SCM ans;
f872b822
MD		 4399 double u = (d < 0) ? -d : d;
4400 while (0 != floor (u))
4401 {
4402 u /= SCM_BIGRAD;
4403 i++;
4404 }
4405 ans = scm_mkbig (i, d < 0);
4406 digits = SCM_BDIGITS (ans);
4407 while (i--)
4408 {
4409 u *= SCM_BIGRAD;
4410 c = floor (u);
4411 u -= c;
4412 digits[i] = c;
4413 }
cf7c17e9 4414#ifndef SCM_RECKLESS
e1724d20 4415 if (u != 0)
52859adf 4416 scm_num_overflow ("dbl2big");
e1724d20 4417#endif
0f2d19dd
JB		 4418 return ans;
4419}
4420
4421
4422
0f2d19dd 4423double
6e8d25a6 4424scm_big2dbl (SCM b)
0f2d19dd
JB		 4425{
4426 double ans = 0.0;
f872b822
MD		 4427 scm_sizet i = SCM_NUMDIGS (b);
4428 SCM_BIGDIG *digits = SCM_BDIGITS (b);
4429 while (i--)
4430 ans = digits[i] + SCM_BIGRAD * ans;
4431 if (scm_tc16_bigneg == SCM_TYP16 (b))
4432 return -ans;
0f2d19dd
JB		 4433 return ans;
4434}
f872b822 4435#endif
0f2d19dd
JB		 4436#endif
4437
1cc91f1b 4438
0f2d19dd 4439SCM
6e8d25a6 4440scm_long2num (long sl)
0f2d19dd 4441{
f872b822
MD		 4442 if (!SCM_FIXABLE (sl))
4443 {
0f2d19dd 4444#ifdef SCM_BIGDIG
f872b822 4445 return scm_long2big (sl);
0f2d19dd 4446#else
f872b822
MD		 4447#ifdef SCM_FLOATS
4448 return scm_makdbl ((double) sl, 0.0);
4449#else
4450 return SCM_BOOL_F;
0f2d19dd 4451#endif
f872b822
MD		 4452#endif
4453 }
4454 return SCM_MAKINUM (sl);
0f2d19dd
JB		 4455}
4456
4457
5c11cc9d 4458#ifdef HAVE_LONG_LONGS
1cc91f1b 4459
0f2d19dd 4460SCM
6e8d25a6 4461scm_long_long2num (long_long sl)
0f2d19dd 4462{
f872b822
MD		 4463 if (!SCM_FIXABLE (sl))
4464 {
0f2d19dd 4465#ifdef SCM_BIGDIG
f872b822 4466 return scm_long_long2big (sl);
0f2d19dd 4467#else
f872b822
MD		 4468#ifdef SCM_FLOATS
4469 return scm_makdbl ((double) sl, 0.0);
4470#else
4471 return SCM_BOOL_F;
0f2d19dd 4472#endif
f872b822
MD		 4473#endif
4474 }
4475 return SCM_MAKINUM (sl);
0f2d19dd
JB		 4476}
4477#endif
4478
4479
1cc91f1b 4480
0f2d19dd 4481SCM
6e8d25a6 4482scm_ulong2num (unsigned long sl)
0f2d19dd 4483{
f872b822
MD		 4484 if (!SCM_POSFIXABLE (sl))
4485 {
0f2d19dd 4486#ifdef SCM_BIGDIG
f872b822 4487 return scm_ulong2big (sl);
0f2d19dd 4488#else
f872b822
MD		 4489#ifdef SCM_FLOATS
4490 return scm_makdbl ((double) sl, 0.0);
4491#else
4492 return SCM_BOOL_F;
0f2d19dd 4493#endif
f872b822
MD		 4494#endif
4495 }
4496 return SCM_MAKINUM (sl);
0f2d19dd
JB		 4497}
4498
1cc91f1b 4499
0f2d19dd 4500long
6e8d25a6 4501scm_num2long (SCM num, char *pos, const char *s_caller)
0f2d19dd
JB		 4502{
4503 long res;
5c11cc9d 4504
f872b822 4505 if (SCM_INUMP (num))
0f2d19dd 4506 {
f872b822 4507 res = SCM_INUM (num);
0f2d19dd
JB		 4508 return res;
4509 }
5c11cc9d 4510 SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
0f2d19dd 4511#ifdef SCM_FLOATS
f872b822 4512 if (SCM_REALP (num))
0f2d19dd 4513 {
5c11cc9d
GH		 4514 volatile double u = SCM_REALPART (num);
4515
0f2d19dd 4516 res = u;
5c11cc9d
GH		 4517 if (res != u)
4518 goto out_of_range;
4519 return res;
0f2d19dd
JB		 4520 }
4521#endif
4522#ifdef SCM_BIGDIG
f872b822
MD		 4523 if (SCM_BIGP (num))
4524 {
5c11cc9d 4525 unsigned long oldres = 0;
f872b822 4526 scm_sizet l;
5c11cc9d
GH		 4527 /* can't use res directly in case num is -2^31. */
4528 unsigned long pos_res = 0;
4529
f872b822
MD		 4530 for (l = SCM_NUMDIGS (num); l--;)
4531 {
5c11cc9d
GH		 4532 pos_res = SCM_BIGUP (pos_res) + SCM_BDIGITS (num)[l];
4533 /* check for overflow. */
4534 if (pos_res < oldres)
4535 goto out_of_range;
4536 oldres = pos_res;
f872b822
MD		 4537 }
4538 if (SCM_TYP16 (num) == scm_tc16_bigpos)
5c11cc9d
GH		 4539 {
4540 res = pos_res;
4541 if (res < 0)
4542 goto out_of_range;
4543 }
f872b822 4544 else
5c11cc9d
GH		 4545 {
4546 res = -pos_res;
4547 if (res > 0)
4548 goto out_of_range;
4549 }
4550 return res;
f872b822 4551 }
0f2d19dd 4552#endif
5c11cc9d
GH		 4553 wrong_type_arg:
4554 scm_wrong_type_arg (s_caller, (int) pos, num);
4555 out_of_range:
4556 scm_out_of_range (s_caller, num);
0f2d19dd
JB		 4557}
4558
4559
4560
5c11cc9d 4561#ifdef HAVE_LONG_LONGS
1cc91f1b 4562
0f2d19dd 4563long_long
6e8d25a6 4564scm_num2long_long (SCM num, char *pos, const char *s_caller)
0f2d19dd
JB		 4565{
4566 long_long res;
5c11cc9d 4567
f872b822
MD		 4568 if (SCM_INUMP (num))
4569 {
5c11cc9d 4570 res = SCM_INUM (num);
0f2d19dd
JB		 4571 return res;
4572 }
5c11cc9d 4573 SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
f872b822
MD		 4574#ifdef SCM_FLOATS
4575 if (SCM_REALP (num))
4576 {
4577 double u = SCM_REALPART (num);
5c11cc9d
GH		 4578
4579 res = u;
4580 if ((res < 0 && u > 0) || (res > 0 && u < 0)) /* check for overflow. */
4581 goto out_of_range;
4582
4583 return res;
f872b822 4584 }
0f2d19dd
JB		 4585#endif
4586#ifdef SCM_BIGDIG
f872b822
MD		 4587 if (SCM_BIGP (num))
4588 {
5c11cc9d
GH		 4589 unsigned long long oldres = 0;
4590 scm_sizet l;
4591 /* can't use res directly in case num is -2^63. */
4592 unsigned long long pos_res = 0;
4593
4594 for (l = SCM_NUMDIGS (num); l--;)
4595 {
4596 pos_res = SCM_LONGLONGBIGUP (pos_res) + SCM_BDIGITS (num)[l];
4597 /* check for overflow. */
4598 if (pos_res < oldres)
4599 goto out_of_range;
4600 oldres = pos_res;
4601 }
4602 if (SCM_TYP16 (num) == scm_tc16_bigpos)
4603 {
4604 res = pos_res;
4605 if (res < 0)
4606 goto out_of_range;
4607 }
4608 else
4609 {
4610 res = -pos_res;
4611 if (res > 0)
4612 goto out_of_range;
4613 }
f872b822
MD		 4614 return res;
4615 }
0f2d19dd 4616#endif
5c11cc9d
GH		 4617 wrong_type_arg:
4618 scm_wrong_type_arg (s_caller, (int) pos, num);
4619 out_of_range:
4620 scm_out_of_range (s_caller, num);
0f2d19dd
JB		 4621}
4622#endif
4623
4624
1cc91f1b 4625
0f2d19dd 4626unsigned long
6e8d25a6 4627scm_num2ulong (SCM num, char *pos, const char *s_caller)
0f2d19dd
JB		 4628{
4629 unsigned long res;
5c11cc9d 4630
f872b822 4631 if (SCM_INUMP (num))
0f2d19dd 4632 {
5c11cc9d
GH		 4633 if (SCM_INUM (num) < 0)
4634 goto out_of_range;
4635 res = SCM_INUM (num);
0f2d19dd
JB		 4636 return res;
4637 }
5c11cc9d 4638 SCM_ASRTGO (SCM_NIMP (num), wrong_type_arg);
0f2d19dd 4639#ifdef SCM_FLOATS
f872b822 4640 if (SCM_REALP (num))
0f2d19dd 4641 {
f872b822 4642 double u = SCM_REALPART (num);
5c11cc9d
GH		 4643
4644 res = u;
4645 if (res != u)
4646 goto out_of_range;
4647 return res;
0f2d19dd
JB		 4648 }
4649#endif
4650#ifdef SCM_BIGDIG
f872b822
MD		 4651 if (SCM_BIGP (num))
4652 {
5c11cc9d 4653 unsigned long oldres = 0;
f872b822 4654 scm_sizet l;
5c11cc9d 4655
f872b822 4656 res = 0;
f872b822
MD		 4657 for (l = SCM_NUMDIGS (num); l--;)
4658 {
4659 res = SCM_BIGUP (res) + SCM_BDIGITS (num)[l];
4660 if (res < oldres)
5c11cc9d 4661 goto out_of_range;
f872b822
MD		 4662 oldres = res;
4663 }
4664 return res;
4665 }
0f2d19dd 4666#endif
5c11cc9d
GH		 4667 wrong_type_arg:
4668 scm_wrong_type_arg (s_caller, (int) pos, num);
4669 out_of_range:
4670 scm_out_of_range (s_caller, num);
0f2d19dd
JB		 4671}
4672
4673
4674#ifdef SCM_FLOATS
f872b822 4675#ifndef DBL_DIG
f872b822 4676static void
6e8d25a6 4677add1 (double f, double *fsum)
0f2d19dd
JB		 4678{
4679 *fsum = f + 1.0;
4680}
f872b822 4681#endif
0f2d19dd
JB		 4682#endif
4683
4684
1cc91f1b 4685
0f2d19dd
JB		 4686void
4687scm_init_numbers ()
0f2d19dd 4688{
dccbb90a 4689 scm_add_feature("complex");
0f2d19dd 4690#ifdef SCM_FLOATS
7e5d1209 4691 scm_add_feature("inexact");
f872b822 4692#ifdef SCM_SINGLES
23a62151 4693 SCM_NEWSMOB(scm_flo0,scm_tc_flo,NULL);
f872b822 4694#else
23a62151 4695 SCM_NEWSMOB(scm_flo0,scm_tc_dblr,scm_must_malloc (1L * sizeof (double), "real"));
f872b822 4696 SCM_REAL (scm_flo0) = 0.0;
f872b822
MD		 4697#endif
4698#ifdef DBL_DIG
0f2d19dd 4699 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
f872b822 4700#else
0f2d19dd
JB		 4701 { /* determine floating point precision */
4702 double f = 0.1;
f872b822
MD		 4703 double fsum = 1.0 + f;
4704 while (fsum != 1.0)
4705 {
4706 f /= 10.0;
4707 if (++scm_dblprec > 20)
4708 break;
4709 add1 (f, &fsum);
4710 }
4711 scm_dblprec = scm_dblprec - 1;
0f2d19dd 4712 }
f872b822 4713#endif /* DBL_DIG */
0f2d19dd
JB		 4714#endif
4715#include "numbers.x"
4716}
Unnamed repository; edit this file 'description' to name the repository.