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