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