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