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