… | |
… | |
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 | { |
… | |
… | |
3912 | SCHEME_V->code = car (args); |
3899 | SCHEME_V->code = car (args); |
3913 | SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); |
3900 | SCHEME_V->args = cons (mk_continuation (SCHEME_A_ ss_get_cont (SCHEME_A)), NIL); |
3914 | s_goto (OP_APPLY); |
3901 | s_goto (OP_APPLY); |
3915 | } |
3902 | } |
3916 | |
3903 | |
3917 | abort (); |
3904 | if (USE_ERROR_CHECKING) abort (); |
3918 | } |
3905 | } |
3919 | |
3906 | |
3920 | static int |
3907 | static int |
3921 | opexe_1 (SCHEME_P_ enum scheme_opcodes op) |
3908 | opexe_1 (SCHEME_P_ enum scheme_opcodes op) |
3922 | { |
3909 | { |
… | |
… | |
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) |
… | |
… | |
4417 | set_vector_elem (x, index, caddr (args)); |
4404 | set_vector_elem (x, index, caddr (args)); |
4418 | s_return (x); |
4405 | s_return (x); |
4419 | } |
4406 | } |
4420 | } |
4407 | } |
4421 | |
4408 | |
4422 | abort (); |
4409 | if (USE_ERROR_CHECKING) abort (); |
4423 | } |
4410 | } |
4424 | |
4411 | |
4425 | INTERFACE int |
4412 | INTERFACE int |
4426 | is_list (SCHEME_P_ pointer a) |
4413 | is_list (SCHEME_P_ pointer a) |
4427 | { |
4414 | { |
… | |
… | |
4868 | case OP_CURR_ENV: /* current-environment */ |
4855 | case OP_CURR_ENV: /* current-environment */ |
4869 | s_return (SCHEME_V->envir); |
4856 | s_return (SCHEME_V->envir); |
4870 | |
4857 | |
4871 | } |
4858 | } |
4872 | |
4859 | |
4873 | abort (); |
4860 | if (USE_ERROR_CHECKING) abort (); |
4874 | } |
4861 | } |
4875 | |
4862 | |
4876 | static int |
4863 | static int |
4877 | opexe_5 (SCHEME_P_ enum scheme_opcodes op) |
4864 | opexe_5 (SCHEME_P_ enum scheme_opcodes op) |
4878 | { |
4865 | { |
… | |
… | |
5211 | s_goto (OP_P0LIST); |
5198 | s_goto (OP_P0LIST); |
5212 | } |
5199 | } |
5213 | } |
5200 | } |
5214 | } |
5201 | } |
5215 | |
5202 | |
5216 | abort (); |
5203 | if (USE_ERROR_CHECKING) abort (); |
5217 | } |
5204 | } |
5218 | |
5205 | |
5219 | static int |
5206 | static int |
5220 | opexe_6 (SCHEME_P_ enum scheme_opcodes op) |
5207 | opexe_6 (SCHEME_P_ enum scheme_opcodes op) |
5221 | { |
5208 | { |
… | |
… | |
5274 | |
5261 | |
5275 | case OP_MACROP: /* macro? */ |
5262 | case OP_MACROP: /* macro? */ |
5276 | s_retbool (is_macro (a)); |
5263 | s_retbool (is_macro (a)); |
5277 | } |
5264 | } |
5278 | |
5265 | |
5279 | abort (); |
5266 | if (USE_ERROR_CHECKING) abort (); |
5280 | } |
5267 | } |
5281 | |
5268 | |
5282 | /* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ |
5269 | /* dispatch functions (opexe_x) return new opcode, or 0 for same opcode, or -1 to stop */ |
5283 | typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); |
5270 | typedef int (*dispatch_func)(SCHEME_P_ enum scheme_opcodes); |
5284 | |
5271 | |