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