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