143 |
/* Copy src_big's value, negate it if same_sign_p is false, and return. */ |
/* Copy src_big's value, negate it if same_sign_p is false, and return. */ |
144 |
SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); |
SCM z = scm_double_cell (scm_tc16_big, 0, 0, 0); |
145 |
mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big)); |
mpz_init_set (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (src_big)); |
146 |
if (!same_sign_p) mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); |
if (!same_sign_p) |
147 |
|
mpz_neg (SCM_I_BIG_MPZ (z), SCM_I_BIG_MPZ (z)); |
148 |
return z; |
return z; |
149 |
} |
} |
150 |
|
|
195 |
"otherwise.") |
"otherwise.") |
196 |
#define FUNC_NAME s_scm_exact_p |
#define FUNC_NAME s_scm_exact_p |
197 |
{ |
{ |
198 |
if (SCM_INUMP (x)) return SCM_BOOL_T; |
if (SCM_INUMP (x)) |
199 |
if (SCM_BIGP (x)) return SCM_BOOL_T; |
return SCM_BOOL_T; |
200 |
|
if (SCM_BIGP (x)) |
201 |
|
return SCM_BOOL_T; |
202 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
203 |
} |
} |
204 |
#undef FUNC_NAME |
#undef FUNC_NAME |
210 |
"otherwise.") |
"otherwise.") |
211 |
#define FUNC_NAME s_scm_odd_p |
#define FUNC_NAME s_scm_odd_p |
212 |
{ |
{ |
213 |
if (SCM_INUMP (n)) { |
if (SCM_INUMP (n)) |
214 |
long val = SCM_INUM (n); |
{ |
215 |
return SCM_BOOL ((val & 1L) != 0); |
long val = SCM_INUM (n); |
216 |
} else if (SCM_BIGP (n)) { |
return SCM_BOOL ((val & 1L) != 0); |
217 |
int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n)); |
} |
218 |
scm_remember_upto_here_1 (n); |
else if (SCM_BIGP (n)) |
219 |
return SCM_BOOL (odd_p); |
{ |
220 |
} else if (scm_inf_p (n)) { |
int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n)); |
221 |
|
scm_remember_upto_here_1 (n); |
222 |
|
return SCM_BOOL (odd_p); |
223 |
|
} |
224 |
|
else if (!SCM_FALSEP (scm_inf_p (n))) |
225 |
return SCM_BOOL_T; |
return SCM_BOOL_T; |
226 |
} else { |
else |
227 |
SCM_WRONG_TYPE_ARG (1, n); |
SCM_WRONG_TYPE_ARG (1, n); |
|
} |
|
228 |
} |
} |
229 |
#undef FUNC_NAME |
#undef FUNC_NAME |
230 |
|
|
235 |
"otherwise.") |
"otherwise.") |
236 |
#define FUNC_NAME s_scm_even_p |
#define FUNC_NAME s_scm_even_p |
237 |
{ |
{ |
238 |
if (SCM_INUMP (n)) { |
if (SCM_INUMP (n)) |
239 |
long val = SCM_INUM (n); |
{ |
240 |
return SCM_BOOL ((val & 1L) == 0); |
long val = SCM_INUM (n); |
241 |
} else if (SCM_BIGP (n)) { |
return SCM_BOOL ((val & 1L) == 0); |
242 |
int even_p = mpz_even_p (SCM_I_BIG_MPZ (n)); |
} |
243 |
scm_remember_upto_here_1 (n); |
else if (SCM_BIGP (n)) |
244 |
return SCM_BOOL (even_p); |
{ |
245 |
} else if (scm_inf_p (n)) { |
int even_p = mpz_even_p (SCM_I_BIG_MPZ (n)); |
246 |
|
scm_remember_upto_here_1 (n); |
247 |
|
return SCM_BOOL (even_p); |
248 |
|
} |
249 |
|
else if (!SCM_FALSEP (scm_inf_p (n))) |
250 |
return SCM_BOOL_T; |
return SCM_BOOL_T; |
251 |
} else { |
else |
252 |
SCM_WRONG_TYPE_ARG (1, n); |
SCM_WRONG_TYPE_ARG (1, n); |
|
} |
|
253 |
} |
} |
254 |
#undef FUNC_NAME |
#undef FUNC_NAME |
255 |
|
|
281 |
"otherwise.") |
"otherwise.") |
282 |
#define FUNC_NAME s_scm_inf_p |
#define FUNC_NAME s_scm_inf_p |
283 |
{ |
{ |
284 |
if (SCM_REALP (n)) { |
if (SCM_REALP (n)) |
285 |
return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); |
return SCM_BOOL (xisinf (SCM_REAL_VALUE (n))); |
286 |
} else if (SCM_COMPLEXP (n)) { |
else if (SCM_COMPLEXP (n)) |
287 |
return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) |
return SCM_BOOL (xisinf (SCM_COMPLEX_REAL (n)) |
288 |
|| xisinf (SCM_COMPLEX_IMAG (n))); |
|| xisinf (SCM_COMPLEX_IMAG (n))); |
289 |
} else { |
else |
290 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
|
} |
|
291 |
} |
} |
292 |
#undef FUNC_NAME |
#undef FUNC_NAME |
293 |
|
|
297 |
"otherwise.") |
"otherwise.") |
298 |
#define FUNC_NAME s_scm_nan_p |
#define FUNC_NAME s_scm_nan_p |
299 |
{ |
{ |
300 |
if (SCM_REALP (n)) { |
if (SCM_REALP (n)) |
301 |
return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); |
return SCM_BOOL (xisnan (SCM_REAL_VALUE (n))); |
302 |
} else if (SCM_COMPLEXP (n)) { |
else if (SCM_COMPLEXP (n)) |
303 |
return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) |
return SCM_BOOL (xisnan (SCM_COMPLEX_REAL (n)) |
304 |
|| xisnan (SCM_COMPLEX_IMAG (n))); |
|| xisnan (SCM_COMPLEX_IMAG (n))); |
305 |
} else { |
else |
306 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
|
} |
|
307 |
} |
} |
308 |
#undef FUNC_NAME |
#undef FUNC_NAME |
309 |
|
|
374 |
#define FUNC_NAME s_scm_nan |
#define FUNC_NAME s_scm_nan |
375 |
{ |
{ |
376 |
static int initialized = 0; |
static int initialized = 0; |
377 |
if (! initialized) |
if (!initialized) |
378 |
{ |
{ |
379 |
guile_ieee_init (); |
guile_ieee_init (); |
380 |
initialized = 1; |
initialized = 1; |
389 |
"Return the absolute value of @var{x}.") |
"Return the absolute value of @var{x}.") |
390 |
#define FUNC_NAME |
#define FUNC_NAME |
391 |
{ |
{ |
392 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
393 |
long int xx = SCM_INUM (x); |
{ |
394 |
if (xx >= 0) { |
long int xx = SCM_INUM (x); |
395 |
return x; |
if (xx >= 0) |
396 |
} else if (SCM_POSFIXABLE (-xx)) { |
return x; |
397 |
return SCM_MAKINUM (-xx); |
else if (SCM_POSFIXABLE (-xx)) |
398 |
} else { |
return SCM_MAKINUM (-xx); |
399 |
return scm_i_long2big (-xx); |
else |
400 |
} |
return scm_i_long2big (-xx); |
401 |
} else if (SCM_BIGP (x)) { |
} |
402 |
const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
else if (SCM_BIGP (x)) |
403 |
if (sgn < 0) { |
{ |
404 |
return scm_i_clonebig (x, 0); |
const int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
405 |
} else { |
if (sgn < 0) |
406 |
return x; |
return scm_i_clonebig (x, 0); |
407 |
|
else |
408 |
|
return x; |
409 |
} |
} |
410 |
} else if (SCM_REALP (x)) { |
else if (SCM_REALP (x)) |
411 |
return scm_make_real (fabs (SCM_REAL_VALUE (x))); |
return scm_make_real (fabs (SCM_REAL_VALUE (x))); |
412 |
} else { |
else |
413 |
SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); |
SCM_WTA_DISPATCH_1 (g_scm_abs, x, 1, s_scm_abs); |
|
} |
|
414 |
} |
} |
415 |
#undef FUNC_NAME |
#undef FUNC_NAME |
416 |
|
|
421 |
SCM |
SCM |
422 |
scm_quotient (SCM x, SCM y) |
scm_quotient (SCM x, SCM y) |
423 |
{ |
{ |
424 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
425 |
long xx = SCM_INUM (x); |
{ |
426 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
427 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
428 |
if (yy == 0) { |
{ |
429 |
scm_num_overflow (s_quotient); |
long yy = SCM_INUM (y); |
430 |
} else { |
if (yy == 0) |
431 |
long z = xx / yy; |
scm_num_overflow (s_quotient); |
432 |
if (SCM_FIXABLE (z)) { |
else |
433 |
return SCM_MAKINUM (z); |
{ |
434 |
} else { |
long z = xx / yy; |
435 |
return scm_i_long2big (z); |
if (SCM_FIXABLE (z)) |
436 |
|
return SCM_MAKINUM (z); |
437 |
|
else |
438 |
|
return scm_i_long2big (z); |
439 |
|
} |
440 |
} |
} |
441 |
} |
else if (SCM_BIGP (y)) |
|
} else if (SCM_BIGP (y)) { |
|
|
if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) |
|
|
&& (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) |
|
442 |
{ |
{ |
443 |
/* Special case: x == fixnum-min && y == abs (fixnum-min) */ |
if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) |
444 |
return SCM_MAKINUM (-1); |
&& (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) |
445 |
|
/* Special case: x == fixnum-min && y == abs (fixnum-min) */ |
446 |
|
return SCM_MAKINUM (-1); |
447 |
|
else |
448 |
|
return SCM_MAKINUM (0); |
449 |
} |
} |
450 |
else |
else |
451 |
return SCM_MAKINUM (0); |
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); |
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); |
|
452 |
} |
} |
453 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
454 |
if (SCM_INUMP (y)) { |
{ |
455 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
456 |
if (yy == 0) { |
{ |
457 |
scm_num_overflow (s_quotient); |
long yy = SCM_INUM (y); |
458 |
} else if (yy == 1) { |
if (yy == 0) |
459 |
return x; |
scm_num_overflow (s_quotient); |
460 |
} else { |
else if (yy == 1) |
461 |
SCM result = scm_i_mkbig (); |
return x; |
462 |
if (yy < 0) { |
else |
463 |
mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - yy); |
{ |
464 |
mpz_neg(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
SCM result = scm_i_mkbig (); |
465 |
} else { |
if (yy < 0) |
466 |
mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); |
{ |
467 |
} |
mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), |
468 |
scm_remember_upto_here_1 (x); |
SCM_I_BIG_MPZ (x), |
469 |
return scm_i_normbig (result); |
- yy); |
470 |
} |
mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
471 |
} else if (SCM_BIGP (y)) { |
} |
472 |
SCM result = scm_i_mkbig (); |
else |
473 |
mpz_tdiv_q(SCM_I_BIG_MPZ (result), |
mpz_tdiv_q_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); |
474 |
SCM_I_BIG_MPZ (x), |
scm_remember_upto_here_1 (x); |
475 |
SCM_I_BIG_MPZ (y)); |
return scm_i_normbig (result); |
476 |
scm_remember_upto_here_2 (x, y); |
} |
477 |
return scm_i_normbig (result); |
} |
478 |
} else { |
else if (SCM_BIGP (y)) |
479 |
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); |
{ |
480 |
|
SCM result = scm_i_mkbig (); |
481 |
|
mpz_tdiv_q (SCM_I_BIG_MPZ (result), |
482 |
|
SCM_I_BIG_MPZ (x), |
483 |
|
SCM_I_BIG_MPZ (y)); |
484 |
|
scm_remember_upto_here_2 (x, y); |
485 |
|
return scm_i_normbig (result); |
486 |
|
} |
487 |
|
else |
488 |
|
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG2, s_quotient); |
489 |
} |
} |
490 |
} else { |
else |
491 |
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient); |
SCM_WTA_DISPATCH_2 (g_quotient, x, y, SCM_ARG1, s_quotient); |
|
} |
|
492 |
} |
} |
493 |
|
|
494 |
SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); |
SCM_GPROC (s_remainder, "remainder", 2, 0, 0, scm_remainder, g_remainder); |
501 |
SCM |
SCM |
502 |
scm_remainder (SCM x, SCM y) |
scm_remainder (SCM x, SCM y) |
503 |
{ |
{ |
504 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
505 |
if (SCM_INUMP (y)) { |
{ |
506 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
507 |
if (yy == 0) { |
{ |
508 |
scm_num_overflow (s_remainder); |
long yy = SCM_INUM (y); |
509 |
} else { |
if (yy == 0) |
510 |
long z = SCM_INUM (x) % yy; |
scm_num_overflow (s_remainder); |
511 |
return SCM_MAKINUM (z); |
else |
512 |
} |
{ |
513 |
} else if (SCM_BIGP (y)) { |
long z = SCM_INUM (x) % yy; |
514 |
if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) |
return SCM_MAKINUM (z); |
515 |
&& (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) |
} |
516 |
|
} |
517 |
|
else if (SCM_BIGP (y)) |
518 |
{ |
{ |
519 |
/* Special case: x == fixnum-min && y == abs (fixnum-min) */ |
if ((SCM_INUM (x) == SCM_MOST_NEGATIVE_FIXNUM) |
520 |
return SCM_MAKINUM (0); |
&& (scm_i_bigcmp (abs_most_negative_fixnum, y) == 0)) |
521 |
|
/* Special case: x == fixnum-min && y == abs (fixnum-min) */ |
522 |
|
return SCM_MAKINUM (0); |
523 |
|
else |
524 |
|
return x; |
525 |
} |
} |
526 |
else |
else |
527 |
return x; |
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); |
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); |
|
528 |
} |
} |
529 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
530 |
if (SCM_INUMP (y)) { |
{ |
531 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
532 |
if (yy == 0) { |
{ |
533 |
scm_num_overflow (s_remainder); |
long yy = SCM_INUM (y); |
534 |
} else { |
if (yy == 0) |
535 |
SCM result = scm_i_mkbig (); |
scm_num_overflow (s_remainder); |
536 |
if (yy < 0) yy = - yy; |
else |
537 |
mpz_tdiv_r_ui(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy); |
{ |
538 |
scm_remember_upto_here_1(x); |
SCM result = scm_i_mkbig (); |
539 |
return scm_i_normbig (result); |
if (yy < 0) |
540 |
} |
yy = - yy; |
541 |
} else if (SCM_BIGP (y)) { |
mpz_tdiv_r_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ(x), yy); |
542 |
SCM result = scm_i_mkbig (); |
scm_remember_upto_here_1 (x); |
543 |
mpz_tdiv_r (SCM_I_BIG_MPZ (result), |
return scm_i_normbig (result); |
544 |
SCM_I_BIG_MPZ (x), |
} |
545 |
SCM_I_BIG_MPZ (y)); |
} |
546 |
scm_remember_upto_here_2(x, y); |
else if (SCM_BIGP (y)) |
547 |
return scm_i_normbig (result); |
{ |
548 |
} else { |
SCM result = scm_i_mkbig (); |
549 |
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); |
mpz_tdiv_r (SCM_I_BIG_MPZ (result), |
550 |
|
SCM_I_BIG_MPZ (x), |
551 |
|
SCM_I_BIG_MPZ (y)); |
552 |
|
scm_remember_upto_here_2 (x, y); |
553 |
|
return scm_i_normbig (result); |
554 |
|
} |
555 |
|
else |
556 |
|
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG2, s_remainder); |
557 |
} |
} |
558 |
} else { |
else |
559 |
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder); |
SCM_WTA_DISPATCH_2 (g_remainder, x, y, SCM_ARG1, s_remainder); |
|
} |
|
560 |
} |
} |
561 |
|
|
562 |
|
|
570 |
SCM |
SCM |
571 |
scm_modulo (SCM x, SCM y) |
scm_modulo (SCM x, SCM y) |
572 |
{ |
{ |
573 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
574 |
long xx = SCM_INUM (x); |
{ |
575 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
576 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
577 |
if (yy == 0) { |
{ |
578 |
scm_num_overflow (s_modulo); |
long yy = SCM_INUM (y); |
579 |
} else { |
if (yy == 0) |
580 |
/* FIXME: I think this may be a bug on some arches -- results |
scm_num_overflow (s_modulo); |
581 |
of % with negative second arg are undefined... */ |
else |
582 |
long z = xx % yy; |
{ |
583 |
long result; |
/* FIXME: I think this may be a bug on some arches -- results |
584 |
|
of % with negative second arg are undefined... */ |
585 |
if (yy < 0) { |
long z = xx % yy; |
586 |
if (z > 0) result = z + yy; |
long result; |
|
else result = z; |
|
|
} else { |
|
|
if (z < 0) result = z + yy; |
|
|
else result = z; |
|
|
} |
|
|
return SCM_MAKINUM (result); |
|
|
} |
|
|
} else if (SCM_BIGP (y)) { |
|
|
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
|
587 |
|
|
588 |
if (sgn_y == 0) { |
if (yy < 0) |
589 |
scm_num_overflow (s_modulo); |
{ |
590 |
} else { |
if (z > 0) |
591 |
mpz_t z_x; |
result = z + yy; |
592 |
SCM result; |
else |
593 |
|
result = z; |
594 |
if (sgn_y < 0) { |
} |
595 |
SCM pos_y = scm_i_clonebig (y, 0); |
else |
596 |
/* do this after the last scm_op */ |
{ |
597 |
mpz_init_set_si (z_x, xx); |
if (z < 0) |
598 |
result = pos_y; /* re-use this bignum */ |
result = z + yy; |
599 |
mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (pos_y)); |
else |
600 |
scm_remember_upto_here_1 (pos_y); |
result = z; |
601 |
} else { |
} |
602 |
result = scm_i_mkbig (); |
return SCM_MAKINUM (result); |
603 |
/* do this after the last scm_op */ |
} |
604 |
mpz_init_set_si (z_x, xx); |
} |
605 |
mpz_mod (SCM_I_BIG_MPZ (result), z_x, SCM_I_BIG_MPZ (y)); |
else if (SCM_BIGP (y)) |
606 |
scm_remember_upto_here_1 (y); |
{ |
607 |
} |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
608 |
|
|
609 |
|
if (sgn_y == 0) |
610 |
|
scm_num_overflow (s_modulo); |
611 |
|
else |
612 |
|
{ |
613 |
|
mpz_t z_x; |
614 |
|
SCM result; |
615 |
|
|
616 |
|
if (sgn_y < 0) |
617 |
|
{ |
618 |
|
SCM pos_y = scm_i_clonebig (y, 0); |
619 |
|
/* do this after the last scm_op */ |
620 |
|
mpz_init_set_si (z_x, xx); |
621 |
|
result = pos_y; /* re-use this bignum */ |
622 |
|
mpz_mod (SCM_I_BIG_MPZ (result), |
623 |
|
z_x, |
624 |
|
SCM_I_BIG_MPZ (pos_y)); |
625 |
|
scm_remember_upto_here_1 (pos_y); |
626 |
|
} |
627 |
|
else |
628 |
|
{ |
629 |
|
result = scm_i_mkbig (); |
630 |
|
/* do this after the last scm_op */ |
631 |
|
mpz_init_set_si (z_x, xx); |
632 |
|
mpz_mod (SCM_I_BIG_MPZ (result), |
633 |
|
z_x, |
634 |
|
SCM_I_BIG_MPZ (y)); |
635 |
|
scm_remember_upto_here_1 (y); |
636 |
|
} |
637 |
|
|
638 |
if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0) { |
if ((sgn_y < 0) && mpz_sgn (SCM_I_BIG_MPZ (result)) != 0) |
639 |
mpz_add (SCM_I_BIG_MPZ (result), |
mpz_add (SCM_I_BIG_MPZ (result), |
640 |
SCM_I_BIG_MPZ (y), |
SCM_I_BIG_MPZ (y), |
641 |
SCM_I_BIG_MPZ (result)); |
SCM_I_BIG_MPZ (result)); |
642 |
} |
scm_remember_upto_here_1 (y); |
643 |
scm_remember_upto_here_1 (y); |
/* and do this before the next one */ |
644 |
/* and do this before the next one */ |
mpz_clear (z_x); |
645 |
mpz_clear (z_x); |
return scm_i_normbig (result); |
646 |
return scm_i_normbig (result); |
} |
647 |
} |
} |
648 |
} else { |
else |
649 |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); |
650 |
} |
} |
651 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
652 |
if (SCM_INUMP (y)) { |
{ |
653 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
654 |
if (yy == 0) { |
{ |
655 |
scm_num_overflow (s_modulo); |
long yy = SCM_INUM (y); |
656 |
} else { |
if (yy == 0) |
657 |
SCM result = scm_i_mkbig (); |
scm_num_overflow (s_modulo); |
658 |
mpz_mod_ui (SCM_I_BIG_MPZ (result), |
else |
659 |
SCM_I_BIG_MPZ (x), |
{ |
660 |
(yy < 0) ? - yy : yy); |
SCM result = scm_i_mkbig (); |
661 |
scm_remember_upto_here_1 (x); |
mpz_mod_ui (SCM_I_BIG_MPZ (result), |
662 |
if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) { |
SCM_I_BIG_MPZ (x), |
663 |
mpz_sub_ui (SCM_I_BIG_MPZ (result), |
(yy < 0) ? - yy : yy); |
664 |
SCM_I_BIG_MPZ (result), |
scm_remember_upto_here_1 (x); |
665 |
- yy); |
if ((yy < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) |
666 |
} |
mpz_sub_ui (SCM_I_BIG_MPZ (result), |
667 |
return scm_i_normbig (result); |
SCM_I_BIG_MPZ (result), |
668 |
} |
- yy); |
669 |
} else if (SCM_BIGP (y)) { |
return scm_i_normbig (result); |
670 |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
} |
671 |
if (sgn_y == 0) { |
} |
672 |
scm_num_overflow (s_modulo); |
else if (SCM_BIGP (y)) |
673 |
} else { |
{ |
674 |
SCM result = scm_i_mkbig (); |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
675 |
int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
if (sgn_y == 0) |
676 |
SCM pos_y = scm_i_clonebig (y, y_sgn >= 0); |
scm_num_overflow (s_modulo); |
677 |
mpz_mod (SCM_I_BIG_MPZ (result), |
else |
678 |
SCM_I_BIG_MPZ (x), |
{ |
679 |
SCM_I_BIG_MPZ (pos_y)); |
SCM result = scm_i_mkbig (); |
680 |
|
int y_sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
681 |
|
SCM pos_y = scm_i_clonebig (y, y_sgn >= 0); |
682 |
|
mpz_mod (SCM_I_BIG_MPZ (result), |
683 |
|
SCM_I_BIG_MPZ (x), |
684 |
|
SCM_I_BIG_MPZ (pos_y)); |
685 |
|
|
686 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
687 |
if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) { |
if ((y_sgn < 0) && (mpz_sgn (SCM_I_BIG_MPZ (result)) != 0)) |
688 |
mpz_add (SCM_I_BIG_MPZ (result), |
mpz_add (SCM_I_BIG_MPZ (result), |
689 |
SCM_I_BIG_MPZ (y), |
SCM_I_BIG_MPZ (y), |
690 |
SCM_I_BIG_MPZ (result)); |
SCM_I_BIG_MPZ (result)); |
691 |
} |
scm_remember_upto_here_2 (y, pos_y); |
692 |
scm_remember_upto_here_2 (y, pos_y); |
return scm_i_normbig (result); |
693 |
return scm_i_normbig (result); |
} |
694 |
} |
} |
695 |
} else { |
else |
696 |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG2, s_modulo); |
697 |
} |
} |
698 |
} else { |
else |
699 |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); |
SCM_WTA_DISPATCH_2 (g_modulo, x, y, SCM_ARG1, s_modulo); |
|
} |
|
700 |
} |
} |
701 |
|
|
702 |
SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); |
SCM_GPROC1 (s_gcd, "gcd", scm_tc7_asubr, scm_gcd, g_gcd); |
707 |
scm_gcd (SCM x, SCM y) |
scm_gcd (SCM x, SCM y) |
708 |
{ |
{ |
709 |
if (SCM_UNBNDP (y)) |
if (SCM_UNBNDP (y)) |
710 |
return (SCM_UNBNDP (x)) ? SCM_INUM0 : x; |
return SCM_UNBNDP (x) ? SCM_INUM0 : x; |
711 |
|
|
712 |
if (SCM_INUMP (x)) |
if (SCM_INUMP (x)) |
713 |
{ |
{ |
718 |
long u = xx < 0 ? -xx : xx; |
long u = xx < 0 ? -xx : xx; |
719 |
long v = yy < 0 ? -yy : yy; |
long v = yy < 0 ? -yy : yy; |
720 |
long result; |
long result; |
721 |
if (xx == 0) { |
if (xx == 0) |
722 |
result = v; |
result = v; |
723 |
} else if (yy == 0) { |
else if (yy == 0) |
724 |
result = u; |
result = u; |
725 |
} else { |
else |
726 |
long k = 1; |
{ |
727 |
long t; |
long k = 1; |
728 |
/* Determine a common factor 2^k */ |
long t; |
729 |
while (!(1 & (u | v))) |
/* Determine a common factor 2^k */ |
730 |
{ |
while (!(1 & (u | v))) |
731 |
k <<= 1; |
{ |
732 |
u >>= 1; |
k <<= 1; |
733 |
v >>= 1; |
u >>= 1; |
734 |
} |
v >>= 1; |
735 |
/* Now, any factor 2^n can be eliminated */ |
} |
736 |
if (u & 1) |
/* Now, any factor 2^n can be eliminated */ |
737 |
t = -v; |
if (u & 1) |
738 |
else |
t = -v; |
739 |
{ |
else |
740 |
t = u; |
{ |
741 |
b3: |
t = u; |
742 |
t = SCM_SRS (t, 1); |
b3: |
743 |
} |
t = SCM_SRS (t, 1); |
744 |
if (!(1 & t)) |
} |
745 |
goto b3; |
if (!(1 & t)) |
746 |
if (t > 0) |
goto b3; |
747 |
u = t; |
if (t > 0) |
748 |
else |
u = t; |
749 |
v = -t; |
else |
750 |
t = u - v; |
v = -t; |
751 |
if (t != 0) |
t = u - v; |
752 |
goto b3; |
if (t != 0) |
753 |
result = u * k; |
goto b3; |
754 |
} |
result = u * k; |
755 |
return SCM_POSFIXABLE (result) \ |
} |
756 |
? SCM_MAKINUM (result) : scm_i_long2big (result); |
return (SCM_POSFIXABLE (result) |
757 |
|
? SCM_MAKINUM (result) |
758 |
|
: scm_i_long2big (result)); |
759 |
} |
} |
760 |
else if (SCM_BIGP (y)) |
else if (SCM_BIGP (y)) |
761 |
{ |
{ |
762 |
SCM result = scm_i_mkbig (); |
SCM result = scm_i_mkbig (); |
763 |
SCM mx = scm_i_mkbig (); |
SCM mx = scm_i_mkbig (); |
764 |
mpz_set_si(SCM_I_BIG_MPZ (mx), SCM_INUM (x)); |
mpz_set_si (SCM_I_BIG_MPZ (mx), SCM_INUM (x)); |
765 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
766 |
mpz_gcd(SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (mx), SCM_I_BIG_MPZ (y)); |
mpz_gcd (SCM_I_BIG_MPZ (result), |
767 |
scm_remember_upto_here_2(mx, y); |
SCM_I_BIG_MPZ (mx), |
768 |
|
SCM_I_BIG_MPZ (y)); |
769 |
|
scm_remember_upto_here_2 (mx, y); |
770 |
return scm_i_normbig (result); |
return scm_i_normbig (result); |
771 |
} |
} |
772 |
else |
else |
780 |
long yy = SCM_INUM (y); |
long yy = SCM_INUM (y); |
781 |
if (yy == 0) |
if (yy == 0) |
782 |
return scm_abs (x); |
return scm_abs (x); |
783 |
if (yy < 0) yy = -yy; |
if (yy < 0) |
784 |
|
yy = -yy; |
785 |
result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy); |
result = mpz_gcd_ui (NULL, SCM_I_BIG_MPZ (x), yy); |
786 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
787 |
return SCM_POSFIXABLE (result) \ |
return (SCM_POSFIXABLE (result) |
788 |
? SCM_MAKINUM (result) : scm_ulong2num (result); |
? SCM_MAKINUM (result) |
789 |
|
: scm_ulong2num (result)); |
790 |
} |
} |
791 |
else if (SCM_BIGP (y)) |
else if (SCM_BIGP (y)) |
792 |
{ |
{ |
793 |
SCM result = scm_i_mkbig (); |
SCM result = scm_i_mkbig (); |
794 |
mpz_gcd(SCM_I_BIG_MPZ (result), |
mpz_gcd (SCM_I_BIG_MPZ (result), |
795 |
SCM_I_BIG_MPZ (x), |
SCM_I_BIG_MPZ (x), |
796 |
SCM_I_BIG_MPZ (y)); |
SCM_I_BIG_MPZ (y)); |
797 |
scm_remember_upto_here_2(x, y); |
scm_remember_upto_here_2 (x, y); |
798 |
return scm_i_normbig (result); |
return scm_i_normbig (result); |
799 |
} |
} |
800 |
else |
else |
923 |
{ |
{ |
924 |
long int nn1; |
long int nn1; |
925 |
|
|
926 |
if (SCM_UNBNDP (n2)) { |
if (SCM_UNBNDP (n2)) |
927 |
if (SCM_UNBNDP (n1)) { |
{ |
928 |
return SCM_MAKINUM (-1); |
if (SCM_UNBNDP (n1)) |
929 |
} else if (!SCM_NUMBERP (n1)) { |
return SCM_MAKINUM (-1); |
930 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
else if (!SCM_NUMBERP (n1)) |
931 |
} else if (SCM_NUMBERP (n1)) { |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
932 |
return n1; |
else if (SCM_NUMBERP (n1)) |
933 |
} else { |
return n1; |
934 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
else |
935 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
936 |
} |
} |
|
} |
|
937 |
|
|
938 |
if (SCM_INUMP (n1)) { |
if (SCM_INUMP (n1)) |
939 |
nn1 = SCM_INUM (n1); |
{ |
|
if (SCM_INUMP (n2)) { |
|
|
long nn2 = SCM_INUM (n2); |
|
|
return SCM_MAKINUM (nn1 & nn2); |
|
|
} else if SCM_BIGP (n2) { |
|
|
intbig: |
|
|
if (n1 == 0) return SCM_INUM0; |
|
|
{ |
|
|
SCM result_z = scm_i_mkbig (); |
|
|
mpz_t nn1_z; |
|
|
mpz_init_set_si (nn1_z, nn1); |
|
|
mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
|
|
scm_remember_upto_here_1 (n2); |
|
|
mpz_clear (nn1_z); |
|
|
return scm_i_normbig (result_z); |
|
|
} |
|
|
} else { |
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
|
|
} |
|
|
} else if (SCM_BIGP (n1)) { |
|
|
if (SCM_INUMP (n2)) { |
|
|
SCM_SWAP (n1, n2); |
|
940 |
nn1 = SCM_INUM (n1); |
nn1 = SCM_INUM (n1); |
941 |
goto intbig; |
if (SCM_INUMP (n2)) |
942 |
} else if (SCM_BIGP (n2)) { |
{ |
943 |
SCM result_z = scm_i_mkbig (); |
long nn2 = SCM_INUM (n2); |
944 |
mpz_and (SCM_I_BIG_MPZ (result_z), |
return SCM_MAKINUM (nn1 & nn2); |
945 |
SCM_I_BIG_MPZ (n1), |
} |
946 |
SCM_I_BIG_MPZ (n2)); |
else if SCM_BIGP (n2) |
947 |
scm_remember_upto_here_2 (n1, n2); |
{ |
948 |
return scm_i_normbig (result_z); |
intbig: |
949 |
} else { |
if (n1 == 0) |
950 |
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
return SCM_INUM0; |
951 |
|
{ |
952 |
|
SCM result_z = scm_i_mkbig (); |
953 |
|
mpz_t nn1_z; |
954 |
|
mpz_init_set_si (nn1_z, nn1); |
955 |
|
mpz_and (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
956 |
|
scm_remember_upto_here_1 (n2); |
957 |
|
mpz_clear (nn1_z); |
958 |
|
return scm_i_normbig (result_z); |
959 |
|
} |
960 |
|
} |
961 |
|
else |
962 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
963 |
} |
} |
964 |
} else { |
else if (SCM_BIGP (n1)) |
965 |
|
{ |
966 |
|
if (SCM_INUMP (n2)) |
967 |
|
{ |
968 |
|
SCM_SWAP (n1, n2); |
969 |
|
nn1 = SCM_INUM (n1); |
970 |
|
goto intbig; |
971 |
|
} |
972 |
|
else if (SCM_BIGP (n2)) |
973 |
|
{ |
974 |
|
SCM result_z = scm_i_mkbig (); |
975 |
|
mpz_and (SCM_I_BIG_MPZ (result_z), |
976 |
|
SCM_I_BIG_MPZ (n1), |
977 |
|
SCM_I_BIG_MPZ (n2)); |
978 |
|
scm_remember_upto_here_2 (n1, n2); |
979 |
|
return scm_i_normbig (result_z); |
980 |
|
} |
981 |
|
else |
982 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
983 |
|
} |
984 |
|
else |
985 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
|
} |
|
986 |
} |
} |
987 |
#undef FUNC_NAME |
#undef FUNC_NAME |
988 |
|
|
999 |
{ |
{ |
1000 |
long int nn1; |
long int nn1; |
1001 |
|
|
1002 |
if (SCM_UNBNDP (n2)) { |
if (SCM_UNBNDP (n2)) |
1003 |
if (SCM_UNBNDP (n1)) { |
{ |
1004 |
return SCM_INUM0; |
if (SCM_UNBNDP (n1)) |
1005 |
} else if (SCM_NUMBERP (n1)) { |
return SCM_INUM0; |
1006 |
return n1; |
else if (SCM_NUMBERP (n1)) |
1007 |
} else { |
return n1; |
1008 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
else |
1009 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
1010 |
} |
} |
|
} |
|
1011 |
|
|
1012 |
if (SCM_INUMP (n1)) { |
if (SCM_INUMP (n1)) |
1013 |
nn1 = SCM_INUM (n1); |
{ |
|
if (SCM_INUMP (n2)) { |
|
|
long nn2 = SCM_INUM (n2); |
|
|
return SCM_MAKINUM (nn1 | nn2); |
|
|
} else if (SCM_BIGP (n2)) { |
|
|
intbig: |
|
|
if (nn1 == 0) return n2; |
|
|
{ |
|
|
SCM result_z = scm_i_mkbig (); |
|
|
mpz_t nn1_z; |
|
|
mpz_init_set_si (nn1_z, nn1); |
|
|
mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
|
|
scm_remember_upto_here_1 (n2); |
|
|
mpz_clear (nn1_z); |
|
|
return result_z; |
|
|
} |
|
|
} else { |
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
|
|
} |
|
|
} else if (SCM_BIGP (n1)) { |
|
|
if (SCM_INUMP (n2)) { |
|
|
SCM_SWAP (n1, n2); |
|
1014 |
nn1 = SCM_INUM (n1); |
nn1 = SCM_INUM (n1); |
1015 |
goto intbig; |
if (SCM_INUMP (n2)) |
1016 |
} else if (SCM_BIGP (n2)) { |
{ |
1017 |
SCM result_z = scm_i_mkbig (); |
long nn2 = SCM_INUM (n2); |
1018 |
mpz_ior (SCM_I_BIG_MPZ (result_z), |
return SCM_MAKINUM (nn1 | nn2); |
1019 |
SCM_I_BIG_MPZ (n1), |
} |
1020 |
SCM_I_BIG_MPZ (n2)); |
else if (SCM_BIGP (n2)) |
1021 |
scm_remember_upto_here_2 (n1, n2); |
{ |
1022 |
return result_z; |
intbig: |
1023 |
} else { |
if (nn1 == 0) |
1024 |
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
return n2; |
1025 |
|
{ |
1026 |
|
SCM result_z = scm_i_mkbig (); |
1027 |
|
mpz_t nn1_z; |
1028 |
|
mpz_init_set_si (nn1_z, nn1); |
1029 |
|
mpz_ior (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
1030 |
|
scm_remember_upto_here_1 (n2); |
1031 |
|
mpz_clear (nn1_z); |
1032 |
|
return result_z; |
1033 |
|
} |
1034 |
|
} |
1035 |
|
else |
1036 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
1037 |
} |
} |
1038 |
} else { |
else if (SCM_BIGP (n1)) |
1039 |
|
{ |
1040 |
|
if (SCM_INUMP (n2)) |
1041 |
|
{ |
1042 |
|
SCM_SWAP (n1, n2); |
1043 |
|
nn1 = SCM_INUM (n1); |
1044 |
|
goto intbig; |
1045 |
|
} |
1046 |
|
else if (SCM_BIGP (n2)) |
1047 |
|
{ |
1048 |
|
SCM result_z = scm_i_mkbig (); |
1049 |
|
mpz_ior (SCM_I_BIG_MPZ (result_z), |
1050 |
|
SCM_I_BIG_MPZ (n1), |
1051 |
|
SCM_I_BIG_MPZ (n2)); |
1052 |
|
scm_remember_upto_here_2 (n1, n2); |
1053 |
|
return result_z; |
1054 |
|
} |
1055 |
|
else |
1056 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
1057 |
|
} |
1058 |
|
else |
1059 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
|
} |
|
1060 |
} |
} |
1061 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1062 |
|
|
1075 |
{ |
{ |
1076 |
long int nn1; |
long int nn1; |
1077 |
|
|
1078 |
if (SCM_UNBNDP (n2)) { |
if (SCM_UNBNDP (n2)) |
1079 |
if (SCM_UNBNDP (n1)) { |
{ |
1080 |
return SCM_INUM0; |
if (SCM_UNBNDP (n1)) |
1081 |
} else if (SCM_NUMBERP (n1)) { |
return SCM_INUM0; |
1082 |
return n1; |
else if (SCM_NUMBERP (n1)) |
1083 |
} else { |
return n1; |
1084 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
else |
1085 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
1086 |
} |
} |
|
} |
|
1087 |
|
|
1088 |
if (SCM_INUMP (n1)) { |
if (SCM_INUMP (n1)) |
1089 |
nn1 = SCM_INUM (n1); |
{ |
|
if (SCM_INUMP (n2)) { |
|
|
long nn2 = SCM_INUM (n2); |
|
|
return SCM_MAKINUM (nn1 ^ nn2); |
|
|
} else if (SCM_BIGP (n2)) { |
|
|
intbig: |
|
|
{ |
|
|
SCM result_z = scm_i_mkbig (); |
|
|
mpz_t nn1_z; |
|
|
mpz_init_set_si (nn1_z, nn1); |
|
|
mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
|
|
scm_remember_upto_here_1 (n2); |
|
|
mpz_clear (nn1_z); |
|
|
return scm_i_normbig (result_z); |
|
|
} |
|
|
} else { |
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
|
|
} |
|
|
} else if (SCM_BIGP (n1)) { |
|
|
if (SCM_INUMP (n2)) { |
|
|
SCM_SWAP (n1, n2); |
|
1090 |
nn1 = SCM_INUM (n1); |
nn1 = SCM_INUM (n1); |
1091 |
goto intbig; |
if (SCM_INUMP (n2)) |
1092 |
} else if (SCM_BIGP (n2)) { |
{ |
1093 |
SCM result_z = scm_i_mkbig (); |
long nn2 = SCM_INUM (n2); |
1094 |
mpz_xor (SCM_I_BIG_MPZ (result_z), |
return SCM_MAKINUM (nn1 ^ nn2); |
1095 |
SCM_I_BIG_MPZ (n1), |
} |
1096 |
SCM_I_BIG_MPZ (n2)); |
else if (SCM_BIGP (n2)) |
1097 |
scm_remember_upto_here_2 (n1, n2); |
{ |
1098 |
return scm_i_normbig (result_z); |
intbig: |
1099 |
} else { |
{ |
1100 |
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
SCM result_z = scm_i_mkbig (); |
1101 |
|
mpz_t nn1_z; |
1102 |
|
mpz_init_set_si (nn1_z, nn1); |
1103 |
|
mpz_xor (SCM_I_BIG_MPZ (result_z), nn1_z, SCM_I_BIG_MPZ (n2)); |
1104 |
|
scm_remember_upto_here_1 (n2); |
1105 |
|
mpz_clear (nn1_z); |
1106 |
|
return scm_i_normbig (result_z); |
1107 |
|
} |
1108 |
|
} |
1109 |
|
else |
1110 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
1111 |
} |
} |
1112 |
} else { |
else if (SCM_BIGP (n1)) |
1113 |
|
{ |
1114 |
|
if (SCM_INUMP (n2)) |
1115 |
|
{ |
1116 |
|
SCM_SWAP (n1, n2); |
1117 |
|
nn1 = SCM_INUM (n1); |
1118 |
|
goto intbig; |
1119 |
|
} |
1120 |
|
else if (SCM_BIGP (n2)) |
1121 |
|
{ |
1122 |
|
SCM result_z = scm_i_mkbig (); |
1123 |
|
mpz_xor (SCM_I_BIG_MPZ (result_z), |
1124 |
|
SCM_I_BIG_MPZ (n1), |
1125 |
|
SCM_I_BIG_MPZ (n2)); |
1126 |
|
scm_remember_upto_here_2 (n1, n2); |
1127 |
|
return scm_i_normbig (result_z); |
1128 |
|
} |
1129 |
|
else |
1130 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, n2); |
1131 |
|
} |
1132 |
|
else |
1133 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n1); |
|
} |
|
1134 |
} |
} |
1135 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1136 |
|
|
1146 |
{ |
{ |
1147 |
long int nj; |
long int nj; |
1148 |
|
|
1149 |
if (SCM_INUMP (j)) { |
if (SCM_INUMP (j)) |
1150 |
nj = SCM_INUM (j); |
{ |
|
if (SCM_INUMP (k)) { |
|
|
long nk = SCM_INUM (k); |
|
|
return SCM_BOOL (nj & nk); |
|
|
} else if (SCM_BIGP (k)) { |
|
|
intbig: |
|
|
if (nj == 0) return SCM_BOOL_F; |
|
|
{ |
|
|
SCM result; |
|
|
mpz_t nj_z; |
|
|
mpz_init_set_si (nj_z, nj); |
|
|
mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k)); |
|
|
scm_remember_upto_here_1 (k); |
|
|
result = SCM_BOOL (mpz_sgn (nj_z) != 0); |
|
|
mpz_clear (nj_z); |
|
|
return result; |
|
|
} |
|
|
} else { |
|
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, k); |
|
|
} |
|
|
} else if (SCM_BIGP (j)) { |
|
|
if (SCM_INUMP (k)) { |
|
|
SCM_SWAP (j, k); |
|
1151 |
nj = SCM_INUM (j); |
nj = SCM_INUM (j); |
1152 |
goto intbig; |
if (SCM_INUMP (k)) |
1153 |
} else if (SCM_BIGP (k)) { |
{ |
1154 |
SCM result; |
long nk = SCM_INUM (k); |
1155 |
mpz_t result_z; |
return SCM_BOOL (nj & nk); |
1156 |
mpz_init (result_z); |
} |
1157 |
mpz_and (result_z, |
else if (SCM_BIGP (k)) |
1158 |
SCM_I_BIG_MPZ (j), |
{ |
1159 |
SCM_I_BIG_MPZ (k)); |
intbig: |
1160 |
scm_remember_upto_here_2 (j, k); |
if (nj == 0) |
1161 |
result = SCM_BOOL (mpz_sgn (result_z) != 0); |
return SCM_BOOL_F; |
1162 |
mpz_clear (result_z); |
{ |
1163 |
return result; |
SCM result; |
1164 |
} else { |
mpz_t nj_z; |
1165 |
SCM_WRONG_TYPE_ARG (SCM_ARG2, k); |
mpz_init_set_si (nj_z, nj); |
1166 |
|
mpz_and (nj_z, nj_z, SCM_I_BIG_MPZ (k)); |
1167 |
|
scm_remember_upto_here_1 (k); |
1168 |
|
result = SCM_BOOL (mpz_sgn (nj_z) != 0); |
1169 |
|
mpz_clear (nj_z); |
1170 |
|
return result; |
1171 |
|
} |
1172 |
|
} |
1173 |
|
else |
1174 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, k); |
1175 |
|
} |
1176 |
|
else if (SCM_BIGP (j)) |
1177 |
|
{ |
1178 |
|
if (SCM_INUMP (k)) |
1179 |
|
{ |
1180 |
|
SCM_SWAP (j, k); |
1181 |
|
nj = SCM_INUM (j); |
1182 |
|
goto intbig; |
1183 |
|
} |
1184 |
|
else if (SCM_BIGP (k)) |
1185 |
|
{ |
1186 |
|
SCM result; |
1187 |
|
mpz_t result_z; |
1188 |
|
mpz_init (result_z); |
1189 |
|
mpz_and (result_z, |
1190 |
|
SCM_I_BIG_MPZ (j), |
1191 |
|
SCM_I_BIG_MPZ (k)); |
1192 |
|
scm_remember_upto_here_2 (j, k); |
1193 |
|
result = SCM_BOOL (mpz_sgn (result_z) != 0); |
1194 |
|
mpz_clear (result_z); |
1195 |
|
return result; |
1196 |
|
} |
1197 |
|
else |
1198 |
|
SCM_WRONG_TYPE_ARG (SCM_ARG2, k); |
1199 |
} |
} |
1200 |
} else { |
else |
1201 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, j); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, j); |
|
} |
|
1202 |
} |
} |
1203 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1204 |
|
|
1220 |
SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0); |
SCM_VALIDATE_INUM_MIN (SCM_ARG1, index, 0); |
1221 |
iindex = (unsigned long int) SCM_INUM (index); |
iindex = (unsigned long int) SCM_INUM (index); |
1222 |
|
|
1223 |
if (SCM_INUMP (j)) { |
if (SCM_INUMP (j)) |
1224 |
return SCM_BOOL ((1L << iindex) & SCM_INUM (j)); |
return SCM_BOOL ((1L << iindex) & SCM_INUM (j)); |
1225 |
} else if (SCM_BIGP (j)) { |
else if (SCM_BIGP (j)) |
1226 |
int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex); |
{ |
1227 |
scm_remember_upto_here_1 (j); |
int val = mpz_tstbit (SCM_I_BIG_MPZ (j), iindex); |
1228 |
return SCM_BOOL (val); |
scm_remember_upto_here_1 (j); |
1229 |
} else { |
return SCM_BOOL (val); |
1230 |
|
} |
1231 |
|
else |
1232 |
SCM_WRONG_TYPE_ARG (SCM_ARG2, j); |
SCM_WRONG_TYPE_ARG (SCM_ARG2, j); |
|
} |
|
1233 |
} |
} |
1234 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1235 |
|
|
1415 |
SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); |
SCM_VALIDATE_INUM_MIN_COPY (3, end, 0, iend); |
1416 |
SCM_ASSERT_RANGE (3, end, (iend >= istart)); |
SCM_ASSERT_RANGE (3, end, (iend >= istart)); |
1417 |
|
|
1418 |
if (SCM_INUMP (n)) { |
if (SCM_INUMP (n)) |
1419 |
long int in = SCM_INUM (n); |
{ |
1420 |
unsigned long int bits = iend - istart; |
long int in = SCM_INUM (n); |
1421 |
|
unsigned long int bits = iend - istart; |
1422 |
|
|
1423 |
if (in < 0 && bits >= SCM_I_FIXNUM_BIT) |
if (in < 0 && bits >= SCM_I_FIXNUM_BIT) |
1424 |
{ |
{ |
1425 |
/* Since we emulate two's complement encoded numbers, this special |
/* Since we emulate two's complement encoded numbers, this |
1426 |
* case requires us to produce a result that has more bits than can be |
* special case requires us to produce a result that has |
1427 |
* stored in a fixnum. Thus, we fall back to the more general |
* more bits than can be stored in a fixnum. Thus, we fall |
1428 |
* algorithm that is used for bignums. |
* back to the more general algorithm that is used for |
1429 |
*/ |
* bignums. |
1430 |
goto generalcase; |
*/ |
1431 |
} |
goto generalcase; |
1432 |
|
} |
1433 |
|
|
1434 |
if (istart < SCM_I_FIXNUM_BIT) |
if (istart < SCM_I_FIXNUM_BIT) |
1435 |
{ |
{ |
1436 |
in = in >> istart; |
in = in >> istart; |
1437 |
if (bits < SCM_I_FIXNUM_BIT) |
if (bits < SCM_I_FIXNUM_BIT) |
1438 |
return SCM_MAKINUM (in & ((1L << bits) - 1)); |
return SCM_MAKINUM (in & ((1L << bits) - 1)); |
1439 |
else /* we know: in >= 0 */ |
else /* we know: in >= 0 */ |
1440 |
return SCM_MAKINUM (in); |
return SCM_MAKINUM (in); |
1441 |
} |
} |
1442 |
else if (in < 0) |
else if (in < 0) |
|
{ |
|
1443 |
return SCM_MAKINUM (-1L & ((1L << bits) - 1)); |
return SCM_MAKINUM (-1L & ((1L << bits) - 1)); |
1444 |
} |
else |
|
else |
|
|
{ |
|
1445 |
return SCM_MAKINUM (0); |
return SCM_MAKINUM (0); |
1446 |
} |
} |
1447 |
} else if (SCM_BIGP (n)) { |
else if (SCM_BIGP (n)) |
|
generalcase: |
|
1448 |
{ |
{ |
1449 |
SCM num1 = SCM_MAKINUM (1L); |
generalcase: |
1450 |
SCM num2 = SCM_MAKINUM (2L); |
{ |
1451 |
SCM bits = SCM_MAKINUM (iend - istart); |
SCM num1 = SCM_MAKINUM (1L); |
1452 |
SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); |
SCM num2 = SCM_MAKINUM (2L); |
1453 |
return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); |
SCM bits = SCM_MAKINUM (iend - istart); |
1454 |
|
SCM mask = scm_difference (scm_integer_expt (num2, bits), num1); |
1455 |
|
return scm_logand (mask, scm_ash (n, SCM_MAKINUM (-istart))); |
1456 |
|
} |
1457 |
} |
} |
1458 |
} else { |
else |
1459 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n); |
|
} |
|
1460 |
} |
} |
1461 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1462 |
|
|
1529 |
"@end lisp") |
"@end lisp") |
1530 |
#define FUNC_NAME s_scm_integer_length |
#define FUNC_NAME s_scm_integer_length |
1531 |
{ |
{ |
1532 |
if (SCM_INUMP (n)) { |
if (SCM_INUMP (n)) |
1533 |
unsigned long int c = 0; |
{ |
1534 |
unsigned int l = 4; |
unsigned long int c = 0; |
1535 |
long int nn = SCM_INUM (n); |
unsigned int l = 4; |
1536 |
if (nn < 0) { |
long int nn = SCM_INUM (n); |
1537 |
nn = -1 - nn; |
if (nn < 0) |
1538 |
}; |
nn = -1 - nn; |
1539 |
while (nn) { |
while (nn) |
1540 |
c += 4; |
{ |
1541 |
l = scm_ilentab [15 & nn]; |
c += 4; |
1542 |
nn >>= 4; |
l = scm_ilentab [15 & nn]; |
1543 |
}; |
nn >>= 4; |
1544 |
return SCM_MAKINUM (c - 4 + l); |
} |
1545 |
} else if (SCM_BIGP (n)) { |
return SCM_MAKINUM (c - 4 + l); |
1546 |
/* mpz_sizeinbase looks at the absolute value of negatives, whereas we |
} |
1547 |
want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is |
else if (SCM_BIGP (n)) |
1548 |
1 too big, so check for that and adjust. */ |
{ |
1549 |
size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2); |
/* mpz_sizeinbase looks at the absolute value of negatives, whereas we |
1550 |
if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0 |
want a ones-complement. If n is ...111100..00 then mpz_sizeinbase is |
1551 |
&& mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */ |
1 too big, so check for that and adjust. */ |
1552 |
mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX) |
size_t size = mpz_sizeinbase (SCM_I_BIG_MPZ (n), 2); |
1553 |
size--; |
if (mpz_sgn (SCM_I_BIG_MPZ (n)) < 0 |
1554 |
scm_remember_upto_here_1 (n); |
&& mpz_scan0 (SCM_I_BIG_MPZ (n), /* no 0 bits above the lowest 1 */ |
1555 |
return SCM_MAKINUM (size); |
mpz_scan1 (SCM_I_BIG_MPZ (n), 0)) == ULONG_MAX) |
1556 |
} else { |
size--; |
1557 |
|
scm_remember_upto_here_1 (n); |
1558 |
|
return SCM_MAKINUM (size); |
1559 |
|
} |
1560 |
|
else |
1561 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, n); |
|
} |
|
1562 |
} |
} |
1563 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1564 |
|
|
1798 |
{ |
{ |
1799 |
int base; |
int base; |
1800 |
|
|
1801 |
if (SCM_UNBNDP (radix)) { |
if (SCM_UNBNDP (radix)) |
1802 |
base = 10; |
base = 10; |
1803 |
} else { |
else |
1804 |
SCM_VALIDATE_INUM (2, radix); |
{ |
1805 |
base = SCM_INUM (radix); |
SCM_VALIDATE_INUM (2, radix); |
1806 |
/* FIXME: ask if range limit was OK, and if so, document */ |
base = SCM_INUM (radix); |
1807 |
SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36)); |
/* FIXME: ask if range limit was OK, and if so, document */ |
1808 |
} |
SCM_ASSERT_RANGE (2, radix, (base >= 2) && (base <= 36)); |
1809 |
|
} |
1810 |
|
|
1811 |
if (SCM_INUMP (n)) { |
if (SCM_INUMP (n)) |
1812 |
char num_buf [SCM_INTBUFLEN]; |
{ |
1813 |
size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); |
char num_buf [SCM_INTBUFLEN]; |
1814 |
return scm_mem2string (num_buf, length); |
size_t length = scm_iint2str (SCM_INUM (n), base, num_buf); |
1815 |
} else if (SCM_BIGP (n)) { |
return scm_mem2string (num_buf, length); |
1816 |
char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n)); |
} |
1817 |
scm_remember_upto_here_1 (n); |
else if (SCM_BIGP (n)) |
1818 |
return scm_take0str (str); |
{ |
1819 |
} else if (SCM_INEXACTP (n)) { |
char *str = mpz_get_str (NULL, base, SCM_I_BIG_MPZ (n)); |
1820 |
char num_buf [FLOBUFLEN]; |
scm_remember_upto_here_1 (n); |
1821 |
return scm_mem2string (num_buf, iflo2str (n, num_buf)); |
return scm_take0str (str); |
1822 |
} else { |
} |
1823 |
|
else if (SCM_INEXACTP (n)) |
1824 |
|
{ |
1825 |
|
char num_buf [FLOBUFLEN]; |
1826 |
|
return scm_mem2string (num_buf, iflo2str (n, num_buf)); |
1827 |
|
} |
1828 |
|
else |
1829 |
SCM_WRONG_TYPE_ARG (1, n); |
SCM_WRONG_TYPE_ARG (1, n); |
|
} |
|
1830 |
} |
} |
1831 |
#undef FUNC_NAME |
#undef FUNC_NAME |
1832 |
|
|
2490 |
SCM |
SCM |
2491 |
scm_make_complex (double x, double y) |
scm_make_complex (double x, double y) |
2492 |
{ |
{ |
2493 |
if (y == 0.0) { |
if (y == 0.0) |
2494 |
return scm_make_real (x); |
return scm_make_real (x); |
2495 |
} else { |
else |
2496 |
SCM z; |
{ |
2497 |
SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), |
SCM z; |
2498 |
"complex")); |
SCM_NEWSMOB (z, scm_tc16_complex, scm_gc_malloc (2*sizeof (double), |
2499 |
SCM_COMPLEX_REAL (z) = x; |
"complex")); |
2500 |
SCM_COMPLEX_IMAG (z) = y; |
SCM_COMPLEX_REAL (z) = x; |
2501 |
return z; |
SCM_COMPLEX_IMAG (z) = y; |
2502 |
} |
return z; |
2503 |
|
} |
2504 |
} |
} |
2505 |
|
|
2506 |
|
|
2563 |
"precision.") |
"precision.") |
2564 |
#define FUNC_NAME s_scm_real_p |
#define FUNC_NAME s_scm_real_p |
2565 |
{ |
{ |
2566 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2567 |
return SCM_BOOL_T; |
return SCM_BOOL_T; |
2568 |
} else if (SCM_IMP (x)) { |
else if (SCM_IMP (x)) |
2569 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
2570 |
} else if (SCM_REALP (x)) { |
else if (SCM_REALP (x)) |
2571 |
return SCM_BOOL_T; |
return SCM_BOOL_T; |
2572 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
2573 |
return SCM_BOOL_T; |
return SCM_BOOL_T; |
2574 |
} else { |
else |
2575 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
|
} |
|
2576 |
} |
} |
2577 |
#undef FUNC_NAME |
#undef FUNC_NAME |
2578 |
|
|
2618 |
SCM |
SCM |
2619 |
scm_num_eq_p (SCM x, SCM y) |
scm_num_eq_p (SCM x, SCM y) |
2620 |
{ |
{ |
2621 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2622 |
long xx = SCM_INUM (x); |
{ |
2623 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
2624 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
2625 |
return SCM_BOOL (xx == yy); |
{ |
2626 |
} else if (SCM_BIGP (y)) { |
long yy = SCM_INUM (y); |
2627 |
return SCM_BOOL_F; |
return SCM_BOOL (xx == yy); |
2628 |
} else if (SCM_REALP (y)) { |
} |
2629 |
return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y)); |
else if (SCM_BIGP (y)) |
2630 |
} else if (SCM_COMPLEXP (y)) { |
return SCM_BOOL_F; |
2631 |
return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y)) |
else if (SCM_REALP (y)) |
2632 |
&& (0.0 == SCM_COMPLEX_IMAG (y))); |
return SCM_BOOL ((double) xx == SCM_REAL_VALUE (y)); |
2633 |
} else { |
else if (SCM_COMPLEXP (y)) |
2634 |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
return SCM_BOOL (((double) xx == SCM_COMPLEX_REAL (y)) |
2635 |
} |
&& (0.0 == SCM_COMPLEX_IMAG (y))); |
2636 |
} else if (SCM_BIGP (x)) { |
else |
2637 |
if (SCM_INUMP (y)) { |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
2638 |
return SCM_BOOL_F; |
} |
2639 |
} else if (SCM_BIGP (y)) { |
else if (SCM_BIGP (x)) |
2640 |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
{ |
2641 |
scm_remember_upto_here_2 (x, y); |
if (SCM_INUMP (y)) |
2642 |
return SCM_BOOL (0 == cmp); |
return SCM_BOOL_F; |
2643 |
} else if (SCM_REALP (y)) { |
else if (SCM_BIGP (y)) |
2644 |
int cmp; |
{ |
2645 |
if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F; |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
2646 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); |
scm_remember_upto_here_2 (x, y); |
2647 |
scm_remember_upto_here_1 (x); |
return SCM_BOOL (0 == cmp); |
2648 |
return SCM_BOOL (0 == cmp); |
} |
2649 |
} else if (SCM_COMPLEXP (y)) { |
else if (SCM_REALP (y)) |
2650 |
int cmp; |
{ |
2651 |
if (0.0 != SCM_COMPLEX_IMAG (y)) return SCM_BOOL_F; |
int cmp; |
2652 |
if (xisnan (SCM_COMPLEX_REAL (y))) return SCM_BOOL_F; |
if (xisnan (SCM_REAL_VALUE (y))) |
2653 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y)); |
return SCM_BOOL_F; |
2654 |
scm_remember_upto_here_1 (x); |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); |
2655 |
return SCM_BOOL (0 == cmp); |
scm_remember_upto_here_1 (x); |
2656 |
} else { |
return SCM_BOOL (0 == cmp); |
2657 |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
} |
2658 |
} |
else if (SCM_COMPLEXP (y)) |
2659 |
} else if (SCM_REALP (x)) { |
{ |
2660 |
if (SCM_INUMP (y)) { |
int cmp; |
2661 |
return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); |
if (0.0 != SCM_COMPLEX_IMAG (y)) |
2662 |
} else if (SCM_BIGP (y)) { |
return SCM_BOOL_F; |
2663 |
int cmp; |
if (xisnan (SCM_COMPLEX_REAL (y))) |
2664 |
if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F; |
return SCM_BOOL_F; |
2665 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_COMPLEX_REAL (y)); |
2666 |
scm_remember_upto_here_1 (y); |
scm_remember_upto_here_1 (x); |
2667 |
return SCM_BOOL (0 == cmp); |
return SCM_BOOL (0 == cmp); |
2668 |
} else if (SCM_REALP (y)) { |
} |
2669 |
return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); |
else |
2670 |
} else if (SCM_COMPLEXP (y)) { |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
2671 |
return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) |
} |
2672 |
&& (0.0 == SCM_COMPLEX_IMAG (y))); |
else if (SCM_REALP (x)) |
2673 |
} else { |
{ |
2674 |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
if (SCM_INUMP (y)) |
2675 |
} |
return SCM_BOOL (SCM_REAL_VALUE (x) == (double) SCM_INUM (y)); |
2676 |
} else if (SCM_COMPLEXP (x)) { |
else if (SCM_BIGP (y)) |
2677 |
if (SCM_INUMP (y)) { |
{ |
2678 |
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) |
int cmp; |
2679 |
&& (SCM_COMPLEX_IMAG (x) == 0.0)); |
if (xisnan (SCM_REAL_VALUE (x))) |
2680 |
} else if (SCM_BIGP (y)) { |
return SCM_BOOL_F; |
2681 |
int cmp; |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); |
2682 |
if (0.0 != SCM_COMPLEX_IMAG (x)) return SCM_BOOL_F; |
scm_remember_upto_here_1 (y); |
2683 |
if (xisnan (SCM_COMPLEX_REAL (x))) return SCM_BOOL_F; |
return SCM_BOOL (0 == cmp); |
2684 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x)); |
} |
2685 |
scm_remember_upto_here_1 (y); |
else if (SCM_REALP (y)) |
2686 |
return SCM_BOOL (0 == cmp); |
return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y)); |
2687 |
} else if (SCM_REALP (y)) { |
else if (SCM_COMPLEXP (y)) |
2688 |
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) |
return SCM_BOOL ((SCM_REAL_VALUE (x) == SCM_COMPLEX_REAL (y)) |
2689 |
&& (SCM_COMPLEX_IMAG (x) == 0.0)); |
&& (0.0 == SCM_COMPLEX_IMAG (y))); |
2690 |
} else if (SCM_COMPLEXP (y)) { |
else |
2691 |
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
|
&& (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
|
2692 |
} |
} |
2693 |
} else { |
else if (SCM_COMPLEXP (x)) |
2694 |
|
{ |
2695 |
|
if (SCM_INUMP (y)) |
2696 |
|
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == (double) SCM_INUM (y)) |
2697 |
|
&& (SCM_COMPLEX_IMAG (x) == 0.0)); |
2698 |
|
else if (SCM_BIGP (y)) |
2699 |
|
{ |
2700 |
|
int cmp; |
2701 |
|
if (0.0 != SCM_COMPLEX_IMAG (x)) |
2702 |
|
return SCM_BOOL_F; |
2703 |
|
if (xisnan (SCM_COMPLEX_REAL (x))) |
2704 |
|
return SCM_BOOL_F; |
2705 |
|
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_COMPLEX_REAL (x)); |
2706 |
|
scm_remember_upto_here_1 (y); |
2707 |
|
return SCM_BOOL (0 == cmp); |
2708 |
|
} |
2709 |
|
else if (SCM_REALP (y)) |
2710 |
|
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_REAL_VALUE (y)) |
2711 |
|
&& (SCM_COMPLEX_IMAG (x) == 0.0)); |
2712 |
|
else if (SCM_COMPLEXP (y)) |
2713 |
|
return SCM_BOOL ((SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)) |
2714 |
|
&& (SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y))); |
2715 |
|
else |
2716 |
|
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARGn, s_eq_p); |
2717 |
|
} |
2718 |
|
else |
2719 |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p); |
SCM_WTA_DISPATCH_2 (g_eq_p, x, y, SCM_ARG1, s_eq_p); |
|
} |
|
2720 |
} |
} |
2721 |
|
|
2722 |
|
|
2727 |
SCM |
SCM |
2728 |
scm_less_p (SCM x, SCM y) |
scm_less_p (SCM x, SCM y) |
2729 |
{ |
{ |
2730 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2731 |
long xx = SCM_INUM (x); |
{ |
2732 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
2733 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
2734 |
return SCM_BOOL (xx < yy); |
{ |
2735 |
} else if (SCM_BIGP (y)) { |
long yy = SCM_INUM (y); |
2736 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
return SCM_BOOL (xx < yy); |
2737 |
scm_remember_upto_here_1 (y); |
} |
2738 |
return SCM_BOOL (sgn > 0); |
else if (SCM_BIGP (y)) |
2739 |
} else if (SCM_REALP (y)) { |
{ |
2740 |
return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
2741 |
} else { |
scm_remember_upto_here_1 (y); |
2742 |
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
return SCM_BOOL (sgn > 0); |
2743 |
|
} |
2744 |
|
else if (SCM_REALP (y)) |
2745 |
|
return SCM_BOOL ((double) xx < SCM_REAL_VALUE (y)); |
2746 |
|
else |
2747 |
|
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
2748 |
} |
} |
2749 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
2750 |
if (SCM_INUMP (y)) { |
{ |
2751 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
if (SCM_INUMP (y)) |
2752 |
scm_remember_upto_here_1 (x); |
{ |
2753 |
return SCM_BOOL (sgn < 0); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
2754 |
} else if (SCM_BIGP (y)) { |
scm_remember_upto_here_1 (x); |
2755 |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
return SCM_BOOL (sgn < 0); |
2756 |
scm_remember_upto_here_2 (x, y); |
} |
2757 |
return SCM_BOOL (cmp < 0); |
else if (SCM_BIGP (y)) |
2758 |
} else if (SCM_REALP (y)) { |
{ |
2759 |
int cmp; |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
2760 |
if (xisnan (SCM_REAL_VALUE (y))) return SCM_BOOL_F; |
scm_remember_upto_here_2 (x, y); |
2761 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); |
return SCM_BOOL (cmp < 0); |
2762 |
scm_remember_upto_here_1 (x); |
} |
2763 |
return SCM_BOOL (cmp < 0); |
else if (SCM_REALP (y)) |
2764 |
} else { |
{ |
2765 |
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
int cmp; |
2766 |
} |
if (xisnan (SCM_REAL_VALUE (y))) |
2767 |
} else if (SCM_REALP (x)) { |
return SCM_BOOL_F; |
2768 |
if (SCM_INUMP (y)) { |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), SCM_REAL_VALUE (y)); |
2769 |
return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); |
scm_remember_upto_here_1 (x); |
2770 |
} else if (SCM_BIGP (y)) { |
return SCM_BOOL (cmp < 0); |
2771 |
int cmp; |
} |
2772 |
if (xisnan (SCM_REAL_VALUE (x))) return SCM_BOOL_F; |
else |
2773 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); |
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
|
scm_remember_upto_here_1 (y); |
|
|
return SCM_BOOL (cmp > 0); |
|
|
} else if (SCM_REALP (y)) { |
|
|
return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
|
2774 |
} |
} |
2775 |
} else { |
else if (SCM_REALP (x)) |
2776 |
|
{ |
2777 |
|
if (SCM_INUMP (y)) |
2778 |
|
return SCM_BOOL (SCM_REAL_VALUE (x) < (double) SCM_INUM (y)); |
2779 |
|
else if (SCM_BIGP (y)) |
2780 |
|
{ |
2781 |
|
int cmp; |
2782 |
|
if (xisnan (SCM_REAL_VALUE (x))) |
2783 |
|
return SCM_BOOL_F; |
2784 |
|
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), SCM_REAL_VALUE (x)); |
2785 |
|
scm_remember_upto_here_1 (y); |
2786 |
|
return SCM_BOOL (cmp > 0); |
2787 |
|
} |
2788 |
|
else if (SCM_REALP (y)) |
2789 |
|
return SCM_BOOL (SCM_REAL_VALUE (x) < SCM_REAL_VALUE (y)); |
2790 |
|
else |
2791 |
|
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARGn, s_less_p); |
2792 |
|
} |
2793 |
|
else |
2794 |
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p); |
SCM_WTA_DISPATCH_2 (g_less_p, x, y, SCM_ARG1, s_less_p); |
|
} |
|
2795 |
} |
} |
2796 |
|
|
2797 |
|
|
2860 |
SCM |
SCM |
2861 |
scm_zero_p (SCM z) |
scm_zero_p (SCM z) |
2862 |
{ |
{ |
2863 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
2864 |
return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0)); |
return SCM_BOOL (SCM_EQ_P (z, SCM_INUM0)); |
2865 |
} else if (SCM_BIGP (z)) { |
else if (SCM_BIGP (z)) |
2866 |
return SCM_BOOL_F; |
return SCM_BOOL_F; |
2867 |
} else if (SCM_REALP (z)) { |
else if (SCM_REALP (z)) |
2868 |
return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0); |
return SCM_BOOL (SCM_REAL_VALUE (z) == 0.0); |
2869 |
} else if (SCM_COMPLEXP (z)) { |
else if (SCM_COMPLEXP (z)) |
2870 |
return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0 |
return SCM_BOOL (SCM_COMPLEX_REAL (z) == 0.0 |
2871 |
&& SCM_COMPLEX_IMAG (z) == 0.0); |
&& SCM_COMPLEX_IMAG (z) == 0.0); |
2872 |
} else { |
else |
2873 |
SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p); |
SCM_WTA_DISPATCH_1 (g_zero_p, z, SCM_ARG1, s_zero_p); |
|
} |
|
2874 |
} |
} |
2875 |
|
|
2876 |
|
|
2881 |
SCM |
SCM |
2882 |
scm_positive_p (SCM x) |
scm_positive_p (SCM x) |
2883 |
{ |
{ |
2884 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2885 |
return SCM_BOOL (SCM_INUM (x) > 0); |
return SCM_BOOL (SCM_INUM (x) > 0); |
2886 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
2887 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
{ |
2888 |
scm_remember_upto_here_1 (x); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
2889 |
return SCM_BOOL (sgn > 0); |
scm_remember_upto_here_1 (x); |
2890 |
} else if (SCM_REALP (x)) { |
return SCM_BOOL (sgn > 0); |
2891 |
|
} |
2892 |
|
else if (SCM_REALP (x)) |
2893 |
return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0); |
return SCM_BOOL(SCM_REAL_VALUE (x) > 0.0); |
2894 |
} else { |
else |
2895 |
SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p); |
SCM_WTA_DISPATCH_1 (g_positive_p, x, SCM_ARG1, s_positive_p); |
|
} |
|
2896 |
} |
} |
2897 |
|
|
2898 |
|
|
2903 |
SCM |
SCM |
2904 |
scm_negative_p (SCM x) |
scm_negative_p (SCM x) |
2905 |
{ |
{ |
2906 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2907 |
return SCM_BOOL (SCM_INUM (x) < 0); |
return SCM_BOOL (SCM_INUM (x) < 0); |
2908 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
2909 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
{ |
2910 |
scm_remember_upto_here_1 (x); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
2911 |
return SCM_BOOL (sgn < 0); |
scm_remember_upto_here_1 (x); |
2912 |
} else if (SCM_REALP (x)) { |
return SCM_BOOL (sgn < 0); |
2913 |
|
} |
2914 |
|
else if (SCM_REALP (x)) |
2915 |
return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0); |
return SCM_BOOL(SCM_REAL_VALUE (x) < 0.0); |
2916 |
} else { |
else |
2917 |
SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p); |
SCM_WTA_DISPATCH_1 (g_negative_p, x, SCM_ARG1, s_negative_p); |
|
} |
|
2918 |
} |
} |
2919 |
|
|
2920 |
|
|
2924 |
SCM |
SCM |
2925 |
scm_max (SCM x, SCM y) |
scm_max (SCM x, SCM y) |
2926 |
{ |
{ |
2927 |
if (SCM_UNBNDP (y)) { |
if (SCM_UNBNDP (y)) |
2928 |
if (SCM_UNBNDP (x)) { |
{ |
2929 |
SCM_WTA_DISPATCH_0 (g_max, s_max); |
if (SCM_UNBNDP (x)) |
2930 |
} else if (SCM_NUMBERP (x)) { |
SCM_WTA_DISPATCH_0 (g_max, s_max); |
2931 |
return x; |
else if (SCM_NUMBERP (x)) |
2932 |
} else { |
return x; |
2933 |
SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max); |
else |
2934 |
|
SCM_WTA_DISPATCH_1 (g_max, x, SCM_ARG1, s_max); |
2935 |
} |
} |
|
} |
|
2936 |
|
|
2937 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
2938 |
long xx = SCM_INUM (x); |
{ |
2939 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
2940 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
2941 |
return (xx < yy) ? y : x; |
{ |
2942 |
} else if (SCM_BIGP (y)) { |
long yy = SCM_INUM (y); |
2943 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
return (xx < yy) ? y : x; |
2944 |
scm_remember_upto_here_1 (y); |
} |
2945 |
return (sgn < 0) ? x : y; |
else if (SCM_BIGP (y)) |
2946 |
} else if (SCM_REALP (y)) { |
{ |
2947 |
double z = xx; |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
2948 |
/* if y==NaN then ">" is false and we return NaN */ |
scm_remember_upto_here_1 (y); |
2949 |
return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; |
return (sgn < 0) ? x : y; |
2950 |
} else { |
} |
2951 |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
else if (SCM_REALP (y)) |
2952 |
|
{ |
2953 |
|
double z = xx; |
2954 |
|
/* if y==NaN then ">" is false and we return NaN */ |
2955 |
|
return (z > SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; |
2956 |
|
} |
2957 |
|
else |
2958 |
|
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
2959 |
} |
} |
2960 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
2961 |
if (SCM_INUMP (y)) { |
{ |
2962 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
if (SCM_INUMP (y)) |
2963 |
scm_remember_upto_here_1 (x); |
{ |
2964 |
return (sgn < 0) ? y : x; |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
2965 |
} else if (SCM_BIGP (y)) { |
scm_remember_upto_here_1 (x); |
2966 |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
return (sgn < 0) ? y : x; |
2967 |
scm_remember_upto_here_2 (x, y); |
} |
2968 |
return (cmp > 0) ? x : y; |
else if (SCM_BIGP (y)) |
2969 |
} else if (SCM_REALP (y)) { |
{ |
2970 |
double yy = SCM_REAL_VALUE (y); |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
2971 |
int cmp; |
scm_remember_upto_here_2 (x, y); |
2972 |
if (xisnan (yy)) |
return (cmp > 0) ? x : y; |
2973 |
return y; |
} |
2974 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); |
else if (SCM_REALP (y)) |
2975 |
scm_remember_upto_here_1 (x); |
{ |
2976 |
return (cmp > 0) ? x : y; |
double yy = SCM_REAL_VALUE (y); |
2977 |
} else { |
int cmp; |
2978 |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
if (xisnan (yy)) |
2979 |
} |
return y; |
2980 |
} else if (SCM_REALP (x)) { |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); |
2981 |
if (SCM_INUMP (y)) { |
scm_remember_upto_here_1 (x); |
2982 |
double z = SCM_INUM (y); |
return (cmp > 0) ? x : y; |
2983 |
/* if x==NaN then "<" is false and we return NaN */ |
} |
2984 |
return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; |
else |
2985 |
} else if (SCM_BIGP (y)) { |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
2986 |
double xx = SCM_REAL_VALUE (x); |
} |
2987 |
int cmp; |
else if (SCM_REALP (x)) |
2988 |
if (xisnan (xx)) |
{ |
2989 |
return x; |
if (SCM_INUMP (y)) |
2990 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); |
{ |
2991 |
scm_remember_upto_here_1 (y); |
double z = SCM_INUM (y); |
2992 |
return (cmp < 0) ? x : y; |
/* if x==NaN then "<" is false and we return NaN */ |
2993 |
} else if (SCM_REALP (y)) { |
return (SCM_REAL_VALUE (x) < z) ? scm_make_real (z) : x; |
2994 |
/* if x==NaN then our explicit check means we return NaN |
} |
2995 |
if y==NaN then ">" is false and we return NaN |
else if (SCM_BIGP (y)) |
2996 |
calling isnan is unavoidable, since it's the only way to know |
{ |
2997 |
which of x or y causes any compares to be false */ |
double xx = SCM_REAL_VALUE (x); |
2998 |
double xx = SCM_REAL_VALUE (x); |
int cmp; |
2999 |
return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y; |
if (xisnan (xx)) |
3000 |
} else { |
return x; |
3001 |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); |
3002 |
|
scm_remember_upto_here_1 (y); |
3003 |
|
return (cmp < 0) ? x : y; |
3004 |
|
} |
3005 |
|
else if (SCM_REALP (y)) |
3006 |
|
{ |
3007 |
|
/* if x==NaN then our explicit check means we return NaN |
3008 |
|
if y==NaN then ">" is false and we return NaN |
3009 |
|
calling isnan is unavoidable, since it's the only way to know |
3010 |
|
which of x or y causes any compares to be false */ |
3011 |
|
double xx = SCM_REAL_VALUE (x); |
3012 |
|
return (xisnan (xx) || xx > SCM_REAL_VALUE (y)) ? x : y; |
3013 |
|
} |
3014 |
|
else |
3015 |
|
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARGn, s_max); |
3016 |
} |
} |
3017 |
} else { |
else |
3018 |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max); |
SCM_WTA_DISPATCH_2 (g_max, x, y, SCM_ARG1, s_max); |
|
} |
|
3019 |
} |
} |
3020 |
|
|
3021 |
|
|
3025 |
SCM |
SCM |
3026 |
scm_min (SCM x, SCM y) |
scm_min (SCM x, SCM y) |
3027 |
{ |
{ |
3028 |
if (SCM_UNBNDP (y)) { |
if (SCM_UNBNDP (y)) |
3029 |
if (SCM_UNBNDP (x)) { |
{ |
3030 |
SCM_WTA_DISPATCH_0 (g_min, s_min); |
if (SCM_UNBNDP (x)) |
3031 |
} else if (SCM_NUMBERP (x)) { |
SCM_WTA_DISPATCH_0 (g_min, s_min); |
3032 |
return x; |
else if (SCM_NUMBERP (x)) |
3033 |
} else { |
return x; |
3034 |
SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min); |
else |
3035 |
|
SCM_WTA_DISPATCH_1 (g_min, x, SCM_ARG1, s_min); |
3036 |
} |
} |
|
} |
|
3037 |
|
|
3038 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
3039 |
long xx = SCM_INUM (x); |
{ |
3040 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
3041 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
3042 |
return (xx < yy) ? x : y; |
{ |
3043 |
} else if (SCM_BIGP (y)) { |
long yy = SCM_INUM (y); |
3044 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
return (xx < yy) ? x : y; |
3045 |
scm_remember_upto_here_1 (y); |
} |
3046 |
return (sgn < 0) ? y : x; |
else if (SCM_BIGP (y)) |
3047 |
} else if (SCM_REALP (y)) { |
{ |
3048 |
double z = xx; |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (y)); |
3049 |
/* if y==NaN then "<" is false and we return NaN */ |
scm_remember_upto_here_1 (y); |
3050 |
return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; |
return (sgn < 0) ? y : x; |
3051 |
} else { |
} |
3052 |
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
else if (SCM_REALP (y)) |
3053 |
|
{ |
3054 |
|
double z = xx; |
3055 |
|
/* if y==NaN then "<" is false and we return NaN */ |
3056 |
|
return (z < SCM_REAL_VALUE (y)) ? scm_make_real (z) : y; |
3057 |
|
} |
3058 |
|
else |
3059 |
|
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
3060 |
} |
} |
3061 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
3062 |
if (SCM_INUMP (y)) { |
{ |
3063 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
if (SCM_INUMP (y)) |
3064 |
scm_remember_upto_here_1 (x); |
{ |
3065 |
return (sgn < 0) ? x : y; |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3066 |
} else if (SCM_BIGP (y)) { |
scm_remember_upto_here_1 (x); |
3067 |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
return (sgn < 0) ? x : y; |
3068 |
scm_remember_upto_here_2 (x, y); |
} |
3069 |
return (cmp > 0) ? y : x; |
else if (SCM_BIGP (y)) |
3070 |
} else if (SCM_REALP (y)) { |
{ |
3071 |
double yy = SCM_REAL_VALUE (y); |
int cmp = mpz_cmp (SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
3072 |
int cmp; |
scm_remember_upto_here_2 (x, y); |
3073 |
if (xisnan (yy)) |
return (cmp > 0) ? y : x; |
3074 |
return y; |
} |
3075 |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); |
else if (SCM_REALP (y)) |
3076 |
scm_remember_upto_here_1 (x); |
{ |
3077 |
return (cmp > 0) ? y : x; |
double yy = SCM_REAL_VALUE (y); |
3078 |
} else { |
int cmp; |
3079 |
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
if (xisnan (yy)) |
3080 |
} |
return y; |
3081 |
} else if (SCM_REALP (x)) { |
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (x), yy); |
3082 |
if (SCM_INUMP (y)) { |
scm_remember_upto_here_1 (x); |
3083 |
double z = SCM_INUM (y); |
return (cmp > 0) ? y : x; |
3084 |
/* if x==NaN then "<" is false and we return NaN */ |
} |
3085 |
return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x; |
else |
3086 |
} else if (SCM_BIGP (y)) { |
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
|
double xx = SCM_REAL_VALUE (x); |
|
|
int cmp; |
|
|
if (xisnan (xx)) |
|
|
return x; |
|
|
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); |
|
|
scm_remember_upto_here_1 (y); |
|
|
return (cmp < 0) ? y : x; |
|
|
} else if (SCM_REALP (y)) { |
|
|
/* if x==NaN then our explicit check means we return NaN |
|
|
if y==NaN then "<" is false and we return NaN |
|
|
calling isnan is unavoidable, since it's the only way to know |
|
|
which of x or y causes any compares to be false */ |
|
|
double xx = SCM_REAL_VALUE (x); |
|
|
return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y; |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
|
3087 |
} |
} |
3088 |
} else { |
else if (SCM_REALP (x)) |
3089 |
|
{ |
3090 |
|
if (SCM_INUMP (y)) |
3091 |
|
{ |
3092 |
|
double z = SCM_INUM (y); |
3093 |
|
/* if x==NaN then "<" is false and we return NaN */ |
3094 |
|
return (z < SCM_REAL_VALUE (x)) ? scm_make_real (z) : x; |
3095 |
|
} |
3096 |
|
else if (SCM_BIGP (y)) |
3097 |
|
{ |
3098 |
|
double xx = SCM_REAL_VALUE (x); |
3099 |
|
int cmp; |
3100 |
|
if (xisnan (xx)) |
3101 |
|
return x; |
3102 |
|
cmp = xmpz_cmp_d (SCM_I_BIG_MPZ (y), xx); |
3103 |
|
scm_remember_upto_here_1 (y); |
3104 |
|
return (cmp < 0) ? y : x; |
3105 |
|
} |
3106 |
|
else if (SCM_REALP (y)) |
3107 |
|
{ |
3108 |
|
/* if x==NaN then our explicit check means we return NaN |
3109 |
|
if y==NaN then "<" is false and we return NaN |
3110 |
|
calling isnan is unavoidable, since it's the only way to know |
3111 |
|
which of x or y causes any compares to be false */ |
3112 |
|
double xx = SCM_REAL_VALUE (x); |
3113 |
|
return (xisnan (xx) || xx < SCM_REAL_VALUE (y)) ? x : y; |
3114 |
|
} |
3115 |
|
else |
3116 |
|
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARGn, s_min); |
3117 |
|
} |
3118 |
|
else |
3119 |
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min); |
SCM_WTA_DISPATCH_2 (g_min, x, y, SCM_ARG1, s_min); |
|
} |
|
3120 |
} |
} |
3121 |
|
|
3122 |
|
|
3161 |
} |
} |
3162 |
else |
else |
3163 |
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
3164 |
} else if (SCM_BIGP (x)) { |
} else if (SCM_BIGP (x)) |
3165 |
if (SCM_INUMP (y)) { |
{ |
3166 |
long int inum; |
if (SCM_INUMP (y)) |
3167 |
int bigsgn; |
{ |
3168 |
add_big_inum: |
long int inum; |
3169 |
inum = SCM_INUM (y); |
int bigsgn; |
3170 |
if (inum == 0) return x; |
add_big_inum: |
3171 |
bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
inum = SCM_INUM (y); |
3172 |
if (inum < 0) { |
if (inum == 0) |
3173 |
SCM result = scm_i_mkbig (); |
return x; |
3174 |
mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum); |
bigsgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3175 |
scm_remember_upto_here_1 (x); |
if (inum < 0) |
3176 |
/* we know the result will have to be a bignum */ |
{ |
3177 |
if (bigsgn == -1) return result; |
SCM result = scm_i_mkbig (); |
3178 |
return scm_i_normbig (result); |
mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), - inum); |
3179 |
} else { |
scm_remember_upto_here_1 (x); |
3180 |
SCM result = scm_i_mkbig (); |
/* we know the result will have to be a bignum */ |
3181 |
mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum); |
if (bigsgn == -1) |
3182 |
scm_remember_upto_here_1 (x); |
return result; |
3183 |
/* we know the result will have to be a bignum */ |
return scm_i_normbig (result); |
3184 |
if (bigsgn == 1) return result; |
} |
3185 |
return result; |
else |
3186 |
return scm_i_normbig (result); |
{ |
3187 |
|
SCM result = scm_i_mkbig (); |
3188 |
|
mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), inum); |
3189 |
|
scm_remember_upto_here_1 (x); |
3190 |
|
/* we know the result will have to be a bignum */ |
3191 |
|
if (bigsgn == 1) |
3192 |
|
return result; |
3193 |
|
return scm_i_normbig (result); |
3194 |
|
} |
3195 |
|
} |
3196 |
|
else if (SCM_BIGP (y)) |
3197 |
|
{ |
3198 |
|
SCM result = scm_i_mkbig (); |
3199 |
|
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3200 |
|
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
3201 |
|
mpz_add (SCM_I_BIG_MPZ (result), |
3202 |
|
SCM_I_BIG_MPZ (x), |
3203 |
|
SCM_I_BIG_MPZ (y)); |
3204 |
|
scm_remember_upto_here_2 (x, y); |
3205 |
|
/* we know the result will have to be a bignum */ |
3206 |
|
if (sgn_x == sgn_y) |
3207 |
|
return result; |
3208 |
|
return scm_i_normbig (result); |
3209 |
|
} |
3210 |
|
else if (SCM_REALP (y)) |
3211 |
|
{ |
3212 |
|
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y); |
3213 |
|
scm_remember_upto_here_1 (x); |
3214 |
|
return scm_make_real (result); |
3215 |
|
} |
3216 |
|
else if (SCM_COMPLEXP (y)) |
3217 |
|
{ |
3218 |
|
double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x)) |
3219 |
|
+ SCM_COMPLEX_REAL (y)); |
3220 |
|
scm_remember_upto_here_1 (x); |
3221 |
|
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); |
3222 |
|
} |
3223 |
|
else |
3224 |
|
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
3225 |
} |
} |
3226 |
|
else if (SCM_REALP (x)) |
3227 |
|
{ |
3228 |
|
if (SCM_INUMP (y)) |
3229 |
|
return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y)); |
3230 |
|
else if (SCM_BIGP (y)) |
3231 |
|
{ |
3232 |
|
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x); |
3233 |
|
scm_remember_upto_here_1 (y); |
3234 |
|
return scm_make_real (result); |
3235 |
|
} |
3236 |
|
else if (SCM_REALP (y)) |
3237 |
|
return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y)); |
3238 |
|
else if (SCM_COMPLEXP (y)) |
3239 |
|
return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y), |
3240 |
|
SCM_COMPLEX_IMAG (y)); |
3241 |
|
else |
3242 |
|
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
3243 |
} |
} |
3244 |
else if (SCM_BIGP (y)) { |
else if (SCM_COMPLEXP (x)) |
3245 |
SCM result = scm_i_mkbig (); |
{ |
3246 |
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
if (SCM_INUMP (y)) |
3247 |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y), |
3248 |
mpz_add (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
SCM_COMPLEX_IMAG (x)); |
3249 |
scm_remember_upto_here_2 (x, y); |
else if (SCM_BIGP (y)) |
3250 |
/* we know the result will have to be a bignum */ |
{ |
3251 |
if (sgn_x == sgn_y) return result; |
double real_part = (mpz_get_d (SCM_I_BIG_MPZ (y)) |
3252 |
return scm_i_normbig (result); |
+ SCM_COMPLEX_REAL (x)); |
3253 |
} |
scm_remember_upto_here_1 (y); |
3254 |
else if (SCM_REALP (y)) { |
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x)); |
3255 |
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_REAL_VALUE (y); |
} |
3256 |
scm_remember_upto_here_1 (x); |
else if (SCM_REALP (y)) |
3257 |
return scm_make_real (result); |
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y), |
3258 |
} |
SCM_COMPLEX_IMAG (x)); |
3259 |
else if (SCM_COMPLEXP (y)) { |
else if (SCM_COMPLEXP (y)) |
3260 |
double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) + SCM_COMPLEX_REAL (y); |
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y), |
3261 |
scm_remember_upto_here_1 (x); |
SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y)); |
3262 |
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); |
else |
3263 |
} |
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
|
else SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
|
|
} else if (SCM_REALP (x)) { |
|
|
if (SCM_INUMP (y)) { |
|
|
return scm_make_real (SCM_REAL_VALUE (x) + SCM_INUM (y)); |
|
|
} else if (SCM_BIGP (y)) { |
|
|
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_REAL_VALUE (x); |
|
|
scm_remember_upto_here_1 (y); |
|
|
return scm_make_real (result); |
|
|
} else if (SCM_REALP (y)) { |
|
|
return scm_make_real (SCM_REAL_VALUE (x) + SCM_REAL_VALUE (y)); |
|
|
} else if (SCM_COMPLEXP (y)) { |
|
|
return scm_make_complex (SCM_REAL_VALUE (x) + SCM_COMPLEX_REAL (y), |
|
|
SCM_COMPLEX_IMAG (y)); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
|
|
} |
|
|
} else if (SCM_COMPLEXP (x)) { |
|
|
if (SCM_INUMP (y)) { |
|
|
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_INUM (y), |
|
|
SCM_COMPLEX_IMAG (x)); |
|
|
} else if (SCM_BIGP (y)) { |
|
|
double real_part = mpz_get_d (SCM_I_BIG_MPZ (y)) + SCM_COMPLEX_REAL (x); |
|
|
scm_remember_upto_here_1 (y); |
|
|
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (x)); |
|
|
} else if (SCM_REALP (y)) { |
|
|
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_REAL_VALUE (y), |
|
|
SCM_COMPLEX_IMAG (x)); |
|
|
} else if (SCM_COMPLEXP (y)) { |
|
|
return scm_make_complex (SCM_COMPLEX_REAL (x) + SCM_COMPLEX_REAL (y), |
|
|
SCM_COMPLEX_IMAG (x) + SCM_COMPLEX_IMAG (y)); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARGn, s_sum); |
|
3264 |
} |
} |
3265 |
} else { |
else |
3266 |
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum); |
SCM_WTA_DISPATCH_2 (g_sum, x, y, SCM_ARG1, s_sum); |
|
} |
|
3267 |
} |
} |
3268 |
|
|
3269 |
|
|
3300 |
SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); |
SCM_WTA_DISPATCH_1 (g_difference, x, SCM_ARG1, s_difference); |
3301 |
} |
} |
3302 |
|
|
3303 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
3304 |
if (SCM_INUMP (y)) { |
{ |
3305 |
long int xx = SCM_INUM (x); |
if (SCM_INUMP (y)) |
3306 |
long int yy = SCM_INUM (y); |
{ |
3307 |
long int z = xx - yy; |
long int xx = SCM_INUM (x); |
3308 |
if (SCM_FIXABLE (z)) { |
long int yy = SCM_INUM (y); |
3309 |
return SCM_MAKINUM (z); |
long int z = xx - yy; |
3310 |
} else { |
if (SCM_FIXABLE (z)) |
3311 |
return scm_i_long2big (z); |
return SCM_MAKINUM (z); |
3312 |
} |
else |
3313 |
} else if (SCM_BIGP (y)) { |
return scm_i_long2big (z); |
3314 |
/* inum-x - big-y */ |
} |
3315 |
long xx = SCM_INUM (x); |
else if (SCM_BIGP (y)) |
3316 |
|
{ |
3317 |
if (xx == 0) |
/* inum-x - big-y */ |
3318 |
return scm_i_clonebig (y, 0); |
long xx = SCM_INUM (x); |
|
else |
|
|
{ |
|
|
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
|
|
SCM result = scm_i_mkbig (); |
|
3319 |
|
|
3320 |
if (xx >= 0) |
if (xx == 0) |
3321 |
mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y)); |
return scm_i_clonebig (y, 0); |
3322 |
else |
else |
3323 |
{ |
{ |
3324 |
/* x - y == -(y + -x) */ |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
3325 |
mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx); |
SCM result = scm_i_mkbig (); |
|
mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
|
|
} |
|
|
scm_remember_upto_here_1 (y); |
|
3326 |
|
|
3327 |
if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0)) |
if (xx >= 0) |
3328 |
/* we know the result will have to be a bignum */ |
mpz_ui_sub (SCM_I_BIG_MPZ (result), xx, SCM_I_BIG_MPZ (y)); |
3329 |
return result; |
else |
3330 |
else |
{ |
3331 |
return scm_i_normbig (result); |
/* x - y == -(y + -x) */ |
3332 |
} |
mpz_add_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), -xx); |
3333 |
} else if (SCM_REALP (y)) { |
mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
3334 |
long int xx = SCM_INUM (x); |
} |
3335 |
return scm_make_real (xx - SCM_REAL_VALUE (y)); |
scm_remember_upto_here_1 (y); |
|
} else if (SCM_COMPLEXP (y)) { |
|
|
long int xx = SCM_INUM (x); |
|
|
return scm_make_complex (xx - SCM_COMPLEX_REAL (y), |
|
|
-SCM_COMPLEX_IMAG (y)); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
|
|
} |
|
|
} else if (SCM_BIGP (x)) { |
|
|
if (SCM_INUMP (y)) { |
|
|
/* big-x - inum-y */ |
|
|
long yy = SCM_INUM (y); |
|
|
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
|
3336 |
|
|
3337 |
scm_remember_upto_here_1 (x); |
if ((xx < 0 && (sgn_y > 0)) || ((xx > 0) && sgn_y < 0)) |
3338 |
if (sgn_x == 0) |
/* we know the result will have to be a bignum */ |
3339 |
return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy); |
return result; |
3340 |
|
else |
3341 |
|
return scm_i_normbig (result); |
3342 |
|
} |
3343 |
|
} |
3344 |
|
else if (SCM_REALP (y)) |
3345 |
|
{ |
3346 |
|
long int xx = SCM_INUM (x); |
3347 |
|
return scm_make_real (xx - SCM_REAL_VALUE (y)); |
3348 |
|
} |
3349 |
|
else if (SCM_COMPLEXP (y)) |
3350 |
|
{ |
3351 |
|
long int xx = SCM_INUM (x); |
3352 |
|
return scm_make_complex (xx - SCM_COMPLEX_REAL (y), |
3353 |
|
- SCM_COMPLEX_IMAG (y)); |
3354 |
|
} |
3355 |
else |
else |
3356 |
{ |
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
3357 |
SCM result = scm_i_mkbig (); |
} |
3358 |
|
else if (SCM_BIGP (x)) |
3359 |
|
{ |
3360 |
|
if (SCM_INUMP (y)) |
3361 |
|
{ |
3362 |
|
/* big-x - inum-y */ |
3363 |
|
long yy = SCM_INUM (y); |
3364 |
|
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3365 |
|
|
3366 |
|
scm_remember_upto_here_1 (x); |
3367 |
|
if (sgn_x == 0) |
3368 |
|
return SCM_FIXABLE (-yy) ? SCM_MAKINUM (-yy) : scm_long2num (-yy); |
3369 |
|
else |
3370 |
|
{ |
3371 |
|
SCM result = scm_i_mkbig (); |
3372 |
|
|
3373 |
mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); |
mpz_sub_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), yy); |
3374 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
3375 |
|
|
3376 |
if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0)) |
if ((sgn_x < 0 && (yy > 0)) || ((sgn_x > 0) && yy < 0)) |
3377 |
/* we know the result will have to be a bignum */ |
/* we know the result will have to be a bignum */ |
3378 |
return result; |
return result; |
3379 |
else |
else |
3380 |
return scm_i_normbig (result); |
return scm_i_normbig (result); |
3381 |
} |
} |
3382 |
} |
} |
3383 |
else if (SCM_BIGP (y)) |
else if (SCM_BIGP (y)) |
3384 |
{ |
{ |
3385 |
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
int sgn_x = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3386 |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
int sgn_y = mpz_sgn (SCM_I_BIG_MPZ (y)); |
3387 |
SCM result = scm_i_mkbig (); |
SCM result = scm_i_mkbig (); |
3388 |
mpz_sub (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
mpz_sub (SCM_I_BIG_MPZ (result), |
3389 |
scm_remember_upto_here_2 (x, y); |
SCM_I_BIG_MPZ (x), |
3390 |
/* we know the result will have to be a bignum */ |
SCM_I_BIG_MPZ (y)); |
3391 |
if ((sgn_x == 1) && (sgn_y == -1)) return result; |
scm_remember_upto_here_2 (x, y); |
3392 |
if ((sgn_x == -1) && (sgn_y == 1)) return result; |
/* we know the result will have to be a bignum */ |
3393 |
return scm_i_normbig (result); |
if ((sgn_x == 1) && (sgn_y == -1)) |
3394 |
} |
return result; |
3395 |
else if (SCM_REALP (y)) { |
if ((sgn_x == -1) && (sgn_y == 1)) |
3396 |
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y); |
return result; |
3397 |
scm_remember_upto_here_1 (x); |
return scm_i_normbig (result); |
3398 |
return scm_make_real (result); |
} |
3399 |
|
else if (SCM_REALP (y)) |
3400 |
|
{ |
3401 |
|
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_REAL_VALUE (y); |
3402 |
|
scm_remember_upto_here_1 (x); |
3403 |
|
return scm_make_real (result); |
3404 |
|
} |
3405 |
|
else if (SCM_COMPLEXP (y)) |
3406 |
|
{ |
3407 |
|
double real_part = (mpz_get_d (SCM_I_BIG_MPZ (x)) |
3408 |
|
- SCM_COMPLEX_REAL (y)); |
3409 |
|
scm_remember_upto_here_1 (x); |
3410 |
|
return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y)); |
3411 |
|
} |
3412 |
|
else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
3413 |
} |
} |
3414 |
else if (SCM_COMPLEXP (y)) { |
else if (SCM_REALP (x)) |
3415 |
double real_part = mpz_get_d (SCM_I_BIG_MPZ (x)) - SCM_COMPLEX_REAL (y); |
{ |
3416 |
scm_remember_upto_here_1 (x); |
if (SCM_INUMP (y)) |
3417 |
return scm_make_complex (real_part, - SCM_COMPLEX_IMAG (y)); |
return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); |
3418 |
|
else if (SCM_BIGP (y)) |
3419 |
|
{ |
3420 |
|
double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); |
3421 |
|
scm_remember_upto_here_1 (x); |
3422 |
|
return scm_make_real (result); |
3423 |
|
} |
3424 |
|
else if (SCM_REALP (y)) |
3425 |
|
return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); |
3426 |
|
else if (SCM_COMPLEXP (y)) |
3427 |
|
return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y), |
3428 |
|
-SCM_COMPLEX_IMAG (y)); |
3429 |
|
else |
3430 |
|
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
3431 |
} |
} |
3432 |
else SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
else if (SCM_COMPLEXP (x)) |
3433 |
} else if (SCM_REALP (x)) { |
{ |
3434 |
if (SCM_INUMP (y)) { |
if (SCM_INUMP (y)) |
3435 |
return scm_make_real (SCM_REAL_VALUE (x) - SCM_INUM (y)); |
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), |
3436 |
} else if (SCM_BIGP (y)) { |
SCM_COMPLEX_IMAG (x)); |
3437 |
double result = SCM_REAL_VALUE (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); |
else if (SCM_BIGP (y)) |
3438 |
scm_remember_upto_here_1 (x); |
{ |
3439 |
return scm_make_real (result); |
double real_part = (SCM_COMPLEX_REAL (x) |
3440 |
} else if (SCM_REALP (y)) { |
- mpz_get_d (SCM_I_BIG_MPZ (y))); |
3441 |
return scm_make_real (SCM_REAL_VALUE (x) - SCM_REAL_VALUE (y)); |
scm_remember_upto_here_1 (x); |
3442 |
} else if (SCM_COMPLEXP (y)) { |
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); |
3443 |
return scm_make_complex (SCM_REAL_VALUE (x) - SCM_COMPLEX_REAL (y), |
} |
3444 |
-SCM_COMPLEX_IMAG (y)); |
else if (SCM_REALP (y)) |
3445 |
} else { |
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), |
3446 |
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
SCM_COMPLEX_IMAG (x)); |
3447 |
} |
else if (SCM_COMPLEXP (y)) |
3448 |
} else if (SCM_COMPLEXP (x)) { |
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y), |
3449 |
if (SCM_INUMP (y)) { |
SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y)); |
3450 |
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_INUM (y), |
else |
3451 |
SCM_COMPLEX_IMAG (x)); |
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
|
} else if (SCM_BIGP (y)) { |
|
|
double real_part = SCM_COMPLEX_REAL (x) - mpz_get_d (SCM_I_BIG_MPZ (y)); |
|
|
scm_remember_upto_here_1 (x); |
|
|
return scm_make_complex (real_part, SCM_COMPLEX_IMAG (y)); |
|
|
} else if (SCM_REALP (y)) { |
|
|
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_REAL_VALUE (y), |
|
|
SCM_COMPLEX_IMAG (x)); |
|
|
} else if (SCM_COMPLEXP (y)) { |
|
|
return scm_make_complex (SCM_COMPLEX_REAL (x) - SCM_COMPLEX_REAL (y), |
|
|
SCM_COMPLEX_IMAG (x) - SCM_COMPLEX_IMAG (y)); |
|
|
} else { |
|
|
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARGn, s_difference); |
|
3452 |
} |
} |
3453 |
} else { |
else |
3454 |
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference); |
SCM_WTA_DISPATCH_2 (g_difference, x, y, SCM_ARG1, s_difference); |
|
} |
|
3455 |
} |
} |
3456 |
#undef FUNC_NAME |
#undef FUNC_NAME |
3457 |
|
|
3463 |
SCM |
SCM |
3464 |
scm_product (SCM x, SCM y) |
scm_product (SCM x, SCM y) |
3465 |
{ |
{ |
3466 |
if (SCM_UNBNDP (y)) { |
if (SCM_UNBNDP (y)) |
3467 |
if (SCM_UNBNDP (x)) { |
{ |
3468 |
return SCM_MAKINUM (1L); |
if (SCM_UNBNDP (x)) |
3469 |
} else if (SCM_NUMBERP (x)) { |
return SCM_MAKINUM (1L); |
3470 |
return x; |
else if (SCM_NUMBERP (x)) |
3471 |
} else { |
return x; |
3472 |
SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product); |
else |
3473 |
|
SCM_WTA_DISPATCH_1 (g_product, x, SCM_ARG1, s_product); |
3474 |
} |
} |
|
} |
|
3475 |
|
|
3476 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
3477 |
long xx; |
{ |
3478 |
|
long xx; |
3479 |
|
|
3480 |
intbig: |
intbig: |
3481 |
xx = SCM_INUM (x); |
xx = SCM_INUM (x); |
3482 |
|
|
3483 |
switch (xx) |
switch (xx) |
3484 |
{ |
{ |
3485 |
case 0: return x; break; |
case 0: return x; break; |
3486 |
case 1: return y; break; |
case 1: return y; break; |
3487 |
} |
} |
3488 |
|
|
3489 |
if (SCM_INUMP (y)) { |
if (SCM_INUMP (y)) |
3490 |
long yy = SCM_INUM (y); |
{ |
3491 |
long kk = xx * yy; |
long yy = SCM_INUM (y); |
3492 |
SCM k = SCM_MAKINUM (kk); |
long kk = xx * yy; |
3493 |
if ((kk == SCM_INUM (k)) && (kk / xx == yy)) { |
SCM k = SCM_MAKINUM (kk); |
3494 |
return k; |
if ((kk == SCM_INUM (k)) && (kk / xx == yy)) |
3495 |
} else { |
return k; |
3496 |
SCM result = scm_i_long2big (xx); |
else |
3497 |
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy); |
{ |
3498 |
return scm_i_normbig (result); |
SCM result = scm_i_long2big (xx); |
3499 |
} |
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result), yy); |
3500 |
} else if (SCM_BIGP (y)) { |
return scm_i_normbig (result); |
3501 |
SCM result = scm_i_mkbig (); |
} |
3502 |
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); |
} |
3503 |
scm_remember_upto_here_1 (y); |
else if (SCM_BIGP (y)) |
3504 |
return result; |
{ |
3505 |
} else if (SCM_REALP (y)) { |
SCM result = scm_i_mkbig (); |
3506 |
return scm_make_real (xx * SCM_REAL_VALUE (y)); |
mpz_mul_si (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (y), xx); |
3507 |
} else if (SCM_COMPLEXP (y)) { |
scm_remember_upto_here_1 (y); |
3508 |
return scm_make_complex (xx * SCM_COMPLEX_REAL (y), |
return result; |
3509 |
xx * SCM_COMPLEX_IMAG (y)); |
} |
3510 |
} else { |
else if (SCM_REALP (y)) |
3511 |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
return scm_make_real (xx * SCM_REAL_VALUE (y)); |
3512 |
} |
else if (SCM_COMPLEXP (y)) |
3513 |
} else if (SCM_BIGP (x)) { |
return scm_make_complex (xx * SCM_COMPLEX_REAL (y), |
3514 |
if (SCM_INUMP (y)) { |
xx * SCM_COMPLEX_IMAG (y)); |
3515 |
SCM_SWAP (x, y); |
else |
3516 |
goto intbig; |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
3517 |
} else if (SCM_BIGP (y)) { |
} |
3518 |
SCM result = scm_i_mkbig (); |
else if (SCM_BIGP (x)) |
3519 |
mpz_mul (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), SCM_I_BIG_MPZ (y)); |
{ |
3520 |
scm_remember_upto_here_2 (x, y); |
if (SCM_INUMP (y)) |
3521 |
return result; |
{ |
3522 |
} else if (SCM_REALP (y)) { |
SCM_SWAP (x, y); |
3523 |
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y); |
goto intbig; |
3524 |
scm_remember_upto_here_1 (x); |
} |
3525 |
return scm_make_real (result); |
else if (SCM_BIGP (y)) |
3526 |
} else if (SCM_COMPLEXP (y)) { |
{ |
3527 |
double z = mpz_get_d (SCM_I_BIG_MPZ (x)); |
SCM result = scm_i_mkbig (); |
3528 |
scm_remember_upto_here_1 (x); |
mpz_mul (SCM_I_BIG_MPZ (result), |
3529 |
return scm_make_complex (z * SCM_COMPLEX_REAL (y), |
SCM_I_BIG_MPZ (x), |
3530 |
z * SCM_COMPLEX_IMAG (y)); |
SCM_I_BIG_MPZ (y)); |
3531 |
} else { |
scm_remember_upto_here_2 (x, y); |
3532 |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
return result; |
3533 |
} |
} |
3534 |
} else if (SCM_REALP (x)) { |
else if (SCM_REALP (y)) |
3535 |
if (SCM_INUMP (y)) { |
{ |
3536 |
return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); |
double result = mpz_get_d (SCM_I_BIG_MPZ (x)) * SCM_REAL_VALUE (y); |
3537 |
} else if (SCM_BIGP (y)) { |
scm_remember_upto_here_1 (x); |
3538 |
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); |
return scm_make_real (result); |
3539 |
scm_remember_upto_here_1 (y); |
} |
3540 |
return scm_make_real (result); |
else if (SCM_COMPLEXP (y)) |
3541 |
} else if (SCM_REALP (y)) { |
{ |
3542 |
return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); |
double z = mpz_get_d (SCM_I_BIG_MPZ (x)); |
3543 |
} else if (SCM_COMPLEXP (y)) { |
scm_remember_upto_here_1 (x); |
3544 |
return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y), |
return scm_make_complex (z * SCM_COMPLEX_REAL (y), |
3545 |
SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y)); |
z * SCM_COMPLEX_IMAG (y)); |
3546 |
} else { |
} |
3547 |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
else |
3548 |
} |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
3549 |
} else if (SCM_COMPLEXP (x)) { |
} |
3550 |
if (SCM_INUMP (y)) { |
else if (SCM_REALP (x)) |
3551 |
return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), |
{ |
3552 |
SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); |
if (SCM_INUMP (y)) |
3553 |
} else if (SCM_BIGP (y)) { |
return scm_make_real (SCM_INUM (y) * SCM_REAL_VALUE (x)); |
3554 |
double z = mpz_get_d (SCM_I_BIG_MPZ (y)); |
else if (SCM_BIGP (y)) |
3555 |
scm_remember_upto_here_1 (y); |
{ |
3556 |
return scm_make_complex (z * SCM_COMPLEX_REAL (y), |
double result = mpz_get_d (SCM_I_BIG_MPZ (y)) * SCM_REAL_VALUE (x); |
3557 |
z * SCM_COMPLEX_IMAG (y)); |
scm_remember_upto_here_1 (y); |
3558 |
} else if (SCM_REALP (y)) { |
return scm_make_real (result); |
3559 |
return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x), |
} |
3560 |
SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x)); |
else if (SCM_REALP (y)) |
3561 |
} else if (SCM_COMPLEXP (y)) { |
return scm_make_real (SCM_REAL_VALUE (x) * SCM_REAL_VALUE (y)); |
3562 |
return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y) |
else if (SCM_COMPLEXP (y)) |
3563 |
- SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y), |
return scm_make_complex (SCM_REAL_VALUE (x) * SCM_COMPLEX_REAL (y), |
3564 |
SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y) |
SCM_REAL_VALUE (x) * SCM_COMPLEX_IMAG (y)); |
3565 |
+ SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y)); |
else |
3566 |
} else { |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
3567 |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
} |
3568 |
|
else if (SCM_COMPLEXP (x)) |
3569 |
|
{ |
3570 |
|
if (SCM_INUMP (y)) |
3571 |
|
return scm_make_complex (SCM_INUM (y) * SCM_COMPLEX_REAL (x), |
3572 |
|
SCM_INUM (y) * SCM_COMPLEX_IMAG (x)); |
3573 |
|
else if (SCM_BIGP (y)) |
3574 |
|
{ |
3575 |
|
double z = mpz_get_d (SCM_I_BIG_MPZ (y)); |
3576 |
|
scm_remember_upto_here_1 (y); |
3577 |
|
return scm_make_complex (z * SCM_COMPLEX_REAL (y), |
3578 |
|
z * SCM_COMPLEX_IMAG (y)); |
3579 |
|
} |
3580 |
|
else if (SCM_REALP (y)) |
3581 |
|
return scm_make_complex (SCM_REAL_VALUE (y) * SCM_COMPLEX_REAL (x), |
3582 |
|
SCM_REAL_VALUE (y) * SCM_COMPLEX_IMAG (x)); |
3583 |
|
else if (SCM_COMPLEXP (y)) |
3584 |
|
{ |
3585 |
|
return scm_make_complex (SCM_COMPLEX_REAL (x) * SCM_COMPLEX_REAL (y) |
3586 |
|
- SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_IMAG (y), |
3587 |
|
SCM_COMPLEX_REAL (x) * SCM_COMPLEX_IMAG (y) |
3588 |
|
+ SCM_COMPLEX_IMAG (x) * SCM_COMPLEX_REAL (y)); |
3589 |
|
} |
3590 |
|
else |
3591 |
|
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARGn, s_product); |
3592 |
} |
} |
3593 |
} else { |
else |
3594 |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product); |
SCM_WTA_DISPATCH_2 (g_product, x, y, SCM_ARG1, s_product); |
|
} |
|
3595 |
} |
} |
3596 |
|
|
3597 |
double |
double |
3598 |
scm_num2dbl (SCM a, const char *why) |
scm_num2dbl (SCM a, const char *why) |
3599 |
#define FUNC_NAME why |
#define FUNC_NAME why |
3600 |
{ |
{ |
3601 |
if (SCM_INUMP (a)) { |
if (SCM_INUMP (a)) |
3602 |
return (double) SCM_INUM (a); |
return (double) SCM_INUM (a); |
3603 |
} else if (SCM_BIGP (a)) { |
else if (SCM_BIGP (a)) |
3604 |
double result = mpz_get_d (SCM_I_BIG_MPZ (a)); |
{ |
3605 |
scm_remember_upto_here_1 (a); |
double result = mpz_get_d (SCM_I_BIG_MPZ (a)); |
3606 |
return result; |
scm_remember_upto_here_1 (a); |
3607 |
} else if (SCM_REALP (a)) { |
return result; |
3608 |
|
} |
3609 |
|
else if (SCM_REALP (a)) |
3610 |
return (SCM_REAL_VALUE (a)); |
return (SCM_REAL_VALUE (a)); |
3611 |
} else { |
else |
3612 |
SCM_WRONG_TYPE_ARG (SCM_ARGn, a); |
SCM_WRONG_TYPE_ARG (SCM_ARGn, a); |
|
} |
|
3613 |
} |
} |
3614 |
#undef FUNC_NAME |
#undef FUNC_NAME |
3615 |
|
|
3656 |
{ |
{ |
3657 |
double a; |
double a; |
3658 |
|
|
3659 |
if (SCM_UNBNDP (y)) { |
if (SCM_UNBNDP (y)) |
3660 |
if (SCM_UNBNDP (x)) { |
{ |
3661 |
SCM_WTA_DISPATCH_0 (g_divide, s_divide); |
if (SCM_UNBNDP (x)) |
3662 |
} else if (SCM_INUMP (x)) { |
SCM_WTA_DISPATCH_0 (g_divide, s_divide); |
3663 |
long xx = SCM_INUM (x); |
else if (SCM_INUMP (x)) |
3664 |
if (xx == 1 || xx == -1) { |
{ |
3665 |
return x; |
long xx = SCM_INUM (x); |
3666 |
|
if (xx == 1 || xx == -1) |
3667 |
|
return x; |
3668 |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3669 |
} else if (xx == 0) { |
else if (xx == 0) |
3670 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3671 |
#endif |
#endif |
3672 |
} else { |
else |
3673 |
return scm_make_real (1.0 / (double) xx); |
return scm_make_real (1.0 / (double) xx); |
3674 |
} |
} |
3675 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
3676 |
return scm_make_real (1.0 / scm_i_big2dbl (x)); |
return scm_make_real (1.0 / scm_i_big2dbl (x)); |
3677 |
} else if (SCM_REALP (x)) { |
else if (SCM_REALP (x)) |
3678 |
double xx = SCM_REAL_VALUE (x); |
{ |
3679 |
|
double xx = SCM_REAL_VALUE (x); |
3680 |
#ifndef ALLOW_DIVIDE_BY_ZERO |
#ifndef ALLOW_DIVIDE_BY_ZERO |
3681 |
if (xx == 0.0) |
if (xx == 0.0) |
3682 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3683 |
else |
else |
3684 |
#endif |
#endif |
3685 |
return scm_make_real (1.0 / xx); |
return scm_make_real (1.0 / xx); |
3686 |
} else if (SCM_COMPLEXP (x)) { |
} |
3687 |
double r = SCM_COMPLEX_REAL (x); |
else if (SCM_COMPLEXP (x)) |
3688 |
double i = SCM_COMPLEX_IMAG (x); |
{ |
3689 |
if (r <= i) { |
double r = SCM_COMPLEX_REAL (x); |
3690 |
double t = r / i; |
double i = SCM_COMPLEX_IMAG (x); |
3691 |
double d = i * (1.0 + t * t); |
if (r <= i) |
3692 |
return scm_make_complex (t / d, -1.0 / d); |
{ |
3693 |
} else { |
double t = r / i; |
3694 |
double t = i / r; |
double d = i * (1.0 + t * t); |
3695 |
double d = r * (1.0 + t * t); |
return scm_make_complex (t / d, -1.0 / d); |
3696 |
return scm_make_complex (1.0 / d, -t / d); |
} |
3697 |
} |
else |
3698 |
} else { |
{ |
3699 |
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
double t = i / r; |
3700 |
|
double d = r * (1.0 + t * t); |
3701 |
|
return scm_make_complex (1.0 / d, -t / d); |
3702 |
|
} |
3703 |
|
} |
3704 |
|
else |
3705 |
|
SCM_WTA_DISPATCH_1 (g_divide, x, SCM_ARG1, s_divide); |
3706 |
} |
} |
|
} |
|
3707 |
|
|
3708 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
3709 |
long xx = SCM_INUM (x); |
{ |
3710 |
if (SCM_INUMP (y)) { |
long xx = SCM_INUM (x); |
3711 |
long yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
3712 |
if (yy == 0) { |
{ |
3713 |
|
long yy = SCM_INUM (y); |
3714 |
|
if (yy == 0) |
3715 |
|
{ |
3716 |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3717 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3718 |
#else |
#else |
3719 |
return scm_make_real ((double) xx / (double) yy); |
return scm_make_real ((double) xx / (double) yy); |
3720 |
#endif |
#endif |
3721 |
} else if (xx % yy != 0) { |
} |
3722 |
return scm_make_real ((double) xx / (double) yy); |
else if (xx % yy != 0) |
3723 |
} else { |
return scm_make_real ((double) xx / (double) yy); |
3724 |
long z = xx / yy; |
else |
3725 |
if (SCM_FIXABLE (z)) { |
{ |
3726 |
return SCM_MAKINUM (z); |
long z = xx / yy; |
3727 |
} else { |
if (SCM_FIXABLE (z)) |
3728 |
return scm_i_long2big (z); |
return SCM_MAKINUM (z); |
3729 |
|
else |
3730 |
|
return scm_i_long2big (z); |
3731 |
|
} |
3732 |
} |
} |
3733 |
} |
else if (SCM_BIGP (y)) |
3734 |
} else if (SCM_BIGP (y)) { |
return scm_make_real ((double) xx / scm_i_big2dbl (y)); |
3735 |
return scm_make_real ((double) xx / scm_i_big2dbl (y)); |
else if (SCM_REALP (y)) |
3736 |
} else if (SCM_REALP (y)) { |
{ |
3737 |
double yy = SCM_REAL_VALUE (y); |
double yy = SCM_REAL_VALUE (y); |
3738 |
#ifndef ALLOW_DIVIDE_BY_ZERO |
#ifndef ALLOW_DIVIDE_BY_ZERO |
3739 |
if (yy == 0.0) |
if (yy == 0.0) |
3740 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3741 |
else |
else |
3742 |
#endif |
#endif |
3743 |
return scm_make_real ((double) xx / yy); |
return scm_make_real ((double) xx / yy); |
|
} else if (SCM_COMPLEXP (y)) { |
|
|
a = xx; |
|
|
complex_div: /* y _must_ be a complex number */ |
|
|
{ |
|
|
double r = SCM_COMPLEX_REAL (y); |
|
|
double i = SCM_COMPLEX_IMAG (y); |
|
|
if (r <= i) { |
|
|
double t = r / i; |
|
|
double d = i * (1.0 + t * t); |
|
|
return scm_make_complex ((a * t) / d, -a / d); |
|
|
} else { |
|
|
double t = i / r; |
|
|
double d = r * (1.0 + t * t); |
|
|
return scm_make_complex (a / d, -(a * t) / d); |
|
3744 |
} |
} |
3745 |
} |
else if (SCM_COMPLEXP (y)) |
3746 |
} else { |
{ |
3747 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
a = xx; |
3748 |
|
complex_div: /* y _must_ be a complex number */ |
3749 |
|
{ |
3750 |
|
double r = SCM_COMPLEX_REAL (y); |
3751 |
|
double i = SCM_COMPLEX_IMAG (y); |
3752 |
|
if (r <= i) |
3753 |
|
{ |
3754 |
|
double t = r / i; |
3755 |
|
double d = i * (1.0 + t * t); |
3756 |
|
return scm_make_complex ((a * t) / d, -a / d); |
3757 |
|
} |
3758 |
|
else |
3759 |
|
{ |
3760 |
|
double t = i / r; |
3761 |
|
double d = r * (1.0 + t * t); |
3762 |
|
return scm_make_complex (a / d, -(a * t) / d); |
3763 |
|
} |
3764 |
|
} |
3765 |
|
} |
3766 |
|
else |
3767 |
|
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3768 |
} |
} |
3769 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
3770 |
if (SCM_INUMP (y)) { |
{ |
3771 |
long int yy = SCM_INUM (y); |
if (SCM_INUMP (y)) |
3772 |
if (yy == 0) { |
{ |
3773 |
|
long int yy = SCM_INUM (y); |
3774 |
|
if (yy == 0) |
3775 |
|
{ |
3776 |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3777 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3778 |
#else |
#else |
3779 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3780 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
3781 |
return (sgn == 0) ? scm_nan () : scm_inf (); |
return (sgn == 0) ? scm_nan () : scm_inf (); |
3782 |
#endif |
#endif |
3783 |
} else if (yy == 1) { |
} |
3784 |
return x; |
else if (yy == 1) |
3785 |
} else { |
return x; |
3786 |
/* FIXME: HMM, what are the relative performance issues here? |
else |
3787 |
We need to test. Is it faster on average to test |
{ |
3788 |
divisible_p, then perform whichever operation, or is it |
/* FIXME: HMM, what are the relative performance issues here? |
3789 |
faster to perform the integer div opportunistically and |
We need to test. Is it faster on average to test |
3790 |
switch to real if there's a remainder? For now we take the |
divisible_p, then perform whichever operation, or is it |
3791 |
middle ground: test, then if divisible, use the faster div |
faster to perform the integer div opportunistically and |
3792 |
func. */ |
switch to real if there's a remainder? For now we take the |
3793 |
|
middle ground: test, then if divisible, use the faster div |
3794 |
|
func. */ |
3795 |
|
|
3796 |
long abs_yy = yy < 0 ? -yy : yy; |
long abs_yy = yy < 0 ? -yy : yy; |
3797 |
int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy); |
int divisible_p = mpz_divisible_ui_p (SCM_I_BIG_MPZ (x), abs_yy); |
3798 |
|
|
3799 |
if (divisible_p) { |
if (divisible_p) |
3800 |
SCM result = scm_i_mkbig (); |
{ |
3801 |
mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy); |
SCM result = scm_i_mkbig (); |
3802 |
scm_remember_upto_here_1 (x); |
mpz_divexact_ui (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (x), abs_yy); |
3803 |
if (yy < 0) |
scm_remember_upto_here_1 (x); |
3804 |
mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
if (yy < 0) |
3805 |
return scm_i_normbig (result); |
mpz_neg (SCM_I_BIG_MPZ (result), SCM_I_BIG_MPZ (result)); |
3806 |
} |
return scm_i_normbig (result); |
3807 |
else { |
} |
3808 |
return scm_make_real (scm_i_big2dbl (x) / (double) yy); |
else |
3809 |
} |
return scm_make_real (scm_i_big2dbl (x) / (double) yy); |
3810 |
} |
} |
3811 |
} else if (SCM_BIGP (y)) { |
} |
3812 |
int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0); |
else if (SCM_BIGP (y)) |
3813 |
if (y_is_zero) { |
{ |
3814 |
|
int y_is_zero = (mpz_sgn (SCM_I_BIG_MPZ (y)) == 0); |
3815 |
|
if (y_is_zero) |
3816 |
|
{ |
3817 |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3818 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3819 |
#else |
#else |
3820 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (x)); |
3821 |
scm_remember_upto_here_1 (x); |
scm_remember_upto_here_1 (x); |
3822 |
return (sgn == 0) ? scm_nan () : scm_inf (); |
return (sgn == 0) ? scm_nan () : scm_inf (); |
3823 |
#endif |
#endif |
3824 |
} else { |
} |
3825 |
/* big_x / big_y */ |
else |
3826 |
int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), |
{ |
3827 |
SCM_I_BIG_MPZ (y)); |
/* big_x / big_y */ |
3828 |
if (divisible_p) { |
int divisible_p = mpz_divisible_p (SCM_I_BIG_MPZ (x), |
3829 |
SCM result = scm_i_mkbig (); |
SCM_I_BIG_MPZ (y)); |
3830 |
mpz_divexact (SCM_I_BIG_MPZ (result), |
if (divisible_p) |
3831 |
SCM_I_BIG_MPZ (x), |
{ |
3832 |
SCM_I_BIG_MPZ (y)); |
SCM result = scm_i_mkbig (); |
3833 |
scm_remember_upto_here_2 (x, y); |
mpz_divexact (SCM_I_BIG_MPZ (result), |
3834 |
return scm_i_normbig (result); |
SCM_I_BIG_MPZ (x), |
3835 |
} |
SCM_I_BIG_MPZ (y)); |
3836 |
else { |
scm_remember_upto_here_2 (x, y); |
3837 |
double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); |
return scm_i_normbig (result); |
3838 |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
} |
3839 |
scm_remember_upto_here_2 (x, y); |
else |
3840 |
return scm_make_real (dbx / dby); |
{ |
3841 |
} |
double dbx = mpz_get_d (SCM_I_BIG_MPZ (x)); |
3842 |
} |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
3843 |
} else if (SCM_REALP (y)) { |
scm_remember_upto_here_2 (x, y); |
3844 |
double yy = SCM_REAL_VALUE (y); |
return scm_make_real (dbx / dby); |
3845 |
|
} |
3846 |
|
} |
3847 |
|
} |
3848 |
|
else if (SCM_REALP (y)) |
3849 |
|
{ |
3850 |
|
double yy = SCM_REAL_VALUE (y); |
3851 |
#ifndef ALLOW_DIVIDE_BY_ZERO |
#ifndef ALLOW_DIVIDE_BY_ZERO |
3852 |
if (yy == 0.0) |
if (yy == 0.0) |
3853 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3854 |
else |
else |
3855 |
#endif |
#endif |
3856 |
return scm_make_real (scm_i_big2dbl (x) / yy); |
return scm_make_real (scm_i_big2dbl (x) / yy); |
3857 |
} else if (SCM_COMPLEXP (y)) { |
} |
3858 |
a = scm_i_big2dbl (x); |
else if (SCM_COMPLEXP (y)) |
3859 |
goto complex_div; |
{ |
3860 |
} else { |
a = scm_i_big2dbl (x); |
3861 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
goto complex_div; |
3862 |
} |
} |
|
} else if (SCM_REALP (x)) { |
|
|
double rx = SCM_REAL_VALUE (x); |
|
|
if (SCM_INUMP (y)) { |
|
|
long int yy = SCM_INUM (y); |
|
|
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
|
|
if (yy == 0) |
|
|
scm_num_overflow (s_divide); |
|
3863 |
else |
else |
3864 |
|
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3865 |
|
} |
3866 |
|
else if (SCM_REALP (x)) |
3867 |
|
{ |
3868 |
|
double rx = SCM_REAL_VALUE (x); |
3869 |
|
if (SCM_INUMP (y)) |
3870 |
|
{ |
3871 |
|
long int yy = SCM_INUM (y); |
3872 |
|
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3873 |
|
if (yy == 0) |
3874 |
|
scm_num_overflow (s_divide); |
3875 |
|
else |
3876 |
#endif |
#endif |
3877 |
return scm_make_real (rx / (double) yy); |
return scm_make_real (rx / (double) yy); |
3878 |
} else if (SCM_BIGP (y)) { |
} |
3879 |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
else if (SCM_BIGP (y)) |
3880 |
scm_remember_upto_here_1 (y); |
{ |
3881 |
return scm_make_real (rx / dby); |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
3882 |
} else if (SCM_REALP (y)) { |
scm_remember_upto_here_1 (y); |
3883 |
double yy = SCM_REAL_VALUE (y); |
return scm_make_real (rx / dby); |
3884 |
|
} |
3885 |
|
else if (SCM_REALP (y)) |
3886 |
|
{ |
3887 |
|
double yy = SCM_REAL_VALUE (y); |
3888 |
#ifndef ALLOW_DIVIDE_BY_ZERO |
#ifndef ALLOW_DIVIDE_BY_ZERO |
3889 |
if (yy == 0.0) |
if (yy == 0.0) |
3890 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3891 |
else |
else |
3892 |
#endif |
#endif |
3893 |
return scm_make_real (rx / yy); |
return scm_make_real (rx / yy); |
3894 |
} else if (SCM_COMPLEXP (y)) { |
} |
3895 |
a = rx; |
else if (SCM_COMPLEXP (y)) |
3896 |
goto complex_div; |
{ |
3897 |
} else { |
a = rx; |
3898 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
goto complex_div; |
3899 |
} |
} |
|
} else if (SCM_COMPLEXP (x)) { |
|
|
double rx = SCM_COMPLEX_REAL (x); |
|
|
double ix = SCM_COMPLEX_IMAG (x); |
|
|
if (SCM_INUMP (y)) { |
|
|
long int yy = SCM_INUM (y); |
|
|
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
|
|
if (yy == 0) |
|
|
scm_num_overflow (s_divide); |
|
3900 |
else |
else |
3901 |
|
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3902 |
|
} |
3903 |
|
else if (SCM_COMPLEXP (x)) |
3904 |
|
{ |
3905 |
|
double rx = SCM_COMPLEX_REAL (x); |
3906 |
|
double ix = SCM_COMPLEX_IMAG (x); |
3907 |
|
if (SCM_INUMP (y)) |
3908 |
|
{ |
3909 |
|
long int yy = SCM_INUM (y); |
3910 |
|
#ifndef ALLOW_DIVIDE_BY_EXACT_ZERO |
3911 |
|
if (yy == 0) |
3912 |
|
scm_num_overflow (s_divide); |
3913 |
|
else |
3914 |
#endif |
#endif |
3915 |
{ |
{ |
3916 |
double d = yy; |
double d = yy; |
3917 |
return scm_make_complex (rx / d, ix / d); |
return scm_make_complex (rx / d, ix / d); |
3918 |
} |
} |
3919 |
} else if (SCM_BIGP (y)) { |
} |
3920 |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
else if (SCM_BIGP (y)) |
3921 |
scm_remember_upto_here_1 (y); |
{ |
3922 |
return scm_make_complex (rx / dby, ix / dby); |
double dby = mpz_get_d (SCM_I_BIG_MPZ (y)); |
3923 |
} else if (SCM_REALP (y)) { |
scm_remember_upto_here_1 (y); |
3924 |
double yy = SCM_REAL_VALUE (y); |
return scm_make_complex (rx / dby, ix / dby); |
3925 |
|
} |
3926 |
|
else if (SCM_REALP (y)) |
3927 |
|
{ |
3928 |
|
double yy = SCM_REAL_VALUE (y); |
3929 |
#ifndef ALLOW_DIVIDE_BY_ZERO |
#ifndef ALLOW_DIVIDE_BY_ZERO |
3930 |
if (yy == 0.0) |
if (yy == 0.0) |
3931 |
scm_num_overflow (s_divide); |
scm_num_overflow (s_divide); |
3932 |
else |
else |
3933 |
#endif |
#endif |
3934 |
return scm_make_complex (rx / yy, ix / yy); |
return scm_make_complex (rx / yy, ix / yy); |
3935 |
} else if (SCM_COMPLEXP (y)) { |
} |
3936 |
double ry = SCM_COMPLEX_REAL (y); |
else if (SCM_COMPLEXP (y)) |
3937 |
double iy = SCM_COMPLEX_IMAG (y); |
{ |
3938 |
if (ry <= iy) { |
double ry = SCM_COMPLEX_REAL (y); |
3939 |
double t = ry / iy; |
double iy = SCM_COMPLEX_IMAG (y); |
3940 |
double d = iy * (1.0 + t * t); |
if (ry <= iy) |
3941 |
return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); |
{ |
3942 |
} else { |
double t = ry / iy; |
3943 |
double t = iy / ry; |
double d = iy * (1.0 + t * t); |
3944 |
double d = ry * (1.0 + t * t); |
return scm_make_complex ((rx * t + ix) / d, (ix * t - rx) / d); |
3945 |
return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); |
} |
3946 |
} |
else |
3947 |
} else { |
{ |
3948 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
double t = iy / ry; |
3949 |
|
double d = ry * (1.0 + t * t); |
3950 |
|
return scm_make_complex ((rx + ix * t) / d, (ix - rx * t) / d); |
3951 |
|
} |
3952 |
|
} |
3953 |
|
else |
3954 |
|
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARGn, s_divide); |
3955 |
} |
} |
3956 |
} else { |
else |
3957 |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); |
SCM_WTA_DISPATCH_2 (g_divide, x, y, SCM_ARG1, s_divide); |
|
} |
|
3958 |
} |
} |
3959 |
#undef FUNC_NAME |
#undef FUNC_NAME |
3960 |
|
|
4031 |
double plus_half = x + 0.5; |
double plus_half = x + 0.5; |
4032 |
double result = floor (plus_half); |
double result = floor (plus_half); |
4033 |
/* Adjust so that the scm_round is towards even. */ |
/* Adjust so that the scm_round is towards even. */ |
4034 |
return (plus_half == result && plus_half / 2 != floor (plus_half / 2)) |
return ((plus_half == result && plus_half / 2 != floor (plus_half / 2)) |
4035 |
? result - 1 : result; |
? result - 1 |
4036 |
|
: result); |
4037 |
} |
} |
4038 |
|
|
4039 |
|
|
4096 |
static void |
static void |
4097 |
scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) |
scm_two_doubles (SCM x, SCM y, const char *sstring, struct dpair *xy) |
4098 |
{ |
{ |
4099 |
if (SCM_INUMP (x)) { |
if (SCM_INUMP (x)) |
4100 |
xy->x = SCM_INUM (x); |
xy->x = SCM_INUM (x); |
4101 |
} else if (SCM_BIGP (x)) { |
else if (SCM_BIGP (x)) |
4102 |
xy->x = scm_i_big2dbl (x); |
xy->x = scm_i_big2dbl (x); |
4103 |
} else if (SCM_REALP (x)) { |
else if (SCM_REALP (x)) |
4104 |
xy->x = SCM_REAL_VALUE (x); |
xy->x = SCM_REAL_VALUE (x); |
4105 |
} else { |
else |
4106 |
scm_wrong_type_arg (sstring, SCM_ARG1, x); |
scm_wrong_type_arg (sstring, SCM_ARG1, x); |
|
} |
|
4107 |
|
|
4108 |
if (SCM_INUMP (y)) { |
if (SCM_INUMP (y)) |
4109 |
xy->y = SCM_INUM (y); |
xy->y = SCM_INUM (y); |
4110 |
} else if (SCM_BIGP (y)) { |
else if (SCM_BIGP (y)) |
4111 |
xy->y = scm_i_big2dbl (y); |
xy->y = scm_i_big2dbl (y); |
4112 |
} else if (SCM_REALP (y)) { |
else if (SCM_REALP (y)) |
4113 |
xy->y = SCM_REAL_VALUE (y); |
xy->y = SCM_REAL_VALUE (y); |
4114 |
} else { |
else |
4115 |
scm_wrong_type_arg (sstring, SCM_ARG2, y); |
scm_wrong_type_arg (sstring, SCM_ARG2, y); |
|
} |
|
4116 |
} |
} |
4117 |
|
|
4118 |
|
|
4184 |
SCM |
SCM |
4185 |
scm_real_part (SCM z) |
scm_real_part (SCM z) |
4186 |
{ |
{ |
4187 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
4188 |
return z; |
return z; |
4189 |
} else if (SCM_BIGP (z)) { |
else if (SCM_BIGP (z)) |
4190 |
return z; |
return z; |
4191 |
} else if (SCM_REALP (z)) { |
else if (SCM_REALP (z)) |
4192 |
return z; |
return z; |
4193 |
} else if (SCM_COMPLEXP (z)) { |
else if (SCM_COMPLEXP (z)) |
4194 |
return scm_make_real (SCM_COMPLEX_REAL (z)); |
return scm_make_real (SCM_COMPLEX_REAL (z)); |
4195 |
} else { |
else |
4196 |
SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); |
SCM_WTA_DISPATCH_1 (g_real_part, z, SCM_ARG1, s_real_part); |
|
} |
|
4197 |
} |
} |
4198 |
|
|
4199 |
|
|
4203 |
SCM |
SCM |
4204 |
scm_imag_part (SCM z) |
scm_imag_part (SCM z) |
4205 |
{ |
{ |
4206 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
4207 |
return SCM_INUM0; |
return SCM_INUM0; |
4208 |
} else if (SCM_BIGP (z)) { |
else if (SCM_BIGP (z)) |
4209 |
return SCM_INUM0; |
return SCM_INUM0; |
4210 |
} else if (SCM_REALP (z)) { |
else if (SCM_REALP (z)) |
4211 |
return scm_flo0; |
return scm_flo0; |
4212 |
} else if (SCM_COMPLEXP (z)) { |
else if (SCM_COMPLEXP (z)) |
4213 |
return scm_make_real (SCM_COMPLEX_IMAG (z)); |
return scm_make_real (SCM_COMPLEX_IMAG (z)); |
4214 |
} else { |
else |
4215 |
SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part); |
SCM_WTA_DISPATCH_1 (g_imag_part, z, SCM_ARG1, s_imag_part); |
|
} |
|
4216 |
} |
} |
4217 |
|
|
4218 |
|
|
4223 |
SCM |
SCM |
4224 |
scm_magnitude (SCM z) |
scm_magnitude (SCM z) |
4225 |
{ |
{ |
4226 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
4227 |
long int zz = SCM_INUM (z); |
{ |
4228 |
if (zz >= 0) { |
long int zz = SCM_INUM (z); |
4229 |
return z; |
if (zz >= 0) |
4230 |
} else if (SCM_POSFIXABLE (-zz)) { |
return z; |
4231 |
return SCM_MAKINUM (-zz); |
else if (SCM_POSFIXABLE (-zz)) |
4232 |
} else { |
return SCM_MAKINUM (-zz); |
4233 |
return scm_i_long2big (-zz); |
else |
4234 |
} |
return scm_i_long2big (-zz); |
4235 |
} else if (SCM_BIGP (z)) { |
} |
4236 |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); |
else if (SCM_BIGP (z)) |
4237 |
scm_remember_upto_here_1 (z); |
{ |
4238 |
if (sgn < 0) { |
int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); |
4239 |
return scm_i_clonebig (z, 0); |
scm_remember_upto_here_1 (z); |
4240 |
} else { |
if (sgn < 0) |
4241 |
return z; |
return scm_i_clonebig (z, 0); |
4242 |
|
else |
4243 |
|
return z; |
4244 |
} |
} |
4245 |
} else if (SCM_REALP (z)) { |
else if (SCM_REALP (z)) |
4246 |
return scm_make_real (fabs (SCM_REAL_VALUE (z))); |
return scm_make_real (fabs (SCM_REAL_VALUE (z))); |
4247 |
} else if (SCM_COMPLEXP (z)) { |
else if (SCM_COMPLEXP (z)) |
4248 |
return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z))); |
return scm_make_real (hypot (SCM_COMPLEX_REAL (z), SCM_COMPLEX_IMAG (z))); |
4249 |
} else { |
else |
4250 |
SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude); |
SCM_WTA_DISPATCH_1 (g_magnitude, z, SCM_ARG1, s_magnitude); |
|
} |
|
4251 |
} |
} |
4252 |
|
|
4253 |
|
|
4257 |
SCM |
SCM |
4258 |
scm_angle (SCM z) |
scm_angle (SCM z) |
4259 |
{ |
{ |
4260 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
4261 |
if (SCM_INUM (z) >= 0) { |
{ |
4262 |
return scm_make_real (atan2 (0.0, 1.0)); |
if (SCM_INUM (z) >= 0) |
4263 |
} else { |
return scm_make_real (atan2 (0.0, 1.0)); |
4264 |
return scm_make_real (atan2 (0.0, -1.0)); |
else |
4265 |
} |
return scm_make_real (atan2 (0.0, -1.0)); |
|
} else if (SCM_BIGP (z)) { |
|
|
int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); |
|
|
scm_remember_upto_here_1 (z); |
|
|
if (sgn < 0) { |
|
|
return scm_make_real (atan2 (0.0, -1.0)); |
|
|
} else { |
|
|
return scm_make_real (atan2 (0.0, 1.0)); |
|
4266 |
} |
} |
4267 |
} else if (SCM_REALP (z)) { |
else if (SCM_BIGP (z)) |
4268 |
|
{ |
4269 |
|
int sgn = mpz_sgn (SCM_I_BIG_MPZ (z)); |
4270 |
|
scm_remember_upto_here_1 (z); |
4271 |
|
if (sgn < 0) |
4272 |
|
return scm_make_real (atan2 (0.0, -1.0)); |
4273 |
|
else |
4274 |
|
return scm_make_real (atan2 (0.0, 1.0)); |
4275 |
|
} |
4276 |
|
else if (SCM_REALP (z)) |
4277 |
return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z))); |
return scm_make_real (atan2 (0.0, SCM_REAL_VALUE (z))); |
4278 |
} else if (SCM_COMPLEXP (z)) { |
else if (SCM_COMPLEXP (z)) |
4279 |
return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); |
return scm_make_real (atan2 (SCM_COMPLEX_IMAG (z), SCM_COMPLEX_REAL (z))); |
4280 |
} else { |
else |
4281 |
SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); |
SCM_WTA_DISPATCH_1 (g_angle, z, SCM_ARG1, s_angle); |
|
} |
|
4282 |
} |
} |
4283 |
|
|
4284 |
|
|
4304 |
"Return an exact number that is numerically closest to @var{z}.") |
"Return an exact number that is numerically closest to @var{z}.") |
4305 |
#define FUNC_NAME s_scm_inexact_to_exact |
#define FUNC_NAME s_scm_inexact_to_exact |
4306 |
{ |
{ |
4307 |
if (SCM_INUMP (z)) { |
if (SCM_INUMP (z)) |
4308 |
return z; |
return z; |
4309 |
} else if (SCM_BIGP (z)) { |
else if (SCM_BIGP (z)) |
4310 |
return z; |
return z; |
4311 |
} else if (SCM_REALP (z)) { |
else if (SCM_REALP (z)) |
4312 |
double u = floor (SCM_REAL_VALUE (z) + 0.5); |
{ |
4313 |
long lu = (long) u; |
double u = floor (SCM_REAL_VALUE (z) + 0.5); |
4314 |
if (SCM_FIXABLE (lu)) { |
long lu = (long) u; |
4315 |
return SCM_MAKINUM (lu); |
if (SCM_FIXABLE (lu)) |
4316 |
} else if (!xisinf (u) && !xisnan (u)) { |
return SCM_MAKINUM (lu); |
4317 |
return scm_i_dbl2big (u); |
else if (!xisinf (u) && !xisnan (u)) |
4318 |
} else { |
return scm_i_dbl2big (u); |
4319 |
scm_num_overflow (s_scm_inexact_to_exact); |
else |
4320 |
|
scm_num_overflow (s_scm_inexact_to_exact); |
4321 |
} |
} |
4322 |
} else { |
else |
4323 |
SCM_WRONG_TYPE_ARG (1, z); |
SCM_WRONG_TYPE_ARG (1, z); |
|
} |
|
4324 |
} |
} |
4325 |
#undef FUNC_NAME |
#undef FUNC_NAME |
4326 |
|
|
4479 |
#define PTRDIFF_MAX (~ PTRDIFF_MIN) |
#define PTRDIFF_MAX (~ PTRDIFF_MIN) |
4480 |
#endif |
#endif |
4481 |
|
|
4482 |
#define CHECK(type, v) \ |
#define CHECK(type, v) \ |
4483 |
do { \ |
do \ |
4484 |
if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ |
{ \ |
4485 |
abort (); \ |
if ((v) != scm_num2##type (scm_##type##2num (v), 1, "check_sanity")) \ |
4486 |
} while (0); |
abort (); \ |
4487 |
|
} \ |
4488 |
|
while (0) |
4489 |
|
|
4490 |
static void |
static void |
4491 |
check_sanity () |
check_sanity () |
4601 |
{ /* determine floating point precision */ |
{ /* determine floating point precision */ |
4602 |
double f = 0.1; |
double f = 0.1; |
4603 |
double fsum = 1.0 + f; |
double fsum = 1.0 + f; |
4604 |
while (fsum != 1.0) { |
while (fsum != 1.0) |
4605 |
if (++scm_dblprec > 20) { |
{ |
4606 |
fsum = 1.0; |
if (++scm_dblprec > 20) |
4607 |
} else { |
fsum = 1.0; |
4608 |
f /= 10.0; |
else |
4609 |
fsum = f + 1.0; |
{ |
4610 |
|
f /= 10.0; |
4611 |
|
fsum = f + 1.0; |
4612 |
|
} |
4613 |
} |
} |
|
} |
|
4614 |
scm_dblprec = scm_dblprec - 1; |
scm_dblprec = scm_dblprec - 1; |
4615 |
} |
} |
4616 |
#endif /* DBL_DIG */ |
#endif /* DBL_DIG */ |