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