HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
*** empty log message ***
[bpt/guile.git] / libguile / numbers.c
CommitLineData
0f2d19dd
JB		 1/* Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, USA.
16 *
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
19 *
20 * The exception is that, if you link the GUILE library with other files
21 * to produce an executable, this does not by itself cause the
22 * resulting executable to be covered by the GNU General Public License.
23 * Your use of that executable is in no way restricted on account of
24 * linking the GUILE library code into it.
25 *
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
28 *
29 * This exception applies only to the code released by the
30 * Free Software Foundation under the name GUILE. If you copy
31 * code from other Free Software Foundation releases into a copy of
32 * GUILE, as the General Public License permits, the exception does
33 * not apply to the code that you add in this way. To avoid misleading
34 * anyone as to the status of such modified files, you must delete
35 * this exception notice from them.
36 *
37 * If you write modifications of your own for GUILE, it is your choice
38 * whether to permit this exception to apply to your modifications.
39 * If you do not wish that, delete this exception notice.
40 */
41\f
42
43#include <stdio.h>
44#include <math.h>
45#include "_scm.h"
20e6290e
JB		 46#include "genio.h"
47#include "unif.h"
0f2d19dd 48
20e6290e 49#include "numbers.h"
0f2d19dd
JB		 50\f
51#define DIGITS '0':case '1':case '2':case '3':case '4':\
52 case '5':case '6':case '7':case '8':case '9'
53
54
55/* IS_INF tests its floating point number for infiniteness
56 */
57#ifndef IS_INF
58# define IS_INF(x) ((x)==(x)/2)
59#endif
60
61/* MAXEXP is the maximum double precision expontent
62 * FLTMAX is less than or scm_equal the largest single precision float
63 */
64
65#ifdef SCM_FLOATS
66# ifdef STDC_HEADERS
67# ifndef GO32
68# include <float.h>
69# endif /* ndef GO32 */
70# endif /* def STDC_HEADERS */
71# ifdef DBL_MAX_10_EXP
72# define MAXEXP DBL_MAX_10_EXP
73# else
74# define MAXEXP 308 /* IEEE doubles */
75# endif /* def DBL_MAX_10_EXP */
76# ifdef FLT_MAX
77# define FLTMAX FLT_MAX
78# else
79# define FLTMAX 1e+23
80# endif /* def FLT_MAX */
81#endif /* def SCM_FLOATS */
82
83\f
84
85SCM_PROC(s_exact_p, "exact?", 1, 0, 0, scm_exact_p);
1cc91f1b 86
0f2d19dd
JB		 87SCM
88scm_exact_p(x)
89 SCM x;
0f2d19dd
JB		 90{
91 if SCM_INUMP(x) return SCM_BOOL_T;
92#ifdef SCM_BIGDIG
93 if (SCM_NIMP(x) && SCM_BIGP(x)) return SCM_BOOL_T;
94#endif
95 return SCM_BOOL_F;
96}
97
98SCM_PROC(s_odd_p, "odd?", 1, 0, 0, scm_odd_p);
1cc91f1b 99
0f2d19dd
JB		 100SCM
101scm_odd_p(n)
102 SCM n;
0f2d19dd
JB		 103{
104#ifdef SCM_BIGDIG
105 if SCM_NINUMP(n) {
106 SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_odd_p);
107 return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_T : SCM_BOOL_F;
108 }
109#else
110 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_odd_p);
111#endif
112 return (4 & (int)n) ? SCM_BOOL_T : SCM_BOOL_F;
113}
114
115SCM_PROC(s_even_p, "even?", 1, 0, 0, scm_even_p);
1cc91f1b 116
0f2d19dd
JB		 117SCM
118scm_even_p(n)
119 SCM n;
0f2d19dd
JB		 120{
121#ifdef SCM_BIGDIG
122 if SCM_NINUMP(n) {
123 SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_even_p);
124 return (1 & SCM_BDIGITS(n)[0]) ? SCM_BOOL_F : SCM_BOOL_T;
125 }
126#else
127 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_even_p);
128#endif
129 return (4 & (int)n) ? SCM_BOOL_F : SCM_BOOL_T;
130}
131
132SCM_PROC(s_abs, "abs", 1, 0, 0, scm_abs);
1cc91f1b 133
0f2d19dd
JB		 134SCM
135scm_abs(x)
136 SCM x;
0f2d19dd
JB		 137{
138#ifdef SCM_BIGDIG
139 if SCM_NINUMP(x) {
140 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_abs);
141 if (SCM_TYP16(x)==scm_tc16_bigpos) return x;
142 return scm_copybig(x, 0);
143 }
144#else
145 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_abs);
146#endif
147 if (SCM_INUM(x) >= 0) return x;
148 x = -SCM_INUM(x);
e2806c10 149 if (!SCM_POSFIXABLE(x))
0f2d19dd
JB		 150#ifdef SCM_BIGDIG
151 return scm_long2big(x);
152#else
52859adf 153 scm_num_overflow (s_abs);
0f2d19dd
JB		 154#endif
155 return SCM_MAKINUM(x);
156}
157
158SCM_PROC(s_quotient, "quotient", 2, 0, 0, scm_quotient);
1cc91f1b 159
0f2d19dd
JB		 160SCM
161scm_quotient(x, y)
162 SCM x;
163 SCM y;
0f2d19dd
JB		 164{
165 register long z;
166#ifdef SCM_BIGDIG
167 if SCM_NINUMP(x) {
168 long w;
169 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_quotient);
170 if SCM_NINUMP(y) {
171 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
172 return scm_divbigbig(SCM_BDIGITS(x),
173 SCM_NUMDIGS(x),
174 SCM_BDIGITS(y),
175 SCM_NUMDIGS(y),
176 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y),
177 2);
178 }
179 z = SCM_INUM(y);
180 SCM_ASRTGO(z, ov);
181 if (1==z) return x;
182 if (z < 0) z = -z;
183 if (z < SCM_BIGRAD) {
184 w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
185 scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z);
186 return scm_normbig(w);
187 }
188#ifndef SCM_DIGSTOOBIG
189 w = scm_pseudolong(z);
190 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&w, SCM_DIGSPERLONG,
191 SCM_BIGSIGN(x) ? (y>0) : (y<0), 2);
192#else
193 { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
194 scm_longdigs(z, zdigs);
195 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
196 SCM_BIGSIGN(x) ? (y>0) : (y<0), 2);
197 }
198#endif
199 }
200 if SCM_NINUMP(y) {
201# ifndef RECKLESS
202 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
203 bady: scm_wta(y, (char *)SCM_ARG2, s_quotient);
204# endif
205 return SCM_INUM0;
206 }
207#else
208 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_quotient);
209 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_quotient);
210#endif
211 if ((z = SCM_INUM(y))==0)
52859adf 212 ov: scm_num_overflow (s_quotient);
0f2d19dd
JB		 213 z = SCM_INUM(x)/z;
214#ifdef BADIVSGNS
215 {
216#if (__TURBOC__==1)
217 long t = ((y<0) ? -SCM_INUM(x) : SCM_INUM(x))%SCM_INUM(y);
218#else
219 long t = SCM_INUM(x)%SCM_INUM(y);
220#endif
221 if (t==0) ;
222 else if (t < 0)
223 if (x < 0) ;
224 else z--;
225 else if (x < 0) z++;
226 }
227#endif
228 if (!SCM_FIXABLE(z))
229#ifdef SCM_BIGDIG
230 return scm_long2big(z);
231#else
52859adf 232 scm_num_overflow (s_quotient);
0f2d19dd
JB		 233#endif
234 return SCM_MAKINUM(z);
235}
236
237SCM_PROC(s_remainder, "remainder", 2, 0, 0, scm_remainder);
1cc91f1b 238
0f2d19dd
JB		 239SCM
240scm_remainder(x, y)
241 SCM x;
242 SCM y;
0f2d19dd
JB		 243{
244 register long z;
245#ifdef SCM_BIGDIG
246 if SCM_NINUMP(x) {
247 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_remainder);
248 if SCM_NINUMP(y) {
249 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
250 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
251 SCM_BIGSIGN(x), 0);
252 }
253 if (!(z = SCM_INUM(y))) goto ov;
254 return scm_divbigint(x, z, SCM_BIGSIGN(x), 0);
255 }
256 if SCM_NINUMP(y) {
257# ifndef RECKLESS
258 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
259 bady: scm_wta(y, (char *)SCM_ARG2, s_remainder);
260# endif
261 return x;
262 }
263#else
264 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_remainder);
265 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_remainder);
266#endif
267 if (!(z = SCM_INUM(y)))
52859adf 268 ov: scm_num_overflow (s_remainder);
0f2d19dd
JB		 269#if (__TURBOC__==1)
270 if (z < 0) z = -z;
271#endif
272 z = SCM_INUM(x)%z;
273#ifdef BADIVSGNS
274 if (!z) ;
275 else if (z < 0)
276 if (x < 0) ;
277 else z += SCM_INUM(y);
278 else if (x < 0) z -= SCM_INUM(y);
279#endif
280 return SCM_MAKINUM(z);
281}
282
283SCM_PROC(s_modulo, "modulo", 2, 0, 0, scm_modulo);
1cc91f1b 284
0f2d19dd
JB		 285SCM
286scm_modulo(x, y)
287 SCM x;
288 SCM y;
0f2d19dd
JB		 289{
290 register long yy, z;
291#ifdef SCM_BIGDIG
292 if SCM_NINUMP(x) {
293 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_modulo);
294 if SCM_NINUMP(y) {
295 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
296 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
297 SCM_BIGSIGN(y), (SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y)) ? 1 : 0);
298 }
299 if (!(z = SCM_INUM(y))) goto ov;
300 return scm_divbigint(x, z, y < 0, (SCM_BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0);
301 }
302 if SCM_NINUMP(y) {
303# ifndef RECKLESS
304 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
305 bady: scm_wta(y, (char *)SCM_ARG2, s_modulo);
306# endif
307 return (SCM_BIGSIGN(y) ? (x>0) : (x<0)) ? scm_sum(x, y) : x;
308 }
309#else
310 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_modulo);
311 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_modulo);
312#endif
313 if (!(yy = SCM_INUM(y)))
52859adf 314 ov: scm_num_overflow (s_modulo);
0f2d19dd
JB		 315#if (__TURBOC__==1)
316 z = SCM_INUM(x);
317 z = ((yy<0) ? -z : z)%yy;
318#else
319 z = SCM_INUM(x)%yy;
320#endif
321 return SCM_MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z);
322}
323
324SCM_PROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd);
1cc91f1b 325
0f2d19dd
JB		 326SCM
327scm_gcd(x, y)
328 SCM x;
329 SCM y;
0f2d19dd
JB		 330{
331 register long u, v, k, t;
332 if SCM_UNBNDP(y) return SCM_UNBNDP(x) ? SCM_INUM0 : x;
333 tailrec:
334#ifdef SCM_BIGDIG
335 if SCM_NINUMP(x) {
336 big_gcd:
337 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_gcd);
338 if SCM_BIGSIGN(x) x = scm_copybig(x, 0);
339 newy:
340 if SCM_NINUMP(y) {
341 SCM_ASSERT(SCM_NIMP(y) && SCM_BIGP(y), y, SCM_ARG2, s_gcd);
342 if SCM_BIGSIGN(y) y = scm_copybig(y, 0);
343 switch (scm_bigcomp(x, y)) {
344 case -1:
345 swaprec: t = scm_remainder(x, y); x = y; y = t; goto tailrec;
346 case 0: return x;
347 case 1: y = scm_remainder(y, x); goto newy;
348 }
349 /* instead of the switch, we could just return scm_gcd(y, scm_modulo(x, y)); */
350 }
351 if (SCM_INUM0==y) return x; goto swaprec;
352 }
353 if SCM_NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
354#else
355 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_gcd);
356 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_gcd);
357#endif
358 u = SCM_INUM(x);
359 if (u<0) u = -u;
360 v = SCM_INUM(y);
361 if (v<0) v = -v;
362 else if (0==v) goto getout;
363 if (0==u) {u = v; goto getout;}
364 for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1);
365 if (1 & (int)u) t = -v;
366 else {
367 t = u;
368 b3:
369 t = SCM_SRS(t, 1);
370 }
371 if (!(1 & (int)t)) goto b3;
372 if (t>0) u = t;
373 else v = -t;
374 if ((t = u-v)) goto b3;
375 u = u*k;
376 getout:
e2806c10 377 if (!SCM_POSFIXABLE(u))
0f2d19dd
JB		 378#ifdef SCM_BIGDIG
379 return scm_long2big(u);
380#else
52859adf 381 scm_num_overflow (s_gcd);
0f2d19dd
JB		 382#endif
383 return SCM_MAKINUM(u);
384}
385
386SCM_PROC1 (s_lcm, "lcm", scm_tc7_asubr, scm_lcm);
1cc91f1b 387
0f2d19dd
JB		 388SCM
389scm_lcm(n1, n2)
390 SCM n1;
391 SCM n2;
0f2d19dd
JB		 392{
393 SCM d;
394 if SCM_UNBNDP(n2) {
395 n2 = SCM_MAKINUM(1L);
396 if SCM_UNBNDP(n1) return n2;
397 }
398 d = scm_gcd(n1, n2);
399 if (SCM_INUM0==d) return d;
400 return scm_abs(scm_product(n1, scm_quotient(n2, d)));
401}
402
403#ifndef SCM_BIGDIG
404# ifndef SCM_FLOATS
405# define scm_long2num SCM_MAKINUM
406# endif
407#endif
408
409#ifndef scm_long2num
410SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
1cc91f1b 411
0f2d19dd
JB		 412SCM
413scm_logand(n1, n2)
414 SCM n1;
415 SCM n2;
0f2d19dd
JB		 416{
417 return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logand)
418 & scm_num2long(n2, (char *)SCM_ARG2, s_logand));
419}
420
421SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
1cc91f1b 422
0f2d19dd
JB		 423SCM
424scm_logior(n1, n2)
425 SCM n1;
426 SCM n2;
0f2d19dd
JB		 427{
428 return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logior)
429 | scm_num2long(n2, (char *)SCM_ARG2, s_logior));
430}
431
432SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
1cc91f1b 433
0f2d19dd
JB		 434SCM
435scm_logxor(n1, n2)
436 SCM n1;
437 SCM n2;
0f2d19dd
JB		 438{
439 return scm_long2num(scm_num2long(n1, (char *)SCM_ARG1, s_logxor)
440 ^ scm_num2long(n2, (char *)SCM_ARG2, s_logxor));
441}
442
443SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
1cc91f1b 444
0f2d19dd
JB		 445SCM
446scm_logtest(n1, n2)
447 SCM n1;
448 SCM n2;
0f2d19dd
JB		 449{
450 return ((scm_num2long (n1, (char *)SCM_ARG1, s_logtest)
451 & scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
452 ? SCM_BOOL_T : SCM_BOOL_F);
453}
454
455
456SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
1cc91f1b 457
0f2d19dd
JB		 458SCM
459scm_logbit_p(n1, n2)
460 SCM n1;
461 SCM n2;
0f2d19dd
JB		 462{
463 return (((1 << scm_num2long (n1, (char *)SCM_ARG1, s_logtest))
464 & scm_num2long (n2, (char *)SCM_ARG2, s_logtest))
465 ? SCM_BOOL_T : SCM_BOOL_F);
466}
467
468#else
469
470SCM_PROC1 (s_logand, "logand", scm_tc7_asubr, scm_logand);
1cc91f1b 471
0f2d19dd
JB		 472SCM
473scm_logand(n1, n2)
474 SCM n1;
475 SCM n2;
0f2d19dd
JB		 476{
477 SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logand);
478 SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logand);
479 return SCM_MAKINUM(SCM_INUM(n1) & SCM_INUM(n2));
480}
481
482SCM_PROC1 (s_logior, "logior", scm_tc7_asubr, scm_logior);
1cc91f1b 483
0f2d19dd
JB		 484SCM
485scm_logior(n1, n2)
486 SCM n1;
487 SCM n2;
0f2d19dd
JB		 488{
489 SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logior);
490 SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logior);
491 return SCM_MAKINUM(SCM_INUM(n1) | SCM_INUM(n2));
492}
493
494SCM_PROC1 (s_logxor, "logxor", scm_tc7_asubr, scm_logxor);
1cc91f1b 495
0f2d19dd
JB		 496SCM
497scm_logxor(n1, n2)
498 SCM n1;
499 SCM n2;
0f2d19dd
JB		 500{
501 SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logxor);
502 SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logxor);
503 return SCM_MAKINUM(SCM_INUM(n1) ^ SCM_INUM(n2));
504}
505
506SCM_PROC(s_logtest, "logtest", 2, 0, 0, scm_logtest);
1cc91f1b 507
0f2d19dd
JB		 508SCM
509scm_logtest(n1, n2)
510 SCM n1;
511 SCM n2;
0f2d19dd
JB		 512{
513 SCM_ASSERT(SCM_INUMP(n1), n1, SCM_ARG1, s_logtest);
514 SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logtest);
515 return (SCM_INUM(n1) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F;
516}
517
518SCM_PROC(s_logbit_p, "logbit?", 2, 0, 0, scm_logbit_p);
1cc91f1b 519
0f2d19dd
JB		 520SCM
521scm_logbit_p(n1, n2)
522 SCM n1;
523 SCM n2;
0f2d19dd
JB		 524{
525 SCM_ASSERT(SCM_INUMP(n1) && SCM_INUM(n1) >= 0, n1, SCM_ARG1, s_logbit_p);
526 SCM_ASSERT(SCM_INUMP(n2), n2, SCM_ARG2, s_logbit_p);
527 return ((1 << SCM_INUM(n1)) & SCM_INUM(n2)) ? SCM_BOOL_T : SCM_BOOL_F;
528}
529#endif
530
531SCM_PROC(s_lognot, "lognot", 1, 0, 0, scm_lognot);
1cc91f1b 532
0f2d19dd
JB		 533SCM
534scm_lognot(n)
535 SCM n;
0f2d19dd
JB		 536{
537 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_lognot);
538 return scm_difference(SCM_MAKINUM(-1L), n);
539}
540
541SCM_PROC(s_integer_expt, "integer-expt", 2, 0, 0, scm_integer_expt);
1cc91f1b 542
0f2d19dd
JB		 543SCM
544scm_integer_expt(z1, z2)
545 SCM z1;
546 SCM z2;
0f2d19dd
JB		 547{
548 SCM acc = SCM_MAKINUM(1L);
549#ifdef SCM_BIGDIG
550 if (SCM_INUM0==z1 || acc==z1) return z1;
551 else if (SCM_MAKINUM(-1L)==z1) return SCM_BOOL_F==scm_even_p(z2)?z1:acc;
552#endif
553 SCM_ASSERT(SCM_INUMP(z2), z2, SCM_ARG2, s_integer_expt);
554 z2 = SCM_INUM(z2);
555 if (z2 < 0) {
556 z2 = -z2;
557 z1 = scm_divide(z1, SCM_UNDEFINED);
558 }
559 while(1) {
560 if (0==z2) return acc;
561 if (1==z2) return scm_product(acc, z1);
562 if (z2 & 1) acc = scm_product(acc, z1);
563 z1 = scm_product(z1, z1);
564 z2 >>= 1;
565 }
566}
567
568SCM_PROC(s_ash, "ash", 2, 0, 0, scm_ash);
1cc91f1b 569
0f2d19dd
JB		 570SCM
571scm_ash(n, cnt)
572 SCM n;
573 SCM cnt;
0f2d19dd
JB		 574{
575 SCM res = SCM_INUM(n);
576 SCM_ASSERT(SCM_INUMP(cnt), cnt, SCM_ARG2, s_ash);
577#ifdef SCM_BIGDIG
578 if(cnt < 0) {
579 res = scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(-SCM_INUM(cnt)));
580 if (SCM_NFALSEP(scm_negative_p(n)))
581 return scm_sum(SCM_MAKINUM(-1L), scm_quotient(scm_sum(SCM_MAKINUM(1L), n), res));
582 else return scm_quotient(n, res);
583 }
584 else return scm_product(n, scm_integer_expt(SCM_MAKINUM(2), cnt));
585#else
586 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_ash);
587 cnt = SCM_INUM(cnt);
588 if (cnt < 0) return SCM_MAKINUM(SCM_SRS(res, -cnt));
589 res = SCM_MAKINUM(res<<cnt);
e1724d20 590 if (SCM_INUM(res)>>cnt != SCM_INUM(n))
52859adf 591 scm_num_overflow (s_ash);
0f2d19dd
JB		 592 return res;
593#endif
594}
595
596SCM_PROC(s_bit_extract, "bit-extract", 3, 0, 0, scm_bit_extract);
1cc91f1b 597
0f2d19dd
JB		 598SCM
599scm_bit_extract(n, start, end)
600 SCM n;
601 SCM start;
602 SCM end;
0f2d19dd
JB		 603{
604 SCM_ASSERT(SCM_INUMP(start), start, SCM_ARG2, s_bit_extract);
605 SCM_ASSERT(SCM_INUMP(end), end, SCM_ARG3, s_bit_extract);
606 start = SCM_INUM(start); end = SCM_INUM(end);
607 SCM_ASSERT(end >= start, SCM_MAKINUM(end), SCM_OUTOFRANGE, s_bit_extract);
608#ifdef SCM_BIGDIG
609 if SCM_NINUMP(n)
610 return
611 scm_logand(scm_difference(scm_integer_expt(SCM_MAKINUM(2), SCM_MAKINUM(end - start)),
612 SCM_MAKINUM(1L)),
613 scm_ash(n, SCM_MAKINUM(-start)));
614#else
615 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_bit_extract);
616#endif
617 return SCM_MAKINUM((SCM_INUM(n)>>start) & ((1L<<(end-start))-1));
618}
619
620char scm_logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
621SCM_PROC(s_logcount, "logcount", 1, 0, 0, scm_logcount);
1cc91f1b 622
0f2d19dd
JB		 623SCM
624scm_logcount(n)
625 SCM n;
0f2d19dd
JB		 626{
627 register unsigned long c = 0;
628 register long nn;
629#ifdef SCM_BIGDIG
630 if SCM_NINUMP(n) {
631 scm_sizet i; SCM_BIGDIG *ds, d;
632 SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_logcount);
633 if SCM_BIGSIGN(n) return scm_logcount(scm_difference(SCM_MAKINUM(-1L), n));
634 ds = SCM_BDIGITS(n);
635 for(i = SCM_NUMDIGS(n); i--; )
636 for(d = ds[i]; d; d >>= 4) c += scm_logtab[15 & d];
637 return SCM_MAKINUM(c);
638 }
639#else
640 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_logcount);
641#endif
642 if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn;
643 for(; nn; nn >>= 4) c += scm_logtab[15 & nn];
644 return SCM_MAKINUM(c);
645}
646
647char scm_ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
648SCM_PROC(s_integer_length, "integer-length", 1, 0, 0, scm_integer_length);
1cc91f1b 649
0f2d19dd
JB		 650SCM
651scm_integer_length(n)
652 SCM n;
0f2d19dd
JB		 653{
654 register unsigned long c = 0;
655 register long nn;
656 unsigned int l = 4;
657#ifdef SCM_BIGDIG
658 if SCM_NINUMP(n) {
659 SCM_BIGDIG *ds, d;
660 SCM_ASSERT(SCM_NIMP(n) && SCM_BIGP(n), n, SCM_ARG1, s_integer_length);
661 if SCM_BIGSIGN(n) return scm_integer_length(scm_difference(SCM_MAKINUM(-1L), n));
662 ds = SCM_BDIGITS(n);
663 d = ds[c = SCM_NUMDIGS(n)-1];
664 for(c *= SCM_BITSPERDIG; d; d >>= 4) {c += 4; l = scm_ilentab[15 & d];}
665 return SCM_MAKINUM(c - 4 + l);
666 }
667#else
668 SCM_ASSERT(SCM_INUMP(n), n, SCM_ARG1, s_integer_length);
669#endif
670 if ((nn = SCM_INUM(n)) < 0) nn = -1 - nn;
671 for(;nn; nn >>= 4) {c += 4; l = scm_ilentab[15 & nn];}
672 return SCM_MAKINUM(c - 4 + l);
673}
674
675
676#ifdef SCM_BIGDIG
677char s_bignum[] = "bignum";
1cc91f1b 678
0f2d19dd
JB		 679SCM
680scm_mkbig(nlen, sign)
681 scm_sizet nlen;
682 int sign;
0f2d19dd
JB		 683{
684 SCM v = nlen;
685 if (((v << 16) >> 16) != nlen)
686 scm_wta(SCM_MAKINUM(nlen), (char *)SCM_NALLOC, s_bignum);
687 SCM_NEWCELL(v);
688 SCM_DEFER_INTS;
689 SCM_SETCHARS(v, scm_must_malloc((long)(nlen*sizeof(SCM_BIGDIG)), s_bignum));
690 SCM_SETNUMDIGS(v, nlen, sign?scm_tc16_bigneg:scm_tc16_bigpos);
691 SCM_ALLOW_INTS;
692 return v;
693}
694
1cc91f1b 695
0f2d19dd
JB		 696SCM
697scm_big2inum(b, l)
698 SCM b;
699 scm_sizet l;
0f2d19dd
JB		 700{
701 unsigned long num = 0;
702 SCM_BIGDIG *tmp = SCM_BDIGITS(b);
703 while (l--) num = SCM_BIGUP(num) + tmp[l];
704 if (SCM_TYP16(b)==scm_tc16_bigpos) {
e2806c10 705 if SCM_POSFIXABLE(num) return SCM_MAKINUM(num);
0f2d19dd 706 }
e2806c10 707 else if SCM_UNEGFIXABLE(num) return SCM_MAKINUM(-num);
0f2d19dd
JB		 708 return b;
709}
710
711
712char s_adjbig[] = "scm_adjbig";
1cc91f1b 713
0f2d19dd
JB		 714SCM
715scm_adjbig(b, nlen)
716 SCM b;
717 scm_sizet nlen;
0f2d19dd
JB		 718{
719 long nsiz = nlen;
720 if (((nsiz << 16) >> 16) != nlen) scm_wta(SCM_MAKINUM(nsiz), (char *)SCM_NALLOC, s_adjbig);
721 SCM_DEFER_INTS;
722 SCM_SETCHARS(b, (SCM_BIGDIG *)scm_must_realloc((char *)SCM_CHARS(b),
723 (long)(SCM_NUMDIGS(b)*sizeof(SCM_BIGDIG)),
724 (long)(nsiz*sizeof(SCM_BIGDIG)), s_adjbig));
725 SCM_SETNUMDIGS(b, nsiz, SCM_TYP16(b));
726 SCM_ALLOW_INTS;
727 return b;
728}
729
730
1cc91f1b 731
0f2d19dd
JB		 732SCM
733scm_normbig(b)
734 SCM b;
0f2d19dd
JB		 735{
736#ifndef _UNICOS
737 scm_sizet nlen = SCM_NUMDIGS(b);
738#else
739 int nlen = SCM_NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */
740#endif
741 SCM_BIGDIG *zds = SCM_BDIGITS(b);
742 while (nlen-- && !zds[nlen]); nlen++;
743 if (nlen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM))
744 if SCM_INUMP(b = scm_big2inum(b, (scm_sizet)nlen)) return b;
745 if (SCM_NUMDIGS(b)==nlen) return b;
746 return scm_adjbig(b, (scm_sizet)nlen);
747}
748
749
1cc91f1b 750
0f2d19dd
JB		 751SCM
752scm_copybig(b, sign)
753 SCM b;
754 int sign;
0f2d19dd
JB		 755{
756 scm_sizet i = SCM_NUMDIGS(b);
757 SCM ans = scm_mkbig(i, sign);
758 SCM_BIGDIG *src = SCM_BDIGITS(b), *dst = SCM_BDIGITS(ans);
759 while (i--) dst[i] = src[i];
760 return ans;
761}
762
763
1cc91f1b 764
0f2d19dd
JB		 765SCM
766scm_long2big(n)
767 long n;
0f2d19dd
JB		 768{
769 scm_sizet i = 0;
770 SCM_BIGDIG *digits;
771 SCM ans = scm_mkbig(SCM_DIGSPERLONG, n<0);
772 digits = SCM_BDIGITS(ans);
773 if (n < 0) n = -n;
774 while (i < SCM_DIGSPERLONG) {
775 digits[i++] = SCM_BIGLO(n);
776 n = SCM_BIGDN((unsigned long)n);
777 }
778 return ans;
779}
780
781#ifdef LONGLONGS
1cc91f1b 782
0f2d19dd
JB		 783SCM
784scm_long_long2big(n)
785 long_long n;
0f2d19dd
JB		 786{
787 scm_sizet i;
788 SCM_BIGDIG *digits;
789 SCM ans;
790 int n_digits;
791
792 {
793 long tn;
794 tn = (long) n;
795 if ((long long)tn == n)
796 return scm_long2big (tn);
797 }
798
799 {
800 long_long tn;
801
802 for (tn = n, n_digits = 0;
803 tn;
804 ++n_digits, tn = SCM_BIGDN ((ulong_long)tn))
805 ;
806 }
807
808 i = 0;
809 ans = scm_mkbig(n_digits, n<0);
810 digits = SCM_BDIGITS(ans);
811 if (n < 0)
812 n = -n;
813 while (i < n_digits) {
814 digits[i++] = SCM_BIGLO(n);
815 n = SCM_BIGDN((ulong_long)n);
816 }
817 return ans;
818}
819#endif
820
1cc91f1b 821
0f2d19dd
JB		 822SCM
823scm_2ulong2big(np)
824 unsigned long * np;
0f2d19dd
JB		 825{
826 unsigned long n;
827 scm_sizet i;
828 SCM_BIGDIG *digits;
829 SCM ans;
830
831 ans = scm_mkbig(2 * SCM_DIGSPERLONG, 0);
832 digits = SCM_BDIGITS(ans);
833
834 n = np[0];
835 for (i = 0; i < SCM_DIGSPERLONG; ++i)
836 {
837 digits[i] = SCM_BIGLO(n);
838 n = SCM_BIGDN((unsigned long)n);
839 }
840 n = np[1];
841 for (i = 0; i < SCM_DIGSPERLONG; ++i)
842 {
843 digits[i + SCM_DIGSPERLONG] = SCM_BIGLO(n);
844 n = SCM_BIGDN((unsigned long)n);
845 }
846 return ans;
847}
848
849
1cc91f1b 850
0f2d19dd
JB		 851SCM
852scm_ulong2big(n)
853 unsigned long n;
0f2d19dd
JB		 854{
855 scm_sizet i = 0;
856 SCM_BIGDIG *digits;
857 SCM ans = scm_mkbig(SCM_DIGSPERLONG, 0);
858 digits = SCM_BDIGITS(ans);
859 while (i < SCM_DIGSPERLONG) {
860 digits[i++] = SCM_BIGLO(n);
861 n = SCM_BIGDN(n);
862 }
863 return ans;
864}
865
866
1cc91f1b 867
0f2d19dd
JB		 868int
869scm_bigcomp(x, y)
870 SCM x;
871 SCM y;
0f2d19dd
JB		 872{
873 int xsign = SCM_BIGSIGN(x);
874 int ysign = SCM_BIGSIGN(y);
875 scm_sizet xlen, ylen;
876 if (ysign < xsign) return 1;
877 if (ysign > xsign) return -1;
878 if ((ylen = SCM_NUMDIGS(y)) > (xlen = SCM_NUMDIGS(x))) return (xsign) ? -1 : 1;
879 if (ylen < xlen) return (xsign) ? 1 : -1;
880 while(xlen-- && (SCM_BDIGITS(y)[xlen]==SCM_BDIGITS(x)[xlen]));
881 if (-1==xlen) return 0;
882 return (SCM_BDIGITS(y)[xlen] > SCM_BDIGITS(x)[xlen]) ?
883 (xsign ? -1 : 1) : (xsign ? 1 : -1);
884}
885
886#ifndef SCM_DIGSTOOBIG
887
1cc91f1b 888
0f2d19dd
JB		 889long
890scm_pseudolong(x)
891 long x;
0f2d19dd
JB		 892{
893 union {
894 long l;
895 SCM_BIGDIG bd[SCM_DIGSPERLONG];
896 } p;
897 scm_sizet i = 0;
898 if (x < 0) x = -x;
899 while (i < SCM_DIGSPERLONG) {p.bd[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);}
900 /* p.bd[0] = SCM_BIGLO(x); p.bd[1] = SCM_BIGDN(x); */
901 return p.l;
902}
903
904#else
905
1cc91f1b 906
0f2d19dd
JB		 907void
908scm_longdigs(x, digs)
909 long x;
910 SCM_BIGDIG digs[];
0f2d19dd
JB		 911{
912 scm_sizet i = 0;
913 if (x < 0) x = -x;
914 while (i < SCM_DIGSPERLONG) {digs[i++] = SCM_BIGLO(x); x = SCM_BIGDN(x);}
915}
916#endif
917
918
1cc91f1b 919
0f2d19dd
JB		 920SCM
921scm_addbig(x, nx, xsgn, bigy, sgny)
922 SCM_BIGDIG *x;
923 scm_sizet nx;
924 int xsgn;
925 SCM bigy;
926 int sgny;
0f2d19dd
JB		 927{
928 /* Assumes nx <= SCM_NUMDIGS(bigy) */
929 /* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
930 long num = 0;
931 scm_sizet i = 0, ny = SCM_NUMDIGS(bigy);
932 SCM z = scm_copybig(bigy, SCM_BIGSIGN(bigy) ^ sgny);
933 SCM_BIGDIG *zds = SCM_BDIGITS(z);
934 if (xsgn ^ SCM_BIGSIGN(z)) {
935 do {
936 num += (long) zds[i] - x[i];
937 if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
938 else {zds[i] = SCM_BIGLO(num); num = 0;}
939 } while (++i < nx);
940 if (num && nx==ny) {
941 num = 1; i = 0;
a6c64c3c 942 SCM_SETCAR (z, SCM_CAR (z) ^ 0x0100);
0f2d19dd
JB		 943 do {
944 num += (SCM_BIGRAD-1) - zds[i];
945 zds[i++] = SCM_BIGLO(num);
946 num = SCM_BIGDN(num);
947 } while (i < ny);
948 }
949 else while (i < ny) {
950 num += zds[i];
951 if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;}
952 else {zds[i++] = SCM_BIGLO(num); num = 0;}
953 }
954 } else {
955 do {
956 num += (long) zds[i] + x[i];
957 zds[i++] = SCM_BIGLO(num);
958 num = SCM_BIGDN(num);
959 } while (i < nx);
960 if (!num) return z;
961 while (i < ny) {
962 num += zds[i];
963 zds[i++] = SCM_BIGLO(num);
964 num = SCM_BIGDN(num);
965 if (!num) return z;
966 }
967 if (num) {z = scm_adjbig(z, ny+1); SCM_BDIGITS(z)[ny] = num; return z;}
968 }
969 return scm_normbig(z);
970}
971
1cc91f1b 972
0f2d19dd
JB		 973SCM
974scm_mulbig(x, nx, y, ny, sgn)
975 SCM_BIGDIG *x;
976 scm_sizet nx;
977 SCM_BIGDIG *y;
978 scm_sizet ny;
979 int sgn;
0f2d19dd
JB		 980{
981 scm_sizet i = 0, j = nx + ny;
982 unsigned long n = 0;
983 SCM z = scm_mkbig(j, sgn);
984 SCM_BIGDIG *zds = SCM_BDIGITS(z);
985 while (j--) zds[j] = 0;
986 do {
987 j = 0;
988 if (x[i]) {
989 do {
990 n += zds[i + j] + ((unsigned long) x[i] * y[j]);
991 zds[i + j++] = SCM_BIGLO(n);
992 n = SCM_BIGDN(n);
993 } while (j < ny);
994 if (n) {zds[i + j] = n; n = 0;}
995 }
996 } while (++i < nx);
997 return scm_normbig(z);
998}
999
1cc91f1b 1000
0f2d19dd
JB		 1001unsigned int
1002scm_divbigdig(ds, h, div)
1003 SCM_BIGDIG *ds;
1004 scm_sizet h;
1005 SCM_BIGDIG div;
0f2d19dd
JB		 1006{
1007 register unsigned long t2 = 0;
1008 while(h--) {
1009 t2 = SCM_BIGUP(t2) + ds[h];
1010 ds[h] = t2 / div;
1011 t2 %= div;
1012 }
1013 return t2;
1014}
1015
1016
1cc91f1b 1017
0f2d19dd
JB		 1018SCM
1019scm_divbigint(x, z, sgn, mode)
1020 SCM x;
1021 long z;
1022 int sgn;
1023 int mode;
0f2d19dd
JB		 1024{
1025 if (z < 0) z = -z;
1026 if (z < SCM_BIGRAD) {
1027 register unsigned long t2 = 0;
1028 register SCM_BIGDIG *ds = SCM_BDIGITS(x);
1029 scm_sizet nd = SCM_NUMDIGS(x);
1030 while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z;
604b0844 1031 if (mode && t2) t2 = z - t2;
0f2d19dd
JB		 1032 return SCM_MAKINUM(sgn ? -t2 : t2);
1033 }
1034 {
1035#ifndef SCM_DIGSTOOBIG
1036 unsigned long t2 = scm_pseudolong(z);
1037 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&t2,
1038 SCM_DIGSPERLONG, sgn, mode);
1039#else
1040 SCM_BIGDIG t2[SCM_DIGSPERLONG];
1041 scm_longdigs(z, t2);
1042 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), t2, SCM_DIGSPERLONG, sgn, mode);
1043#endif
1044 }
1045}
1046
1cc91f1b 1047
0f2d19dd
JB		 1048SCM
1049scm_divbigbig(x, nx, y, ny, sgn, modes)
1050 SCM_BIGDIG *x;
1051 scm_sizet nx;
1052 SCM_BIGDIG *y;
1053 scm_sizet ny;
1054 int sgn;
1055 int modes;
0f2d19dd
JB		 1056{
1057 /* modes description
1058 0 remainder
1059 1 scm_modulo
1060 2 quotient
1061 3 quotient but returns 0 if division is not exact. */
1062 scm_sizet i = 0, j = 0;
1063 long num = 0;
1064 unsigned long t2 = 0;
1065 SCM z, newy;
1066 SCM_BIGDIG d = 0, qhat, *zds, *yds;
1067 /* algorithm requires nx >= ny */
1068 if (nx < ny)
1069 switch (modes) {
1070 case 0: /* remainder -- just return x */
1071 z = scm_mkbig(nx, sgn); zds = SCM_BDIGITS(z);
1072 do {zds[i] = x[i];} while (++i < nx);
1073 return z;
1074 case 1: /* scm_modulo -- return y-x */
1075 z = scm_mkbig(ny, sgn); zds = SCM_BDIGITS(z);
1076 do {
1077 num += (long) y[i] - x[i];
1078 if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
1079 else {zds[i] = num; num = 0;}
1080 } while (++i < nx);
1081 while (i < ny) {
1082 num += y[i];
1083 if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;}
1084 else {zds[i++] = num; num = 0;}
1085 }
1086 goto doadj;
1087 case 2: return SCM_INUM0; /* quotient is zero */
1088 case 3: return 0; /* the division is not exact */
1089 }
1090
1091 z = scm_mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = SCM_BDIGITS(z);
1092 if (nx==ny) zds[nx+1] = 0;
1093 while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */
1094 if (y[ny-1] < (SCM_BIGRAD>>1)) { /* normalize operands */
1095 d = SCM_BIGRAD/(y[ny-1]+1);
1096 newy = scm_mkbig(ny, 0); yds = SCM_BDIGITS(newy);
1097 while(j < ny)
1098 {t2 += (unsigned long) y[j]*d; yds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
1099 y = yds; j = 0; t2 = 0;
1100 while(j < nx)
1101 {t2 += (unsigned long) x[j]*d; zds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
1102 zds[j] = t2;
1103 }
1104 else {zds[j = nx] = 0; while (j--) zds[j] = x[j];}
1105 j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */
1106 do { /* loop over digits of quotient */
1107 if (zds[j]==y[ny-1]) qhat = SCM_BIGRAD-1;
1108 else qhat = (SCM_BIGUP(zds[j]) + zds[j-1])/y[ny-1];
1109 if (!qhat) continue;
1110 i = 0; num = 0; t2 = 0;
1111 do { /* multiply and subtract */
1112 t2 += (unsigned long) y[i] * qhat;
1113 num += zds[j - ny + i] - SCM_BIGLO(t2);
1114 if (num < 0) {zds[j - ny + i] = num + SCM_BIGRAD; num = -1;}
1115 else {zds[j - ny + i] = num; num = 0;}
1116 t2 = SCM_BIGDN(t2);
1117 } while (++i < ny);
1118 num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
1119 while (num) { /* "add back" required */
1120 i = 0; num = 0; qhat--;
1121 do {
1122 num += (long) zds[j - ny + i] + y[i];
1123 zds[j - ny + i] = SCM_BIGLO(num);
1124 num = SCM_BIGDN(num);
1125 } while (++i < ny);
1126 num--;
1127 }
1128 if (modes & 2) zds[j] = qhat;
1129 } while (--j >= ny);
1130 switch (modes) {
1131 case 3: /* check that remainder==0 */
1132 for(j = ny;j && !zds[j-1];--j) ; if (j) return 0;
1133 case 2: /* move quotient down in z */
1134 j = (nx==ny ? nx+2 : nx+1) - ny;
1135 for (i = 0;i < j;i++) zds[i] = zds[i+ny];
1136 ny = i;
1137 break;
1138 case 1: /* subtract for scm_modulo */
1139 i = 0; num = 0; j = 0;
1140 do {num += y[i] - zds[i];
1141 j = j | zds[i];
1142 if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
1143 else {zds[i] = num; num = 0;}
1144 } while (++i < ny);
1145 if (!j) return SCM_INUM0;
1146 case 0: /* just normalize remainder */
1147 if (d) scm_divbigdig(zds, ny, d);
1148 }
1149 doadj:
1150 for(j = ny;j && !zds[j-1];--j) ;
1151 if (j * SCM_BITSPERDIG <= sizeof(SCM)*SCM_CHAR_BIT)
1152 if SCM_INUMP(z = scm_big2inum(z, j)) return z;
1153 return scm_adjbig(z, j);
1154}
1155#endif
1156
1157
1158
1159\f
1160
1161/*** NUMBERS -> STRINGS ***/
1162#ifdef SCM_FLOATS
1163int scm_dblprec;
1164static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1165 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1166 5e-11,5e-12,5e-13,5e-14,5e-15,
1167 5e-16,5e-17,5e-18,5e-19,5e-20};
1168
1169
1170
1cc91f1b
JB		 1171
1172static scm_sizet idbl2str SCM_P ((double f, char *a));
1173
0f2d19dd
JB		 1174static scm_sizet
1175idbl2str(f, a)
1176 double f;
1177 char *a;
0f2d19dd
JB		 1178{
1179 int efmt, dpt, d, i, wp = scm_dblprec;
1180 scm_sizet ch = 0;
1181 int exp = 0;
1182
1183 if (f == 0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1184 if (f < 0.0) {f = -f;a[ch++]='-';}
1185 else if (f > 0.0) ;
1186 else goto funny;
1187 if (IS_INF(f))
1188 {
1189 if (ch == 0) a[ch++]='+';
1190 funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
1191 }
1192# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1193 make-uniform-vector, from causing infinite loops. */
1194 while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;}
1195 while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;}
1196# else
1197 while (f < 1.0) {f *= 10.0; exp--;}
1198 while (f > 10.0) {f /= 10.0; exp++;}
1199# endif
1200 if (f+fx[wp] >= 10.0) {f = 1.0; exp++;}
1201 zero:
1202# ifdef ENGNOT
1203 dpt = (exp+9999)%3;
1204 exp -= dpt++;
1205 efmt = 1;
1206# else
1207 efmt = (exp < -3) || (exp > wp+2);
1208 if (!efmt)
1209 if (exp < 0) {
1210 a[ch++] = '0';
1211 a[ch++] = '.';
1212 dpt = exp;
1213 while (++dpt) a[ch++] = '0';
1214 } else
1215 dpt = exp+1;
1216 else
1217 dpt = 1;
1218# endif
1219
1220 do {
1221 d = f;
1222 f -= d;
1223 a[ch++] = d+'0';
1224 if (f < fx[wp]) break;
1225 if (f+fx[wp] >= 1.0) {
1226 a[ch-1]++;
1227 break;
1228 }
1229 f *= 10.0;
1230 if (!(--dpt)) a[ch++] = '.';
1231 } while (wp--);
1232
1233 if (dpt > 0)
1234# ifndef ENGNOT
1235 if ((dpt > 4) && (exp > 6)) {
1236 d = (a[0]=='-'?2:1);
1237 for (i = ch++; i > d; i--)
1238 a[i] = a[i-1];
1239 a[d] = '.';
1240 efmt = 1;
1241 } else
1242# endif
1243 {
1244 while (--dpt) a[ch++] = '0';
1245 a[ch++] = '.';
1246 }
1247 if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */
1248 if (efmt && exp) {
1249 a[ch++] = 'e';
1250 if (exp < 0) {
1251 exp = -exp;
1252 a[ch++] = '-';
1253 }
1254 for (i = 10; i <= exp; i *= 10);
1255 for (i /= 10; i; i /= 10) {
1256 a[ch++] = exp/i + '0';
1257 exp %= i;
1258 }
1259 }
1260 return ch;
1261}
1262
1cc91f1b
JB		 1263
1264static scm_sizet iflo2str SCM_P ((SCM flt, char *str));
1265
0f2d19dd
JB		 1266static scm_sizet
1267iflo2str(flt, str)
1268 SCM flt;
1269 char *str;
0f2d19dd
JB		 1270{
1271 scm_sizet i;
1272# ifdef SCM_SINGLES
1273 if SCM_SINGP(flt) i = idbl2str(SCM_FLO(flt), str);
1274 else
1275# endif
1276 i = idbl2str(SCM_REAL(flt), str);
1277 if SCM_CPLXP(flt) {
1278 if(0 <= SCM_IMAG(flt)) /* jeh */
1279 str[i++] = '+'; /* jeh */
1280 i += idbl2str(SCM_IMAG(flt), &str[i]);
1281 str[i++] = 'i';
1282 }
1283 return i;
1284}
1285#endif /* SCM_FLOATS */
1286
1cc91f1b 1287
0f2d19dd
JB		 1288scm_sizet
1289scm_iint2str(num, rad, p)
1290 long num;
1291 int rad;
1292 char *p;
0f2d19dd
JB		 1293{
1294 scm_sizet j;
1295 register int i = 1, d;
1296 register long n = num;
1297 if (n < 0) {n = -n; i++;}
1298 for (n /= rad;n > 0;n /= rad) i++;
1299 j = i;
1300 n = num;
1301 if (n < 0) {n = -n; *p++ = '-'; i--;}
1302 while (i--) {
1303 d = n % rad;
1304 n /= rad;
1305 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1306 }
1307 return j;
1308}
1309
1310
1311#ifdef SCM_BIGDIG
1cc91f1b
JB		 1312
1313static SCM big2str SCM_P ((SCM b, register unsigned int radix));
1314
0f2d19dd
JB		 1315static SCM
1316big2str(b, radix)
1317 SCM b;
1318 register unsigned int radix;
0f2d19dd
JB		 1319{
1320 SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */
1321 register SCM_BIGDIG *ds = SCM_BDIGITS(t);
1322 scm_sizet i = SCM_NUMDIGS(t);
1323 scm_sizet j = radix==16 ? (SCM_BITSPERDIG*i)/4+2
1324 : radix >= 10 ? (SCM_BITSPERDIG*i*241L)/800+2
1325 : (SCM_BITSPERDIG*i)+2;
1326 scm_sizet k = 0;
1327 scm_sizet radct = 0;
1328 scm_sizet ch; /* jeh */
1329 SCM_BIGDIG radpow = 1, radmod = 0;
1330 SCM ss = scm_makstr((long)j, 0);
1331 char *s = SCM_CHARS(ss), c;
1332 while ((long) radpow * radix < SCM_BIGRAD) {
1333 radpow *= radix;
1334 radct++;
1335 }
1336 s[0] = scm_tc16_bigneg==SCM_TYP16(b) ? '-' : '+';
1337 while ((i || radmod) && j) {
1338 if (k == 0) {
1339 radmod = (SCM_BIGDIG)scm_divbigdig(ds, i, radpow);
1340 k = radct;
1341 if (!ds[i-1]) i--;
1342 }
1343 c = radmod % radix; radmod /= radix; k--;
1344 s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
1345 }
1346 ch = s[0] == '-' ? 1 : 0; /* jeh */
1347 if (ch < j) { /* jeh */
1348 for(i = j;j < SCM_LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
1349 scm_vector_set_length_x(ss, (SCM)SCM_MAKINUM(ch+SCM_LENGTH(ss)-i)); /* jeh */
1350 }
1351 return ss;
1352}
1353#endif
1354
1355
1356SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string);
1cc91f1b 1357
0f2d19dd
JB		 1358SCM
1359scm_number_to_string(x, radix)
1360 SCM x;
1361 SCM radix;
0f2d19dd
JB		 1362{
1363 if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
1364 else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string);
1365#ifdef SCM_FLOATS
1366 if SCM_NINUMP(x) {
1367 char num_buf[SCM_FLOBUFLEN];
1368# ifdef SCM_BIGDIG
1369 SCM_ASRTGO(SCM_NIMP(x), badx);
1370 if SCM_BIGP(x) return big2str(x, (unsigned int)SCM_INUM(radix));
1371# ifndef RECKLESS
1372 if (!(SCM_INEXP(x)))
1373 badx: scm_wta(x, (char *)SCM_ARG1, s_number_to_string);
1374# endif
1375# else
1376 SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_number_to_string);
1377# endif
1378 return scm_makfromstr(num_buf, iflo2str(x, num_buf), 0);
1379 }
1380#else
1381# ifdef SCM_BIGDIG
1382 if SCM_NINUMP(x) {
1383 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_number_to_string);
1384 return big2str(x, (unsigned int)SCM_INUM(radix));
1385 }
1386# else
1387 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_number_to_string);
1388# endif
1389#endif
1390 {
1391 char num_buf[SCM_INTBUFLEN];
1392 return scm_makfromstr(num_buf,
1393 scm_iint2str(SCM_INUM(x), (int)SCM_INUM(radix), num_buf), 0);
1394 }
1395}
1396
1397
1398/* These print routines are stubbed here so that scm_repl.c doesn't need
1399 SCM_FLOATS or SCM_BIGDIGs conditionals */
1cc91f1b 1400
0f2d19dd 1401int
19402679 1402scm_floprint(sexp, port, pstate)
0f2d19dd
JB		 1403 SCM sexp;
1404 SCM port;
19402679 1405 scm_print_state *pstate;
0f2d19dd
JB		 1406{
1407#ifdef SCM_FLOATS
1408 char num_buf[SCM_FLOBUFLEN];
1409 scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port);
1410#else
1411 scm_ipruk("float", sexp, port);
1412#endif
1413 return !0;
1414}
1415
1416
1cc91f1b 1417
0f2d19dd 1418int
19402679 1419scm_bigprint(exp, port, pstate)
0f2d19dd
JB		 1420 SCM exp;
1421 SCM port;
19402679 1422 scm_print_state *pstate;
0f2d19dd
JB		 1423{
1424#ifdef SCM_BIGDIG
1425 exp = big2str(exp, (unsigned int)10);
1426 scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port);
1427#else
1428 scm_ipruk("bignum", exp, port);
1429#endif
1430 return !0;
1431}
1432/*** END nums->strs ***/
1433
1434/*** STRINGS -> NUMBERS ***/
2a8fecee 1435
1cc91f1b
JB		 1436static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix));
1437
2a8fecee
JB		 1438static SCM
1439scm_small_istr2int(str, len, radix)
1440 char *str;
1441 long len;
1442 long radix;
1443{
1444 register long n = 0, ln;
1445 register int c;
1446 register int i = 0;
1447 int lead_neg = 0;
1448 if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
1449 switch (*str) { /* leading sign */
1450 case '-': lead_neg = 1;
1451 case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1452 }
1453
1454 do {
1455 switch (c = str[i++]) {
1456 case DIGITS:
1457 c = c - '0';
1458 goto accumulate;
1459 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1460 c = c-'A'+10;
1461 goto accumulate;
1462 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1463 c = c-'a'+10;
1464 accumulate:
1465 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1466 ln = n;
1467 n = n * radix - c;
1468 /* Negation is a workaround for HP700 cc bug */
1469 if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
1470 break;
1471 default:
1472 return SCM_BOOL_F; /* not a digit */
1473 }
1474 } while (i < len);
1475 if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
1476 return SCM_MAKINUM(n);
1477 ovfl: /* overflow scheme integer */
1478 return SCM_BOOL_F;
1479}
1480
1481
1cc91f1b 1482
0f2d19dd
JB		 1483SCM
1484scm_istr2int(str, len, radix)
1485 char *str;
1486 long len;
1487 long radix;
0f2d19dd
JB		 1488{
1489 scm_sizet j;
1490 register scm_sizet k, blen = 1;
1491 scm_sizet i = 0;
1492 int c;
1493 SCM res;
1494 register SCM_BIGDIG *ds;
1495 register unsigned long t2;
1496
1497 if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
2a8fecee
JB		 1498
1499 /* Short numbers we parse directly into an int, to avoid the overhead
1500 of creating a bignum. */
1501 if (len < 6)
1502 return scm_small_istr2int (str, len, radix);
1503
0f2d19dd
JB		 1504 if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG);
1505 else if (10 <= radix)
1506 j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25);
1507 else j = 1+(len*sizeof(char))/(SCM_BITSPERDIG);
1508 switch (str[0]) { /* leading sign */
1509 case '-':
1510 case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1511 }
1512 res = scm_mkbig(j, '-'==str[0]);
1513 ds = SCM_BDIGITS(res);
1514 for (k = j;k--;) ds[k] = 0;
1515 do {
1516 switch (c = str[i++]) {
1517 case DIGITS:
1518 c = c - '0';
1519 goto accumulate;
1520 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1521 c = c-'A'+10;
1522 goto accumulate;
1523 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1524 c = c-'a'+10;
1525 accumulate:
1526 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1527 k = 0;
1528 t2 = c;
1529 moretodo:
1530 while(k < blen) {
1531 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1532 t2 += ds[k]*radix;
1533 ds[k++] = SCM_BIGLO(t2);
1534 t2 = SCM_BIGDN(t2);
1535 }
e1724d20 1536 if (blen > j)
52859adf 1537 scm_num_overflow ("bignum");
0f2d19dd
JB		 1538 if (t2) {blen++; goto moretodo;}
1539 break;
1540 default:
1541 return SCM_BOOL_F; /* not a digit */
1542 }
1543 } while (i < len);
1544 if (blen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM))
1545 if SCM_INUMP(res = scm_big2inum(res, blen)) return res;
1546 if (j==blen) return res;
1547 return scm_adjbig(res, blen);
1548}
0f2d19dd
JB		 1549
1550#ifdef SCM_FLOATS
1cc91f1b 1551
0f2d19dd
JB		 1552SCM
1553scm_istr2flo(str, len, radix)
1554 char *str;
1555 long len;
1556 long radix;
0f2d19dd
JB		 1557{
1558 register int c, i = 0;
1559 double lead_sgn;
1560 double res = 0.0, tmp = 0.0;
1561 int flg = 0;
1562 int point = 0;
1563 SCM second;
1564
1565 if (i >= len) return SCM_BOOL_F; /* zero scm_length */
1566
1567 switch (*str) { /* leading sign */
1568 case '-': lead_sgn = -1.0; i++; break;
1569 case '+': lead_sgn = 1.0; i++; break;
1570 default : lead_sgn = 0.0;
1571 }
1572 if (i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1573
1574 if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */
1575 if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
1576 if (++i < len) return SCM_BOOL_F; /* `i' not last character */
1577 return scm_makdbl(0.0, lead_sgn);
1578 }
1579 do { /* check initial digits */
1580 switch (c = str[i]) {
1581 case DIGITS:
1582 c = c - '0';
1583 goto accum1;
1584 case 'D': case 'E': case 'F':
1585 if (radix==10) goto out1; /* must be exponent */
1586 case 'A': case 'B': case 'C':
1587 c = c-'A'+10;
1588 goto accum1;
1589 case 'd': case 'e': case 'f':
1590 if (radix==10) goto out1;
1591 case 'a': case 'b': case 'c':
1592 c = c-'a'+10;
1593 accum1:
1594 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1595 res = res * radix + c;
1596 flg = 1; /* res is valid */
1597 break;
1598 default:
1599 goto out1;
1600 }
1601 } while (++i < len);
1602 out1:
1603
1604 /* if true, then we did see a digit above, and res is valid */
1605 if (i==len) goto done;
1606
1607 /* By here, must have seen a digit,
1608 or must have next char be a `.' with radix==10 */
1609 if (!flg)
1610 if (!(str[i]=='.' && radix==10))
1611 return SCM_BOOL_F;
1612
1613 while (str[i]=='#') { /* optional sharps */
1614 res *= radix;
1615 if (++i==len) goto done;
1616 }
1617
1618 if (str[i]=='/') {
1619 while (++i < len) {
1620 switch (c = str[i]) {
1621 case DIGITS:
1622 c = c - '0';
1623 goto accum2;
1624 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1625 c = c-'A'+10;
1626 goto accum2;
1627 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1628 c = c-'a'+10;
1629 accum2:
1630 if (c >= radix) return SCM_BOOL_F;
1631 tmp = tmp * radix + c;
1632 break;
1633 default:
1634 goto out2;
1635 }
1636 }
1637 out2:
1638 if (tmp==0.0) return SCM_BOOL_F; /* `slash zero' not allowed */
1639 if (i < len)
1640 while (str[i]=='#') { /* optional sharps */
1641 tmp *= radix;
1642 if (++i==len) break;
1643 }
1644 res /= tmp;
1645 goto done;
1646 }
1647
1648 if (str[i]=='.') { /* decimal point notation */
1649 if (radix != 10) return SCM_BOOL_F; /* must be radix 10 */
1650 while (++i < len) {
1651 switch (c = str[i]) {
1652 case DIGITS:
1653 point--;
1654 res = res*10.0 + c-'0';
1655 flg = 1;
1656 break;
1657 default:
1658 goto out3;
1659 }
1660 }
1661 out3:
1662 if (!flg) return SCM_BOOL_F; /* no digits before or after decimal point */
1663 if (i==len) goto adjust;
1664 while (str[i]=='#') { /* ignore remaining sharps */
1665 if (++i==len) goto adjust;
1666 }
1667 }
1668
1669 switch (str[i]) { /* exponent */
1670 case 'd': case 'D':
1671 case 'e': case 'E':
1672 case 'f': case 'F':
1673 case 'l': case 'L':
1674 case 's': case 'S': {
1675 int expsgn = 1, expon = 0;
1676 if (radix != 10) return SCM_BOOL_F; /* only in radix 10 */
1677 if (++i==len) return SCM_BOOL_F; /* bad exponent */
1678 switch (str[i]) {
1679 case '-': expsgn=(-1);
1680 case '+': if (++i==len) return SCM_BOOL_F; /* bad exponent */
1681 }
1682 if (str[i] < '0' || str[i] > '9') return SCM_BOOL_F; /* bad exponent */
1683 do {
1684 switch (c = str[i]) {
1685 case DIGITS:
1686 expon = expon*10 + c-'0';
1687 if (expon > MAXEXP) return SCM_BOOL_F; /* exponent too large */
1688 break;
1689 default:
1690 goto out4;
1691 }
1692 } while (++i < len);
1693 out4:
1694 point += expsgn*expon;
1695 }
1696 }
1697
1698 adjust:
1699 if (point >= 0)
1700 while (point--) res *= 10.0;
1701 else
1702# ifdef _UNICOS
1703 while (point++) res *= 0.1;
1704# else
1705 while (point++) res /= 10.0;
1706# endif
1707
1708 done:
1709 /* at this point, we have a legitimate floating point result */
1710 if (lead_sgn==-1.0) res = -res;
1711 if (i==len) return scm_makdbl(res, 0.0);
1712
1713 if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */
1714 if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
1715 if (++i < len) return SCM_BOOL_F; /* `i' not last character */
1716 return scm_makdbl(0.0, res);
1717 }
1718
1719 switch (str[i++]) {
1720 case '-': lead_sgn = -1.0; break;
1721 case '+': lead_sgn = 1.0; break;
1722 case '@': { /* polar input for complex number */
1723 /* get a `real' for scm_angle */
1724 second = scm_istr2flo(&str[i], (long)(len-i), radix);
1725 if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `real' */
1726 if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `real' */
1727 tmp = SCM_REALPART(second);
1728 return scm_makdbl(res*cos(tmp), res*sin(tmp));
1729 }
1730 default: return SCM_BOOL_F;
1731 }
1732
1733 /* at this point, last char must be `i' */
1734 if (str[len-1] != 'i' && str[len-1] != 'I') return SCM_BOOL_F;
1735 /* handles `x+i' and `x-i' */
1736 if (i==(len-1)) return scm_makdbl(res, lead_sgn);
1737 /* get a `ureal' for complex part */
1738 second = scm_istr2flo(&str[i], (long)((len-i)-1), radix);
1739 if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `ureal' */
1740 if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `ureal' */
1741 tmp = SCM_REALPART(second);
1742 if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */
1743 return scm_makdbl(res, (lead_sgn*tmp));
1744}
1745#endif /* SCM_FLOATS */
1746
1747
1cc91f1b 1748
0f2d19dd
JB		 1749SCM
1750scm_istring2number(str, len, radix)
1751 char *str;
1752 long len;
1753 long radix;
0f2d19dd
JB		 1754{
1755 int i = 0;
1756 char ex = 0;
1757 char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
1758 SCM res;
1759 if (len==1)
1760 if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
1761 return SCM_BOOL_F;
1762
1763 while ((len-i) >= 2 && str[i]=='#' && ++i)
1764 switch (str[i++]) {
1765 case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break;
1766 case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break;
1767 case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break;
1768 case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break;
1769 case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break;
1770 case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break;
1771 default: return SCM_BOOL_F;
1772 }
1773
1774 switch (ex) {
1775 case 1:
1776 return scm_istr2int(&str[i], len-i, radix);
1777 case 0:
1778 res = scm_istr2int(&str[i], len-i, radix);
1779 if SCM_NFALSEP(res) return res;
1780#ifdef SCM_FLOATS
1781 case 2: return scm_istr2flo(&str[i], len-i, radix);
1782#endif
1783 }
1784 return SCM_BOOL_F;
1785}
1786
1787
1788SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number);
1cc91f1b 1789
0f2d19dd
JB		 1790SCM
1791scm_string_to_number(str, radix)
1792 SCM str;
1793 SCM radix;
0f2d19dd
JB		 1794{
1795 SCM answer;
1796 if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
1797 else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_string_to_number);
1798 SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, s_string_to_number);
1799 answer = scm_istring2number(SCM_ROCHARS(str), SCM_ROLENGTH(str), SCM_INUM(radix));
1800 return scm_return_first (answer, str);
1801}
1802/*** END strs->nums ***/
1803
1804#ifdef SCM_FLOATS
1cc91f1b 1805
0f2d19dd
JB		 1806SCM
1807scm_makdbl (x, y)
1808 double x;
1809 double y;
0f2d19dd
JB		 1810{
1811 SCM z;
1812 if ((y==0.0) && (x==0.0)) return scm_flo0;
1813 SCM_NEWCELL(z);
1814 SCM_DEFER_INTS;
1815 if (y==0.0) {
1816# ifdef SCM_SINGLES
1817 float fx = x;
1818# ifndef SCM_SINGLESONLY
1819 if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x))
1820# endif
1821 {
a6c64c3c 1822 SCM_SETCAR (z, scm_tc_flo);
0f2d19dd
JB		 1823 SCM_FLO(z) = x;
1824 SCM_ALLOW_INTS;
1825 return z;
1826 }
1827# endif/* def SCM_SINGLES */
a6c64c3c
MD		 1828 SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
1829 SCM_SETCAR (z, scm_tc_dblr);
0f2d19dd
JB		 1830 }
1831 else {
a6c64c3c
MD		 1832 SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex"));
1833 SCM_SETCAR (z, scm_tc_dblc);
0f2d19dd
JB		 1834 SCM_IMAG(z) = y;
1835 }
1836 SCM_REAL(z) = x;
1837 SCM_ALLOW_INTS;
1838 return z;
1839}
1840#endif
1841
1842
1cc91f1b 1843
0f2d19dd
JB		 1844SCM
1845scm_bigequal(x, y)
1846 SCM x;
1847 SCM y;
0f2d19dd
JB		 1848{
1849#ifdef SCM_BIGDIG
1850 if (0==scm_bigcomp(x, y)) return SCM_BOOL_T;
1851#endif
1852 return SCM_BOOL_F;
1853}
1854
1855
1cc91f1b 1856
0f2d19dd
JB		 1857SCM
1858scm_floequal(x, y)
1859 SCM x;
1860 SCM y;
0f2d19dd
JB		 1861{
1862#ifdef SCM_FLOATS
1863 if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
1864 if (!(SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y)))) return SCM_BOOL_T;
1865#endif
1866 return SCM_BOOL_F;
1867}
1868
1869
1870
1871
1872SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p);
1873SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p);
1cc91f1b 1874
0f2d19dd
JB		 1875SCM
1876scm_number_p(x)
1877 SCM x;
0f2d19dd
JB		 1878{
1879 if SCM_INUMP(x) return SCM_BOOL_T;
1880#ifdef SCM_FLOATS
1881 if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
1882#else
1883# ifdef SCM_BIGDIG
1884 if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
1885# endif
1886#endif
1887 return SCM_BOOL_F;
1888}
1889
1890
1891
1892#ifdef SCM_FLOATS
1893SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p);
1894SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p);
1cc91f1b 1895
0f2d19dd
JB		 1896SCM
1897scm_real_p(x)
1898 SCM x;
0f2d19dd
JB		 1899{
1900 if (SCM_INUMP(x))
1901 return SCM_BOOL_T;
1902 if (SCM_IMP(x))
1903 return SCM_BOOL_F;
1904 if (SCM_REALP(x))
1905 return SCM_BOOL_T;
1906# ifdef SCM_BIGDIG
1907 if (SCM_BIGP(x))
1908 return SCM_BOOL_T;
1909# endif
1910 return SCM_BOOL_F;
1911}
1912
1913
1914
f693191c 1915SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p);
1cc91f1b 1916
0f2d19dd 1917SCM
f693191c 1918scm_integer_p(x)
0f2d19dd 1919 SCM x;
0f2d19dd
JB		 1920{
1921 double r;
1922 if SCM_INUMP(x) return SCM_BOOL_T;
1923 if SCM_IMP(x) return SCM_BOOL_F;
1924# ifdef SCM_BIGDIG
1925 if SCM_BIGP(x) return SCM_BOOL_T;
1926# endif
1927 if (!SCM_INEXP(x)) return SCM_BOOL_F;
f693191c 1928 if (SCM_CPLXP(x)) return SCM_BOOL_F;
0f2d19dd
JB		 1929 r = SCM_REALPART(x);
1930 if (r==floor(r)) return SCM_BOOL_T;
1931 return SCM_BOOL_F;
1932}
1933
1934
1935
1936#endif /* SCM_FLOATS */
1937
1938SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p);
1cc91f1b 1939
0f2d19dd
JB		 1940SCM
1941scm_inexact_p(x)
1942 SCM x;
0f2d19dd
JB		 1943{
1944#ifdef SCM_FLOATS
1945 if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T;
1946#endif
1947 return SCM_BOOL_F;
1948}
1949
1950
1951
1952
f693191c 1953SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p);
1cc91f1b 1954
0f2d19dd
JB		 1955SCM
1956scm_num_eq_p (x, y)
1957 SCM x;
1958 SCM y;
0f2d19dd
JB		 1959{
1960#ifdef SCM_FLOATS
1961 SCM t;
1962 if SCM_NINUMP(x) {
1963# ifdef SCM_BIGDIG
1964# ifndef RECKLESS
1965 if (!(SCM_NIMP(x)))
1966 badx: scm_wta(x, (char *)SCM_ARG1, s_eq_p);
1967# endif
1968 if SCM_BIGP(x) {
1969 if SCM_INUMP(y) return SCM_BOOL_F;
1970 SCM_ASRTGO(SCM_NIMP(y), bady);
1971 if SCM_BIGP(y) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
1972 SCM_ASRTGO(SCM_INEXP(y), bady);
1973 bigreal:
1974 return (SCM_REALP(y) && (scm_big2dbl(x)==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
1975 }
1976 SCM_ASRTGO(SCM_INEXP(x), badx);
1977# else
1978 SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_eq_p);
1979# endif
1980 if SCM_INUMP(y) {t = x; x = y; y = t; goto realint;}
1981# ifdef SCM_BIGDIG
1982 SCM_ASRTGO(SCM_NIMP(y), bady);
1983 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
1984 SCM_ASRTGO(SCM_INEXP(y), bady);
1985# else
1986 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
1987# endif
1988 if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
1989 if SCM_CPLXP(x)
1990 return (SCM_CPLXP(y) && (SCM_IMAG(x)==SCM_IMAG(y))) ? SCM_BOOL_T : SCM_BOOL_F;
1991 return SCM_CPLXP(y) ? SCM_BOOL_F : SCM_BOOL_T;
1992 }
1993 if SCM_NINUMP(y) {
1994# ifdef SCM_BIGDIG
1995 SCM_ASRTGO(SCM_NIMP(y), bady);
1996 if SCM_BIGP(y) return SCM_BOOL_F;
1997# ifndef RECKLESS
1998 if (!(SCM_INEXP(y)))
1999 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2000# endif
2001# else
2002# ifndef RECKLESS
2003 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2004 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2005# endif
2006# endif
2007 realint:
2008 return (SCM_REALP(y) && (((double)SCM_INUM(x))==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
2009 }
2010#else
2011# ifdef SCM_BIGDIG
2012 if SCM_NINUMP(x) {
2013 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_eq_p);
2014 if SCM_INUMP(y) return SCM_BOOL_F;
2015 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2016 return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2017 }
2018 if SCM_NINUMP(y) {
2019# ifndef RECKLESS
2020 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2021 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2022# endif
2023 return SCM_BOOL_F;
2024 }
2025# else
2026 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_eq_p);
2027 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_eq_p);
2028# endif
2029#endif
2030 return ((long)x==(long)y) ? SCM_BOOL_T : SCM_BOOL_F;
2031}
2032
2033
2034
f693191c 2035SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p);
1cc91f1b 2036
0f2d19dd
JB		 2037SCM
2038scm_less_p(x, y)
2039 SCM x;
2040 SCM y;
0f2d19dd
JB		 2041{
2042#ifdef SCM_FLOATS
2043 if SCM_NINUMP(x) {
2044# ifdef SCM_BIGDIG
2045# ifndef RECKLESS
2046 if (!(SCM_NIMP(x)))
2047 badx: scm_wta(x, (char *)SCM_ARG1, s_less_p);
2048# endif
2049 if SCM_BIGP(x) {
2050 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
2051 SCM_ASRTGO(SCM_NIMP(y), bady);
2052 if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2053 SCM_ASRTGO(SCM_REALP(y), bady);
2054 return (scm_big2dbl(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2055 }
2056 SCM_ASRTGO(SCM_REALP(x), badx);
2057# else
2058 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_less_p);
2059# endif
2060 if (SCM_INUMP(y))
2061 return (SCM_REALPART(x) < ((double)SCM_INUM(y))) ? SCM_BOOL_T : SCM_BOOL_F;
2062# ifdef SCM_BIGDIG
2063 SCM_ASRTGO(SCM_NIMP(y), bady);
2064 if SCM_BIGP(y) return (SCM_REALPART(x) < scm_big2dbl(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2065 SCM_ASRTGO(SCM_REALP(y), bady);
2066# else
2067 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2068# endif
2069 return (SCM_REALPART(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2070 }
2071 if SCM_NINUMP(y) {
2072# ifdef SCM_BIGDIG
2073 SCM_ASRTGO(SCM_NIMP(y), bady);
2074 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
2075# ifndef RECKLESS
2076 if (!(SCM_REALP(y)))
2077 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2078# endif
2079# else
2080# ifndef RECKLESS
2081 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2082 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2083# endif
2084# endif
2085 return (((double)SCM_INUM(x)) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2086 }
2087#else
2088# ifdef SCM_BIGDIG
2089 if SCM_NINUMP(x) {
2090 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_less_p);
2091 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
2092 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2093 return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2094 }
2095 if SCM_NINUMP(y) {
2096# ifndef RECKLESS
2097 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2098 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2099# endif
2100 return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
2101 }
2102# else
2103 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_less_p);
2104 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_less_p);
2105# endif
2106#endif
2107 return ((long)x < (long)y) ? SCM_BOOL_T : SCM_BOOL_F;
2108}
2109
2110
f693191c 2111SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p);
1cc91f1b 2112
0f2d19dd
JB		 2113SCM
2114scm_gr_p(x, y)
2115 SCM x;
2116 SCM y;
0f2d19dd
JB		 2117{
2118 return scm_less_p(y, x);
2119}
2120
2121
2122
f693191c 2123SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p);
1cc91f1b 2124
0f2d19dd
JB		 2125SCM
2126scm_leq_p(x, y)
2127 SCM x;
2128 SCM y;
0f2d19dd
JB		 2129{
2130 return SCM_BOOL_NOT(scm_less_p(y, x));
2131}
2132
2133
2134
f693191c 2135SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p);
1cc91f1b 2136
0f2d19dd
JB		 2137SCM
2138scm_geq_p(x, y)
2139 SCM x;
2140 SCM y;
0f2d19dd
JB		 2141{
2142 return SCM_BOOL_NOT(scm_less_p(x, y));
2143}
2144
2145
2146
2147SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p);
1cc91f1b 2148
0f2d19dd
JB		 2149SCM
2150scm_zero_p(z)
2151 SCM z;
0f2d19dd
JB		 2152{
2153#ifdef SCM_FLOATS
2154 if SCM_NINUMP(z) {
2155# ifdef SCM_BIGDIG
2156 SCM_ASRTGO(SCM_NIMP(z), badz);
2157 if SCM_BIGP(z) return SCM_BOOL_F;
2158# ifndef RECKLESS
2159 if (!(SCM_INEXP(z)))
2160 badz: scm_wta(z, (char *)SCM_ARG1, s_zero_p);
2161# endif
2162# else
2163 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_zero_p);
2164# endif
2165 return (z==scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F;
2166 }
2167#else
2168# ifdef SCM_BIGDIG
2169 if SCM_NINUMP(z) {
2170 SCM_ASSERT(SCM_NIMP(z) && SCM_BIGP(z), z, SCM_ARG1, s_zero_p);
2171 return SCM_BOOL_F;
2172 }
2173# else
2174 SCM_ASSERT(SCM_INUMP(z), z, SCM_ARG1, s_zero_p);
2175# endif
2176#endif
2177 return (z==SCM_INUM0) ? SCM_BOOL_T: SCM_BOOL_F;
2178}
2179
2180
2181
2182SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p);
1cc91f1b 2183
0f2d19dd
JB		 2184SCM
2185scm_positive_p(x)
2186 SCM x;
0f2d19dd
JB		 2187{
2188#ifdef SCM_FLOATS
2189 if SCM_NINUMP(x) {
2190# ifdef SCM_BIGDIG
2191 SCM_ASRTGO(SCM_NIMP(x), badx);
2192 if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2193# ifndef RECKLESS
2194 if (!(SCM_REALP(x)))
2195 badx: scm_wta(x, (char *)SCM_ARG1, s_positive_p);
2196# endif
2197# else
2198 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_positive_p);
2199# endif
2200 return (SCM_REALPART(x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2201 }
2202#else
2203# ifdef SCM_BIGDIG
2204 if SCM_NINUMP(x) {
2205 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_positive_p);
2206 return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2207 }
2208# else
2209 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_positive_p);
2210# endif
2211#endif
2212 return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2213}
2214
2215
2216
2217SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p);
1cc91f1b 2218
0f2d19dd
JB		 2219SCM
2220scm_negative_p(x)
2221 SCM x;
0f2d19dd
JB		 2222{
2223#ifdef SCM_FLOATS
2224 if SCM_NINUMP(x) {
2225# ifdef SCM_BIGDIG
2226 SCM_ASRTGO(SCM_NIMP(x), badx);
2227 if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T;
2228# ifndef RECKLESS
2229 if (!(SCM_REALP(x)))
2230 badx: scm_wta(x, (char *)SCM_ARG1, s_negative_p);
2231# endif
2232# else
2233 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_negative_p);
2234# endif
2235 return (SCM_REALPART(x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2236 }
2237#else
2238# ifdef SCM_BIGDIG
2239 if SCM_NINUMP(x) {
2240 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_negative_p);
2241 return (SCM_TYP16(x)==scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F;
2242 }
2243# else
2244 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_negative_p);
2245# endif
2246#endif
2247 return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2248}
2249
2250
2251SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
1cc91f1b 2252
0f2d19dd
JB		 2253SCM
2254scm_max(x, y)
2255 SCM x;
2256 SCM y;
0f2d19dd
JB		 2257{
2258#ifdef SCM_FLOATS
2259 double z;
2260#endif
2261 if SCM_UNBNDP(y) {
2262#ifndef RECKLESS
2263 if (!(SCM_NUMBERP(x)))
2264 badx: scm_wta(x, (char *)SCM_ARG1, s_max);
2265#endif
2266 return x;
2267 }
2268#ifdef SCM_FLOATS
2269 if SCM_NINUMP(x) {
2270# ifdef SCM_BIGDIG
2271 SCM_ASRTGO(SCM_NIMP(x), badx);
2272 if SCM_BIGP(x) {
2273 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
2274 SCM_ASRTGO(SCM_NIMP(y), bady);
2275 if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? y : x;
2276 SCM_ASRTGO(SCM_REALP(y), bady);
2277 z = scm_big2dbl(x);
2278 return (z < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2279 }
2280 SCM_ASRTGO(SCM_REALP(x), badx);
2281# else
2282 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_max);
2283# endif
2284 if (SCM_INUMP(y))
2285 return (SCM_REALPART(x) < (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
2286# ifdef SCM_BIGDIG
2287 SCM_ASRTGO(SCM_NIMP(y), bady);
2288 if (SCM_BIGP(y))
2289 return (SCM_REALPART(x) < (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
2290 SCM_ASRTGO(SCM_REALP(y), bady);
2291# else
2292 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2293# endif
2294 return (SCM_REALPART(x) < SCM_REALPART(y)) ? y : x;
2295 }
2296 if SCM_NINUMP(y) {
2297# ifdef SCM_BIGDIG
2298 SCM_ASRTGO(SCM_NIMP(y), bady);
2299 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? x : y;
2300# ifndef RECKLESS
2301 if (!(SCM_REALP(y)))
2302 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2303# endif
2304# else
2305# ifndef RECKLESS
2306 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2307 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2308# endif
2309# endif
2310 return ((z = SCM_INUM(x)) < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2311 }
2312#else
2313# ifdef SCM_BIGDIG
2314 if SCM_NINUMP(x) {
2315 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_max);
2316 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
2317 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2318 return (1==scm_bigcomp(x, y)) ? y : x;
2319 }
2320 if SCM_NINUMP(y) {
2321# ifndef RECKLESS
2322 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2323 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2324# endif
2325 return SCM_BIGSIGN(y) ? x : y;
2326 }
2327# else
2328 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_max);
2329 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_max);
2330# endif
2331#endif
2332 return ((long)x < (long)y) ? y : x;
2333}
2334
2335
2336
2337
2338SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
1cc91f1b 2339
0f2d19dd
JB		 2340SCM
2341scm_min(x, y)
2342 SCM x;
2343 SCM y;
0f2d19dd
JB		 2344{
2345#ifdef SCM_FLOATS
2346 double z;
2347#endif
2348 if SCM_UNBNDP(y) {
2349#ifndef RECKLESS
2350 if (!(SCM_NUMBERP(x)))
2351 badx:scm_wta(x, (char *)SCM_ARG1, s_min);
2352#endif
2353 return x;
2354 }
2355#ifdef SCM_FLOATS
2356 if SCM_NINUMP(x) {
2357# ifdef SCM_BIGDIG
2358 SCM_ASRTGO(SCM_NIMP(x), badx);
2359 if SCM_BIGP(x) {
2360 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
2361 SCM_ASRTGO(SCM_NIMP(y), bady);
2362 if SCM_BIGP(y) return (-1==scm_bigcomp(x, y)) ? y : x;
2363 SCM_ASRTGO(SCM_REALP(y), bady);
2364 z = scm_big2dbl(x);
2365 return (z > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2366 }
2367 SCM_ASRTGO(SCM_REALP(x), badx);
2368# else
2369 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_min);
2370# endif
2371 if SCM_INUMP(y) return (SCM_REALPART(x) > (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
2372# ifdef SCM_BIGDIG
2373 SCM_ASRTGO(SCM_NIMP(y), bady);
2374 if SCM_BIGP(y) return (SCM_REALPART(x) > (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
2375 SCM_ASRTGO(SCM_REALP(y), bady);
2376# else
2377 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2378# endif
2379 return (SCM_REALPART(x) > SCM_REALPART(y)) ? y : x;
2380 }
2381 if SCM_NINUMP(y) {
2382# ifdef SCM_BIGDIG
2383 SCM_ASRTGO(SCM_NIMP(y), bady);
2384 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? y : x;
2385# ifndef RECKLESS
2386 if (!(SCM_REALP(y)))
2387 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2388# endif
2389# else
2390# ifndef RECKLESS
2391 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2392 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2393# endif
2394# endif
2395 return ((z = SCM_INUM(x)) > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2396 }
2397#else
2398# ifdef SCM_BIGDIG
2399 if SCM_NINUMP(x) {
2400 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_min);
2401 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
2402 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2403 return (-1==scm_bigcomp(x, y)) ? y : x;
2404 }
2405 if SCM_NINUMP(y) {
2406# ifndef RECKLESS
2407 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2408 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2409# endif
2410 return SCM_BIGSIGN(y) ? y : x;
2411 }
2412# else
2413 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_min);
2414 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_min);
2415# endif
2416#endif
2417 return ((long)x > (long)y) ? y : x;
2418}
2419
2420
2421
2422
2423SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
1cc91f1b 2424
0f2d19dd
JB		 2425SCM
2426scm_sum(x, y)
2427 SCM x;
2428 SCM y;
0f2d19dd
JB		 2429{
2430 if SCM_UNBNDP(y) {
2431 if SCM_UNBNDP(x) return SCM_INUM0;
2432#ifndef RECKLESS
2433 if (!(SCM_NUMBERP(x)))
2434 badx: scm_wta(x, (char *)SCM_ARG1, s_sum);
2435#endif
2436 return x;
2437 }
2438#ifdef SCM_FLOATS
2439 if SCM_NINUMP(x) {
2440 SCM t;
2441# ifdef SCM_BIGDIG
2442 SCM_ASRTGO(SCM_NIMP(x), badx);
2443 if SCM_BIGP(x) {
2444 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2445 SCM_ASRTGO(SCM_NIMP(y), bady);
2446 if SCM_BIGP(y) {
2447 if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
2448 return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
2449 }
2450 SCM_ASRTGO(SCM_INEXP(y), bady);
2451 bigreal: return scm_makdbl(scm_big2dbl(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
2452 }
2453 SCM_ASRTGO(SCM_INEXP(x), badx);
2454# else
2455 SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
2456# endif
2457 if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
2458# ifdef SCM_BIGDIG
2459 SCM_ASRTGO(SCM_NIMP(y), bady);
2460 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
2461# ifndef RECKLESS
2462 else if (!(SCM_INEXP(y)))
2463 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2464# endif
2465# else
2466# ifndef RECKLESS
2467 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2468 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2469# endif
2470# endif
2471 { double i = 0.0;
2472 if SCM_CPLXP(x) i = SCM_IMAG(x);
2473 if SCM_CPLXP(y) i += SCM_IMAG(y);
2474 return scm_makdbl(SCM_REALPART(x)+SCM_REALPART(y), i); }
2475 }
2476 if SCM_NINUMP(y) {
2477# ifdef SCM_BIGDIG
2478 SCM_ASRTGO(SCM_NIMP(y), bady);
2479 if SCM_BIGP(y)
2480 intbig: {
2481# ifndef SCM_DIGSTOOBIG
2482 long z = scm_pseudolong(SCM_INUM(x));
2483 return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2484# else
2485 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2486 scm_longdigs(SCM_INUM(x), zdigs);
2487 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2488# endif
2489 }
2490 SCM_ASRTGO(SCM_INEXP(y), bady);
2491# else
2492 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2493# endif
2494 intreal: return scm_makdbl(SCM_INUM(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
2495 }
2496#else
2497# ifdef SCM_BIGDIG
2498 if SCM_NINUMP(x) {
2499 SCM t;
2500 SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
2501 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2502 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2503 if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
2504 return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
2505 }
2506 if SCM_NINUMP(y) {
2507# ifndef RECKLESS
2508 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2509 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2510# endif
2511 intbig: {
2512# ifndef SCM_DIGSTOOBIG
2513 long z = scm_pseudolong(SCM_INUM(x));
2514 return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2515# else
2516 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2517 scm_longdigs(SCM_INUM(x), zdigs);
2518 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2519# endif
2520 }
2521 }
2522# else
2523 SCM_ASRTGO(SCM_INUMP(x), badx);
2524 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_sum);
2525# endif
2526#endif
2527 x = SCM_INUM(x)+SCM_INUM(y);
2528 if SCM_FIXABLE(x) return SCM_MAKINUM(x);
2529#ifdef SCM_BIGDIG
2530 return scm_long2big(x);
2531#else
2532# ifdef SCM_FLOATS
2533 return scm_makdbl((double)x, 0.0);
2534# else
52859adf 2535 scm_num_overflow (s_sum);
0f2d19dd
JB		 2536 return SCM_UNSPECIFIED;
2537# endif
2538#endif
2539}
2540
2541
2542
2543
2544SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
1cc91f1b 2545
0f2d19dd
JB		 2546SCM
2547scm_difference(x, y)
2548 SCM x;
2549 SCM y;
0f2d19dd
JB		 2550{
2551#ifdef SCM_FLOATS
2552 if SCM_NINUMP(x) {
2553# ifndef RECKLESS
2554 if (!(SCM_NIMP(x)))
2555 badx: scm_wta(x, (char *)SCM_ARG1, s_difference);
2556# endif
2557 if SCM_UNBNDP(y) {
2558# ifdef SCM_BIGDIG
2559 if SCM_BIGP(x) {
2560 x = scm_copybig(x, !SCM_BIGSIGN(x));
2561 return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
2562 scm_big2inum(x, SCM_NUMDIGS(x)) : x;
2563 }
2564# endif
2565 SCM_ASRTGO(SCM_INEXP(x), badx);
2566 return scm_makdbl(-SCM_REALPART(x), SCM_CPLXP(x)?-SCM_IMAG(x):0.0);
2567 }
2568 if SCM_INUMP(y) return scm_sum(x, SCM_MAKINUM(-SCM_INUM(y)));
2569# ifdef SCM_BIGDIG
2570 SCM_ASRTGO(SCM_NIMP(y), bady);
2571 if SCM_BIGP(x) {
2572 if SCM_BIGP(y) return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
2573 scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
2574 scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
2575 SCM_ASRTGO(SCM_INEXP(y), bady);
2576 return scm_makdbl(scm_big2dbl(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2577 }
2578 SCM_ASRTGO(SCM_INEXP(x), badx);
2579 if SCM_BIGP(y) return scm_makdbl(SCM_REALPART(x)-scm_big2dbl(y), SCM_CPLXP(x)?SCM_IMAG(x):0.0);
2580 SCM_ASRTGO(SCM_INEXP(y), bady);
2581# else
2582 SCM_ASRTGO(SCM_INEXP(x), badx);
2583 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2584# endif
2585 if SCM_CPLXP(x)
2586 if SCM_CPLXP(y)
2587 return scm_makdbl(SCM_REAL(x)-SCM_REAL(y), SCM_IMAG(x)-SCM_IMAG(y));
2588 else
2589 return scm_makdbl(SCM_REAL(x)-SCM_REALPART(y), SCM_IMAG(x));
2590 return scm_makdbl(SCM_REALPART(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2591 }
2592 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2593 if SCM_NINUMP(y) {
2594# ifdef SCM_BIGDIG
2595 SCM_ASRTGO(SCM_NIMP(y), bady);
2596 if SCM_BIGP(y) {
2597# ifndef SCM_DIGSTOOBIG
2598 long z = scm_pseudolong(SCM_INUM(x));
2599 return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2600# else
2601 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2602 scm_longdigs(SCM_INUM(x), zdigs);
2603 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2604# endif
2605 }
2606# ifndef RECKLESS
2607 if (!(SCM_INEXP(y)))
2608 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2609# endif
2610# else
2611# ifndef RECKLESS
2612 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2613 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2614# endif
2615# endif
2616 return scm_makdbl(SCM_INUM(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2617 }
2618#else
2619# ifdef SCM_BIGDIG
2620 if SCM_NINUMP(x) {
2621 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_difference);
2622 if SCM_UNBNDP(y) {
2623 x = scm_copybig(x, !SCM_BIGSIGN(x));
2624 return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
2625 scm_big2inum(x, SCM_NUMDIGS(x)) : x;
2626 }
2627 if SCM_INUMP(y) {
2628# ifndef SCM_DIGSTOOBIG
2629 long z = scm_pseudolong(SCM_INUM(y));
2630 return scm_addbig(&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
2631# else
2632 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2633 scm_longdigs(SCM_INUM(x), zdigs);
2634 return scm_addbig(zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
2635# endif
2636 }
2637 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2638 return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
2639 scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
2640 scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
2641 }
2642 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2643 if SCM_NINUMP(y) {
2644# ifndef RECKLESS
2645 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2646 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2647# endif
2648 {
2649# ifndef SCM_DIGSTOOBIG
2650 long z = scm_pseudolong(SCM_INUM(x));
2651 return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2652# else
2653 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2654 scm_longdigs(SCM_INUM(x), zdigs);
2655 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2656# endif
2657 }
2658 }
2659# else
2660 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_difference);
2661 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2662 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_difference);
2663# endif
2664#endif
2665 x = SCM_INUM(x)-SCM_INUM(y);
2666 checkx:
2667 if SCM_FIXABLE(x) return SCM_MAKINUM(x);
2668#ifdef SCM_BIGDIG
2669 return scm_long2big(x);
2670#else
2671# ifdef SCM_FLOATS
2672 return scm_makdbl((double)x, 0.0);
2673# else
52859adf 2674 scm_num_overflow (s_difference);
0f2d19dd
JB		 2675 return SCM_UNSPECIFIED;
2676# endif
2677#endif
2678}
2679
2680
2681
2682
2683SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
1cc91f1b 2684
0f2d19dd
JB		 2685SCM
2686scm_product(x, y)
2687 SCM x;
2688 SCM y;
0f2d19dd
JB		 2689{
2690 if SCM_UNBNDP(y) {
2691 if SCM_UNBNDP(x) return SCM_MAKINUM(1L);
2692#ifndef RECKLESS
2693 if (!(SCM_NUMBERP(x)))
2694 badx: scm_wta(x, (char *)SCM_ARG1, s_product);
2695#endif
2696 return x;
2697 }
2698#ifdef SCM_FLOATS
2699 if SCM_NINUMP(x) {
2700 SCM t;
2701# ifdef SCM_BIGDIG
2702 SCM_ASRTGO(SCM_NIMP(x), badx);
2703 if SCM_BIGP(x) {
2704 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2705 SCM_ASRTGO(SCM_NIMP(y), bady);
2706 if SCM_BIGP(y) return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2707 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
2708 SCM_ASRTGO(SCM_INEXP(y), bady);
2709 bigreal: {
2710 double bg = scm_big2dbl(x);
2711 return scm_makdbl(bg*SCM_REALPART(y), SCM_CPLXP(y)?bg*SCM_IMAG(y):0.0); }
2712 }
2713 SCM_ASRTGO(SCM_INEXP(x), badx);
2714# else
2715 SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
2716# endif
2717 if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
2718# ifdef SCM_BIGDIG
2719 SCM_ASRTGO(SCM_NIMP(y), bady);
2720 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
2721# ifndef RECKLESS
2722 else if (!(SCM_INEXP(y)))
2723 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2724# endif
2725# else
2726# ifndef RECKLESS
2727 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2728 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2729# endif
2730# endif
2731 if SCM_CPLXP(x)
2732 if SCM_CPLXP(y)
2733 return scm_makdbl(SCM_REAL(x)*SCM_REAL(y)-SCM_IMAG(x)*SCM_IMAG(y),
2734 SCM_REAL(x)*SCM_IMAG(y)+SCM_IMAG(x)*SCM_REAL(y));
2735 else
2736 return scm_makdbl(SCM_REAL(x)*SCM_REALPART(y), SCM_IMAG(x)*SCM_REALPART(y));
2737 return scm_makdbl(SCM_REALPART(x)*SCM_REALPART(y),
2738 SCM_CPLXP(y)?SCM_REALPART(x)*SCM_IMAG(y):0.0);
2739 }
2740 if SCM_NINUMP(y) {
2741# ifdef SCM_BIGDIG
2742 SCM_ASRTGO(SCM_NIMP(y), bady);
2743 if SCM_BIGP(y) {
2744 intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
2745 {
2746# ifndef SCM_DIGSTOOBIG
2747 long z = scm_pseudolong(SCM_INUM(x));
2748 return scm_mulbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2749 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2750# else
2751 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2752 scm_longdigs(SCM_INUM(x), zdigs);
2753 return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2754 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2755# endif
2756 }
2757 }
2758 SCM_ASRTGO(SCM_INEXP(y), bady);
2759# else
2760 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2761# endif
2762 intreal: return scm_makdbl(SCM_INUM(x)*SCM_REALPART(y), SCM_CPLXP(y)?SCM_INUM(x)*SCM_IMAG(y):0.0);
2763 }
2764#else
2765# ifdef SCM_BIGDIG
2766 if SCM_NINUMP(x) {
2767 SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
2768 if SCM_INUMP(y) {SCM t = x; x = y; y = t; goto intbig;}
2769 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2770 return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2771 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
2772 }
2773 if SCM_NINUMP(y) {
2774# ifndef RECKLESS
2775 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2776 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2777# endif
2778 intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
2779 {
2780# ifndef SCM_DIGSTOOBIG
2781 long z = scm_pseudolong(SCM_INUM(x));
2782 return scm_mulbig(&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2783 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2784# else
2785 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2786 scm_longdigs(SCM_INUM(x), zdigs);
2787 return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2788 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2789# endif
2790 }
2791 }
2792# else
2793 SCM_ASRTGO(SCM_INUMP(x), badx);
2794 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_product);
2795# endif
2796#endif
2797 {
2798 long i, j, k;
2799 i = SCM_INUM(x);
2800 if (0==i) return x;
2801 j = SCM_INUM(y);
2802 k = i * j;
2803 y = SCM_MAKINUM(k);
2804 if (k != SCM_INUM(y) || k/i != j)
2805#ifdef SCM_BIGDIG
2806 { int sgn = (i < 0) ^ (j < 0);
2807# ifndef SCM_DIGSTOOBIG
2808 i = scm_pseudolong(i);
2809 j = scm_pseudolong(j);
2810 return scm_mulbig((SCM_BIGDIG *)&i, SCM_DIGSPERLONG,
2811 (SCM_BIGDIG *)&j, SCM_DIGSPERLONG, sgn);
2812# else /* SCM_DIGSTOOBIG */
2813 SCM_BIGDIG idigs[SCM_DIGSPERLONG];
2814 SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
2815 scm_longdigs(i, idigs);
2816 scm_longdigs(j, jdigs);
2817 return scm_mulbig(idigs, SCM_DIGSPERLONG, jdigs, SCM_DIGSPERLONG, sgn);
2818# endif
2819 }
2820#else
2821# ifdef SCM_FLOATS
2822 return scm_makdbl(((double)i)*((double)j), 0.0);
2823# else
52859adf 2824 scm_num_overflow (s_product);
0f2d19dd
JB		 2825# endif
2826#endif
2827 return y;
2828 }
2829}
2830
2831
1cc91f1b 2832
0f2d19dd
JB		 2833double
2834scm_num2dbl (a, why)
2835 SCM a;
2836 char * why;
0f2d19dd
JB		 2837{
2838 if (SCM_INUMP (a))
2839 return (double) SCM_INUM (a);
2840#ifdef SCM_FLOATS
2841 SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
2842 if (SCM_REALP (a))
2843 return (SCM_REALPART (a));
2844#endif
2845#ifdef SCM_BIGDIG
2846 return scm_big2dbl (a);
2847#endif
2848 SCM_ASSERT (0, a, "wrong type argument", why);
2849 return SCM_UNSPECIFIED;
2850}
2851
2852
0f2d19dd 2853SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
1cc91f1b 2854
0f2d19dd
JB		 2855SCM
2856scm_divide(x, y)
2857 SCM x;
2858 SCM y;
0f2d19dd
JB		 2859{
2860#ifdef SCM_FLOATS
2861 double d, r, i, a;
2862 if SCM_NINUMP(x) {
2863# ifndef RECKLESS
2864 if (!(SCM_NIMP(x)))
2865 badx: scm_wta(x, (char *)SCM_ARG1, s_divide);
2866# endif
2867 if SCM_UNBNDP(y) {
2868# ifdef SCM_BIGDIG
2869 if SCM_BIGP(x) return scm_makdbl(1.0/scm_big2dbl(x), 0.0);
2870# endif
2871 SCM_ASRTGO(SCM_INEXP(x), badx);
2872 if SCM_REALP(x) return scm_makdbl(1.0/SCM_REALPART(x), 0.0);
2873 r = SCM_REAL(x); i = SCM_IMAG(x); d = r*r+i*i;
2874 return scm_makdbl(r/d, -i/d);
2875 }
2876# ifdef SCM_BIGDIG
2877 if SCM_BIGP(x) {
2878 SCM z;
2879 if SCM_INUMP(y) {
2880 z = SCM_INUM(y);
e1724d20
GH		 2881#ifndef RECKLESS
2882 if (!z)
52859adf 2883 scm_num_overflow (s_divide);
e1724d20 2884#endif
0f2d19dd
JB		 2885 if (1==z) return x;
2886 if (z < 0) z = -z;
2887 if (z < SCM_BIGRAD) {
2888 SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
2889 return scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z) ?
2890 scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0) : scm_normbig(w);
2891 }
2892# ifndef SCM_DIGSTOOBIG
2893 z = scm_pseudolong(z);
2894 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&z, SCM_DIGSPERLONG,
2895 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
2896# else
2897 { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2898 scm_longdigs(z, zdigs);
2899 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
2900 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
2901# endif
2902 return z ? z : scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0);
2903 }
2904 SCM_ASRTGO(SCM_NIMP(y), bady);
2905 if SCM_BIGP(y) {
2906 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2907 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
2908 return z ? z : scm_makdbl(scm_big2dbl(x)/scm_big2dbl(y), 0.0);
2909 }
2910 SCM_ASRTGO(SCM_INEXP(y), bady);
2911 if SCM_REALP(y) return scm_makdbl(scm_big2dbl(x)/SCM_REALPART(y), 0.0);
2912 a = scm_big2dbl(x);
2913 goto complex_div;
2914 }
2915# endif
2916 SCM_ASRTGO(SCM_INEXP(x), badx);
2917 if SCM_INUMP(y) {d = SCM_INUM(y); goto basic_div;}
2918# ifdef SCM_BIGDIG
2919 SCM_ASRTGO(SCM_NIMP(y), bady);
2920 if SCM_BIGP(y) {d = scm_big2dbl(y); goto basic_div;}
2921 SCM_ASRTGO(SCM_INEXP(y), bady);
2922# else
2923 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2924# endif
2925 if SCM_REALP(y) {
2926 d = SCM_REALPART(y);
2927 basic_div: return scm_makdbl(SCM_REALPART(x)/d, SCM_CPLXP(x)?SCM_IMAG(x)/d:0.0);
2928 }
2929 a = SCM_REALPART(x);
2930 if SCM_REALP(x) goto complex_div;
2931 r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
2932 return scm_makdbl((a*r+SCM_IMAG(x)*i)/d, (SCM_IMAG(x)*r-a*i)/d);
2933 }
2934 if SCM_UNBNDP(y) {
2935 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
2936 return scm_makdbl(1.0/((double)SCM_INUM(x)), 0.0);
2937 }
2938 if SCM_NINUMP(y) {
2939# ifdef SCM_BIGDIG
2940 SCM_ASRTGO(SCM_NIMP(y), bady);
2941 if SCM_BIGP(y) return scm_makdbl(SCM_INUM(x)/scm_big2dbl(y), 0.0);
2942# ifndef RECKLESS
2943 if (!(SCM_INEXP(y)))
2944 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
2945# endif
2946# else
2947# ifndef RECKLESS
2948 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2949 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
2950# endif
2951# endif
2952 if (SCM_REALP(y))
2953 return scm_makdbl(SCM_INUM(x)/SCM_REALPART(y), 0.0);
2954 a = SCM_INUM(x);
2955 complex_div:
2956 r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
2957 return scm_makdbl((a*r)/d, (-a*i)/d);
2958 }
2959#else
2960# ifdef SCM_BIGDIG
2961 if SCM_NINUMP(x) {
2962 SCM z;
2963 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_divide);
2964 if SCM_UNBNDP(y) goto ov;
2965 if SCM_INUMP(y) {
2966 z = SCM_INUM(y);
2967 if (!z) goto ov;
2968 if (1==z) return x;
2969 if (z < 0) z = -z;
2970 if (z < SCM_BIGRAD) {
2971 SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
2972 if (scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z)) goto ov;
2973 return w;
2974 }
2975# ifndef SCM_DIGSTOOBIG
2976 z = scm_pseudolong(z);
2977 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), &z, SCM_DIGSPERLONG,
2978 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
2979# else
2980 { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2981 scm_longdigs(z, zdigs);
2982 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
2983 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
2984# endif
2985 } else {
2986 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2987 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2988 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
2989 }
2990 if (!z) goto ov;
2991 return z;
2992 }
2993 if SCM_UNBNDP(y) {
2994 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
2995 goto ov;
2996 }
2997 if SCM_NINUMP(y) {
2998# ifndef RECKLESS
2999 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
3000 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
3001# endif
3002 goto ov;
3003 }
3004# else
3005 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_divide);
3006 if SCM_UNBNDP(y) {
3007 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
3008 goto ov;
3009 }
3010 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_divide);
3011# endif
3012#endif
3013 {
3014 long z = SCM_INUM(y);
3015 if ((0==z) || SCM_INUM(x)%z) goto ov;
3016 z = SCM_INUM(x)/z;
3017 if SCM_FIXABLE(z) return SCM_MAKINUM(z);
3018#ifdef SCM_BIGDIG
3019 return scm_long2big(z);
3020#endif
3021#ifdef SCM_FLOATS
3022 ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0);
3023#else
52859adf 3024 ov: scm_num_overflow (s_divide);
0f2d19dd
JB		 3025 return SCM_UNSPECIFIED;
3026#endif
3027 }
3028}
3029
3030
3031
3032
3033#ifdef SCM_FLOATS
3034SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
1cc91f1b 3035
0f2d19dd
JB		 3036double
3037scm_asinh(x)
3038 double x;
0f2d19dd
JB		 3039{
3040 return log(x+sqrt(x*x+1));
3041}
3042
3043
3044
3045
3046SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
1cc91f1b 3047
0f2d19dd
JB		 3048double
3049scm_acosh(x)
3050 double x;
0f2d19dd
JB		 3051{
3052 return log(x+sqrt(x*x-1));
3053}
3054
3055
3056
3057
3058SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
1cc91f1b 3059
0f2d19dd
JB		 3060double
3061scm_atanh(x)
3062 double x;
0f2d19dd
JB		 3063{
3064 return 0.5*log((1+x)/(1-x));
3065}
3066
3067
3068
3069
3070SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
1cc91f1b 3071
0f2d19dd
JB		 3072double
3073scm_truncate(x)
3074 double x;
0f2d19dd
JB		 3075{
3076 if (x < 0.0) return -floor(-x);
3077 return floor(x);
3078}
3079
3080
3081
3082SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
1cc91f1b 3083
0f2d19dd
JB		 3084double
3085scm_round(x)
3086 double x;
0f2d19dd
JB		 3087{
3088 double plus_half = x + 0.5;
3089 double result = floor(plus_half);
3090 /* Adjust so that the scm_round is towards even. */
3091 return (plus_half == result && plus_half / 2 != floor(plus_half / 2))
3092 ? result - 1 : result;
3093}
3094
3095
3096
3097SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
1cc91f1b 3098
0f2d19dd
JB		 3099double
3100scm_exact_to_inexact(z)
3101 double z;
0f2d19dd
JB		 3102{
3103 return z;
3104}
3105
3106
3107SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor);
3108SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil);
3109SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)())sqrt);
3110SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)())fabs);
3111SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)())exp);
3112SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)())log);
3113SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)())sin);
3114SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)())cos);
3115SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)())tan);
3116SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)())asin);
3117SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)())acos);
3118SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)())atan);
3119SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)())sinh);
3120SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)())cosh);
3121SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh);
3122
3123struct dpair {double x, y;};
3124
1cc91f1b
JB		 3125static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy));
3126
3a2425b9
JB		 3127static void
3128scm_two_doubles(z1, z2, sstring, xy)
0f2d19dd
JB		 3129 SCM z1, z2;
3130 char *sstring;
3131 struct dpair *xy;
3132{
3133 if SCM_INUMP(z1) xy->x = SCM_INUM(z1);
3134 else {
3135# ifdef SCM_BIGDIG
3136 SCM_ASRTGO(SCM_NIMP(z1), badz1);
3137 if SCM_BIGP(z1) xy->x = scm_big2dbl(z1);
3138 else {
3139# ifndef RECKLESS
3140 if (!(SCM_REALP(z1)))
3141 badz1: scm_wta(z1, (char *)SCM_ARG1, sstring);
3142# endif
3143 xy->x = SCM_REALPART(z1);}
3144# else
3145 {SCM_ASSERT(SCM_NIMP(z1) && SCM_REALP(z1), z1, SCM_ARG1, sstring);
3146 xy->x = SCM_REALPART(z1);}
3147# endif
3148 }
3149 if SCM_INUMP(z2) xy->y = SCM_INUM(z2);
3150 else {
3151# ifdef SCM_BIGDIG
3152 SCM_ASRTGO(SCM_NIMP(z2), badz2);
3153 if SCM_BIGP(z2) xy->y = scm_big2dbl(z2);
3154 else {
3155# ifndef RECKLESS
3156 if (!(SCM_REALP(z2)))
3157 badz2: scm_wta(z2, (char *)SCM_ARG2, sstring);
3158# endif
3159 xy->y = SCM_REALPART(z2);}
3160# else
3161 {SCM_ASSERT(SCM_NIMP(z2) && SCM_REALP(z2), z2, SCM_ARG2, sstring);
3162 xy->y = SCM_REALPART(z2);}
3163# endif
3164 }
3165}
3166
3167
3168
3169
02b754d3 3170SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
1cc91f1b 3171
0f2d19dd
JB		 3172SCM
3173scm_sys_expt(z1, z2)
3174 SCM z1;
3175 SCM z2;
0f2d19dd
JB		 3176{
3177 struct dpair xy;
3178 scm_two_doubles(z1, z2, s_sys_expt, &xy);
3179 return scm_makdbl(pow(xy.x, xy.y), 0.0);
3180}
3181
3182
3183
02b754d3 3184SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
1cc91f1b 3185
0f2d19dd
JB		 3186SCM
3187scm_sys_atan2(z1, z2)
3188 SCM z1;
3189 SCM z2;
0f2d19dd
JB		 3190{
3191 struct dpair xy;
3192 scm_two_doubles(z1, z2, s_sys_atan2, &xy);
3193 return scm_makdbl(atan2(xy.x, xy.y), 0.0);
3194}
3195
3196
3197
3198SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular);
1cc91f1b 3199
0f2d19dd
JB		 3200SCM
3201scm_make_rectangular(z1, z2)
3202 SCM z1;
3203 SCM z2;
0f2d19dd
JB		 3204{
3205 struct dpair xy;
3206 scm_two_doubles(z1, z2, s_make_rectangular, &xy);
3207 return scm_makdbl(xy.x, xy.y);
3208}
3209
3210
3211
3212SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar);
1cc91f1b 3213
0f2d19dd
JB		 3214SCM
3215scm_make_polar(z1, z2)
3216 SCM z1;
3217 SCM z2;
0f2d19dd
JB		 3218{
3219 struct dpair xy;
3220 scm_two_doubles(z1, z2, s_make_polar, &xy);
3221 return scm_makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
3222}
3223
3224
3225
3226
3227SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part);
1cc91f1b 3228
0f2d19dd
JB		 3229SCM
3230scm_real_part(z)
3231 SCM z;
0f2d19dd
JB		 3232{
3233 if SCM_NINUMP(z) {
3234# ifdef SCM_BIGDIG
3235 SCM_ASRTGO(SCM_NIMP(z), badz);
3236 if SCM_BIGP(z) return z;
3237# ifndef RECKLESS
3238 if (!(SCM_INEXP(z)))
3239 badz: scm_wta(z, (char *)SCM_ARG1, s_real_part);
3240# endif
3241# else
3242 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_real_part);
3243# endif
3244 if SCM_CPLXP(z) return scm_makdbl(SCM_REAL(z), 0.0);
3245 }
3246 return z;
3247}
3248
3249
3250
3251SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part);
1cc91f1b 3252
0f2d19dd
JB		 3253SCM
3254scm_imag_part(z)
3255 SCM z;
0f2d19dd
JB		 3256{
3257 if SCM_INUMP(z) return SCM_INUM0;
3258# ifdef SCM_BIGDIG
3259 SCM_ASRTGO(SCM_NIMP(z), badz);
3260 if SCM_BIGP(z) return SCM_INUM0;
3261# ifndef RECKLESS
3262 if (!(SCM_INEXP(z)))
3263 badz: scm_wta(z, (char *)SCM_ARG1, s_imag_part);
3264# endif
3265# else
3266 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_imag_part);
3267# endif
3268 if SCM_CPLXP(z) return scm_makdbl(SCM_IMAG(z), 0.0);
3269 return scm_flo0;
3270}
3271
3272
3273
3274SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
1cc91f1b 3275
0f2d19dd
JB		 3276SCM
3277scm_magnitude(z)
3278 SCM z;
0f2d19dd
JB		 3279{
3280 if SCM_INUMP(z) return scm_abs(z);
3281# ifdef SCM_BIGDIG
3282 SCM_ASRTGO(SCM_NIMP(z), badz);
3283 if SCM_BIGP(z) return scm_abs(z);
3284# ifndef RECKLESS
3285 if (!(SCM_INEXP(z)))
3286 badz: scm_wta(z, (char *)SCM_ARG1, s_magnitude);
3287# endif
3288# else
3289 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_magnitude);
3290# endif
3291 if SCM_CPLXP(z)
3292 {
3293 double i = SCM_IMAG(z), r = SCM_REAL(z);
3294 return scm_makdbl(sqrt(i*i+r*r), 0.0);
3295 }
3296 return scm_makdbl(fabs(SCM_REALPART(z)), 0.0);
3297}
3298
3299
3300
3301
3302SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle);
1cc91f1b 3303
0f2d19dd
JB		 3304SCM
3305scm_angle(z)
3306 SCM z;
0f2d19dd
JB		 3307{
3308 double x, y = 0.0;
3309 if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;}
3310# ifdef SCM_BIGDIG
3311 SCM_ASRTGO(SCM_NIMP(z), badz);
3312 if SCM_BIGP(z) {x = (SCM_TYP16(z)==scm_tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
3313# ifndef RECKLESS
3314 if (!(SCM_INEXP(z))) {
3315 badz: scm_wta(z, (char *)SCM_ARG1, s_angle);}
3316# endif
3317# else
3318 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_angle);
3319# endif
3320 if (SCM_REALP(z))
3321 {
3322 x = SCM_REALPART(z);
3323 goto do_angle;
3324 }
3325 x = SCM_REAL(z); y = SCM_IMAG(z);
3326 do_angle:
3327 return scm_makdbl(atan2(y, x), 0.0);
3328}
3329
3330
3331SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact);
1cc91f1b 3332
0f2d19dd
JB		 3333SCM
3334scm_inexact_to_exact(z)
3335 SCM z;
0f2d19dd
JB		 3336{
3337 if SCM_INUMP(z) return z;
3338# ifdef SCM_BIGDIG
3339 SCM_ASRTGO(SCM_NIMP(z), badz);
3340 if SCM_BIGP(z) return z;
3341# ifndef RECKLESS
3342 if (!(SCM_REALP(z)))
3343 badz: scm_wta(z, (char *)SCM_ARG1, s_inexact_to_exact);
3344# endif
3345# else
3346 SCM_ASSERT(SCM_NIMP(z) && SCM_REALP(z), z, SCM_ARG1, s_inexact_to_exact);
3347# endif
3348# ifdef SCM_BIGDIG
3349 {
3350 double u = floor(SCM_REALPART(z)+0.5);
3351 if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM)) {
3352 /* Negation is a workaround for HP700 cc bug */
3353 SCM ans = SCM_MAKINUM((long)u);
3354 if (SCM_INUM(ans)==(long)u) return ans;
3355 }
3356 SCM_ASRTGO(!IS_INF(u), badz); /* problem? */
3357 return scm_dbl2big(u);
3358 }
3359# else
3360 return SCM_MAKINUM((long)floor(SCM_REALPART(z)+0.5));
3361# endif
3362}
3363
3364
3365
3366#else /* ~SCM_FLOATS */
3367SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc);
1cc91f1b 3368
0f2d19dd
JB		 3369SCM
3370scm_trunc(x)
3371 SCM x;
0f2d19dd
JB		 3372{
3373 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate);
3374 return x;
3375}
3376
3377
3378
3379#endif /* SCM_FLOATS */
3380
3381#ifdef SCM_BIGDIG
3382# ifdef SCM_FLOATS
3383/* d must be integer */
1cc91f1b 3384
0f2d19dd
JB		 3385SCM
3386scm_dbl2big(d)
3387 double d;
0f2d19dd
JB		 3388{
3389 scm_sizet i = 0;
3390 long c;
3391 SCM_BIGDIG *digits;
3392 SCM ans;
3393 double u = (d < 0)?-d:d;
3394 while (0 != floor(u)) {u /= SCM_BIGRAD;i++;}
3395 ans = scm_mkbig(i, d < 0);
3396 digits = SCM_BDIGITS(ans);
3397 while (i--) {
3398 u *= SCM_BIGRAD;
3399 c = floor(u);
3400 u -= c;
3401 digits[i] = c;
3402 }
e1724d20
GH		 3403#ifndef RECKLESS
3404 if (u != 0)
52859adf 3405 scm_num_overflow ("dbl2big");
e1724d20 3406#endif
0f2d19dd
JB		 3407 return ans;
3408}
3409
3410
3411
1cc91f1b 3412
0f2d19dd
JB		 3413double
3414scm_big2dbl(b)
3415 SCM b;
0f2d19dd
JB		 3416{
3417 double ans = 0.0;
3418 scm_sizet i = SCM_NUMDIGS(b);
3419 SCM_BIGDIG *digits = SCM_BDIGITS(b);
3420 while (i--) ans = digits[i] + SCM_BIGRAD*ans;
3421 if (scm_tc16_bigneg==SCM_TYP16(b)) return -ans;
3422 return ans;
3423}
3424# endif
3425#endif
3426
1cc91f1b 3427
0f2d19dd
JB		 3428SCM
3429scm_long2num(sl)
3430 long sl;
0f2d19dd
JB		 3431{
3432 if (!SCM_FIXABLE(sl)) {
3433#ifdef SCM_BIGDIG
3434 return scm_long2big(sl);
3435#else
3436# ifdef SCM_FLOATS
3437 return scm_makdbl((double) sl, 0.0);
3438# else
3439 return SCM_BOOL_F;
3440# endif
3441#endif
3442 }
3443 return SCM_MAKINUM(sl);
3444}
3445
3446
3447#ifdef LONGLONGS
1cc91f1b 3448
0f2d19dd
JB		 3449SCM
3450scm_long_long2num(sl)
3451 long_long sl;
0f2d19dd
JB		 3452{
3453 if (!SCM_FIXABLE(sl)) {
3454#ifdef SCM_BIGDIG
3455 return scm_long_long2big(sl);
3456#else
3457# ifdef SCM_FLOATS
3458 return scm_makdbl((double) sl, 0.0);
3459# else
3460 return SCM_BOOL_F;
3461# endif
3462#endif
3463 }
3464 return SCM_MAKINUM(sl);
3465}
3466#endif
3467
3468
1cc91f1b 3469
0f2d19dd
JB		 3470SCM
3471scm_ulong2num(sl)
3472 unsigned long sl;
0f2d19dd 3473{
e2806c10 3474 if (!SCM_POSFIXABLE(sl)) {
0f2d19dd
JB		 3475#ifdef SCM_BIGDIG
3476 return scm_ulong2big(sl);
3477#else
3478# ifdef SCM_FLOATS
3479 return scm_makdbl((double) sl, 0.0);
3480# else
3481 return SCM_BOOL_F;
3482# endif
3483#endif
3484 }
3485 return SCM_MAKINUM(sl);
3486}
3487
1cc91f1b 3488
0f2d19dd
JB		 3489long
3490scm_num2long(num, pos, s_caller)
3491 SCM num;
3492 char *pos;
3493 char *s_caller;
0f2d19dd
JB		 3494{
3495 long res;
3496 if (SCM_INUMP(num))
3497 {
3498 res = SCM_INUM(num);
3499 return res;
3500 }
3501 SCM_ASRTGO(SCM_NIMP(num), errout);
3502#ifdef SCM_FLOATS
3503 if (SCM_REALP(num))
3504 {
3505 double u = SCM_REALPART(num);
3506 res = u;
3507 if ((double)res == u)
3508 {
3509 return res;
3510 }
3511 }
3512#endif
3513#ifdef SCM_BIGDIG
3514 if (SCM_BIGP(num)) {
3515 long oldres;
3516 scm_sizet l;
3517 res = 0;
3518 oldres = 0;
3519 for(l = SCM_NUMDIGS(num);l--;)
3520 {
3521 res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3522 if (res < oldres)
3523 goto errout;
3524 oldres = res;
3525 }
3526 if (SCM_TYP16 (num) == scm_tc16_bigpos)
3527 return res;
3528 else
3529 return -res;
3530 }
3531#endif
3532 errout: scm_wta(num, pos, s_caller);
3533 return SCM_UNSPECIFIED;
3534}
3535
3536
3537
3538
1cc91f1b 3539
0f2d19dd
JB		 3540long
3541num2long(num, pos, s_caller)
3542 SCM num;
3543 char *pos;
3544 char *s_caller;
0f2d19dd
JB		 3545{
3546 long res;
3547 if SCM_INUMP(num) {
3548 res = SCM_INUM((long)num);
3549 return res;
3550 }
3551 SCM_ASRTGO(SCM_NIMP(num), errout);
3552#ifdef SCM_FLOATS
3553 if SCM_REALP(num) {
3554 double u = SCM_REALPART(num);
3555 if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
3556 && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
3557 res = u;
3558 return res;
3559 }
3560 }
3561#endif
3562#ifdef SCM_BIGDIG
3563 if SCM_BIGP(num) {
3564 scm_sizet l = SCM_NUMDIGS(num);
3565 SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout);
3566 res = 0;
3567 for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3568 return res;
3569 }
3570#endif
3571 errout: scm_wta(num, pos, s_caller);
3572 return SCM_UNSPECIFIED;
3573}
3574
3575
3576#ifdef LONGLONGS
1cc91f1b 3577
0f2d19dd
JB		 3578long_long
3579scm_num2long_long(num, pos, s_caller)
3580 SCM num;
3581 char *pos;
3582 char *s_caller;
0f2d19dd
JB		 3583{
3584 long_long res;
3585 if SCM_INUMP(num) {
3586 res = SCM_INUM((long_long)num);
3587 return res;
3588 }
3589 SCM_ASRTGO(SCM_NIMP(num), errout);
3590#ifdef SCM_FLOATS
3591 if SCM_REALP(num) {
3592 double u = SCM_REALPART(num);
3593 if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
3594 && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
3595 res = u;
3596 return res;
3597 }
3598 }
3599#endif
3600#ifdef SCM_BIGDIG
3601 if SCM_BIGP(num) {
3602 scm_sizet l = SCM_NUMDIGS(num);
3603 SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout);
3604 res = 0;
e2806c10 3605 for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l];
0f2d19dd
JB		 3606 return res;
3607 }
3608#endif
3609 errout: scm_wta(num, pos, s_caller);
3610 return SCM_UNSPECIFIED;
3611}
3612#endif
3613
3614
1cc91f1b 3615
0f2d19dd
JB		 3616unsigned long
3617scm_num2ulong(num, pos, s_caller)
3618 SCM num;
3619 char *pos;
3620 char *s_caller;
0f2d19dd
JB		 3621{
3622 unsigned long res;
3623 if (SCM_INUMP(num))
3624 {
3625 res = SCM_INUM((unsigned long)num);
3626 return res;
3627 }
3628 SCM_ASRTGO(SCM_NIMP(num), errout);
3629#ifdef SCM_FLOATS
3630 if (SCM_REALP(num))
3631 {
3632 double u = SCM_REALPART(num);
3633 if ((0 <= u) && (u <= (unsigned long)~0L))
3634 {
3635 res = u;
3636 return res;
3637 }
3638 }
3639#endif
3640#ifdef SCM_BIGDIG
3641 if (SCM_BIGP(num)) {
3642 unsigned long oldres;
3643 scm_sizet l;
3644 res = 0;
3645 oldres = 0;
3646 for(l = SCM_NUMDIGS(num);l--;)
3647 {
3648 res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3649 if (res < oldres)
3650 goto errout;
3651 oldres = res;
3652 }
3653 return res;
3654 }
3655#endif
3656 errout: scm_wta(num, pos, s_caller);
3657 return SCM_UNSPECIFIED;
3658}
3659
3660
3661#ifdef SCM_FLOATS
3662# ifndef DBL_DIG
1cc91f1b 3663static void add1 SCM_P ((double f, double *fsum));
0f2d19dd
JB		 3664static void add1(f, fsum)
3665 double f, *fsum;
3666{
3667 *fsum = f + 1.0;
3668}
3669# endif
3670#endif
3671
3672
1cc91f1b 3673
0f2d19dd
JB		 3674void
3675scm_init_numbers ()
0f2d19dd
JB		 3676{
3677#ifdef SCM_FLOATS
3678 SCM_NEWCELL(scm_flo0);
3679# ifdef SCM_SINGLES
a6c64c3c 3680 SCM_SETCAR (scm_flo0, scm_tc_flo);
0f2d19dd
JB		 3681 SCM_FLO(scm_flo0) = 0.0;
3682# else
a6c64c3c 3683 SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
0f2d19dd 3684 SCM_REAL(scm_flo0) = 0.0;
a6c64c3c 3685 SCM_SETCAR (scm_flo0, scm_tc_dblr);
0f2d19dd
JB		 3686# endif
3687# ifdef DBL_DIG
3688 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
3689# else
3690 { /* determine floating point precision */
3691 double f = 0.1;
3692 double fsum = 1.0+f;
3693 while (fsum != 1.0) {
3694 f /= 10.0;
3695 if (++scm_dblprec > 20) break;
3696 add1(f, &fsum);
3697 }
3698 scm_dblprec = scm_dblprec-1;
3699 }
3700# endif /* DBL_DIG */
3701#endif
3702#include "numbers.x"
3703}
3704
Unnamed repository; edit this file 'description' to name the repository.