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