diff --git a/contrib/10.math/math.c b/contrib/10.math/math.c index 329f78a1..012be4ec 100644 --- a/contrib/10.math/math.c +++ b/contrib/10.math/math.c @@ -1,5 +1,110 @@ #include "picrin.h" +static pic_value +pic_number_floor2(pic_state *pic) +{ + int i, j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + int k; + + k = (i < 0 && j < 0) || (0 <= i && 0 <= j) + ? i / j + : (i / j) - 1; + + return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); + } else { + double q, r; + + q = floor((double)i/j); + r = i - j * q; + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_trunc2(pic_state *pic) +{ + int i, j; + bool e1, e2; + + pic_get_args(pic, "II", &i, &e1, &j, &e2); + + if (e1 && e2) { + return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); + } else { + double q, r; + + q = trunc((double)i/j); + r = i - j * q; + + return pic_values2(pic, pic_float_value(q), pic_float_value(r)); + } +} + +static pic_value +pic_number_floor(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } else { + return pic_float_value(floor(f)); + } +} + +static pic_value +pic_number_ceil(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } else { + return pic_float_value(ceil(f)); + } +} + +static pic_value +pic_number_trunc(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } else { + return pic_float_value(trunc(f)); + } +} + +static pic_value +pic_number_round(pic_state *pic) +{ + double f; + bool e; + + pic_get_args(pic, "F", &f, &e); + + if (e) { + return pic_int_value((int)f); + } else { + return pic_float_value(round(f)); + } +} + static pic_value pic_number_finite_p(pic_state *pic) { @@ -145,6 +250,14 @@ void pic_init_math(pic_state *pic) { pic_deflibrary (pic, "(picrin math)") { + pic_defun(pic, "floor/", pic_number_floor2); + pic_defun(pic, "truncate/", pic_number_trunc2); + + pic_defun(pic, "floor", pic_number_floor); + pic_defun(pic, "ceiling", pic_number_ceil); + pic_defun(pic, "truncate", pic_number_trunc); + pic_defun(pic, "round", pic_number_round); + pic_defun(pic, "finite?", pic_number_finite_p); pic_defun(pic, "infinite?", pic_number_infinite_p); pic_defun(pic, "nan?", pic_number_nan_p); diff --git a/contrib/20.r7rs/scheme/base.scm b/contrib/20.r7rs/scheme/base.scm index 1e05cdec..590ac754 100644 --- a/contrib/20.r7rs/scheme/base.scm +++ b/contrib/20.r7rs/scheme/base.scm @@ -1,6 +1,13 @@ (define-library (scheme base) (import (picrin base) - (only (picrin math) sqrt) + (only (picrin math) + floor/ + truncate/ + floor + ceiling + truncate + round + sqrt) (picrin macro) (picrin string) (scheme file)) diff --git a/extlib/benz/number.c b/extlib/benz/number.c index 3999a328..f234b700 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -133,6 +133,26 @@ pic_number_inexact_p(pic_state *pic) #endif } +static pic_value +pic_number_inexact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_float_value(f); +} + +static pic_value +pic_number_exact(pic_state *pic) +{ + double f; + + pic_get_args(pic, "f", &f); + + return pic_int_value((int)(round(f))); +} + #define DEFINE_ARITH_CMP(op, name) \ static pic_value \ pic_number_##name(pic_state *pic) \ @@ -391,159 +411,6 @@ pic_number_expt(pic_state *pic) #endif } -static pic_value -pic_number_floor2(pic_state *pic) -{ -#if PIC_ENABLE_FLOAT - int i, j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - int k; - - k = (i < 0 && j < 0) || (0 <= i && 0 <= j) - ? i / j - : (i / j) - 1; - - return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); - } - else { - double q, r; - - q = floor((double)i/j); - r = i - j * q; - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); - } -#else - int i, j, k; - - pic_get_args(pic, "ii", &i, &j); - - k = (i < 0 && j < 0) || (0 <= i && 0 <= j) - ? i / j - : (i / j) - 1; - - return pic_values2(pic, pic_int_value(k), pic_int_value(i - k * j)); -#endif -} - -static pic_value -pic_number_trunc2(pic_state *pic) -{ -#if PIC_ENABLE_FLOAT - int i, j; - bool e1, e2; - - pic_get_args(pic, "II", &i, &e1, &j, &e2); - - if (e1 && e2) { - return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); - } - else { - double q, r; - - q = trunc((double)i/j); - r = i - j * q; - - return pic_values2(pic, pic_float_value(q), pic_float_value(r)); - } -#else - int i, j; - - pic_get_args(pic, "ii", &i, &j); - - return pic_values2(pic, pic_int_value(i/j), pic_int_value(i - (i/j) * j)); -#endif -} - -#if PIC_ENABLE_FLOAT -static pic_value -pic_number_floor(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(floor(f)); - } -} - -static pic_value -pic_number_ceil(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(ceil(f)); - } -} - -static pic_value -pic_number_trunc(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(trunc(f)); - } -} - -static pic_value -pic_number_round(pic_state *pic) -{ - double f; - bool e; - - pic_get_args(pic, "F", &f, &e); - - if (e) { - return pic_int_value((int)f); - } - else { - return pic_float_value(round(f)); - } -} - -static pic_value -pic_number_inexact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_float_value(f); -} - -static pic_value -pic_number_exact(pic_state *pic) -{ - double f; - - pic_get_args(pic, "f", &f); - - return pic_int_value((int)(round(f))); -} -#endif - static pic_value pic_number_number_to_string(pic_state *pic) { @@ -671,6 +538,10 @@ pic_init_number(pic_state *pic) pic_defun(pic, "inexact?", pic_number_inexact_p); pic_gc_arena_restore(pic, ai); + pic_defun(pic, "inexact", pic_number_inexact); + pic_defun(pic, "exact", pic_number_exact); + pic_gc_arena_restore(pic, ai); + pic_defun(pic, "=", pic_number_eq); pic_defun(pic, "<", pic_number_lt); pic_defun(pic, ">", pic_number_gt); @@ -688,28 +559,6 @@ pic_init_number(pic_state *pic) pic_defun(pic, "expt", pic_number_expt); pic_gc_arena_restore(pic, ai); - pic_defun(pic, "floor/", pic_number_floor2); - pic_defun(pic, "truncate/", pic_number_trunc2); - pic_gc_arena_restore(pic, ai); - -#if PIC_ENABLE_FLOAT - pic_defun(pic, "floor", pic_number_floor); - pic_defun(pic, "ceiling", pic_number_ceil); - pic_defun(pic, "truncate", pic_number_trunc); - pic_defun(pic, "round", pic_number_round); - pic_defun(pic, "inexact", pic_number_inexact); - pic_defun(pic, "exact", pic_number_exact); - pic_gc_arena_restore(pic, ai); -#else - pic_defun(pic, "floor", pic_number_id); - pic_defun(pic, "ceiling", pic_number_id); - pic_defun(pic, "truncate", pic_number_id); - pic_defun(pic, "round", pic_number_id); - pic_defun(pic, "inexact", pic_number_id); - pic_defun(pic, "exact", pic_number_id); - pic_gc_arena_restore(pic, ai); -#endif - pic_defun(pic, "number->string", pic_number_number_to_string); pic_defun(pic, "string->number", pic_number_string_to_number); pic_gc_arena_restore(pic, ai);