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