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