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