conservatory
/
picrin
4
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

add PIC_ENABLE_FLOAT and PIC_WORD_BOXING

This commit is contained in:
Yuichi Nishiwaki 2015-05-28 01:48:38 +09:00
parent 4bdb17db2f
commit 7dcd050e1a
10 changed files with 615 additions and 194 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
extlib/benz/codegen.c
View File

@ -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);

4
extlib/benz/gc.c
View File

@ -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:

6
extlib/benz/include/picrin.h
View File

@ -30,7 +30,6 @@ extern "C" {
#include <stddef.h>
#include <stdbool.h>
#include <stdint.h>
#include <limits.h>
#include <stdarg.h>
@ -38,12 +37,15 @@ extern "C" {
#include <assert.h>
#include <string.h>
#include <stdlib.h>
#include <math.h>
#include <ctype.h>
#include "picrin/config.h"
#include "picrin/util.h"
#if PIC_ENABLE_FLOAT
# include <math.h>
#endif
#include "picrin/xvect.h"
#include "picrin/xhash.h"
#include "picrin/xfile.h"

36
extlib/benz/include/picrin/config.h
View File

@ -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

110
extlib/benz/include/picrin/value.h
View File

@ -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 <stdint.h>
/**
* 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:

582
extlib/benz/number.c
View File

@ -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
}

14
extlib/benz/read.c
View File

@ -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;
}
}

2
extlib/benz/string.c
View File

@ -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 '~':

47
extlib/benz/vm.c
View File

@ -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) {

4
extlib/benz/write.c
View File

@ -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;