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