HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* gtcl.scm (make-tcl-binder): Rewritten to choose bindings
[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
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
0f2d19dd
JB		 41\f
42
43#include <stdio.h>
44#include <math.h>
45#include "_scm.h"
20e6290e
JB		 46#include "genio.h"
47#include "unif.h"
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
805df3e8
JB		 1001/* Sun's compiler complains about the fact that this function has an
1002 ANSI prototype in numbers.h, but a K&R declaration here, and the
1003 two specify different promotions for the third argument. I'm going
1004 to turn this into an ANSI declaration, and see if anyone complains
1005 about it not being K&R. */
1006
0f2d19dd 1007unsigned int
805df3e8
JB		 1008scm_divbigdig(SCM_BIGDIG *ds,
1009 scm_sizet h,
1010 SCM_BIGDIG div)
0f2d19dd
JB		 1011{
1012 register unsigned long t2 = 0;
1013 while(h--) {
1014 t2 = SCM_BIGUP(t2) + ds[h];
1015 ds[h] = t2 / div;
1016 t2 %= div;
1017 }
1018 return t2;
1019}
1020
1021
1cc91f1b 1022
0f2d19dd
JB		 1023SCM
1024scm_divbigint(x, z, sgn, mode)
1025 SCM x;
1026 long z;
1027 int sgn;
1028 int mode;
0f2d19dd
JB		 1029{
1030 if (z < 0) z = -z;
1031 if (z < SCM_BIGRAD) {
1032 register unsigned long t2 = 0;
1033 register SCM_BIGDIG *ds = SCM_BDIGITS(x);
1034 scm_sizet nd = SCM_NUMDIGS(x);
1035 while(nd--) t2 = (SCM_BIGUP(t2) + ds[nd]) % z;
604b0844 1036 if (mode && t2) t2 = z - t2;
0f2d19dd
JB		 1037 return SCM_MAKINUM(sgn ? -t2 : t2);
1038 }
1039 {
1040#ifndef SCM_DIGSTOOBIG
1041 unsigned long t2 = scm_pseudolong(z);
1042 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&t2,
1043 SCM_DIGSPERLONG, sgn, mode);
1044#else
1045 SCM_BIGDIG t2[SCM_DIGSPERLONG];
1046 scm_longdigs(z, t2);
1047 return scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), t2, SCM_DIGSPERLONG, sgn, mode);
1048#endif
1049 }
1050}
1051
1cc91f1b 1052
0f2d19dd
JB		 1053SCM
1054scm_divbigbig(x, nx, y, ny, sgn, modes)
1055 SCM_BIGDIG *x;
1056 scm_sizet nx;
1057 SCM_BIGDIG *y;
1058 scm_sizet ny;
1059 int sgn;
1060 int modes;
0f2d19dd
JB		 1061{
1062 /* modes description
1063 0 remainder
1064 1 scm_modulo
1065 2 quotient
1066 3 quotient but returns 0 if division is not exact. */
1067 scm_sizet i = 0, j = 0;
1068 long num = 0;
1069 unsigned long t2 = 0;
1070 SCM z, newy;
1071 SCM_BIGDIG d = 0, qhat, *zds, *yds;
1072 /* algorithm requires nx >= ny */
1073 if (nx < ny)
1074 switch (modes) {
1075 case 0: /* remainder -- just return x */
1076 z = scm_mkbig(nx, sgn); zds = SCM_BDIGITS(z);
1077 do {zds[i] = x[i];} while (++i < nx);
1078 return z;
1079 case 1: /* scm_modulo -- return y-x */
1080 z = scm_mkbig(ny, sgn); zds = SCM_BDIGITS(z);
1081 do {
1082 num += (long) y[i] - x[i];
1083 if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
1084 else {zds[i] = num; num = 0;}
1085 } while (++i < nx);
1086 while (i < ny) {
1087 num += y[i];
1088 if (num < 0) {zds[i++] = num + SCM_BIGRAD; num = -1;}
1089 else {zds[i++] = num; num = 0;}
1090 }
1091 goto doadj;
1092 case 2: return SCM_INUM0; /* quotient is zero */
1093 case 3: return 0; /* the division is not exact */
1094 }
1095
1096 z = scm_mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = SCM_BDIGITS(z);
1097 if (nx==ny) zds[nx+1] = 0;
1098 while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */
1099 if (y[ny-1] < (SCM_BIGRAD>>1)) { /* normalize operands */
1100 d = SCM_BIGRAD/(y[ny-1]+1);
1101 newy = scm_mkbig(ny, 0); yds = SCM_BDIGITS(newy);
1102 while(j < ny)
1103 {t2 += (unsigned long) y[j]*d; yds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
1104 y = yds; j = 0; t2 = 0;
1105 while(j < nx)
1106 {t2 += (unsigned long) x[j]*d; zds[j++] = SCM_BIGLO(t2); t2 = SCM_BIGDN(t2);}
1107 zds[j] = t2;
1108 }
1109 else {zds[j = nx] = 0; while (j--) zds[j] = x[j];}
1110 j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */
1111 do { /* loop over digits of quotient */
1112 if (zds[j]==y[ny-1]) qhat = SCM_BIGRAD-1;
1113 else qhat = (SCM_BIGUP(zds[j]) + zds[j-1])/y[ny-1];
1114 if (!qhat) continue;
1115 i = 0; num = 0; t2 = 0;
1116 do { /* multiply and subtract */
1117 t2 += (unsigned long) y[i] * qhat;
1118 num += zds[j - ny + i] - SCM_BIGLO(t2);
1119 if (num < 0) {zds[j - ny + i] = num + SCM_BIGRAD; num = -1;}
1120 else {zds[j - ny + i] = num; num = 0;}
1121 t2 = SCM_BIGDN(t2);
1122 } while (++i < ny);
1123 num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
1124 while (num) { /* "add back" required */
1125 i = 0; num = 0; qhat--;
1126 do {
1127 num += (long) zds[j - ny + i] + y[i];
1128 zds[j - ny + i] = SCM_BIGLO(num);
1129 num = SCM_BIGDN(num);
1130 } while (++i < ny);
1131 num--;
1132 }
1133 if (modes & 2) zds[j] = qhat;
1134 } while (--j >= ny);
1135 switch (modes) {
1136 case 3: /* check that remainder==0 */
1137 for(j = ny;j && !zds[j-1];--j) ; if (j) return 0;
1138 case 2: /* move quotient down in z */
1139 j = (nx==ny ? nx+2 : nx+1) - ny;
1140 for (i = 0;i < j;i++) zds[i] = zds[i+ny];
1141 ny = i;
1142 break;
1143 case 1: /* subtract for scm_modulo */
1144 i = 0; num = 0; j = 0;
1145 do {num += y[i] - zds[i];
1146 j = j | zds[i];
1147 if (num < 0) {zds[i] = num + SCM_BIGRAD; num = -1;}
1148 else {zds[i] = num; num = 0;}
1149 } while (++i < ny);
1150 if (!j) return SCM_INUM0;
1151 case 0: /* just normalize remainder */
1152 if (d) scm_divbigdig(zds, ny, d);
1153 }
1154 doadj:
1155 for(j = ny;j && !zds[j-1];--j) ;
1156 if (j * SCM_BITSPERDIG <= sizeof(SCM)*SCM_CHAR_BIT)
1157 if SCM_INUMP(z = scm_big2inum(z, j)) return z;
1158 return scm_adjbig(z, j);
1159}
1160#endif
1161
1162
1163
1164\f
1165
1166/*** NUMBERS -> STRINGS ***/
1167#ifdef SCM_FLOATS
1168int scm_dblprec;
1169static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
1170 5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
1171 5e-11,5e-12,5e-13,5e-14,5e-15,
1172 5e-16,5e-17,5e-18,5e-19,5e-20};
1173
1174
1175
1cc91f1b
JB		 1176
1177static scm_sizet idbl2str SCM_P ((double f, char *a));
1178
0f2d19dd
JB		 1179static scm_sizet
1180idbl2str(f, a)
1181 double f;
1182 char *a;
0f2d19dd
JB		 1183{
1184 int efmt, dpt, d, i, wp = scm_dblprec;
1185 scm_sizet ch = 0;
1186 int exp = 0;
1187
1188 if (f == 0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
1189 if (f < 0.0) {f = -f;a[ch++]='-';}
1190 else if (f > 0.0) ;
1191 else goto funny;
1192 if (IS_INF(f))
1193 {
1194 if (ch == 0) a[ch++]='+';
1195 funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
1196 }
1197# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from
1198 make-uniform-vector, from causing infinite loops. */
1199 while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;}
1200 while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;}
1201# else
1202 while (f < 1.0) {f *= 10.0; exp--;}
1203 while (f > 10.0) {f /= 10.0; exp++;}
1204# endif
1205 if (f+fx[wp] >= 10.0) {f = 1.0; exp++;}
1206 zero:
1207# ifdef ENGNOT
1208 dpt = (exp+9999)%3;
1209 exp -= dpt++;
1210 efmt = 1;
1211# else
1212 efmt = (exp < -3) || (exp > wp+2);
1213 if (!efmt)
1214 if (exp < 0) {
1215 a[ch++] = '0';
1216 a[ch++] = '.';
1217 dpt = exp;
1218 while (++dpt) a[ch++] = '0';
1219 } else
1220 dpt = exp+1;
1221 else
1222 dpt = 1;
1223# endif
1224
1225 do {
1226 d = f;
1227 f -= d;
1228 a[ch++] = d+'0';
1229 if (f < fx[wp]) break;
1230 if (f+fx[wp] >= 1.0) {
1231 a[ch-1]++;
1232 break;
1233 }
1234 f *= 10.0;
1235 if (!(--dpt)) a[ch++] = '.';
1236 } while (wp--);
1237
1238 if (dpt > 0)
1239# ifndef ENGNOT
1240 if ((dpt > 4) && (exp > 6)) {
1241 d = (a[0]=='-'?2:1);
1242 for (i = ch++; i > d; i--)
1243 a[i] = a[i-1];
1244 a[d] = '.';
1245 efmt = 1;
1246 } else
1247# endif
1248 {
1249 while (--dpt) a[ch++] = '0';
1250 a[ch++] = '.';
1251 }
1252 if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */
1253 if (efmt && exp) {
1254 a[ch++] = 'e';
1255 if (exp < 0) {
1256 exp = -exp;
1257 a[ch++] = '-';
1258 }
1259 for (i = 10; i <= exp; i *= 10);
1260 for (i /= 10; i; i /= 10) {
1261 a[ch++] = exp/i + '0';
1262 exp %= i;
1263 }
1264 }
1265 return ch;
1266}
1267
1cc91f1b
JB		 1268
1269static scm_sizet iflo2str SCM_P ((SCM flt, char *str));
1270
0f2d19dd
JB		 1271static scm_sizet
1272iflo2str(flt, str)
1273 SCM flt;
1274 char *str;
0f2d19dd
JB		 1275{
1276 scm_sizet i;
1277# ifdef SCM_SINGLES
1278 if SCM_SINGP(flt) i = idbl2str(SCM_FLO(flt), str);
1279 else
1280# endif
1281 i = idbl2str(SCM_REAL(flt), str);
1282 if SCM_CPLXP(flt) {
1283 if(0 <= SCM_IMAG(flt)) /* jeh */
1284 str[i++] = '+'; /* jeh */
1285 i += idbl2str(SCM_IMAG(flt), &str[i]);
1286 str[i++] = 'i';
1287 }
1288 return i;
1289}
1290#endif /* SCM_FLOATS */
1291
1cc91f1b 1292
0f2d19dd
JB		 1293scm_sizet
1294scm_iint2str(num, rad, p)
1295 long num;
1296 int rad;
1297 char *p;
0f2d19dd
JB		 1298{
1299 scm_sizet j;
1300 register int i = 1, d;
1301 register long n = num;
1302 if (n < 0) {n = -n; i++;}
1303 for (n /= rad;n > 0;n /= rad) i++;
1304 j = i;
1305 n = num;
1306 if (n < 0) {n = -n; *p++ = '-'; i--;}
1307 while (i--) {
1308 d = n % rad;
1309 n /= rad;
1310 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
1311 }
1312 return j;
1313}
1314
1315
1316#ifdef SCM_BIGDIG
1cc91f1b
JB		 1317
1318static SCM big2str SCM_P ((SCM b, register unsigned int radix));
1319
0f2d19dd
JB		 1320static SCM
1321big2str(b, radix)
1322 SCM b;
1323 register unsigned int radix;
0f2d19dd
JB		 1324{
1325 SCM t = scm_copybig(b, 0); /* sign of temp doesn't matter */
1326 register SCM_BIGDIG *ds = SCM_BDIGITS(t);
1327 scm_sizet i = SCM_NUMDIGS(t);
1328 scm_sizet j = radix==16 ? (SCM_BITSPERDIG*i)/4+2
1329 : radix >= 10 ? (SCM_BITSPERDIG*i*241L)/800+2
1330 : (SCM_BITSPERDIG*i)+2;
1331 scm_sizet k = 0;
1332 scm_sizet radct = 0;
1333 scm_sizet ch; /* jeh */
1334 SCM_BIGDIG radpow = 1, radmod = 0;
1335 SCM ss = scm_makstr((long)j, 0);
1336 char *s = SCM_CHARS(ss), c;
1337 while ((long) radpow * radix < SCM_BIGRAD) {
1338 radpow *= radix;
1339 radct++;
1340 }
1341 s[0] = scm_tc16_bigneg==SCM_TYP16(b) ? '-' : '+';
1342 while ((i || radmod) && j) {
1343 if (k == 0) {
1344 radmod = (SCM_BIGDIG)scm_divbigdig(ds, i, radpow);
1345 k = radct;
1346 if (!ds[i-1]) i--;
1347 }
1348 c = radmod % radix; radmod /= radix; k--;
1349 s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
1350 }
1351 ch = s[0] == '-' ? 1 : 0; /* jeh */
1352 if (ch < j) { /* jeh */
1353 for(i = j;j < SCM_LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
1354 scm_vector_set_length_x(ss, (SCM)SCM_MAKINUM(ch+SCM_LENGTH(ss)-i)); /* jeh */
1355 }
1356 return ss;
1357}
1358#endif
1359
1360
1361SCM_PROC(s_number_to_string, "number->string", 1, 1, 0, scm_number_to_string);
1cc91f1b 1362
0f2d19dd
JB		 1363SCM
1364scm_number_to_string(x, radix)
1365 SCM x;
1366 SCM radix;
0f2d19dd
JB		 1367{
1368 if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
1369 else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_number_to_string);
1370#ifdef SCM_FLOATS
1371 if SCM_NINUMP(x) {
1372 char num_buf[SCM_FLOBUFLEN];
1373# ifdef SCM_BIGDIG
1374 SCM_ASRTGO(SCM_NIMP(x), badx);
1375 if SCM_BIGP(x) return big2str(x, (unsigned int)SCM_INUM(radix));
1376# ifndef RECKLESS
1377 if (!(SCM_INEXP(x)))
1378 badx: scm_wta(x, (char *)SCM_ARG1, s_number_to_string);
1379# endif
1380# else
1381 SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_number_to_string);
1382# endif
1383 return scm_makfromstr(num_buf, iflo2str(x, num_buf), 0);
1384 }
1385#else
1386# ifdef SCM_BIGDIG
1387 if SCM_NINUMP(x) {
1388 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_number_to_string);
1389 return big2str(x, (unsigned int)SCM_INUM(radix));
1390 }
1391# else
1392 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_number_to_string);
1393# endif
1394#endif
1395 {
1396 char num_buf[SCM_INTBUFLEN];
1397 return scm_makfromstr(num_buf,
1398 scm_iint2str(SCM_INUM(x), (int)SCM_INUM(radix), num_buf), 0);
1399 }
1400}
1401
1402
1403/* These print routines are stubbed here so that scm_repl.c doesn't need
1404 SCM_FLOATS or SCM_BIGDIGs conditionals */
1cc91f1b 1405
0f2d19dd 1406int
19402679 1407scm_floprint(sexp, port, pstate)
0f2d19dd
JB		 1408 SCM sexp;
1409 SCM port;
19402679 1410 scm_print_state *pstate;
0f2d19dd
JB		 1411{
1412#ifdef SCM_FLOATS
1413 char num_buf[SCM_FLOBUFLEN];
1414 scm_gen_write (scm_regular_string, num_buf, iflo2str(sexp, num_buf), port);
1415#else
1416 scm_ipruk("float", sexp, port);
1417#endif
1418 return !0;
1419}
1420
1421
1cc91f1b 1422
0f2d19dd 1423int
19402679 1424scm_bigprint(exp, port, pstate)
0f2d19dd
JB		 1425 SCM exp;
1426 SCM port;
19402679 1427 scm_print_state *pstate;
0f2d19dd
JB		 1428{
1429#ifdef SCM_BIGDIG
1430 exp = big2str(exp, (unsigned int)10);
1431 scm_gen_write (scm_regular_string, SCM_CHARS(exp), (scm_sizet)SCM_LENGTH(exp), port);
1432#else
1433 scm_ipruk("bignum", exp, port);
1434#endif
1435 return !0;
1436}
1437/*** END nums->strs ***/
1438
1439/*** STRINGS -> NUMBERS ***/
2a8fecee 1440
1cc91f1b
JB		 1441static SCM scm_small_istr2int SCM_P ((char *str, long len, long radix));
1442
2a8fecee
JB		 1443static SCM
1444scm_small_istr2int(str, len, radix)
1445 char *str;
1446 long len;
1447 long radix;
1448{
1449 register long n = 0, ln;
1450 register int c;
1451 register int i = 0;
1452 int lead_neg = 0;
1453 if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
1454 switch (*str) { /* leading sign */
1455 case '-': lead_neg = 1;
1456 case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1457 }
1458
1459 do {
1460 switch (c = str[i++]) {
1461 case DIGITS:
1462 c = c - '0';
1463 goto accumulate;
1464 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1465 c = c-'A'+10;
1466 goto accumulate;
1467 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1468 c = c-'a'+10;
1469 accumulate:
1470 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1471 ln = n;
1472 n = n * radix - c;
1473 /* Negation is a workaround for HP700 cc bug */
1474 if (n > ln || (-n > -SCM_MOST_NEGATIVE_FIXNUM)) goto ovfl;
1475 break;
1476 default:
1477 return SCM_BOOL_F; /* not a digit */
1478 }
1479 } while (i < len);
1480 if (!lead_neg) if ((n = -n) > SCM_MOST_POSITIVE_FIXNUM) goto ovfl;
1481 return SCM_MAKINUM(n);
1482 ovfl: /* overflow scheme integer */
1483 return SCM_BOOL_F;
1484}
1485
1486
1cc91f1b 1487
0f2d19dd
JB		 1488SCM
1489scm_istr2int(str, len, radix)
1490 char *str;
1491 long len;
1492 long radix;
0f2d19dd
JB		 1493{
1494 scm_sizet j;
1495 register scm_sizet k, blen = 1;
1496 scm_sizet i = 0;
1497 int c;
1498 SCM res;
1499 register SCM_BIGDIG *ds;
1500 register unsigned long t2;
1501
1502 if (0 >= len) return SCM_BOOL_F; /* zero scm_length */
2a8fecee
JB		 1503
1504 /* Short numbers we parse directly into an int, to avoid the overhead
1505 of creating a bignum. */
1506 if (len < 6)
1507 return scm_small_istr2int (str, len, radix);
1508
0f2d19dd
JB		 1509 if (16==radix) j = 1+(4*len*sizeof(char))/(SCM_BITSPERDIG);
1510 else if (10 <= radix)
1511 j = 1+(84*len*sizeof(char))/(SCM_BITSPERDIG*25);
1512 else j = 1+(len*sizeof(char))/(SCM_BITSPERDIG);
1513 switch (str[0]) { /* leading sign */
1514 case '-':
1515 case '+': if (++i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1516 }
1517 res = scm_mkbig(j, '-'==str[0]);
1518 ds = SCM_BDIGITS(res);
1519 for (k = j;k--;) ds[k] = 0;
1520 do {
1521 switch (c = str[i++]) {
1522 case DIGITS:
1523 c = c - '0';
1524 goto accumulate;
1525 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1526 c = c-'A'+10;
1527 goto accumulate;
1528 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1529 c = c-'a'+10;
1530 accumulate:
1531 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1532 k = 0;
1533 t2 = c;
1534 moretodo:
1535 while(k < blen) {
1536 /* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
1537 t2 += ds[k]*radix;
1538 ds[k++] = SCM_BIGLO(t2);
1539 t2 = SCM_BIGDN(t2);
1540 }
e1724d20 1541 if (blen > j)
52859adf 1542 scm_num_overflow ("bignum");
0f2d19dd
JB		 1543 if (t2) {blen++; goto moretodo;}
1544 break;
1545 default:
1546 return SCM_BOOL_F; /* not a digit */
1547 }
1548 } while (i < len);
1549 if (blen * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM))
1550 if SCM_INUMP(res = scm_big2inum(res, blen)) return res;
1551 if (j==blen) return res;
1552 return scm_adjbig(res, blen);
1553}
0f2d19dd
JB		 1554
1555#ifdef SCM_FLOATS
1cc91f1b 1556
0f2d19dd
JB		 1557SCM
1558scm_istr2flo(str, len, radix)
1559 char *str;
1560 long len;
1561 long radix;
0f2d19dd
JB		 1562{
1563 register int c, i = 0;
1564 double lead_sgn;
1565 double res = 0.0, tmp = 0.0;
1566 int flg = 0;
1567 int point = 0;
1568 SCM second;
1569
1570 if (i >= len) return SCM_BOOL_F; /* zero scm_length */
1571
1572 switch (*str) { /* leading sign */
1573 case '-': lead_sgn = -1.0; i++; break;
1574 case '+': lead_sgn = 1.0; i++; break;
1575 default : lead_sgn = 0.0;
1576 }
1577 if (i==len) return SCM_BOOL_F; /* bad if lone `+' or `-' */
1578
1579 if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */
1580 if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
1581 if (++i < len) return SCM_BOOL_F; /* `i' not last character */
1582 return scm_makdbl(0.0, lead_sgn);
1583 }
1584 do { /* check initial digits */
1585 switch (c = str[i]) {
1586 case DIGITS:
1587 c = c - '0';
1588 goto accum1;
1589 case 'D': case 'E': case 'F':
1590 if (radix==10) goto out1; /* must be exponent */
1591 case 'A': case 'B': case 'C':
1592 c = c-'A'+10;
1593 goto accum1;
1594 case 'd': case 'e': case 'f':
1595 if (radix==10) goto out1;
1596 case 'a': case 'b': case 'c':
1597 c = c-'a'+10;
1598 accum1:
1599 if (c >= radix) return SCM_BOOL_F; /* bad digit for radix */
1600 res = res * radix + c;
1601 flg = 1; /* res is valid */
1602 break;
1603 default:
1604 goto out1;
1605 }
1606 } while (++i < len);
1607 out1:
1608
1609 /* if true, then we did see a digit above, and res is valid */
1610 if (i==len) goto done;
1611
1612 /* By here, must have seen a digit,
1613 or must have next char be a `.' with radix==10 */
1614 if (!flg)
1615 if (!(str[i]=='.' && radix==10))
1616 return SCM_BOOL_F;
1617
1618 while (str[i]=='#') { /* optional sharps */
1619 res *= radix;
1620 if (++i==len) goto done;
1621 }
1622
1623 if (str[i]=='/') {
1624 while (++i < len) {
1625 switch (c = str[i]) {
1626 case DIGITS:
1627 c = c - '0';
1628 goto accum2;
1629 case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
1630 c = c-'A'+10;
1631 goto accum2;
1632 case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
1633 c = c-'a'+10;
1634 accum2:
1635 if (c >= radix) return SCM_BOOL_F;
1636 tmp = tmp * radix + c;
1637 break;
1638 default:
1639 goto out2;
1640 }
1641 }
1642 out2:
1643 if (tmp==0.0) return SCM_BOOL_F; /* `slash zero' not allowed */
1644 if (i < len)
1645 while (str[i]=='#') { /* optional sharps */
1646 tmp *= radix;
1647 if (++i==len) break;
1648 }
1649 res /= tmp;
1650 goto done;
1651 }
1652
1653 if (str[i]=='.') { /* decimal point notation */
1654 if (radix != 10) return SCM_BOOL_F; /* must be radix 10 */
1655 while (++i < len) {
1656 switch (c = str[i]) {
1657 case DIGITS:
1658 point--;
1659 res = res*10.0 + c-'0';
1660 flg = 1;
1661 break;
1662 default:
1663 goto out3;
1664 }
1665 }
1666 out3:
1667 if (!flg) return SCM_BOOL_F; /* no digits before or after decimal point */
1668 if (i==len) goto adjust;
1669 while (str[i]=='#') { /* ignore remaining sharps */
1670 if (++i==len) goto adjust;
1671 }
1672 }
1673
1674 switch (str[i]) { /* exponent */
1675 case 'd': case 'D':
1676 case 'e': case 'E':
1677 case 'f': case 'F':
1678 case 'l': case 'L':
1679 case 's': case 'S': {
1680 int expsgn = 1, expon = 0;
1681 if (radix != 10) return SCM_BOOL_F; /* only in radix 10 */
1682 if (++i==len) return SCM_BOOL_F; /* bad exponent */
1683 switch (str[i]) {
1684 case '-': expsgn=(-1);
1685 case '+': if (++i==len) return SCM_BOOL_F; /* bad exponent */
1686 }
1687 if (str[i] < '0' || str[i] > '9') return SCM_BOOL_F; /* bad exponent */
1688 do {
1689 switch (c = str[i]) {
1690 case DIGITS:
1691 expon = expon*10 + c-'0';
1692 if (expon > MAXEXP) return SCM_BOOL_F; /* exponent too large */
1693 break;
1694 default:
1695 goto out4;
1696 }
1697 } while (++i < len);
1698 out4:
1699 point += expsgn*expon;
1700 }
1701 }
1702
1703 adjust:
1704 if (point >= 0)
1705 while (point--) res *= 10.0;
1706 else
1707# ifdef _UNICOS
1708 while (point++) res *= 0.1;
1709# else
1710 while (point++) res /= 10.0;
1711# endif
1712
1713 done:
1714 /* at this point, we have a legitimate floating point result */
1715 if (lead_sgn==-1.0) res = -res;
1716 if (i==len) return scm_makdbl(res, 0.0);
1717
1718 if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */
1719 if (lead_sgn==0.0) return SCM_BOOL_F; /* must have leading sign */
1720 if (++i < len) return SCM_BOOL_F; /* `i' not last character */
1721 return scm_makdbl(0.0, res);
1722 }
1723
1724 switch (str[i++]) {
1725 case '-': lead_sgn = -1.0; break;
1726 case '+': lead_sgn = 1.0; break;
1727 case '@': { /* polar input for complex number */
1728 /* get a `real' for scm_angle */
1729 second = scm_istr2flo(&str[i], (long)(len-i), radix);
1730 if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `real' */
1731 if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `real' */
1732 tmp = SCM_REALPART(second);
1733 return scm_makdbl(res*cos(tmp), res*sin(tmp));
1734 }
1735 default: return SCM_BOOL_F;
1736 }
1737
1738 /* at this point, last char must be `i' */
1739 if (str[len-1] != 'i' && str[len-1] != 'I') return SCM_BOOL_F;
1740 /* handles `x+i' and `x-i' */
1741 if (i==(len-1)) return scm_makdbl(res, lead_sgn);
1742 /* get a `ureal' for complex part */
1743 second = scm_istr2flo(&str[i], (long)((len-i)-1), radix);
1744 if (!(SCM_INEXP(second))) return SCM_BOOL_F; /* not `ureal' */
1745 if (SCM_CPLXP(second)) return SCM_BOOL_F; /* not `ureal' */
1746 tmp = SCM_REALPART(second);
1747 if (tmp < 0.0) return SCM_BOOL_F; /* not `ureal' */
1748 return scm_makdbl(res, (lead_sgn*tmp));
1749}
1750#endif /* SCM_FLOATS */
1751
1752
1cc91f1b 1753
0f2d19dd
JB		 1754SCM
1755scm_istring2number(str, len, radix)
1756 char *str;
1757 long len;
1758 long radix;
0f2d19dd
JB		 1759{
1760 int i = 0;
1761 char ex = 0;
1762 char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */
1763 SCM res;
1764 if (len==1)
1765 if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
1766 return SCM_BOOL_F;
1767
1768 while ((len-i) >= 2 && str[i]=='#' && ++i)
1769 switch (str[i++]) {
1770 case 'b': case 'B': if (rx_p++) return SCM_BOOL_F; radix = 2; break;
1771 case 'o': case 'O': if (rx_p++) return SCM_BOOL_F; radix = 8; break;
1772 case 'd': case 'D': if (rx_p++) return SCM_BOOL_F; radix = 10; break;
1773 case 'x': case 'X': if (rx_p++) return SCM_BOOL_F; radix = 16; break;
1774 case 'i': case 'I': if (ex_p++) return SCM_BOOL_F; ex = 2; break;
1775 case 'e': case 'E': if (ex_p++) return SCM_BOOL_F; ex = 1; break;
1776 default: return SCM_BOOL_F;
1777 }
1778
1779 switch (ex) {
1780 case 1:
1781 return scm_istr2int(&str[i], len-i, radix);
1782 case 0:
1783 res = scm_istr2int(&str[i], len-i, radix);
1784 if SCM_NFALSEP(res) return res;
1785#ifdef SCM_FLOATS
1786 case 2: return scm_istr2flo(&str[i], len-i, radix);
1787#endif
1788 }
1789 return SCM_BOOL_F;
1790}
1791
1792
1793SCM_PROC(s_string_to_number, "string->number", 1, 1, 0, scm_string_to_number);
1cc91f1b 1794
0f2d19dd
JB		 1795SCM
1796scm_string_to_number(str, radix)
1797 SCM str;
1798 SCM radix;
0f2d19dd
JB		 1799{
1800 SCM answer;
1801 if SCM_UNBNDP(radix) radix=SCM_MAKINUM(10L);
1802 else SCM_ASSERT(SCM_INUMP(radix), radix, SCM_ARG2, s_string_to_number);
1803 SCM_ASSERT(SCM_NIMP(str) && SCM_ROSTRINGP(str), str, SCM_ARG1, s_string_to_number);
1804 answer = scm_istring2number(SCM_ROCHARS(str), SCM_ROLENGTH(str), SCM_INUM(radix));
1805 return scm_return_first (answer, str);
1806}
1807/*** END strs->nums ***/
1808
1809#ifdef SCM_FLOATS
1cc91f1b 1810
0f2d19dd
JB		 1811SCM
1812scm_makdbl (x, y)
1813 double x;
1814 double y;
0f2d19dd
JB		 1815{
1816 SCM z;
1817 if ((y==0.0) && (x==0.0)) return scm_flo0;
1818 SCM_NEWCELL(z);
1819 SCM_DEFER_INTS;
1820 if (y==0.0) {
1821# ifdef SCM_SINGLES
1822 float fx = x;
1823# ifndef SCM_SINGLESONLY
1824 if ((-FLTMAX < x) && (x < FLTMAX) && (fx==x))
1825# endif
1826 {
a6c64c3c 1827 SCM_SETCAR (z, scm_tc_flo);
0f2d19dd
JB		 1828 SCM_FLO(z) = x;
1829 SCM_ALLOW_INTS;
1830 return z;
1831 }
1832# endif/* def SCM_SINGLES */
a6c64c3c
MD		 1833 SCM_SETCDR (z, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
1834 SCM_SETCAR (z, scm_tc_dblr);
0f2d19dd
JB		 1835 }
1836 else {
a6c64c3c
MD		 1837 SCM_SETCDR (z, (SCM)scm_must_malloc(2L*sizeof(double), "complex"));
1838 SCM_SETCAR (z, scm_tc_dblc);
0f2d19dd
JB		 1839 SCM_IMAG(z) = y;
1840 }
1841 SCM_REAL(z) = x;
1842 SCM_ALLOW_INTS;
1843 return z;
1844}
1845#endif
1846
1847
1cc91f1b 1848
0f2d19dd
JB		 1849SCM
1850scm_bigequal(x, y)
1851 SCM x;
1852 SCM y;
0f2d19dd
JB		 1853{
1854#ifdef SCM_BIGDIG
1855 if (0==scm_bigcomp(x, y)) return SCM_BOOL_T;
1856#endif
1857 return SCM_BOOL_F;
1858}
1859
1860
1cc91f1b 1861
0f2d19dd
JB		 1862SCM
1863scm_floequal(x, y)
1864 SCM x;
1865 SCM y;
0f2d19dd
JB		 1866{
1867#ifdef SCM_FLOATS
1868 if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
1869 if (!(SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y)))) return SCM_BOOL_T;
1870#endif
1871 return SCM_BOOL_F;
1872}
1873
1874
1875
1876
1877SCM_PROC(s_number_p, "number?", 1, 0, 0, scm_number_p);
1878SCM_PROC(s_complex_p, "complex?", 1, 0, 0, scm_number_p);
1cc91f1b 1879
0f2d19dd
JB		 1880SCM
1881scm_number_p(x)
1882 SCM x;
0f2d19dd
JB		 1883{
1884 if SCM_INUMP(x) return SCM_BOOL_T;
1885#ifdef SCM_FLOATS
1886 if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
1887#else
1888# ifdef SCM_BIGDIG
1889 if (SCM_NIMP(x) && SCM_NUMP(x)) return SCM_BOOL_T;
1890# endif
1891#endif
1892 return SCM_BOOL_F;
1893}
1894
1895
1896
1897#ifdef SCM_FLOATS
1898SCM_PROC(s_real_p, "real?", 1, 0, 0, scm_real_p);
1899SCM_PROC(s_rational_p, "rational?", 1, 0, 0, scm_real_p);
1cc91f1b 1900
0f2d19dd
JB		 1901SCM
1902scm_real_p(x)
1903 SCM x;
0f2d19dd
JB		 1904{
1905 if (SCM_INUMP(x))
1906 return SCM_BOOL_T;
1907 if (SCM_IMP(x))
1908 return SCM_BOOL_F;
1909 if (SCM_REALP(x))
1910 return SCM_BOOL_T;
1911# ifdef SCM_BIGDIG
1912 if (SCM_BIGP(x))
1913 return SCM_BOOL_T;
1914# endif
1915 return SCM_BOOL_F;
1916}
1917
1918
1919
f693191c 1920SCM_PROC(s_int_p, "integer?", 1, 0, 0, scm_integer_p);
1cc91f1b 1921
0f2d19dd 1922SCM
f693191c 1923scm_integer_p(x)
0f2d19dd 1924 SCM x;
0f2d19dd
JB		 1925{
1926 double r;
1927 if SCM_INUMP(x) return SCM_BOOL_T;
1928 if SCM_IMP(x) return SCM_BOOL_F;
1929# ifdef SCM_BIGDIG
1930 if SCM_BIGP(x) return SCM_BOOL_T;
1931# endif
1932 if (!SCM_INEXP(x)) return SCM_BOOL_F;
f693191c 1933 if (SCM_CPLXP(x)) return SCM_BOOL_F;
0f2d19dd
JB		 1934 r = SCM_REALPART(x);
1935 if (r==floor(r)) return SCM_BOOL_T;
1936 return SCM_BOOL_F;
1937}
1938
1939
1940
1941#endif /* SCM_FLOATS */
1942
1943SCM_PROC(s_inexact_p, "inexact?", 1, 0, 0, scm_inexact_p);
1cc91f1b 1944
0f2d19dd
JB		 1945SCM
1946scm_inexact_p(x)
1947 SCM x;
0f2d19dd
JB		 1948{
1949#ifdef SCM_FLOATS
1950 if (SCM_NIMP(x) && SCM_INEXP(x)) return SCM_BOOL_T;
1951#endif
1952 return SCM_BOOL_F;
1953}
1954
1955
1956
1957
f693191c 1958SCM_PROC1 (s_eq_p, "=", scm_tc7_rpsubr, scm_num_eq_p);
1cc91f1b 1959
0f2d19dd
JB		 1960SCM
1961scm_num_eq_p (x, y)
1962 SCM x;
1963 SCM y;
0f2d19dd
JB		 1964{
1965#ifdef SCM_FLOATS
1966 SCM t;
1967 if SCM_NINUMP(x) {
1968# ifdef SCM_BIGDIG
1969# ifndef RECKLESS
1970 if (!(SCM_NIMP(x)))
1971 badx: scm_wta(x, (char *)SCM_ARG1, s_eq_p);
1972# endif
1973 if SCM_BIGP(x) {
1974 if SCM_INUMP(y) return SCM_BOOL_F;
1975 SCM_ASRTGO(SCM_NIMP(y), bady);
1976 if SCM_BIGP(y) return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
1977 SCM_ASRTGO(SCM_INEXP(y), bady);
1978 bigreal:
1979 return (SCM_REALP(y) && (scm_big2dbl(x)==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
1980 }
1981 SCM_ASRTGO(SCM_INEXP(x), badx);
1982# else
1983 SCM_ASSERT(SCM_NIMP(x) && SCM_INEXP(x), x, SCM_ARG1, s_eq_p);
1984# endif
1985 if SCM_INUMP(y) {t = x; x = y; y = t; goto realint;}
1986# ifdef SCM_BIGDIG
1987 SCM_ASRTGO(SCM_NIMP(y), bady);
1988 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
1989 SCM_ASRTGO(SCM_INEXP(y), bady);
1990# else
1991 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
1992# endif
1993 if (SCM_REALPART(x) != SCM_REALPART(y)) return SCM_BOOL_F;
1994 if SCM_CPLXP(x)
1995 return (SCM_CPLXP(y) && (SCM_IMAG(x)==SCM_IMAG(y))) ? SCM_BOOL_T : SCM_BOOL_F;
1996 return SCM_CPLXP(y) ? SCM_BOOL_F : SCM_BOOL_T;
1997 }
1998 if SCM_NINUMP(y) {
1999# ifdef SCM_BIGDIG
2000 SCM_ASRTGO(SCM_NIMP(y), bady);
2001 if SCM_BIGP(y) return SCM_BOOL_F;
2002# ifndef RECKLESS
2003 if (!(SCM_INEXP(y)))
2004 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2005# endif
2006# else
2007# ifndef RECKLESS
2008 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2009 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2010# endif
2011# endif
2012 realint:
2013 return (SCM_REALP(y) && (((double)SCM_INUM(x))==SCM_REALPART(y))) ? SCM_BOOL_T : SCM_BOOL_F;
2014 }
2015#else
2016# ifdef SCM_BIGDIG
2017 if SCM_NINUMP(x) {
2018 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_eq_p);
2019 if SCM_INUMP(y) return SCM_BOOL_F;
2020 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2021 return (0==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2022 }
2023 if SCM_NINUMP(y) {
2024# ifndef RECKLESS
2025 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2026 bady: scm_wta(y, (char *)SCM_ARG2, s_eq_p);
2027# endif
2028 return SCM_BOOL_F;
2029 }
2030# else
2031 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_eq_p);
2032 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_eq_p);
2033# endif
2034#endif
2035 return ((long)x==(long)y) ? SCM_BOOL_T : SCM_BOOL_F;
2036}
2037
2038
2039
f693191c 2040SCM_PROC1 (s_less_p, "<", scm_tc7_rpsubr, scm_less_p);
1cc91f1b 2041
0f2d19dd
JB		 2042SCM
2043scm_less_p(x, y)
2044 SCM x;
2045 SCM y;
0f2d19dd
JB		 2046{
2047#ifdef SCM_FLOATS
2048 if SCM_NINUMP(x) {
2049# ifdef SCM_BIGDIG
2050# ifndef RECKLESS
2051 if (!(SCM_NIMP(x)))
2052 badx: scm_wta(x, (char *)SCM_ARG1, s_less_p);
2053# endif
2054 if SCM_BIGP(x) {
2055 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
2056 SCM_ASRTGO(SCM_NIMP(y), bady);
2057 if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2058 SCM_ASRTGO(SCM_REALP(y), bady);
2059 return (scm_big2dbl(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2060 }
2061 SCM_ASRTGO(SCM_REALP(x), badx);
2062# else
2063 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_less_p);
2064# endif
2065 if (SCM_INUMP(y))
2066 return (SCM_REALPART(x) < ((double)SCM_INUM(y))) ? SCM_BOOL_T : SCM_BOOL_F;
2067# ifdef SCM_BIGDIG
2068 SCM_ASRTGO(SCM_NIMP(y), bady);
2069 if SCM_BIGP(y) return (SCM_REALPART(x) < scm_big2dbl(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2070 SCM_ASRTGO(SCM_REALP(y), bady);
2071# else
2072 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2073# endif
2074 return (SCM_REALPART(x) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2075 }
2076 if SCM_NINUMP(y) {
2077# ifdef SCM_BIGDIG
2078 SCM_ASRTGO(SCM_NIMP(y), bady);
2079 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
2080# ifndef RECKLESS
2081 if (!(SCM_REALP(y)))
2082 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2083# endif
2084# else
2085# ifndef RECKLESS
2086 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2087 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2088# endif
2089# endif
2090 return (((double)SCM_INUM(x)) < SCM_REALPART(y)) ? SCM_BOOL_T : SCM_BOOL_F;
2091 }
2092#else
2093# ifdef SCM_BIGDIG
2094 if SCM_NINUMP(x) {
2095 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_less_p);
2096 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? SCM_BOOL_T : SCM_BOOL_F;
2097 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2098 return (1==scm_bigcomp(x, y)) ? SCM_BOOL_T : SCM_BOOL_F;
2099 }
2100 if SCM_NINUMP(y) {
2101# ifndef RECKLESS
2102 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2103 bady: scm_wta(y, (char *)SCM_ARG2, s_less_p);
2104# endif
2105 return SCM_BIGSIGN(y) ? SCM_BOOL_F : SCM_BOOL_T;
2106 }
2107# else
2108 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_less_p);
2109 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_less_p);
2110# endif
2111#endif
2112 return ((long)x < (long)y) ? SCM_BOOL_T : SCM_BOOL_F;
2113}
2114
2115
f693191c 2116SCM_PROC1 (s_gr_p, ">", scm_tc7_rpsubr, scm_gr_p);
1cc91f1b 2117
0f2d19dd
JB		 2118SCM
2119scm_gr_p(x, y)
2120 SCM x;
2121 SCM y;
0f2d19dd
JB		 2122{
2123 return scm_less_p(y, x);
2124}
2125
2126
2127
f693191c 2128SCM_PROC1 (s_leq_p, "<=", scm_tc7_rpsubr, scm_leq_p);
1cc91f1b 2129
0f2d19dd
JB		 2130SCM
2131scm_leq_p(x, y)
2132 SCM x;
2133 SCM y;
0f2d19dd
JB		 2134{
2135 return SCM_BOOL_NOT(scm_less_p(y, x));
2136}
2137
2138
2139
f693191c 2140SCM_PROC1 (s_geq_p, ">=", scm_tc7_rpsubr, scm_geq_p);
1cc91f1b 2141
0f2d19dd
JB		 2142SCM
2143scm_geq_p(x, y)
2144 SCM x;
2145 SCM y;
0f2d19dd
JB		 2146{
2147 return SCM_BOOL_NOT(scm_less_p(x, y));
2148}
2149
2150
2151
2152SCM_PROC(s_zero_p, "zero?", 1, 0, 0, scm_zero_p);
1cc91f1b 2153
0f2d19dd
JB		 2154SCM
2155scm_zero_p(z)
2156 SCM z;
0f2d19dd
JB		 2157{
2158#ifdef SCM_FLOATS
2159 if SCM_NINUMP(z) {
2160# ifdef SCM_BIGDIG
2161 SCM_ASRTGO(SCM_NIMP(z), badz);
2162 if SCM_BIGP(z) return SCM_BOOL_F;
2163# ifndef RECKLESS
2164 if (!(SCM_INEXP(z)))
2165 badz: scm_wta(z, (char *)SCM_ARG1, s_zero_p);
2166# endif
2167# else
2168 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_zero_p);
2169# endif
2170 return (z==scm_flo0) ? SCM_BOOL_T : SCM_BOOL_F;
2171 }
2172#else
2173# ifdef SCM_BIGDIG
2174 if SCM_NINUMP(z) {
2175 SCM_ASSERT(SCM_NIMP(z) && SCM_BIGP(z), z, SCM_ARG1, s_zero_p);
2176 return SCM_BOOL_F;
2177 }
2178# else
2179 SCM_ASSERT(SCM_INUMP(z), z, SCM_ARG1, s_zero_p);
2180# endif
2181#endif
2182 return (z==SCM_INUM0) ? SCM_BOOL_T: SCM_BOOL_F;
2183}
2184
2185
2186
2187SCM_PROC(s_positive_p, "positive?", 1, 0, 0, scm_positive_p);
1cc91f1b 2188
0f2d19dd
JB		 2189SCM
2190scm_positive_p(x)
2191 SCM x;
0f2d19dd
JB		 2192{
2193#ifdef SCM_FLOATS
2194 if SCM_NINUMP(x) {
2195# ifdef SCM_BIGDIG
2196 SCM_ASRTGO(SCM_NIMP(x), badx);
2197 if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2198# ifndef RECKLESS
2199 if (!(SCM_REALP(x)))
2200 badx: scm_wta(x, (char *)SCM_ARG1, s_positive_p);
2201# endif
2202# else
2203 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_positive_p);
2204# endif
2205 return (SCM_REALPART(x) > 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2206 }
2207#else
2208# ifdef SCM_BIGDIG
2209 if SCM_NINUMP(x) {
2210 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_positive_p);
2211 return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_T : SCM_BOOL_F;
2212 }
2213# else
2214 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_positive_p);
2215# endif
2216#endif
2217 return (x > SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2218}
2219
2220
2221
2222SCM_PROC(s_negative_p, "negative?", 1, 0, 0, scm_negative_p);
1cc91f1b 2223
0f2d19dd
JB		 2224SCM
2225scm_negative_p(x)
2226 SCM x;
0f2d19dd
JB		 2227{
2228#ifdef SCM_FLOATS
2229 if SCM_NINUMP(x) {
2230# ifdef SCM_BIGDIG
2231 SCM_ASRTGO(SCM_NIMP(x), badx);
2232 if SCM_BIGP(x) return SCM_TYP16(x)==scm_tc16_bigpos ? SCM_BOOL_F : SCM_BOOL_T;
2233# ifndef RECKLESS
2234 if (!(SCM_REALP(x)))
2235 badx: scm_wta(x, (char *)SCM_ARG1, s_negative_p);
2236# endif
2237# else
2238 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_negative_p);
2239# endif
2240 return (SCM_REALPART(x) < 0.0) ? SCM_BOOL_T : SCM_BOOL_F;
2241 }
2242#else
2243# ifdef SCM_BIGDIG
2244 if SCM_NINUMP(x) {
2245 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_negative_p);
2246 return (SCM_TYP16(x)==scm_tc16_bigneg) ? SCM_BOOL_T : SCM_BOOL_F;
2247 }
2248# else
2249 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_negative_p);
2250# endif
2251#endif
2252 return (x < SCM_INUM0) ? SCM_BOOL_T : SCM_BOOL_F;
2253}
2254
2255
2256SCM_PROC1 (s_max, "max", scm_tc7_asubr, scm_max);
1cc91f1b 2257
0f2d19dd
JB		 2258SCM
2259scm_max(x, y)
2260 SCM x;
2261 SCM y;
0f2d19dd
JB		 2262{
2263#ifdef SCM_FLOATS
2264 double z;
2265#endif
2266 if SCM_UNBNDP(y) {
2267#ifndef RECKLESS
2268 if (!(SCM_NUMBERP(x)))
2269 badx: scm_wta(x, (char *)SCM_ARG1, s_max);
2270#endif
2271 return x;
2272 }
2273#ifdef SCM_FLOATS
2274 if SCM_NINUMP(x) {
2275# ifdef SCM_BIGDIG
2276 SCM_ASRTGO(SCM_NIMP(x), badx);
2277 if SCM_BIGP(x) {
2278 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
2279 SCM_ASRTGO(SCM_NIMP(y), bady);
2280 if SCM_BIGP(y) return (1==scm_bigcomp(x, y)) ? y : x;
2281 SCM_ASRTGO(SCM_REALP(y), bady);
2282 z = scm_big2dbl(x);
2283 return (z < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2284 }
2285 SCM_ASRTGO(SCM_REALP(x), badx);
2286# else
2287 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_max);
2288# endif
2289 if (SCM_INUMP(y))
2290 return (SCM_REALPART(x) < (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
2291# ifdef SCM_BIGDIG
2292 SCM_ASRTGO(SCM_NIMP(y), bady);
2293 if (SCM_BIGP(y))
2294 return (SCM_REALPART(x) < (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
2295 SCM_ASRTGO(SCM_REALP(y), bady);
2296# else
2297 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2298# endif
2299 return (SCM_REALPART(x) < SCM_REALPART(y)) ? y : x;
2300 }
2301 if SCM_NINUMP(y) {
2302# ifdef SCM_BIGDIG
2303 SCM_ASRTGO(SCM_NIMP(y), bady);
2304 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? x : y;
2305# ifndef RECKLESS
2306 if (!(SCM_REALP(y)))
2307 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2308# endif
2309# else
2310# ifndef RECKLESS
2311 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2312 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2313# endif
2314# endif
2315 return ((z = SCM_INUM(x)) < SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2316 }
2317#else
2318# ifdef SCM_BIGDIG
2319 if SCM_NINUMP(x) {
2320 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_max);
2321 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? y : x;
2322 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2323 return (1==scm_bigcomp(x, y)) ? y : x;
2324 }
2325 if SCM_NINUMP(y) {
2326# ifndef RECKLESS
2327 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2328 bady: scm_wta(y, (char *)SCM_ARG2, s_max);
2329# endif
2330 return SCM_BIGSIGN(y) ? x : y;
2331 }
2332# else
2333 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_max);
2334 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_max);
2335# endif
2336#endif
2337 return ((long)x < (long)y) ? y : x;
2338}
2339
2340
2341
2342
2343SCM_PROC1 (s_min, "min", scm_tc7_asubr, scm_min);
1cc91f1b 2344
0f2d19dd
JB		 2345SCM
2346scm_min(x, y)
2347 SCM x;
2348 SCM y;
0f2d19dd
JB		 2349{
2350#ifdef SCM_FLOATS
2351 double z;
2352#endif
2353 if SCM_UNBNDP(y) {
2354#ifndef RECKLESS
2355 if (!(SCM_NUMBERP(x)))
2356 badx:scm_wta(x, (char *)SCM_ARG1, s_min);
2357#endif
2358 return x;
2359 }
2360#ifdef SCM_FLOATS
2361 if SCM_NINUMP(x) {
2362# ifdef SCM_BIGDIG
2363 SCM_ASRTGO(SCM_NIMP(x), badx);
2364 if SCM_BIGP(x) {
2365 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
2366 SCM_ASRTGO(SCM_NIMP(y), bady);
2367 if SCM_BIGP(y) return (-1==scm_bigcomp(x, y)) ? y : x;
2368 SCM_ASRTGO(SCM_REALP(y), bady);
2369 z = scm_big2dbl(x);
2370 return (z > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2371 }
2372 SCM_ASRTGO(SCM_REALP(x), badx);
2373# else
2374 SCM_ASSERT(SCM_NIMP(x) && SCM_REALP(x), x, SCM_ARG1, s_min);
2375# endif
2376 if SCM_INUMP(y) return (SCM_REALPART(x) > (z = SCM_INUM(y))) ? scm_makdbl(z, 0.0) : x;
2377# ifdef SCM_BIGDIG
2378 SCM_ASRTGO(SCM_NIMP(y), bady);
2379 if SCM_BIGP(y) return (SCM_REALPART(x) > (z = scm_big2dbl(y))) ? scm_makdbl(z, 0.0) : x;
2380 SCM_ASRTGO(SCM_REALP(y), bady);
2381# else
2382 SCM_ASRTGO(SCM_NIMP(y) && SCM_REALP(y), bady);
2383# endif
2384 return (SCM_REALPART(x) > SCM_REALPART(y)) ? y : x;
2385 }
2386 if SCM_NINUMP(y) {
2387# ifdef SCM_BIGDIG
2388 SCM_ASRTGO(SCM_NIMP(y), bady);
2389 if SCM_BIGP(y) return SCM_BIGSIGN(y) ? y : x;
2390# ifndef RECKLESS
2391 if (!(SCM_REALP(y)))
2392 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2393# endif
2394# else
2395# ifndef RECKLESS
2396 if (!(SCM_NIMP(y) && SCM_REALP(y)))
2397 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2398# endif
2399# endif
2400 return ((z = SCM_INUM(x)) > SCM_REALPART(y)) ? y : scm_makdbl(z, 0.0);
2401 }
2402#else
2403# ifdef SCM_BIGDIG
2404 if SCM_NINUMP(x) {
2405 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_min);
2406 if SCM_INUMP(y) return SCM_BIGSIGN(x) ? x : y;
2407 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2408 return (-1==scm_bigcomp(x, y)) ? y : x;
2409 }
2410 if SCM_NINUMP(y) {
2411# ifndef RECKLESS
2412 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2413 bady: scm_wta(y, (char *)SCM_ARG2, s_min);
2414# endif
2415 return SCM_BIGSIGN(y) ? y : x;
2416 }
2417# else
2418 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_min);
2419 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_min);
2420# endif
2421#endif
2422 return ((long)x > (long)y) ? y : x;
2423}
2424
2425
2426
2427
2428SCM_PROC1 (s_sum, "+", scm_tc7_asubr, scm_sum);
1cc91f1b 2429
0f2d19dd
JB		 2430SCM
2431scm_sum(x, y)
2432 SCM x;
2433 SCM y;
0f2d19dd
JB		 2434{
2435 if SCM_UNBNDP(y) {
2436 if SCM_UNBNDP(x) return SCM_INUM0;
2437#ifndef RECKLESS
2438 if (!(SCM_NUMBERP(x)))
2439 badx: scm_wta(x, (char *)SCM_ARG1, s_sum);
2440#endif
2441 return x;
2442 }
2443#ifdef SCM_FLOATS
2444 if SCM_NINUMP(x) {
2445 SCM t;
2446# ifdef SCM_BIGDIG
2447 SCM_ASRTGO(SCM_NIMP(x), badx);
2448 if SCM_BIGP(x) {
2449 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2450 SCM_ASRTGO(SCM_NIMP(y), bady);
2451 if SCM_BIGP(y) {
2452 if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
2453 return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
2454 }
2455 SCM_ASRTGO(SCM_INEXP(y), bady);
2456 bigreal: return scm_makdbl(scm_big2dbl(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
2457 }
2458 SCM_ASRTGO(SCM_INEXP(x), badx);
2459# else
2460 SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
2461# endif
2462 if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
2463# ifdef SCM_BIGDIG
2464 SCM_ASRTGO(SCM_NIMP(y), bady);
2465 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
2466# ifndef RECKLESS
2467 else if (!(SCM_INEXP(y)))
2468 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2469# endif
2470# else
2471# ifndef RECKLESS
2472 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2473 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2474# endif
2475# endif
2476 { double i = 0.0;
2477 if SCM_CPLXP(x) i = SCM_IMAG(x);
2478 if SCM_CPLXP(y) i += SCM_IMAG(y);
2479 return scm_makdbl(SCM_REALPART(x)+SCM_REALPART(y), i); }
2480 }
2481 if SCM_NINUMP(y) {
2482# ifdef SCM_BIGDIG
2483 SCM_ASRTGO(SCM_NIMP(y), bady);
2484 if SCM_BIGP(y)
2485 intbig: {
2486# ifndef SCM_DIGSTOOBIG
2487 long z = scm_pseudolong(SCM_INUM(x));
2488 return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2489# else
2490 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2491 scm_longdigs(SCM_INUM(x), zdigs);
2492 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2493# endif
2494 }
2495 SCM_ASRTGO(SCM_INEXP(y), bady);
2496# else
2497 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2498# endif
2499 intreal: return scm_makdbl(SCM_INUM(x)+SCM_REALPART(y), SCM_CPLXP(y)?SCM_IMAG(y):0.0);
2500 }
2501#else
2502# ifdef SCM_BIGDIG
2503 if SCM_NINUMP(x) {
2504 SCM t;
2505 SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
2506 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2507 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2508 if (SCM_NUMDIGS(x) > SCM_NUMDIGS(y)) {t = x; x = y; y = t;}
2509 return scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0);
2510 }
2511 if SCM_NINUMP(y) {
2512# ifndef RECKLESS
2513 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2514 bady: scm_wta(y, (char *)SCM_ARG2, s_sum);
2515# endif
2516 intbig: {
2517# ifndef SCM_DIGSTOOBIG
2518 long z = scm_pseudolong(SCM_INUM(x));
2519 return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2520# else
2521 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2522 scm_longdigs(SCM_INUM(x), zdigs);
2523 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
2524# endif
2525 }
2526 }
2527# else
2528 SCM_ASRTGO(SCM_INUMP(x), badx);
2529 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_sum);
2530# endif
2531#endif
2532 x = SCM_INUM(x)+SCM_INUM(y);
2533 if SCM_FIXABLE(x) return SCM_MAKINUM(x);
2534#ifdef SCM_BIGDIG
2535 return scm_long2big(x);
2536#else
2537# ifdef SCM_FLOATS
2538 return scm_makdbl((double)x, 0.0);
2539# else
52859adf 2540 scm_num_overflow (s_sum);
0f2d19dd
JB		 2541 return SCM_UNSPECIFIED;
2542# endif
2543#endif
2544}
2545
2546
2547
2548
2549SCM_PROC1 (s_difference, "-", scm_tc7_asubr, scm_difference);
1cc91f1b 2550
0f2d19dd
JB		 2551SCM
2552scm_difference(x, y)
2553 SCM x;
2554 SCM y;
0f2d19dd
JB		 2555{
2556#ifdef SCM_FLOATS
2557 if SCM_NINUMP(x) {
2558# ifndef RECKLESS
2559 if (!(SCM_NIMP(x)))
2560 badx: scm_wta(x, (char *)SCM_ARG1, s_difference);
2561# endif
2562 if SCM_UNBNDP(y) {
2563# ifdef SCM_BIGDIG
2564 if SCM_BIGP(x) {
2565 x = scm_copybig(x, !SCM_BIGSIGN(x));
2566 return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
2567 scm_big2inum(x, SCM_NUMDIGS(x)) : x;
2568 }
2569# endif
2570 SCM_ASRTGO(SCM_INEXP(x), badx);
2571 return scm_makdbl(-SCM_REALPART(x), SCM_CPLXP(x)?-SCM_IMAG(x):0.0);
2572 }
2573 if SCM_INUMP(y) return scm_sum(x, SCM_MAKINUM(-SCM_INUM(y)));
2574# ifdef SCM_BIGDIG
2575 SCM_ASRTGO(SCM_NIMP(y), bady);
2576 if SCM_BIGP(x) {
2577 if SCM_BIGP(y) return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
2578 scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
2579 scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
2580 SCM_ASRTGO(SCM_INEXP(y), bady);
2581 return scm_makdbl(scm_big2dbl(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2582 }
2583 SCM_ASRTGO(SCM_INEXP(x), badx);
2584 if SCM_BIGP(y) return scm_makdbl(SCM_REALPART(x)-scm_big2dbl(y), SCM_CPLXP(x)?SCM_IMAG(x):0.0);
2585 SCM_ASRTGO(SCM_INEXP(y), bady);
2586# else
2587 SCM_ASRTGO(SCM_INEXP(x), badx);
2588 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2589# endif
2590 if SCM_CPLXP(x)
2591 if SCM_CPLXP(y)
2592 return scm_makdbl(SCM_REAL(x)-SCM_REAL(y), SCM_IMAG(x)-SCM_IMAG(y));
2593 else
2594 return scm_makdbl(SCM_REAL(x)-SCM_REALPART(y), SCM_IMAG(x));
2595 return scm_makdbl(SCM_REALPART(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2596 }
2597 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2598 if SCM_NINUMP(y) {
2599# ifdef SCM_BIGDIG
2600 SCM_ASRTGO(SCM_NIMP(y), bady);
2601 if SCM_BIGP(y) {
2602# ifndef SCM_DIGSTOOBIG
2603 long z = scm_pseudolong(SCM_INUM(x));
2604 return scm_addbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2605# else
2606 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2607 scm_longdigs(SCM_INUM(x), zdigs);
2608 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2609# endif
2610 }
2611# ifndef RECKLESS
2612 if (!(SCM_INEXP(y)))
2613 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2614# endif
2615# else
2616# ifndef RECKLESS
2617 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2618 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2619# endif
2620# endif
2621 return scm_makdbl(SCM_INUM(x)-SCM_REALPART(y), SCM_CPLXP(y)?-SCM_IMAG(y):0.0);
2622 }
2623#else
2624# ifdef SCM_BIGDIG
2625 if SCM_NINUMP(x) {
2626 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_difference);
2627 if SCM_UNBNDP(y) {
2628 x = scm_copybig(x, !SCM_BIGSIGN(x));
2629 return SCM_NUMDIGS(x) * SCM_BITSPERDIG/SCM_CHAR_BIT <= sizeof(SCM) ?
2630 scm_big2inum(x, SCM_NUMDIGS(x)) : x;
2631 }
2632 if SCM_INUMP(y) {
2633# ifndef SCM_DIGSTOOBIG
2634 long z = scm_pseudolong(SCM_INUM(y));
2635 return scm_addbig(&z, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
2636# else
2637 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2638 scm_longdigs(SCM_INUM(x), zdigs);
2639 return scm_addbig(zdigs, SCM_DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
2640# endif
2641 }
2642 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2643 return (SCM_NUMDIGS(x) < SCM_NUMDIGS(y)) ?
2644 scm_addbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BIGSIGN(x), y, 0x0100) :
2645 scm_addbig(SCM_BDIGITS(y), SCM_NUMDIGS(y), SCM_BIGSIGN(y) ^ 0x0100, x, 0);
2646 }
2647 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2648 if SCM_NINUMP(y) {
2649# ifndef RECKLESS
2650 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2651 bady: scm_wta(y, (char *)SCM_ARG2, s_difference);
2652# endif
2653 {
2654# ifndef SCM_DIGSTOOBIG
2655 long z = scm_pseudolong(SCM_INUM(x));
2656 return scm_addbig(&z, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2657# else
2658 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2659 scm_longdigs(SCM_INUM(x), zdigs);
2660 return scm_addbig(zdigs, SCM_DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
2661# endif
2662 }
2663 }
2664# else
2665 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_difference);
2666 if SCM_UNBNDP(y) {x = -SCM_INUM(x); goto checkx;}
2667 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_difference);
2668# endif
2669#endif
2670 x = SCM_INUM(x)-SCM_INUM(y);
2671 checkx:
2672 if SCM_FIXABLE(x) return SCM_MAKINUM(x);
2673#ifdef SCM_BIGDIG
2674 return scm_long2big(x);
2675#else
2676# ifdef SCM_FLOATS
2677 return scm_makdbl((double)x, 0.0);
2678# else
52859adf 2679 scm_num_overflow (s_difference);
0f2d19dd
JB		 2680 return SCM_UNSPECIFIED;
2681# endif
2682#endif
2683}
2684
2685
2686
2687
2688SCM_PROC1 (s_product, "*", scm_tc7_asubr, scm_product);
1cc91f1b 2689
0f2d19dd
JB		 2690SCM
2691scm_product(x, y)
2692 SCM x;
2693 SCM y;
0f2d19dd
JB		 2694{
2695 if SCM_UNBNDP(y) {
2696 if SCM_UNBNDP(x) return SCM_MAKINUM(1L);
2697#ifndef RECKLESS
2698 if (!(SCM_NUMBERP(x)))
2699 badx: scm_wta(x, (char *)SCM_ARG1, s_product);
2700#endif
2701 return x;
2702 }
2703#ifdef SCM_FLOATS
2704 if SCM_NINUMP(x) {
2705 SCM t;
2706# ifdef SCM_BIGDIG
2707 SCM_ASRTGO(SCM_NIMP(x), badx);
2708 if SCM_BIGP(x) {
2709 if SCM_INUMP(y) {t = x; x = y; y = t; goto intbig;}
2710 SCM_ASRTGO(SCM_NIMP(y), bady);
2711 if SCM_BIGP(y) return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2712 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
2713 SCM_ASRTGO(SCM_INEXP(y), bady);
2714 bigreal: {
2715 double bg = scm_big2dbl(x);
2716 return scm_makdbl(bg*SCM_REALPART(y), SCM_CPLXP(y)?bg*SCM_IMAG(y):0.0); }
2717 }
2718 SCM_ASRTGO(SCM_INEXP(x), badx);
2719# else
2720 SCM_ASRTGO(SCM_NIMP(x) && SCM_INEXP(x), badx);
2721# endif
2722 if SCM_INUMP(y) {t = x; x = y; y = t; goto intreal;}
2723# ifdef SCM_BIGDIG
2724 SCM_ASRTGO(SCM_NIMP(y), bady);
2725 if SCM_BIGP(y) {t = x; x = y; y = t; goto bigreal;}
2726# ifndef RECKLESS
2727 else if (!(SCM_INEXP(y)))
2728 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2729# endif
2730# else
2731# ifndef RECKLESS
2732 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2733 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2734# endif
2735# endif
2736 if SCM_CPLXP(x)
2737 if SCM_CPLXP(y)
2738 return scm_makdbl(SCM_REAL(x)*SCM_REAL(y)-SCM_IMAG(x)*SCM_IMAG(y),
2739 SCM_REAL(x)*SCM_IMAG(y)+SCM_IMAG(x)*SCM_REAL(y));
2740 else
2741 return scm_makdbl(SCM_REAL(x)*SCM_REALPART(y), SCM_IMAG(x)*SCM_REALPART(y));
2742 return scm_makdbl(SCM_REALPART(x)*SCM_REALPART(y),
2743 SCM_CPLXP(y)?SCM_REALPART(x)*SCM_IMAG(y):0.0);
2744 }
2745 if SCM_NINUMP(y) {
2746# ifdef SCM_BIGDIG
2747 SCM_ASRTGO(SCM_NIMP(y), bady);
2748 if SCM_BIGP(y) {
2749 intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
2750 {
2751# ifndef SCM_DIGSTOOBIG
2752 long z = scm_pseudolong(SCM_INUM(x));
2753 return scm_mulbig((SCM_BIGDIG *)&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2754 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2755# else
2756 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2757 scm_longdigs(SCM_INUM(x), zdigs);
2758 return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2759 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2760# endif
2761 }
2762 }
2763 SCM_ASRTGO(SCM_INEXP(y), bady);
2764# else
2765 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2766# endif
2767 intreal: return scm_makdbl(SCM_INUM(x)*SCM_REALPART(y), SCM_CPLXP(y)?SCM_INUM(x)*SCM_IMAG(y):0.0);
2768 }
2769#else
2770# ifdef SCM_BIGDIG
2771 if SCM_NINUMP(x) {
2772 SCM_ASRTGO(SCM_NIMP(x) && SCM_BIGP(x), badx);
2773 if SCM_INUMP(y) {SCM t = x; x = y; y = t; goto intbig;}
2774 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2775 return scm_mulbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2776 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y));
2777 }
2778 if SCM_NINUMP(y) {
2779# ifndef RECKLESS
2780 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
2781 bady: scm_wta(y, (char *)SCM_ARG2, s_product);
2782# endif
2783 intbig: if (SCM_INUM0==x) return x; if (SCM_MAKINUM(1L)==x) return y;
2784 {
2785# ifndef SCM_DIGSTOOBIG
2786 long z = scm_pseudolong(SCM_INUM(x));
2787 return scm_mulbig(&z, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2788 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2789# else
2790 SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2791 scm_longdigs(SCM_INUM(x), zdigs);
2792 return scm_mulbig(zdigs, SCM_DIGSPERLONG, SCM_BDIGITS(y), SCM_NUMDIGS(y),
2793 SCM_BIGSIGN(y) ? (x>0) : (x<0));
2794# endif
2795 }
2796 }
2797# else
2798 SCM_ASRTGO(SCM_INUMP(x), badx);
2799 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_product);
2800# endif
2801#endif
2802 {
2803 long i, j, k;
2804 i = SCM_INUM(x);
2805 if (0==i) return x;
2806 j = SCM_INUM(y);
2807 k = i * j;
2808 y = SCM_MAKINUM(k);
2809 if (k != SCM_INUM(y) || k/i != j)
2810#ifdef SCM_BIGDIG
2811 { int sgn = (i < 0) ^ (j < 0);
2812# ifndef SCM_DIGSTOOBIG
2813 i = scm_pseudolong(i);
2814 j = scm_pseudolong(j);
2815 return scm_mulbig((SCM_BIGDIG *)&i, SCM_DIGSPERLONG,
2816 (SCM_BIGDIG *)&j, SCM_DIGSPERLONG, sgn);
2817# else /* SCM_DIGSTOOBIG */
2818 SCM_BIGDIG idigs[SCM_DIGSPERLONG];
2819 SCM_BIGDIG jdigs[SCM_DIGSPERLONG];
2820 scm_longdigs(i, idigs);
2821 scm_longdigs(j, jdigs);
2822 return scm_mulbig(idigs, SCM_DIGSPERLONG, jdigs, SCM_DIGSPERLONG, sgn);
2823# endif
2824 }
2825#else
2826# ifdef SCM_FLOATS
2827 return scm_makdbl(((double)i)*((double)j), 0.0);
2828# else
52859adf 2829 scm_num_overflow (s_product);
0f2d19dd
JB		 2830# endif
2831#endif
2832 return y;
2833 }
2834}
2835
2836
1cc91f1b 2837
0f2d19dd
JB		 2838double
2839scm_num2dbl (a, why)
2840 SCM a;
2841 char * why;
0f2d19dd
JB		 2842{
2843 if (SCM_INUMP (a))
2844 return (double) SCM_INUM (a);
2845#ifdef SCM_FLOATS
2846 SCM_ASSERT (SCM_NIMP (a), a, "wrong type argument", why);
2847 if (SCM_REALP (a))
2848 return (SCM_REALPART (a));
2849#endif
2850#ifdef SCM_BIGDIG
2851 return scm_big2dbl (a);
2852#endif
2853 SCM_ASSERT (0, a, "wrong type argument", why);
2854 return SCM_UNSPECIFIED;
2855}
2856
2857
0f2d19dd 2858SCM_PROC1 (s_divide, "/", scm_tc7_asubr, scm_divide);
1cc91f1b 2859
0f2d19dd
JB		 2860SCM
2861scm_divide(x, y)
2862 SCM x;
2863 SCM y;
0f2d19dd
JB		 2864{
2865#ifdef SCM_FLOATS
2866 double d, r, i, a;
2867 if SCM_NINUMP(x) {
2868# ifndef RECKLESS
2869 if (!(SCM_NIMP(x)))
2870 badx: scm_wta(x, (char *)SCM_ARG1, s_divide);
2871# endif
2872 if SCM_UNBNDP(y) {
2873# ifdef SCM_BIGDIG
2874 if SCM_BIGP(x) return scm_makdbl(1.0/scm_big2dbl(x), 0.0);
2875# endif
2876 SCM_ASRTGO(SCM_INEXP(x), badx);
2877 if SCM_REALP(x) return scm_makdbl(1.0/SCM_REALPART(x), 0.0);
2878 r = SCM_REAL(x); i = SCM_IMAG(x); d = r*r+i*i;
2879 return scm_makdbl(r/d, -i/d);
2880 }
2881# ifdef SCM_BIGDIG
2882 if SCM_BIGP(x) {
2883 SCM z;
2884 if SCM_INUMP(y) {
2885 z = SCM_INUM(y);
e1724d20
GH		 2886#ifndef RECKLESS
2887 if (!z)
52859adf 2888 scm_num_overflow (s_divide);
e1724d20 2889#endif
0f2d19dd
JB		 2890 if (1==z) return x;
2891 if (z < 0) z = -z;
2892 if (z < SCM_BIGRAD) {
2893 SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
2894 return scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z) ?
2895 scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0) : scm_normbig(w);
2896 }
2897# ifndef SCM_DIGSTOOBIG
2898 z = scm_pseudolong(z);
2899 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), (SCM_BIGDIG *)&z, SCM_DIGSPERLONG,
2900 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
2901# else
2902 { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2903 scm_longdigs(z, zdigs);
2904 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
2905 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
2906# endif
2907 return z ? z : scm_makdbl(scm_big2dbl(x)/SCM_INUM(y), 0.0);
2908 }
2909 SCM_ASRTGO(SCM_NIMP(y), bady);
2910 if SCM_BIGP(y) {
2911 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2912 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
2913 return z ? z : scm_makdbl(scm_big2dbl(x)/scm_big2dbl(y), 0.0);
2914 }
2915 SCM_ASRTGO(SCM_INEXP(y), bady);
2916 if SCM_REALP(y) return scm_makdbl(scm_big2dbl(x)/SCM_REALPART(y), 0.0);
2917 a = scm_big2dbl(x);
2918 goto complex_div;
2919 }
2920# endif
2921 SCM_ASRTGO(SCM_INEXP(x), badx);
2922 if SCM_INUMP(y) {d = SCM_INUM(y); goto basic_div;}
2923# ifdef SCM_BIGDIG
2924 SCM_ASRTGO(SCM_NIMP(y), bady);
2925 if SCM_BIGP(y) {d = scm_big2dbl(y); goto basic_div;}
2926 SCM_ASRTGO(SCM_INEXP(y), bady);
2927# else
2928 SCM_ASRTGO(SCM_NIMP(y) && SCM_INEXP(y), bady);
2929# endif
2930 if SCM_REALP(y) {
2931 d = SCM_REALPART(y);
2932 basic_div: return scm_makdbl(SCM_REALPART(x)/d, SCM_CPLXP(x)?SCM_IMAG(x)/d:0.0);
2933 }
2934 a = SCM_REALPART(x);
2935 if SCM_REALP(x) goto complex_div;
2936 r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
2937 return scm_makdbl((a*r+SCM_IMAG(x)*i)/d, (SCM_IMAG(x)*r-a*i)/d);
2938 }
2939 if SCM_UNBNDP(y) {
2940 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
2941 return scm_makdbl(1.0/((double)SCM_INUM(x)), 0.0);
2942 }
2943 if SCM_NINUMP(y) {
2944# ifdef SCM_BIGDIG
2945 SCM_ASRTGO(SCM_NIMP(y), bady);
2946 if SCM_BIGP(y) return scm_makdbl(SCM_INUM(x)/scm_big2dbl(y), 0.0);
2947# ifndef RECKLESS
2948 if (!(SCM_INEXP(y)))
2949 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
2950# endif
2951# else
2952# ifndef RECKLESS
2953 if (!(SCM_NIMP(y) && SCM_INEXP(y)))
2954 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
2955# endif
2956# endif
2957 if (SCM_REALP(y))
2958 return scm_makdbl(SCM_INUM(x)/SCM_REALPART(y), 0.0);
2959 a = SCM_INUM(x);
2960 complex_div:
2961 r = SCM_REAL(y); i = SCM_IMAG(y); d = r*r+i*i;
2962 return scm_makdbl((a*r)/d, (-a*i)/d);
2963 }
2964#else
2965# ifdef SCM_BIGDIG
2966 if SCM_NINUMP(x) {
2967 SCM z;
2968 SCM_ASSERT(SCM_NIMP(x) && SCM_BIGP(x), x, SCM_ARG1, s_divide);
2969 if SCM_UNBNDP(y) goto ov;
2970 if SCM_INUMP(y) {
2971 z = SCM_INUM(y);
2972 if (!z) goto ov;
2973 if (1==z) return x;
2974 if (z < 0) z = -z;
2975 if (z < SCM_BIGRAD) {
2976 SCM w = scm_copybig(x, SCM_BIGSIGN(x) ? (y>0) : (y<0));
2977 if (scm_divbigdig(SCM_BDIGITS(w), SCM_NUMDIGS(w), (SCM_BIGDIG)z)) goto ov;
2978 return w;
2979 }
2980# ifndef SCM_DIGSTOOBIG
2981 z = scm_pseudolong(z);
2982 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), &z, SCM_DIGSPERLONG,
2983 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);
2984# else
2985 { SCM_BIGDIG zdigs[SCM_DIGSPERLONG];
2986 scm_longdigs(z, zdigs);
2987 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), zdigs, SCM_DIGSPERLONG,
2988 SCM_BIGSIGN(x) ? (y>0) : (y<0), 3);}
2989# endif
2990 } else {
2991 SCM_ASRTGO(SCM_NIMP(y) && SCM_BIGP(y), bady);
2992 z = scm_divbigbig(SCM_BDIGITS(x), SCM_NUMDIGS(x), SCM_BDIGITS(y), SCM_NUMDIGS(y),
2993 SCM_BIGSIGN(x) ^ SCM_BIGSIGN(y), 3);
2994 }
2995 if (!z) goto ov;
2996 return z;
2997 }
2998 if SCM_UNBNDP(y) {
2999 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
3000 goto ov;
3001 }
3002 if SCM_NINUMP(y) {
3003# ifndef RECKLESS
3004 if (!(SCM_NIMP(y) && SCM_BIGP(y)))
3005 bady: scm_wta(y, (char *)SCM_ARG2, s_divide);
3006# endif
3007 goto ov;
3008 }
3009# else
3010 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_divide);
3011 if SCM_UNBNDP(y) {
3012 if ((SCM_MAKINUM(1L)==x) || (SCM_MAKINUM(-1L)==x)) return x;
3013 goto ov;
3014 }
3015 SCM_ASSERT(SCM_INUMP(y), y, SCM_ARG2, s_divide);
3016# endif
3017#endif
3018 {
3019 long z = SCM_INUM(y);
3020 if ((0==z) || SCM_INUM(x)%z) goto ov;
3021 z = SCM_INUM(x)/z;
3022 if SCM_FIXABLE(z) return SCM_MAKINUM(z);
3023#ifdef SCM_BIGDIG
3024 return scm_long2big(z);
3025#endif
3026#ifdef SCM_FLOATS
3027 ov: return scm_makdbl(((double)SCM_INUM(x))/((double)SCM_INUM(y)), 0.0);
3028#else
52859adf 3029 ov: scm_num_overflow (s_divide);
0f2d19dd
JB		 3030 return SCM_UNSPECIFIED;
3031#endif
3032 }
3033}
3034
3035
3036
3037
3038#ifdef SCM_FLOATS
3039SCM_PROC1 (s_asinh, "$asinh", scm_tc7_cxr, (SCM (*)()) scm_asinh);
1cc91f1b 3040
0f2d19dd
JB		 3041double
3042scm_asinh(x)
3043 double x;
0f2d19dd
JB		 3044{
3045 return log(x+sqrt(x*x+1));
3046}
3047
3048
3049
3050
3051SCM_PROC1 (s_acosh, "$acosh", scm_tc7_cxr, (SCM (*)()) scm_acosh);
1cc91f1b 3052
0f2d19dd
JB		 3053double
3054scm_acosh(x)
3055 double x;
0f2d19dd
JB		 3056{
3057 return log(x+sqrt(x*x-1));
3058}
3059
3060
3061
3062
3063SCM_PROC1 (s_atanh, "$atanh", scm_tc7_cxr, (SCM (*)()) scm_atanh);
1cc91f1b 3064
0f2d19dd
JB		 3065double
3066scm_atanh(x)
3067 double x;
0f2d19dd
JB		 3068{
3069 return 0.5*log((1+x)/(1-x));
3070}
3071
3072
3073
3074
3075SCM_PROC1 (s_truncate, "truncate", scm_tc7_cxr, (SCM (*)()) scm_truncate);
1cc91f1b 3076
0f2d19dd
JB		 3077double
3078scm_truncate(x)
3079 double x;
0f2d19dd
JB		 3080{
3081 if (x < 0.0) return -floor(-x);
3082 return floor(x);
3083}
3084
3085
3086
3087SCM_PROC1 (s_round, "round", scm_tc7_cxr, (SCM (*)()) scm_round);
1cc91f1b 3088
0f2d19dd
JB		 3089double
3090scm_round(x)
3091 double x;
0f2d19dd
JB		 3092{
3093 double plus_half = x + 0.5;
3094 double result = floor(plus_half);
3095 /* Adjust so that the scm_round is towards even. */
3096 return (plus_half == result && plus_half / 2 != floor(plus_half / 2))
3097 ? result - 1 : result;
3098}
3099
3100
3101
3102SCM_PROC1 (s_exact_to_inexact, "exact->inexact", scm_tc7_cxr, (SCM (*)()) scm_exact_to_inexact);
1cc91f1b 3103
0f2d19dd
JB		 3104double
3105scm_exact_to_inexact(z)
3106 double z;
0f2d19dd
JB		 3107{
3108 return z;
3109}
3110
3111
3112SCM_PROC1 (s_i_floor, "floor", scm_tc7_cxr, (SCM (*)()) floor);
3113SCM_PROC1 (s_i_ceil, "ceiling", scm_tc7_cxr, (SCM (*)()) ceil);
3114SCM_PROC1 (s_i_sqrt, "$sqrt", scm_tc7_cxr, (SCM (*)())sqrt);
3115SCM_PROC1 (s_i_abs, "$abs", scm_tc7_cxr, (SCM (*)())fabs);
3116SCM_PROC1 (s_i_exp, "$exp", scm_tc7_cxr, (SCM (*)())exp);
3117SCM_PROC1 (s_i_log, "$log", scm_tc7_cxr, (SCM (*)())log);
3118SCM_PROC1 (s_i_sin, "$sin", scm_tc7_cxr, (SCM (*)())sin);
3119SCM_PROC1 (s_i_cos, "$cos", scm_tc7_cxr, (SCM (*)())cos);
3120SCM_PROC1 (s_i_tan, "$tan", scm_tc7_cxr, (SCM (*)())tan);
3121SCM_PROC1 (s_i_asin, "$asin", scm_tc7_cxr, (SCM (*)())asin);
3122SCM_PROC1 (s_i_acos, "$acos", scm_tc7_cxr, (SCM (*)())acos);
3123SCM_PROC1 (s_i_atan, "$atan", scm_tc7_cxr, (SCM (*)())atan);
3124SCM_PROC1 (s_i_sinh, "$sinh", scm_tc7_cxr, (SCM (*)())sinh);
3125SCM_PROC1 (s_i_cosh, "$cosh", scm_tc7_cxr, (SCM (*)())cosh);
3126SCM_PROC1 (s_i_tanh, "$tanh", scm_tc7_cxr, (SCM (*)())tanh);
3127
3128struct dpair {double x, y;};
3129
1cc91f1b
JB		 3130static void scm_two_doubles SCM_P ((SCM z1, SCM z2, char *sstring, struct dpair *xy));
3131
3a2425b9
JB		 3132static void
3133scm_two_doubles(z1, z2, sstring, xy)
0f2d19dd
JB		 3134 SCM z1, z2;
3135 char *sstring;
3136 struct dpair *xy;
3137{
3138 if SCM_INUMP(z1) xy->x = SCM_INUM(z1);
3139 else {
3140# ifdef SCM_BIGDIG
3141 SCM_ASRTGO(SCM_NIMP(z1), badz1);
3142 if SCM_BIGP(z1) xy->x = scm_big2dbl(z1);
3143 else {
3144# ifndef RECKLESS
3145 if (!(SCM_REALP(z1)))
3146 badz1: scm_wta(z1, (char *)SCM_ARG1, sstring);
3147# endif
3148 xy->x = SCM_REALPART(z1);}
3149# else
3150 {SCM_ASSERT(SCM_NIMP(z1) && SCM_REALP(z1), z1, SCM_ARG1, sstring);
3151 xy->x = SCM_REALPART(z1);}
3152# endif
3153 }
3154 if SCM_INUMP(z2) xy->y = SCM_INUM(z2);
3155 else {
3156# ifdef SCM_BIGDIG
3157 SCM_ASRTGO(SCM_NIMP(z2), badz2);
3158 if SCM_BIGP(z2) xy->y = scm_big2dbl(z2);
3159 else {
3160# ifndef RECKLESS
3161 if (!(SCM_REALP(z2)))
3162 badz2: scm_wta(z2, (char *)SCM_ARG2, sstring);
3163# endif
3164 xy->y = SCM_REALPART(z2);}
3165# else
3166 {SCM_ASSERT(SCM_NIMP(z2) && SCM_REALP(z2), z2, SCM_ARG2, sstring);
3167 xy->y = SCM_REALPART(z2);}
3168# endif
3169 }
3170}
3171
3172
3173
3174
02b754d3 3175SCM_PROC(s_sys_expt, "$expt", 2, 0, 0, scm_sys_expt);
1cc91f1b 3176
0f2d19dd
JB		 3177SCM
3178scm_sys_expt(z1, z2)
3179 SCM z1;
3180 SCM z2;
0f2d19dd
JB		 3181{
3182 struct dpair xy;
3183 scm_two_doubles(z1, z2, s_sys_expt, &xy);
3184 return scm_makdbl(pow(xy.x, xy.y), 0.0);
3185}
3186
3187
3188
02b754d3 3189SCM_PROC(s_sys_atan2, "$atan2", 2, 0, 0, scm_sys_atan2);
1cc91f1b 3190
0f2d19dd
JB		 3191SCM
3192scm_sys_atan2(z1, z2)
3193 SCM z1;
3194 SCM z2;
0f2d19dd
JB		 3195{
3196 struct dpair xy;
3197 scm_two_doubles(z1, z2, s_sys_atan2, &xy);
3198 return scm_makdbl(atan2(xy.x, xy.y), 0.0);
3199}
3200
3201
3202
3203SCM_PROC(s_make_rectangular, "make-rectangular", 2, 0, 0, scm_make_rectangular);
1cc91f1b 3204
0f2d19dd
JB		 3205SCM
3206scm_make_rectangular(z1, z2)
3207 SCM z1;
3208 SCM z2;
0f2d19dd
JB		 3209{
3210 struct dpair xy;
3211 scm_two_doubles(z1, z2, s_make_rectangular, &xy);
3212 return scm_makdbl(xy.x, xy.y);
3213}
3214
3215
3216
3217SCM_PROC(s_make_polar, "make-polar", 2, 0, 0, scm_make_polar);
1cc91f1b 3218
0f2d19dd
JB		 3219SCM
3220scm_make_polar(z1, z2)
3221 SCM z1;
3222 SCM z2;
0f2d19dd
JB		 3223{
3224 struct dpair xy;
3225 scm_two_doubles(z1, z2, s_make_polar, &xy);
3226 return scm_makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
3227}
3228
3229
3230
3231
3232SCM_PROC(s_real_part, "real-part", 1, 0, 0, scm_real_part);
1cc91f1b 3233
0f2d19dd
JB		 3234SCM
3235scm_real_part(z)
3236 SCM z;
0f2d19dd
JB		 3237{
3238 if SCM_NINUMP(z) {
3239# ifdef SCM_BIGDIG
3240 SCM_ASRTGO(SCM_NIMP(z), badz);
3241 if SCM_BIGP(z) return z;
3242# ifndef RECKLESS
3243 if (!(SCM_INEXP(z)))
3244 badz: scm_wta(z, (char *)SCM_ARG1, s_real_part);
3245# endif
3246# else
3247 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_real_part);
3248# endif
3249 if SCM_CPLXP(z) return scm_makdbl(SCM_REAL(z), 0.0);
3250 }
3251 return z;
3252}
3253
3254
3255
3256SCM_PROC(s_imag_part, "imag-part", 1, 0, 0, scm_imag_part);
1cc91f1b 3257
0f2d19dd
JB		 3258SCM
3259scm_imag_part(z)
3260 SCM z;
0f2d19dd
JB		 3261{
3262 if SCM_INUMP(z) return SCM_INUM0;
3263# ifdef SCM_BIGDIG
3264 SCM_ASRTGO(SCM_NIMP(z), badz);
3265 if SCM_BIGP(z) return SCM_INUM0;
3266# ifndef RECKLESS
3267 if (!(SCM_INEXP(z)))
3268 badz: scm_wta(z, (char *)SCM_ARG1, s_imag_part);
3269# endif
3270# else
3271 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_imag_part);
3272# endif
3273 if SCM_CPLXP(z) return scm_makdbl(SCM_IMAG(z), 0.0);
3274 return scm_flo0;
3275}
3276
3277
3278
3279SCM_PROC(s_magnitude, "magnitude", 1, 0, 0, scm_magnitude);
1cc91f1b 3280
0f2d19dd
JB		 3281SCM
3282scm_magnitude(z)
3283 SCM z;
0f2d19dd
JB		 3284{
3285 if SCM_INUMP(z) return scm_abs(z);
3286# ifdef SCM_BIGDIG
3287 SCM_ASRTGO(SCM_NIMP(z), badz);
3288 if SCM_BIGP(z) return scm_abs(z);
3289# ifndef RECKLESS
3290 if (!(SCM_INEXP(z)))
3291 badz: scm_wta(z, (char *)SCM_ARG1, s_magnitude);
3292# endif
3293# else
3294 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_magnitude);
3295# endif
3296 if SCM_CPLXP(z)
3297 {
3298 double i = SCM_IMAG(z), r = SCM_REAL(z);
3299 return scm_makdbl(sqrt(i*i+r*r), 0.0);
3300 }
3301 return scm_makdbl(fabs(SCM_REALPART(z)), 0.0);
3302}
3303
3304
3305
3306
3307SCM_PROC(s_angle, "angle", 1, 0, 0, scm_angle);
1cc91f1b 3308
0f2d19dd
JB		 3309SCM
3310scm_angle(z)
3311 SCM z;
0f2d19dd
JB		 3312{
3313 double x, y = 0.0;
3314 if SCM_INUMP(z) {x = (z>=SCM_INUM0) ? 1.0 : -1.0; goto do_angle;}
3315# ifdef SCM_BIGDIG
3316 SCM_ASRTGO(SCM_NIMP(z), badz);
3317 if SCM_BIGP(z) {x = (SCM_TYP16(z)==scm_tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
3318# ifndef RECKLESS
3319 if (!(SCM_INEXP(z))) {
3320 badz: scm_wta(z, (char *)SCM_ARG1, s_angle);}
3321# endif
3322# else
3323 SCM_ASSERT(SCM_NIMP(z) && SCM_INEXP(z), z, SCM_ARG1, s_angle);
3324# endif
3325 if (SCM_REALP(z))
3326 {
3327 x = SCM_REALPART(z);
3328 goto do_angle;
3329 }
3330 x = SCM_REAL(z); y = SCM_IMAG(z);
3331 do_angle:
3332 return scm_makdbl(atan2(y, x), 0.0);
3333}
3334
3335
3336SCM_PROC(s_inexact_to_exact, "inexact->exact", 1, 0, 0, scm_inexact_to_exact);
1cc91f1b 3337
0f2d19dd
JB		 3338SCM
3339scm_inexact_to_exact(z)
3340 SCM z;
0f2d19dd
JB		 3341{
3342 if SCM_INUMP(z) return z;
3343# ifdef SCM_BIGDIG
3344 SCM_ASRTGO(SCM_NIMP(z), badz);
3345 if SCM_BIGP(z) return z;
3346# ifndef RECKLESS
3347 if (!(SCM_REALP(z)))
3348 badz: scm_wta(z, (char *)SCM_ARG1, s_inexact_to_exact);
3349# endif
3350# else
3351 SCM_ASSERT(SCM_NIMP(z) && SCM_REALP(z), z, SCM_ARG1, s_inexact_to_exact);
3352# endif
3353# ifdef SCM_BIGDIG
3354 {
3355 double u = floor(SCM_REALPART(z)+0.5);
3356 if ((u <= SCM_MOST_POSITIVE_FIXNUM) && (-u <= -SCM_MOST_NEGATIVE_FIXNUM)) {
3357 /* Negation is a workaround for HP700 cc bug */
3358 SCM ans = SCM_MAKINUM((long)u);
3359 if (SCM_INUM(ans)==(long)u) return ans;
3360 }
3361 SCM_ASRTGO(!IS_INF(u), badz); /* problem? */
3362 return scm_dbl2big(u);
3363 }
3364# else
3365 return SCM_MAKINUM((long)floor(SCM_REALPART(z)+0.5));
3366# endif
3367}
3368
3369
3370
3371#else /* ~SCM_FLOATS */
3372SCM_PROC(s_trunc, "truncate", 1, 0, 0, scm_trunc);
1cc91f1b 3373
0f2d19dd
JB		 3374SCM
3375scm_trunc(x)
3376 SCM x;
0f2d19dd
JB		 3377{
3378 SCM_ASSERT(SCM_INUMP(x), x, SCM_ARG1, s_truncate);
3379 return x;
3380}
3381
3382
3383
3384#endif /* SCM_FLOATS */
3385
3386#ifdef SCM_BIGDIG
3387# ifdef SCM_FLOATS
3388/* d must be integer */
1cc91f1b 3389
0f2d19dd
JB		 3390SCM
3391scm_dbl2big(d)
3392 double d;
0f2d19dd
JB		 3393{
3394 scm_sizet i = 0;
3395 long c;
3396 SCM_BIGDIG *digits;
3397 SCM ans;
3398 double u = (d < 0)?-d:d;
3399 while (0 != floor(u)) {u /= SCM_BIGRAD;i++;}
3400 ans = scm_mkbig(i, d < 0);
3401 digits = SCM_BDIGITS(ans);
3402 while (i--) {
3403 u *= SCM_BIGRAD;
3404 c = floor(u);
3405 u -= c;
3406 digits[i] = c;
3407 }
e1724d20
GH		 3408#ifndef RECKLESS
3409 if (u != 0)
52859adf 3410 scm_num_overflow ("dbl2big");
e1724d20 3411#endif
0f2d19dd
JB		 3412 return ans;
3413}
3414
3415
3416
1cc91f1b 3417
0f2d19dd
JB		 3418double
3419scm_big2dbl(b)
3420 SCM b;
0f2d19dd
JB		 3421{
3422 double ans = 0.0;
3423 scm_sizet i = SCM_NUMDIGS(b);
3424 SCM_BIGDIG *digits = SCM_BDIGITS(b);
3425 while (i--) ans = digits[i] + SCM_BIGRAD*ans;
3426 if (scm_tc16_bigneg==SCM_TYP16(b)) return -ans;
3427 return ans;
3428}
3429# endif
3430#endif
3431
1cc91f1b 3432
0f2d19dd
JB		 3433SCM
3434scm_long2num(sl)
3435 long sl;
0f2d19dd
JB		 3436{
3437 if (!SCM_FIXABLE(sl)) {
3438#ifdef SCM_BIGDIG
3439 return scm_long2big(sl);
3440#else
3441# ifdef SCM_FLOATS
3442 return scm_makdbl((double) sl, 0.0);
3443# else
3444 return SCM_BOOL_F;
3445# endif
3446#endif
3447 }
3448 return SCM_MAKINUM(sl);
3449}
3450
3451
3452#ifdef LONGLONGS
1cc91f1b 3453
0f2d19dd
JB		 3454SCM
3455scm_long_long2num(sl)
3456 long_long sl;
0f2d19dd
JB		 3457{
3458 if (!SCM_FIXABLE(sl)) {
3459#ifdef SCM_BIGDIG
3460 return scm_long_long2big(sl);
3461#else
3462# ifdef SCM_FLOATS
3463 return scm_makdbl((double) sl, 0.0);
3464# else
3465 return SCM_BOOL_F;
3466# endif
3467#endif
3468 }
3469 return SCM_MAKINUM(sl);
3470}
3471#endif
3472
3473
1cc91f1b 3474
0f2d19dd
JB		 3475SCM
3476scm_ulong2num(sl)
3477 unsigned long sl;
0f2d19dd 3478{
e2806c10 3479 if (!SCM_POSFIXABLE(sl)) {
0f2d19dd
JB		 3480#ifdef SCM_BIGDIG
3481 return scm_ulong2big(sl);
3482#else
3483# ifdef SCM_FLOATS
3484 return scm_makdbl((double) sl, 0.0);
3485# else
3486 return SCM_BOOL_F;
3487# endif
3488#endif
3489 }
3490 return SCM_MAKINUM(sl);
3491}
3492
1cc91f1b 3493
0f2d19dd
JB		 3494long
3495scm_num2long(num, pos, s_caller)
3496 SCM num;
3497 char *pos;
3498 char *s_caller;
0f2d19dd
JB		 3499{
3500 long res;
3501 if (SCM_INUMP(num))
3502 {
3503 res = SCM_INUM(num);
3504 return res;
3505 }
3506 SCM_ASRTGO(SCM_NIMP(num), errout);
3507#ifdef SCM_FLOATS
3508 if (SCM_REALP(num))
3509 {
3510 double u = SCM_REALPART(num);
3511 res = u;
3512 if ((double)res == u)
3513 {
3514 return res;
3515 }
3516 }
3517#endif
3518#ifdef SCM_BIGDIG
3519 if (SCM_BIGP(num)) {
3520 long oldres;
3521 scm_sizet l;
3522 res = 0;
3523 oldres = 0;
3524 for(l = SCM_NUMDIGS(num);l--;)
3525 {
3526 res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3527 if (res < oldres)
3528 goto errout;
3529 oldres = res;
3530 }
3531 if (SCM_TYP16 (num) == scm_tc16_bigpos)
3532 return res;
3533 else
3534 return -res;
3535 }
3536#endif
3537 errout: scm_wta(num, pos, s_caller);
3538 return SCM_UNSPECIFIED;
3539}
3540
3541
3542
3543
1cc91f1b 3544
0f2d19dd
JB		 3545long
3546num2long(num, pos, s_caller)
3547 SCM num;
3548 char *pos;
3549 char *s_caller;
0f2d19dd
JB		 3550{
3551 long res;
3552 if SCM_INUMP(num) {
3553 res = SCM_INUM((long)num);
3554 return res;
3555 }
3556 SCM_ASRTGO(SCM_NIMP(num), errout);
3557#ifdef SCM_FLOATS
3558 if SCM_REALP(num) {
3559 double u = SCM_REALPART(num);
3560 if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
3561 && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
3562 res = u;
3563 return res;
3564 }
3565 }
3566#endif
3567#ifdef SCM_BIGDIG
3568 if SCM_BIGP(num) {
3569 scm_sizet l = SCM_NUMDIGS(num);
3570 SCM_ASRTGO(SCM_DIGSPERLONG >= l, errout);
3571 res = 0;
3572 for(;l--;) res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3573 return res;
3574 }
3575#endif
3576 errout: scm_wta(num, pos, s_caller);
3577 return SCM_UNSPECIFIED;
3578}
3579
3580
3581#ifdef LONGLONGS
1cc91f1b 3582
0f2d19dd
JB		 3583long_long
3584scm_num2long_long(num, pos, s_caller)
3585 SCM num;
3586 char *pos;
3587 char *s_caller;
0f2d19dd
JB		 3588{
3589 long_long res;
3590 if SCM_INUMP(num) {
3591 res = SCM_INUM((long_long)num);
3592 return res;
3593 }
3594 SCM_ASRTGO(SCM_NIMP(num), errout);
3595#ifdef SCM_FLOATS
3596 if SCM_REALP(num) {
3597 double u = SCM_REALPART(num);
3598 if (((SCM_MOST_NEGATIVE_FIXNUM * 4) <= u)
3599 && (u <= (SCM_MOST_POSITIVE_FIXNUM * 4 + 3))) {
3600 res = u;
3601 return res;
3602 }
3603 }
3604#endif
3605#ifdef SCM_BIGDIG
3606 if SCM_BIGP(num) {
3607 scm_sizet l = SCM_NUMDIGS(num);
3608 SCM_ASRTGO(SCM_DIGSPERLONGLONG >= l, errout);
3609 res = 0;
e2806c10 3610 for(;l--;) res = SCM_LONGLONGBIGUP(res) + SCM_BDIGITS(num)[l];
0f2d19dd
JB		 3611 return res;
3612 }
3613#endif
3614 errout: scm_wta(num, pos, s_caller);
3615 return SCM_UNSPECIFIED;
3616}
3617#endif
3618
3619
1cc91f1b 3620
0f2d19dd
JB		 3621unsigned long
3622scm_num2ulong(num, pos, s_caller)
3623 SCM num;
3624 char *pos;
3625 char *s_caller;
0f2d19dd
JB		 3626{
3627 unsigned long res;
3628 if (SCM_INUMP(num))
3629 {
3630 res = SCM_INUM((unsigned long)num);
3631 return res;
3632 }
3633 SCM_ASRTGO(SCM_NIMP(num), errout);
3634#ifdef SCM_FLOATS
3635 if (SCM_REALP(num))
3636 {
3637 double u = SCM_REALPART(num);
3638 if ((0 <= u) && (u <= (unsigned long)~0L))
3639 {
3640 res = u;
3641 return res;
3642 }
3643 }
3644#endif
3645#ifdef SCM_BIGDIG
3646 if (SCM_BIGP(num)) {
3647 unsigned long oldres;
3648 scm_sizet l;
3649 res = 0;
3650 oldres = 0;
3651 for(l = SCM_NUMDIGS(num);l--;)
3652 {
3653 res = SCM_BIGUP(res) + SCM_BDIGITS(num)[l];
3654 if (res < oldres)
3655 goto errout;
3656 oldres = res;
3657 }
3658 return res;
3659 }
3660#endif
3661 errout: scm_wta(num, pos, s_caller);
3662 return SCM_UNSPECIFIED;
3663}
3664
3665
3666#ifdef SCM_FLOATS
3667# ifndef DBL_DIG
1cc91f1b 3668static void add1 SCM_P ((double f, double *fsum));
0f2d19dd
JB		 3669static void add1(f, fsum)
3670 double f, *fsum;
3671{
3672 *fsum = f + 1.0;
3673}
3674# endif
3675#endif
3676
3677
1cc91f1b 3678
0f2d19dd
JB		 3679void
3680scm_init_numbers ()
0f2d19dd
JB		 3681{
3682#ifdef SCM_FLOATS
3683 SCM_NEWCELL(scm_flo0);
3684# ifdef SCM_SINGLES
a6c64c3c 3685 SCM_SETCAR (scm_flo0, scm_tc_flo);
0f2d19dd
JB		 3686 SCM_FLO(scm_flo0) = 0.0;
3687# else
a6c64c3c 3688 SCM_SETCDR (scm_flo0, (SCM)scm_must_malloc(1L*sizeof(double), "real"));
0f2d19dd 3689 SCM_REAL(scm_flo0) = 0.0;
a6c64c3c 3690 SCM_SETCAR (scm_flo0, scm_tc_dblr);
0f2d19dd
JB		 3691# endif
3692# ifdef DBL_DIG
3693 scm_dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
3694# else
3695 { /* determine floating point precision */
3696 double f = 0.1;
3697 double fsum = 1.0+f;
3698 while (fsum != 1.0) {
3699 f /= 10.0;
3700 if (++scm_dblprec > 20) break;
3701 add1(f, &fsum);
3702 }
3703 scm_dblprec = scm_dblprec-1;
3704 }
3705# endif /* DBL_DIG */
3706#endif
3707#include "numbers.x"
3708}
3709
Unnamed repository; edit this file 'description' to name the repository.