From 7dcd050e1a7bf87601709b87ffb63ea01d6c8b76 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Thu, 28 May 2015 01:48:38 +0900 Subject: [PATCH] add PIC_ENABLE_FLOAT and PIC_WORD_BOXING --- extlib/benz/codegen.c | 4 + extlib/benz/gc.c | 4 + extlib/benz/include/picrin.h | 6 +- extlib/benz/include/picrin/config.h | 36 +- extlib/benz/include/picrin/value.h | 110 +++++- extlib/benz/number.c | 582 +++++++++++++++++++--------- extlib/benz/read.c | 14 + extlib/benz/string.c | 2 + extlib/benz/vm.c | 47 +++ extlib/benz/write.c | 4 + 10 files changed, 615 insertions(+), 194 deletions(-) diff --git a/extlib/benz/codegen.c b/extlib/benz/codegen.c index f3f003ad..fdc209de 100644 --- a/extlib/benz/codegen.c +++ b/extlib/benz/codegen.c @@ -635,7 +635,11 @@ analyze_div(analyze_state *state, pic_value obj) switch (pic_length(pic, obj)) { case 2: args = pic_cdr(pic, obj); +#if PIC_ENABLE_FLOAT obj = pic_list3(pic, pic_car(pic, obj), pic_float_value(1), pic_car(pic, args)); +#else + obj = pic_list3(pic, pic_car(pic, obj), pic_int_value(1), pic_car(pic, args)); +#endif return analyze(state, obj, false); default: args = pic_cdr(pic, obj); diff --git a/extlib/benz/gc.c b/extlib/benz/gc.c index fd319454..74c3e7bf 100644 --- a/extlib/benz/gc.c +++ b/extlib/benz/gc.c @@ -489,7 +489,9 @@ gc_mark_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_NIL: case PIC_TT_BOOL: +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: +#endif case PIC_TT_INT: case PIC_TT_CHAR: case PIC_TT_EOF: @@ -691,7 +693,9 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj) } case PIC_TT_NIL: case PIC_TT_BOOL: +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: +#endif case PIC_TT_INT: case PIC_TT_CHAR: case PIC_TT_EOF: diff --git a/extlib/benz/include/picrin.h b/extlib/benz/include/picrin.h index eaefc79b..3d43a428 100644 --- a/extlib/benz/include/picrin.h +++ b/extlib/benz/include/picrin.h @@ -30,7 +30,6 @@ extern "C" { #include #include -#include #include #include @@ -38,12 +37,15 @@ extern "C" { #include #include #include -#include #include #include "picrin/config.h" #include "picrin/util.h" +#if PIC_ENABLE_FLOAT +# include +#endif + #include "picrin/xvect.h" #include "picrin/xhash.h" #include "picrin/xfile.h" diff --git a/extlib/benz/include/picrin/config.h b/extlib/benz/include/picrin/config.h index 2853c572..edf07594 100644 --- a/extlib/benz/include/picrin/config.h +++ b/extlib/benz/include/picrin/config.h @@ -8,6 +8,12 @@ /** switch internal value representation */ /* #define PIC_NAN_BOXING 1 */ +/** enable word boxing */ +/* #define PIC_WORD_BOXING 0 */ + +/** enable floating point number support */ +/* #define PIC_ENABLE_FLOAT 1 */ + /** treat false value as none */ /* #define PIC_NONE_IS_FALSE 1 */ @@ -50,12 +56,36 @@ # endif #endif -#ifndef PIC_NAN_BOXING -# if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1 -# define PIC_NAN_BOXING 1 +#if PIC_NAN_BOXING && PIC_WORD_BOXING +# error cannot enable both PIC_NAN_BOXING and PIC_WORD_BOXING simultaneously +#endif + +#if PIC_WORD_BOXING && PIC_ENABLE_FLOAT +# error cannot enable both PIC_WORD_BOXING and PIC_ENABLE_FLOAT simultaneously +#endif + +#ifndef PIC_WORD_BOXING +# define PIC_WORD_BOXING 0 +#endif + +#if ! PIC_WORD_BOXING +# ifndef PIC_NAN_BOXING +# if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1 +# define PIC_NAN_BOXING 1 +# endif # endif #endif +#ifndef PIC_ENABLE_FLOAT +# if ! PIC_WORD_BOXING +# define PIC_ENABLE_FLOAT 1 +# endif +#endif + +#if PIC_NAN_BOXING && defined(PIC_ENABLE_FLOAT) && ! PIC_ENABLE_FLOAT +# error cannot disable float support when nan boxing is on +#endif + #ifndef PIC_NONE_IS_FALSE # define PIC_NONE_IS_FALSE 1 #endif diff --git a/extlib/benz/include/picrin/value.h b/extlib/benz/include/picrin/value.h index 21a3e54d..42c65295 100644 --- a/extlib/benz/include/picrin/value.h +++ b/extlib/benz/include/picrin/value.h @@ -19,7 +19,9 @@ enum pic_vtype { PIC_VTYPE_TRUE, PIC_VTYPE_FALSE, PIC_VTYPE_UNDEF, +#if PIC_ENABLE_FLOAT PIC_VTYPE_FLOAT, +#endif PIC_VTYPE_INT, PIC_VTYPE_CHAR, PIC_VTYPE_EOF, @@ -28,6 +30,8 @@ enum pic_vtype { #if PIC_NAN_BOXING +#include + /** * value representation by nan-boxing: * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF @@ -65,13 +69,55 @@ pic_int(pic_value v) #define pic_char(v) ((v) & 0xfffffffful) +#elif PIC_WORD_BOXING + +typedef unsigned long pic_value; + +#define pic_ptr(v) ((void *)(v)) +#define pic_init_value(v,vtype) do { \ + v = (vtype << 3) + 7; \ + } while (0) + +PIC_INLINE enum pic_vtype +pic_vtype(pic_value v) +{ + if ((v & 1) == 0) { + return PIC_VTYPE_HEAP; + } + if ((v & 2) == 0) { + return PIC_VTYPE_INT; + } + if ((v & 4) == 0) { + return PIC_VTYPE_CHAR; + } + return v >> 3; +} + +PIC_INLINE int +pic_int(pic_value v) +{ + v >>= 2; + if ((v & ((ULONG_MAX >> 3) + 1)) != 0) { + v |= ULONG_MAX - (ULONG_MAX >> 2); + } + return v; +} + +PIC_INLINE char +pic_char(pic_value v) +{ + return v >> 3; +} + #else typedef struct { enum pic_vtype type; union { void *data; +#if PIC_ENABLE_FLOAT double f; +#endif int i; char c; } u; @@ -81,7 +127,9 @@ typedef struct { #define pic_vtype(v) ((v).type) #define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) -#define pic_float(v) ((v).u.f) +#if PIC_ENABLE_FLOAT +# define pic_float(v) ((v).u.f) +#endif #define pic_int(v) ((v).u.i) #define pic_char(v) ((v).u.c) @@ -91,7 +139,9 @@ enum pic_tt { /* immediate */ PIC_TT_NIL, PIC_TT_BOOL, +#if PIC_ENABLE_FLOAT PIC_TT_FLOAT, +#endif PIC_TT_INT, PIC_TT_CHAR, PIC_TT_EOF, @@ -161,7 +211,21 @@ PIC_INLINE const char *pic_type_repr(enum pic_tt); pic_errorf(pic, "expected " #type ", but got ~s", v); \ } -PIC_INLINE bool pic_valid_int(double); +#if PIC_ENABLE_FLOAT +PIC_INLINE bool +pic_valid_int(double v) +{ + return INT_MIN <= v && v <= INT_MAX; +} + +#else +PIC_INLINE bool +pic_valid_int(int v) +{ + PIC_UNUSED(v); + return true; +} +#endif PIC_INLINE pic_value pic_nil_value(); PIC_INLINE pic_value pic_true_value(); @@ -169,7 +233,9 @@ PIC_INLINE pic_value pic_false_value(); PIC_INLINE pic_value pic_bool_value(bool); PIC_INLINE pic_value pic_undef_value(); PIC_INLINE pic_value pic_obj_value(void *); +#if PIC_ENABLE_FLOAT PIC_INLINE pic_value pic_float_value(double); +#endif PIC_INLINE pic_value pic_int_value(int); PIC_INLINE pic_value pic_size_value(size_t); PIC_INLINE pic_value pic_char_value(char c); @@ -190,8 +256,10 @@ pic_type(pic_value v) return PIC_TT_BOOL; case PIC_VTYPE_UNDEF: return PIC_TT_UNDEF; +#if PIC_ENABLE_FLOAT case PIC_VTYPE_FLOAT: return PIC_TT_FLOAT; +#endif case PIC_VTYPE_INT: return PIC_TT_INT; case PIC_VTYPE_CHAR: @@ -213,8 +281,10 @@ pic_type_repr(enum pic_tt tt) return "nil"; case PIC_TT_BOOL: return "boolean"; +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: return "float"; +#endif case PIC_TT_INT: return "int"; case PIC_TT_SYMBOL: @@ -257,12 +327,6 @@ pic_type_repr(enum pic_tt tt) PIC_UNREACHABLE(); } -PIC_INLINE bool -pic_valid_int(double v) -{ - return INT_MIN <= v && v <= INT_MAX; -} - PIC_INLINE pic_value pic_nil_value() { @@ -302,11 +366,13 @@ pic_bool_value(bool b) PIC_INLINE pic_value pic_size_value(size_t s) { +#if PIC_ENABLE_FLOAT if (sizeof(unsigned) < sizeof(size_t)) { if (s > (size_t)INT_MAX) { return pic_float_value(s); } } +#endif return pic_int_value((int)s); } @@ -358,6 +424,26 @@ pic_char_value(char c) return v; } +#elif PIC_WORD_BOXING + +PIC_INLINE pic_value +pic_obj_value(void *ptr) +{ + return (pic_value)ptr; +} + +PIC_INLINE pic_value +pic_int_value(int i) +{ + return (i << 2) + 1; +} + +PIC_INLINE pic_value +pic_char_value(char c) +{ + return (c << 3) + 3; +} + #else PIC_INLINE pic_value @@ -370,6 +456,8 @@ pic_obj_value(void *ptr) return v; } +#if PIC_ENABLE_FLOAT + PIC_INLINE pic_value pic_float_value(double f) { @@ -380,6 +468,8 @@ pic_float_value(double f) return v; } +#endif + PIC_INLINE pic_value pic_int_value(int i) { @@ -421,7 +511,7 @@ pic_none_value() #endif } -#if PIC_NAN_BOXING +#if PIC_NAN_BOXING || PIC_WORD_BOXING PIC_INLINE bool pic_eq_p(pic_value x, pic_value y) @@ -464,8 +554,10 @@ pic_eqv_p(pic_value x, pic_value y) return true; case PIC_TT_BOOL: return pic_vtype(x) == pic_vtype(y); +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: return pic_float(x) == pic_float(y); +#endif case PIC_TT_INT: return pic_int(x) == pic_int(y); default: diff --git a/extlib/benz/number.c b/extlib/benz/number.c index c3ec4dcf..928ba50e 100644 --- a/extlib/benz/number.c +++ b/extlib/benz/number.c @@ -5,6 +5,19 @@ #include "picrin.h" #include "picrin/string.h" #include "picrin/cont.h" +#include "picrin/port.h" + +#if ! PIC_ENABLE_FLOAT +static pic_value +pic_number_id(pic_state *pic) +{ + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(i); +} +#endif /** * Returns the length of string representing val. @@ -66,7 +79,11 @@ pic_number_real_p(pic_state *pic) pic_get_args(pic, "o", &v); +#if PIC_ENABLE_FLOAT return pic_bool_value(pic_float_p(v) || pic_int_p(v)); +#else + return pic_bool_value(pic_int_p(v)); +#endif } static pic_value @@ -79,6 +96,7 @@ pic_number_integer_p(pic_state *pic) if (pic_int_p(v)) { return pic_true_value(); } +#if PIC_ENABLE_FLOAT if (pic_float_p(v)) { double f = pic_float(v); @@ -90,6 +108,7 @@ pic_number_integer_p(pic_state *pic) return pic_true_value(); } } +#endif return pic_false_value(); } @@ -110,48 +129,11 @@ pic_number_inexact_p(pic_state *pic) pic_get_args(pic, "o", &v); +#if PIC_ENABLE_FLOAT return pic_bool_value(pic_float_p(v)); -} - -static pic_value -pic_number_finite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_int_p(v)) - return pic_true_value(); - if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_infinite_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isinf(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); -} - -static pic_value -pic_number_nan_p(pic_state *pic) -{ - pic_value v; - - pic_get_args(pic, "o", &v); - - if (pic_float_p(v) && isnan(pic_float(v))) - return pic_true_value(); - else - return pic_false_value(); +#else + return pic_false_value(); +#endif } #define DEFINE_ARITH_CMP(op, name) \ @@ -183,11 +165,46 @@ pic_number_nan_p(pic_state *pic) return pic_true_value(); \ } +#define DEFINE_ARITH_CMP2(op, name) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f,g; \ + \ + pic_get_args(pic, "ii*", &f, &g, &argc, &argv); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + \ + for (i = 0; i < argc; ++i) { \ + f = g; \ + if (pic_int_p(argv[i])) \ + g = pic_int(argv[i]); \ + else \ + pic_errorf(pic, #op ": number required"); \ + \ + if (! (f op g)) \ + return pic_false_value(); \ + } \ + \ + return pic_true_value(); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_CMP(==, eq) DEFINE_ARITH_CMP(<, lt) DEFINE_ARITH_CMP(>, gt) DEFINE_ARITH_CMP(<=, le) DEFINE_ARITH_CMP(>=, ge) +#else +DEFINE_ARITH_CMP2(==, eq) +DEFINE_ARITH_CMP2(<, lt) +DEFINE_ARITH_CMP2(>, gt) +DEFINE_ARITH_CMP2(<=, le) +DEFINE_ARITH_CMP2(>=, ge) +#endif #define DEFINE_ARITH_OP(op, name, unit) \ static pic_value \ @@ -217,63 +234,170 @@ DEFINE_ARITH_CMP(>=, ge) return e ? pic_int_value((int)f) : pic_float_value(f); \ } +#define DEFINE_ARITH_OP2(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f; \ + \ + pic_get_args(pic, "*", &argc, &argv); \ + \ + f = unit; \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return pic_int_value(f); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_OP(+, add, 0) DEFINE_ARITH_OP(*, mul, 1) +#else +DEFINE_ARITH_OP2(+, add, 0) +DEFINE_ARITH_OP2(*, mul, 1) +#endif #define DEFINE_ARITH_INV_OP(op, name, unit, exact) \ static pic_value \ pic_number_##name(pic_state *pic) \ { \ size_t argc, i; \ - pic_value *argv; \ - double f; \ - bool e; \ + pic_value *argv; \ + double f; \ + bool e = true; \ \ - pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ + pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ \ - e = e && exact; \ + e = e && exact; \ \ - if (argc == 0) { \ - f = unit op f; \ - } \ - for (i = 0; i < argc; ++i) { \ - if (pic_int_p(argv[i])) { \ - f op##= pic_int(argv[i]); \ - } \ - else if (pic_float_p(argv[i])) { \ - e = false; \ - f op##= pic_float(argv[i]); \ - } \ - else { \ - pic_errorf(pic, #op ": number required"); \ - } \ - } \ + if (argc == 0) { \ + f = unit op f; \ + } \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else if (pic_float_p(argv[i])) { \ + e = false; \ + f op##= pic_float(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ \ - return e ? pic_int_value((int)f) : pic_float_value(f); \ + return e ? pic_int_value((int)f) : pic_float_value(f); \ } +#define DEFINE_ARITH_INV_OP2(op, name, unit) \ + static pic_value \ + pic_number_##name(pic_state *pic) \ + { \ + size_t argc, i; \ + pic_value *argv; \ + int f; \ + \ + pic_get_args(pic, "i*", &f, &argc, &argv); \ + \ + if (argc == 0) { \ + f = unit op f; \ + } \ + for (i = 0; i < argc; ++i) { \ + if (pic_int_p(argv[i])) { \ + f op##= pic_int(argv[i]); \ + } \ + else { \ + pic_errorf(pic, #op ": number required"); \ + } \ + } \ + \ + return pic_int_value(f); \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_INV_OP(-, sub, 0, true) DEFINE_ARITH_INV_OP(/, div, 1, false) +#else +DEFINE_ARITH_INV_OP2(-, sub, 0) +DEFINE_ARITH_INV_OP2(/, div, 1) +#endif static pic_value pic_number_abs(pic_state *pic) { +#if PIC_ENABLE_FLOAT double f; bool e; pic_get_args(pic, "F", &f, &e); if (e) { - return pic_int_value(abs((int)f)); + return pic_int_value(f < 0 ? -f : f); } else { return pic_float_value(fabs(f)); } +#else + int i; + + pic_get_args(pic, "i", &i); + + return pic_int_value(i < 0 ? -i : i); +#endif +} + +static pic_value +pic_number_expt(pic_state *pic) +{ +#if PIC_ENABLE_FLOAT + double f, g, h; + bool e1, e2; + + pic_get_args(pic, "FF", &f, &e1, &g, &e2); + + h = pow(f, g); + if (e1 && e2) { + if (h <= INT_MAX) { + return pic_int_value((int)h); + } + } + return pic_float_value(h); +#else + int x, y, i, e = 1, r = 1, s = 0; + + pic_get_args(pic, "ii", &x, &y); + + if (y < 0) { + s = 1; + y = -y; + } + e = x; + for (i = 0; y; ++i) { + if ((y & 1) != 0) { + r *= e; + } + e *= e; + y >>= 1; + } + if (s != 0) { + r = 1 / r; + } + return pic_int_value(r); +#endif } static pic_value pic_number_floor2(pic_state *pic) { +#if PIC_ENABLE_FLOAT int i, j; bool e1, e2; @@ -295,11 +419,23 @@ pic_number_floor2(pic_state *pic) 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; @@ -316,8 +452,16 @@ pic_number_trunc2(pic_state *pic) 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) { @@ -382,6 +526,180 @@ pic_number_round(pic_state *pic) } } +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) +{ +#if PIC_ENABLE_FLOAT + double f; + bool e; + int radix = 10; + pic_str *str; + + pic_get_args(pic, "F|i", &f, &e, &radix); + + if (radix < 2 || radix > 36) { + pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + } + + if (e) { + int ival = (int) f; + int ilen = number_string_length(ival, radix); + size_t s = ilen + 1; + char *buf = pic_malloc(pic, s); + + number_string(ival, radix, ilen, buf); + + str = pic_make_str(pic, buf, s - 1); + + pic_free(pic, buf); + } + else { + struct pic_port *port = pic_open_output_string(pic); + + xfprintf(port->file, "%f", f); + + str = pic_get_output_string(pic, port); + + pic_close_port(pic, port); + } + + return pic_obj_value(str); +#else + int f; + bool e; + int radix = 10; + pic_str *str; + size_t s; + char *buf; + int ival, ilen; + + pic_get_args(pic, "i|i", &f, &e, &radix); + + if (radix < 2 || radix > 36) { + pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); + } + + ival = f; + ilen = number_string_length(ival, radix); + s = ilen + 1; + + buf = pic_malloc(pic, s); + + number_string(ival, radix, ilen, buf); + + str = pic_make_str(pic, buf, s - 1); + + pic_free(pic, buf); + + return pic_obj_value(str); +#endif +} + +static pic_value +pic_number_string_to_number(pic_state *pic) +{ +#if PIC_ENABLE_FLOAT + const char *str; + int radix = 10; + long num; + char *eptr; + double flo; + + pic_get_args(pic, "z|i", &str, &radix); + + num = strtol(str, &eptr, radix); + if (*eptr == '\0') { + return pic_valid_int(num) + ? pic_int_value((int)num) + : pic_float_value(num); + } + + flo = strtod(str, &eptr); + if (*eptr == '\0') { + return pic_float_value(flo); + } + + pic_errorf(pic, "invalid string given: %s", str); +#else + const char *str; + int radix = 10; + long num; + char *eptr; + + pic_get_args(pic, "z|i", &str, &radix); + + num = strtol(str, &eptr, radix); + if (*eptr == '\0') { + return pic_int_value(num); + } + + pic_errorf(pic, "invalid string given: %s", str); +#endif +} + +#if PIC_ENABLE_FLOAT +static pic_value +pic_number_finite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_int_p(v)) + return pic_true_value(); + if (pic_float_p(v) && ! (isinf(pic_float(v)) || isnan(pic_float(v)))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_infinite_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isinf(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + +static pic_value +pic_number_nan_p(pic_state *pic) +{ + pic_value v; + + pic_get_args(pic, "o", &v); + + if (pic_float_p(v) && isnan(pic_float(v))) + return pic_true_value(); + else + return pic_false_value(); +} + static pic_value pic_number_exp(pic_state *pic) { @@ -481,113 +799,7 @@ pic_number_sqrt(pic_state *pic) return pic_float_value(sqrt(f)); } - -static pic_value -pic_number_expt(pic_state *pic) -{ - double f, g, h; - bool e1, e2; - - pic_get_args(pic, "FF", &f, &e1, &g, &e2); - - h = pow(f, g); - if (e1 && e2) { - if (h <= INT_MAX) { - return pic_int_value((int)h); - } - } - return pic_float_value(h); -} - -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))); -} - -static pic_value -pic_number_number_to_string(pic_state *pic) -{ - double f; - bool e; - int radix = 10; - pic_str *str; - size_t s; - char *buf; - - pic_get_args(pic, "F|i", &f, &e, &radix); - - if (radix < 2 || radix > 36) { - pic_errorf(pic, "number->string: invalid radix %d (between 2 and 36, inclusive)", radix); - } - - if (e) { - int ival = (int) f; - int ilen = number_string_length(ival, radix); - s = ilen + 1; - - buf = pic_malloc(pic, s); - - number_string(ival, radix, ilen, buf); - } - else { - s = snprintf(NULL, 0, "%f", f) + 1; - - buf = pic_malloc(pic, s); - - - snprintf(buf, s, "%f", f); - - while(buf[s - 2] == '0') - s -= 1; - - } - str = pic_make_str(pic, buf, s - 1); - - pic_free(pic, buf); - - return pic_obj_value(str); -} - -static pic_value -pic_number_string_to_number(pic_state *pic) -{ - const char *str; - int radix = 10; - long num; - char *eptr; - double flo; - - pic_get_args(pic, "z|i", &str, &radix); - - num = strtol(str, &eptr, radix); - if (*eptr == '\0') { - return pic_valid_int(num) - ? pic_int_value((int)num) - : pic_float_value(num); - } - - flo = strtod(str, &eptr); - if (*eptr == '\0') { - return pic_float_value(flo); - } - - pic_errorf(pic, "invalid string given: %s", str); -} +#endif void pic_init_number(pic_state *pic) @@ -618,27 +830,40 @@ pic_init_number(pic_state *pic) pic_defun(pic, "/", pic_number_div); pic_gc_arena_restore(pic, ai); + pic_defun(pic, "abs", pic_number_abs); + 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_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); +#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); + +#if PIC_ENABLE_FLOAT pic_defun(pic, "finite?", pic_number_finite_p); pic_defun(pic, "infinite?", pic_number_infinite_p); pic_defun(pic, "nan?", pic_number_nan_p); - pic_gc_arena_restore(pic, ai); - - pic_defun(pic, "abs", pic_number_abs); - pic_defun(pic, "expt", pic_number_expt); pic_defun(pic, "sqrt", pic_number_sqrt); pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "log", pic_number_log); @@ -649,8 +874,5 @@ pic_init_number(pic_state *pic) pic_defun(pic, "asin", pic_number_asin); pic_defun(pic, "atan", pic_number_atan); pic_gc_arena_restore(pic, ai); - - 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); +#endif } diff --git a/extlib/benz/read.c b/extlib/benz/read.c index 8262e0d7..4f6c6b30 100644 --- a/extlib/benz/read.c +++ b/extlib/benz/read.c @@ -67,6 +67,7 @@ isdelim(int c) return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ } +#if PIC_ENABLE_FLOAT static bool strcaseeq(const char *s1, const char *s2) { @@ -78,6 +79,7 @@ strcaseeq(const char *s1, const char *s2) } return a == b; } +#endif static int case_fold(pic_state *pic, int c) @@ -269,11 +271,14 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c) { unsigned u; int exp, s, i, e; +#if PIC_ENABLE_FLOAT double f, g; +#endif u = read_uinteger(pic, port, c); switch (peek(port)) { +#if PIC_ENABLE_FLOAT case '.': next(port); g = 0, e = 0; @@ -300,6 +305,7 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c) exp >>= 1; } return pic_float_value(f); +#endif default: exp = read_suffix(pic, port); @@ -332,11 +338,15 @@ read_number(pic_state *pic, struct pic_port *port, int c) static pic_value negate(pic_value n) { +#if PIC_ENABLE_FLOAT if (pic_int_p(n)) { return pic_int_value(-pic_int(n)); } else { return pic_float_value(-pic_float(n)); } +#else + return pic_int_value(-pic_int(n)); +#endif } static pic_value @@ -349,12 +359,14 @@ read_minus(pic_state *pic, struct pic_port *port, int c) } else { sym = read_symbol(pic, port, c); +#if PIC_ENABLE_FLOAT if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) { return pic_float_value(-INFINITY); } if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) { return pic_float_value(-NAN); } +#endif return sym; } } @@ -369,12 +381,14 @@ read_plus(pic_state *pic, struct pic_port *port, int c) } else { sym = read_symbol(pic, port, c); +#if PIC_ENABLE_FLOAT if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) { return pic_float_value(INFINITY); } if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) { return pic_float_value(NAN); } +#endif return sym; } } diff --git a/extlib/benz/string.c b/extlib/benz/string.c index d2924ac6..aeafef93 100644 --- a/extlib/benz/string.c +++ b/extlib/benz/string.c @@ -347,9 +347,11 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap) case 'p': xfprintf(file, "%p", va_arg(ap, void *)); break; +#if PIC_ENABLE_FLOAT case 'f': xfprintf(file, "%f", va_arg(ap, double)); break; +#endif } break; case '~': diff --git a/extlib/benz/vm.c b/extlib/benz/vm.c index 2425bc89..130084cd 100644 --- a/extlib/benz/vm.c +++ b/extlib/benz/vm.c @@ -119,6 +119,7 @@ pic_get_args(pic_state *pic, const char *format, ...) *p = GET_OPERAND(pic,i); break; } +#if PIC_ENABLE_FLOAT case 'f': { double *f; @@ -184,6 +185,7 @@ pic_get_args(pic_state *pic, const char *format, ...) } break; } +#endif case 'i': { int *k; @@ -192,9 +194,11 @@ pic_get_args(pic_state *pic, const char *format, ...) v = GET_OPERAND(pic, i); switch (pic_type(v)) { +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: *k = (int)pic_float(v); break; +#endif case PIC_TT_INT: *k = pic_int(v); break; @@ -1060,10 +1064,31 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; \ } +#define DEFINE_ARITH_OP2(opcode, op) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + PUSH(pic_int_value(pic_int(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + +#if PIC_ENABLE_FLOAT DEFINE_ARITH_OP(OP_ADD, +, true); DEFINE_ARITH_OP(OP_SUB, -, true); DEFINE_ARITH_OP(OP_MUL, *, true); DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); +#else + DEFINE_ARITH_OP2(OP_ADD, +); + DEFINE_ARITH_OP2(OP_SUB, -); + DEFINE_ARITH_OP2(OP_MUL, *); + DEFINE_ARITH_OP2(OP_DIV, /); +#endif CASE(OP_MINUS) { pic_value n; @@ -1071,9 +1096,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) if (pic_int_p(n)) { PUSH(pic_int_value(-pic_int(n))); } +#if PIC_ENABLE_FLOAT else if (pic_float_p(n)) { PUSH(pic_float_value(-pic_float(n))); } +#endif else { pic_errorf(pic, "unary - got a non-number operand"); } @@ -1103,9 +1130,29 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args) NEXT; \ } +#define DEFINE_COMP_OP2(opcode, op) \ + CASE(opcode) { \ + pic_value a, b; \ + b = POP(); \ + a = POP(); \ + if (pic_int_p(a) && pic_int_p(b)) { \ + PUSH(pic_bool_value(pic_int(a) op pic_int(b))); \ + } \ + else { \ + pic_errorf(pic, #op " got non-number operands"); \ + } \ + NEXT; \ + } + +#if PIC_ENABLE_FLOAT DEFINE_COMP_OP(OP_EQ, ==); DEFINE_COMP_OP(OP_LT, <); DEFINE_COMP_OP(OP_LE, <=); +#else + DEFINE_COMP_OP2(OP_EQ, ==); + DEFINE_COMP_OP2(OP_LT, <); + DEFINE_COMP_OP2(OP_LE, <=); +#endif CASE(OP_STOP) { diff --git a/extlib/benz/write.c b/extlib/benz/write.c index f89e0703..e01966de 100644 --- a/extlib/benz/write.c +++ b/extlib/benz/write.c @@ -210,7 +210,9 @@ write_core(struct writer_control *p, pic_value obj) size_t i; xh_entry *e, *it; int c; +#if PIC_ENABLE_FLOAT double f; +#endif /* shared objects */ if (pic_vtype(obj) == PIC_VTYPE_HEAP @@ -285,6 +287,7 @@ write_core(struct writer_control *p, pic_value obj) case '\t': xfprintf(file, "#\\tab"); break; } break; +#if PIC_ENABLE_FLOAT case PIC_TT_FLOAT: f = pic_float(obj); if (isnan(f)) { @@ -295,6 +298,7 @@ write_core(struct writer_control *p, pic_value obj) xfprintf(file, "%f", pic_float(obj)); } break; +#endif case PIC_TT_INT: xfprintf(file, "%d", pic_int(obj)); break;