… | |
… | |
219 | #if USE_MATH |
219 | #if USE_MATH |
220 | static double round_per_R5RS (double x); |
220 | static double round_per_R5RS (double x); |
221 | #endif |
221 | #endif |
222 | static int is_zero_rvalue (RVALUE x); |
222 | static int is_zero_rvalue (RVALUE x); |
223 | |
223 | |
224 | ecb_inline int |
|
|
225 | num_is_integer (pointer p) |
|
|
226 | { |
|
|
227 | return num_is_fixnum (p->object.number); |
|
|
228 | } |
|
|
229 | |
|
|
230 | static num num_zero; |
224 | static num num_zero; |
231 | static num num_one; |
225 | static num num_one; |
232 | |
226 | |
233 | /* macros for cell operations */ |
227 | /* macros for cell operations */ |
234 | #define typeflag(p) ((p)->flag + 0) |
228 | #define typeflag(p) ((p)->flag + 0) |
… | |
… | |
272 | } |
266 | } |
273 | |
267 | |
274 | INTERFACE int |
268 | INTERFACE int |
275 | is_integer (pointer p) |
269 | is_integer (pointer p) |
276 | { |
270 | { |
277 | if (!is_number (p)) |
271 | return is_number (p) && num_is_fixnum (p->object.number); |
278 | return 0; |
|
|
279 | |
|
|
280 | if (num_is_integer (p) || ivalue (p) == rvalue (p)) |
|
|
281 | return 1; |
|
|
282 | |
|
|
283 | return 0; |
|
|
284 | } |
272 | } |
285 | |
273 | |
286 | INTERFACE int |
274 | INTERFACE int |
287 | is_real (pointer p) |
275 | is_real (pointer p) |
288 | { |
276 | { |
… | |
… | |
2480 | { |
2468 | { |
2481 | p = SCHEME_V->strbuff; |
2469 | p = SCHEME_V->strbuff; |
2482 | |
2470 | |
2483 | if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ |
2471 | if (f <= 1 || f == 10) /* f is the base for numbers if > 1 */ |
2484 | { |
2472 | { |
2485 | if (num_is_integer (l)) |
2473 | if (is_integer (l)) |
2486 | xnum (p, ivalue_unchecked (l)); |
2474 | xnum (p, ivalue_unchecked (l)); |
2487 | #if USE_REAL |
2475 | #if USE_REAL |
2488 | else |
2476 | else |
2489 | { |
2477 | { |
2490 | snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); |
2478 | snprintf (p, STRBUFFSIZE, "%.10g", rvalue_unchecked (l)); |
… | |
… | |
2745 | return 0; |
2733 | return 0; |
2746 | } |
2734 | } |
2747 | else if (is_number (a)) |
2735 | else if (is_number (a)) |
2748 | { |
2736 | { |
2749 | if (is_number (b)) |
2737 | if (is_number (b)) |
2750 | if (num_is_integer (a) == num_is_integer (b)) |
|
|
2751 | return num_cmp (nvalue (a), nvalue (b)) == 0; |
2738 | return num_cmp (nvalue (a), nvalue (b)) == 0; |
2752 | |
2739 | |
2753 | return 0; |
2740 | return 0; |
2754 | } |
2741 | } |
2755 | else if (is_character (a)) |
2742 | else if (is_character (a)) |
2756 | { |
2743 | { |
… | |
… | |
3930 | |
3917 | |
3931 | switch (op) |
3918 | switch (op) |
3932 | { |
3919 | { |
3933 | #if USE_MATH |
3920 | #if USE_MATH |
3934 | case OP_INEX2EX: /* inexact->exact */ |
3921 | case OP_INEX2EX: /* inexact->exact */ |
3935 | if (num_is_integer (x)) |
3922 | if (is_integer (x)) |
3936 | s_return (x); |
3923 | s_return (x); |
3937 | else if (modf (rvalue_unchecked (x), &dd) == 0) |
3924 | else if (modf (rvalue_unchecked (x), &dd) == 0) |
3938 | s_return (mk_integer (SCHEME_A_ ivalue (x))); |
3925 | s_return (mk_integer (SCHEME_A_ ivalue (x))); |
3939 | else |
3926 | else |
3940 | Error_1 ("inexact->exact: not integral:", x); |
3927 | Error_1 ("inexact->exact: not integral:", x); |
… | |
… | |
3963 | { |
3950 | { |
3964 | RVALUE result; |
3951 | RVALUE result; |
3965 | int real_result = 1; |
3952 | int real_result = 1; |
3966 | pointer y = cadr (args); |
3953 | pointer y = cadr (args); |
3967 | |
3954 | |
3968 | if (num_is_integer (x) && num_is_integer (y)) |
3955 | if (is_integer (x) && is_integer (y)) |
3969 | real_result = 0; |
3956 | real_result = 0; |
3970 | |
3957 | |
3971 | /* This 'if' is an R5RS compatibility fix. */ |
3958 | /* This 'if' is an R5RS compatibility fix. */ |
3972 | /* NOTE: Remove this 'if' fix for R6RS. */ |
3959 | /* NOTE: Remove this 'if' fix for R6RS. */ |
3973 | if (rvalue (x) == 0 && rvalue (y) < 0) |
3960 | if (rvalue (x) == 0 && rvalue (y) < 0) |