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)) { switch (pic_length(pic, obj)) {
case 2: case 2:
args = pic_cdr(pic, obj); 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)); 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); return analyze(state, obj, false);
default: default:
args = pic_cdr(pic, obj); 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_NIL:
case PIC_TT_BOOL: case PIC_TT_BOOL:
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
#endif
case PIC_TT_INT: case PIC_TT_INT:
case PIC_TT_CHAR: case PIC_TT_CHAR:
case PIC_TT_EOF: 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_NIL:
case PIC_TT_BOOL: case PIC_TT_BOOL:
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
#endif
case PIC_TT_INT: case PIC_TT_INT:
case PIC_TT_CHAR: case PIC_TT_CHAR:
case PIC_TT_EOF: case PIC_TT_EOF:

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

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

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

@ -8,6 +8,12 @@
/** switch internal value representation */ /** switch internal value representation */
/* #define PIC_NAN_BOXING 1 */ /* #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 */ /** treat false value as none */
/* #define PIC_NONE_IS_FALSE 1 */ /* #define PIC_NONE_IS_FALSE 1 */
@ -50,10 +56,34 @@
# endif # endif
#endif #endif
#ifndef PIC_NAN_BOXING #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 # if __x86_64__ && (defined(__GNUC__) || defined(__clang__)) && __STRICT_ANSI__ != 1
# define PIC_NAN_BOXING 1 # define PIC_NAN_BOXING 1
# endif # 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 #endif
#ifndef PIC_NONE_IS_FALSE #ifndef PIC_NONE_IS_FALSE

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

@ -19,7 +19,9 @@ enum pic_vtype {
PIC_VTYPE_TRUE, PIC_VTYPE_TRUE,
PIC_VTYPE_FALSE, PIC_VTYPE_FALSE,
PIC_VTYPE_UNDEF, PIC_VTYPE_UNDEF,
#if PIC_ENABLE_FLOAT
PIC_VTYPE_FLOAT, PIC_VTYPE_FLOAT,
#endif
PIC_VTYPE_INT, PIC_VTYPE_INT,
PIC_VTYPE_CHAR, PIC_VTYPE_CHAR,
PIC_VTYPE_EOF, PIC_VTYPE_EOF,
@ -28,6 +30,8 @@ enum pic_vtype {
#if PIC_NAN_BOXING #if PIC_NAN_BOXING
#include <stdint.h>
/** /**
* value representation by nan-boxing: * value representation by nan-boxing:
* float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF * float : FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF FFFFFFFFFFFFFFFF
@ -65,13 +69,55 @@ pic_int(pic_value v)
#define pic_char(v) ((v) & 0xfffffffful) #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 #else
typedef struct { typedef struct {
enum pic_vtype type; enum pic_vtype type;
union { union {
void *data; void *data;
#if PIC_ENABLE_FLOAT
double f; double f;
#endif
int i; int i;
char c; char c;
} u; } u;
@ -81,7 +127,9 @@ typedef struct {
#define pic_vtype(v) ((v).type) #define pic_vtype(v) ((v).type)
#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL) #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_int(v) ((v).u.i)
#define pic_char(v) ((v).u.c) #define pic_char(v) ((v).u.c)
@ -91,7 +139,9 @@ enum pic_tt {
/* immediate */ /* immediate */
PIC_TT_NIL, PIC_TT_NIL,
PIC_TT_BOOL, PIC_TT_BOOL,
#if PIC_ENABLE_FLOAT
PIC_TT_FLOAT, PIC_TT_FLOAT,
#endif
PIC_TT_INT, PIC_TT_INT,
PIC_TT_CHAR, PIC_TT_CHAR,
PIC_TT_EOF, 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_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_nil_value();
PIC_INLINE pic_value pic_true_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_bool_value(bool);
PIC_INLINE pic_value pic_undef_value(); PIC_INLINE pic_value pic_undef_value();
PIC_INLINE pic_value pic_obj_value(void *); PIC_INLINE pic_value pic_obj_value(void *);
#if PIC_ENABLE_FLOAT
PIC_INLINE pic_value pic_float_value(double); PIC_INLINE pic_value pic_float_value(double);
#endif
PIC_INLINE pic_value pic_int_value(int); PIC_INLINE pic_value pic_int_value(int);
PIC_INLINE pic_value pic_size_value(size_t); PIC_INLINE pic_value pic_size_value(size_t);
PIC_INLINE pic_value pic_char_value(char c); PIC_INLINE pic_value pic_char_value(char c);
@ -190,8 +256,10 @@ pic_type(pic_value v)
return PIC_TT_BOOL; return PIC_TT_BOOL;
case PIC_VTYPE_UNDEF: case PIC_VTYPE_UNDEF:
return PIC_TT_UNDEF; return PIC_TT_UNDEF;
#if PIC_ENABLE_FLOAT
case PIC_VTYPE_FLOAT: case PIC_VTYPE_FLOAT:
return PIC_TT_FLOAT; return PIC_TT_FLOAT;
#endif
case PIC_VTYPE_INT: case PIC_VTYPE_INT:
return PIC_TT_INT; return PIC_TT_INT;
case PIC_VTYPE_CHAR: case PIC_VTYPE_CHAR:
@ -213,8 +281,10 @@ pic_type_repr(enum pic_tt tt)
return "nil"; return "nil";
case PIC_TT_BOOL: case PIC_TT_BOOL:
return "boolean"; return "boolean";
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
return "float"; return "float";
#endif
case PIC_TT_INT: case PIC_TT_INT:
return "int"; return "int";
case PIC_TT_SYMBOL: case PIC_TT_SYMBOL:
@ -257,12 +327,6 @@ pic_type_repr(enum pic_tt tt)
PIC_UNREACHABLE(); PIC_UNREACHABLE();
} }
PIC_INLINE bool
pic_valid_int(double v)
{
return INT_MIN <= v && v <= INT_MAX;
}
PIC_INLINE pic_value PIC_INLINE pic_value
pic_nil_value() pic_nil_value()
{ {
@ -302,11 +366,13 @@ pic_bool_value(bool b)
PIC_INLINE pic_value PIC_INLINE pic_value
pic_size_value(size_t s) pic_size_value(size_t s)
{ {
#if PIC_ENABLE_FLOAT
if (sizeof(unsigned) < sizeof(size_t)) { if (sizeof(unsigned) < sizeof(size_t)) {
if (s > (size_t)INT_MAX) { if (s > (size_t)INT_MAX) {
return pic_float_value(s); return pic_float_value(s);
} }
} }
#endif
return pic_int_value((int)s); return pic_int_value((int)s);
} }
@ -358,6 +424,26 @@ pic_char_value(char c)
return v; 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 #else
PIC_INLINE pic_value PIC_INLINE pic_value
@ -370,6 +456,8 @@ pic_obj_value(void *ptr)
return v; return v;
} }
#if PIC_ENABLE_FLOAT
PIC_INLINE pic_value PIC_INLINE pic_value
pic_float_value(double f) pic_float_value(double f)
{ {
@ -380,6 +468,8 @@ pic_float_value(double f)
return v; return v;
} }
#endif
PIC_INLINE pic_value PIC_INLINE pic_value
pic_int_value(int i) pic_int_value(int i)
{ {
@ -421,7 +511,7 @@ pic_none_value()
#endif #endif
} }
#if PIC_NAN_BOXING #if PIC_NAN_BOXING || PIC_WORD_BOXING
PIC_INLINE bool PIC_INLINE bool
pic_eq_p(pic_value x, pic_value y) pic_eq_p(pic_value x, pic_value y)
@ -464,8 +554,10 @@ pic_eqv_p(pic_value x, pic_value y)
return true; return true;
case PIC_TT_BOOL: case PIC_TT_BOOL:
return pic_vtype(x) == pic_vtype(y); return pic_vtype(x) == pic_vtype(y);
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
return pic_float(x) == pic_float(y); return pic_float(x) == pic_float(y);
#endif
case PIC_TT_INT: case PIC_TT_INT:
return pic_int(x) == pic_int(y); return pic_int(x) == pic_int(y);
default: default:

540
extlib/benz/number.c
View File

@ -5,6 +5,19 @@
#include "picrin.h" #include "picrin.h"
#include "picrin/string.h" #include "picrin/string.h"
#include "picrin/cont.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. * Returns the length of string representing val.
@ -66,7 +79,11 @@ pic_number_real_p(pic_state *pic)
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
#if PIC_ENABLE_FLOAT
return pic_bool_value(pic_float_p(v) || pic_int_p(v)); 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 static pic_value
@ -79,6 +96,7 @@ pic_number_integer_p(pic_state *pic)
if (pic_int_p(v)) { if (pic_int_p(v)) {
return pic_true_value(); return pic_true_value();
} }
#if PIC_ENABLE_FLOAT
if (pic_float_p(v)) { if (pic_float_p(v)) {
double f = pic_float(v); double f = pic_float(v);
@ -90,6 +108,7 @@ pic_number_integer_p(pic_state *pic)
return pic_true_value(); return pic_true_value();
} }
} }
#endif
return pic_false_value(); return pic_false_value();
} }
@ -110,48 +129,11 @@ pic_number_inexact_p(pic_state *pic)
pic_get_args(pic, "o", &v); pic_get_args(pic, "o", &v);
#if PIC_ENABLE_FLOAT
return pic_bool_value(pic_float_p(v)); return pic_bool_value(pic_float_p(v));
} #else
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(); return pic_false_value();
#endif
} }
#define DEFINE_ARITH_CMP(op, name) \ #define DEFINE_ARITH_CMP(op, name) \
@ -183,11 +165,46 @@ pic_number_nan_p(pic_state *pic)
return pic_true_value(); \ 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(==, eq)
DEFINE_ARITH_CMP(<, lt) DEFINE_ARITH_CMP(<, lt)
DEFINE_ARITH_CMP(>, gt) DEFINE_ARITH_CMP(>, gt)
DEFINE_ARITH_CMP(<=, le) DEFINE_ARITH_CMP(<=, le)
DEFINE_ARITH_CMP(>=, ge) 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) \ #define DEFINE_ARITH_OP(op, name, unit) \
static pic_value \ static pic_value \
@ -217,8 +234,36 @@ DEFINE_ARITH_CMP(>=, ge)
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_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(+, add, 0)
DEFINE_ARITH_OP(*, mul, 1) 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) \ #define DEFINE_ARITH_INV_OP(op, name, unit, exact) \
static pic_value \ static pic_value \
@ -227,7 +272,7 @@ DEFINE_ARITH_OP(*, mul, 1)
size_t argc, i; \ size_t argc, i; \
pic_value *argv; \ pic_value *argv; \
double f; \ double f; \
bool e; \ bool e = true; \
\ \
pic_get_args(pic, "F*", &f, &e, &argc, &argv); \ pic_get_args(pic, "F*", &f, &e, &argc, &argv); \
\ \
@ -252,28 +297,107 @@ DEFINE_ARITH_OP(*, mul, 1)
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(-, sub, 0, true)
DEFINE_ARITH_INV_OP(/, div, 1, false) DEFINE_ARITH_INV_OP(/, div, 1, false)
#else
DEFINE_ARITH_INV_OP2(-, sub, 0)
DEFINE_ARITH_INV_OP2(/, div, 1)
#endif
static pic_value static pic_value
pic_number_abs(pic_state *pic) pic_number_abs(pic_state *pic)
{ {
#if PIC_ENABLE_FLOAT
double f; double f;
bool e; bool e;
pic_get_args(pic, "F", &f, &e); pic_get_args(pic, "F", &f, &e);
if (e) { if (e) {
return pic_int_value(abs((int)f)); return pic_int_value(f < 0 ? -f : f);
} }
else { else {
return pic_float_value(fabs(f)); 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 static pic_value
pic_number_floor2(pic_state *pic) pic_number_floor2(pic_state *pic)
{ {
#if PIC_ENABLE_FLOAT
int i, j; int i, j;
bool e1, e2; bool e1, e2;
@ -295,11 +419,23 @@ pic_number_floor2(pic_state *pic)
r = i - j * q; r = i - j * q;
return pic_values2(pic, pic_float_value(q), pic_float_value(r)); 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 static pic_value
pic_number_trunc2(pic_state *pic) pic_number_trunc2(pic_state *pic)
{ {
#if PIC_ENABLE_FLOAT
int i, j; int i, j;
bool e1, e2; 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)); 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 static pic_value
pic_number_floor(pic_state *pic) 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 static pic_value
pic_number_exp(pic_state *pic) pic_number_exp(pic_state *pic)
{ {
@ -481,113 +799,7 @@ pic_number_sqrt(pic_state *pic)
return pic_float_value(sqrt(f)); return pic_float_value(sqrt(f));
} }
#endif
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);
}
void void
pic_init_number(pic_state *pic) pic_init_number(pic_state *pic)
@ -618,27 +830,40 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "/", pic_number_div); pic_defun(pic, "/", pic_number_div);
pic_gc_arena_restore(pic, ai); 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, "floor/", pic_number_floor2);
pic_defun(pic, "truncate/", pic_number_trunc2); pic_defun(pic, "truncate/", pic_number_trunc2);
pic_gc_arena_restore(pic, ai); pic_gc_arena_restore(pic, ai);
#if PIC_ENABLE_FLOAT
pic_defun(pic, "floor", pic_number_floor); pic_defun(pic, "floor", pic_number_floor);
pic_defun(pic, "ceiling", pic_number_ceil); pic_defun(pic, "ceiling", pic_number_ceil);
pic_defun(pic, "truncate", pic_number_trunc); pic_defun(pic, "truncate", pic_number_trunc);
pic_defun(pic, "round", pic_number_round); pic_defun(pic, "round", pic_number_round);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "inexact", pic_number_inexact); pic_defun(pic, "inexact", pic_number_inexact);
pic_defun(pic, "exact", pic_number_exact); pic_defun(pic, "exact", pic_number_exact);
pic_gc_arena_restore(pic, ai); 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, "finite?", pic_number_finite_p);
pic_defun(pic, "infinite?", pic_number_infinite_p); pic_defun(pic, "infinite?", pic_number_infinite_p);
pic_defun(pic, "nan?", pic_number_nan_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, "sqrt", pic_number_sqrt);
pic_defun(pic, "exp", pic_number_exp); pic_defun(pic, "exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log); 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, "asin", pic_number_asin);
pic_defun(pic, "atan", pic_number_atan); pic_defun(pic, "atan", pic_number_atan);
pic_gc_arena_restore(pic, ai); 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);
} }

14
extlib/benz/read.c
View File

@ -67,6 +67,7 @@ isdelim(int c)
return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */ return c == EOF || strchr("();,|\" \t\n\r", c) != NULL; /* ignores "#", "'" */
} }
#if PIC_ENABLE_FLOAT
static bool static bool
strcaseeq(const char *s1, const char *s2) strcaseeq(const char *s1, const char *s2)
{ {
@ -78,6 +79,7 @@ strcaseeq(const char *s1, const char *s2)
} }
return a == b; return a == b;
} }
#endif
static int static int
case_fold(pic_state *pic, int c) case_fold(pic_state *pic, int c)
@ -269,11 +271,14 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
{ {
unsigned u; unsigned u;
int exp, s, i, e; int exp, s, i, e;
#if PIC_ENABLE_FLOAT
double f, g; double f, g;
#endif
u = read_uinteger(pic, port, c); u = read_uinteger(pic, port, c);
switch (peek(port)) { switch (peek(port)) {
#if PIC_ENABLE_FLOAT
case '.': case '.':
next(port); next(port);
g = 0, e = 0; g = 0, e = 0;
@ -300,6 +305,7 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
exp >>= 1; exp >>= 1;
} }
return pic_float_value(f); return pic_float_value(f);
#endif
default: default:
exp = read_suffix(pic, port); exp = read_suffix(pic, port);
@ -332,11 +338,15 @@ read_number(pic_state *pic, struct pic_port *port, int c)
static pic_value static pic_value
negate(pic_value n) negate(pic_value n)
{ {
#if PIC_ENABLE_FLOAT
if (pic_int_p(n)) { if (pic_int_p(n)) {
return pic_int_value(-pic_int(n)); return pic_int_value(-pic_int(n));
} else { } else {
return pic_float_value(-pic_float(n)); return pic_float_value(-pic_float(n));
} }
#else
return pic_int_value(-pic_int(n));
#endif
} }
static pic_value static pic_value
@ -349,12 +359,14 @@ read_minus(pic_state *pic, struct pic_port *port, int c)
} }
else { else {
sym = read_symbol(pic, port, c); sym = read_symbol(pic, port, c);
#if PIC_ENABLE_FLOAT
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-inf.0")) {
return pic_float_value(-INFINITY); return pic_float_value(-INFINITY);
} }
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) {
return pic_float_value(-NAN); return pic_float_value(-NAN);
} }
#endif
return sym; return sym;
} }
} }
@ -369,12 +381,14 @@ read_plus(pic_state *pic, struct pic_port *port, int c)
} }
else { else {
sym = read_symbol(pic, port, c); sym = read_symbol(pic, port, c);
#if PIC_ENABLE_FLOAT
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+inf.0")) {
return pic_float_value(INFINITY); return pic_float_value(INFINITY);
} }
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) { if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) {
return pic_float_value(NAN); return pic_float_value(NAN);
} }
#endif
return sym; 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': case 'p':
xfprintf(file, "%p", va_arg(ap, void *)); xfprintf(file, "%p", va_arg(ap, void *));
break; break;
#if PIC_ENABLE_FLOAT
case 'f': case 'f':
xfprintf(file, "%f", va_arg(ap, double)); xfprintf(file, "%f", va_arg(ap, double));
break; break;
#endif
} }
break; break;
case '~': 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); *p = GET_OPERAND(pic,i);
break; break;
} }
#if PIC_ENABLE_FLOAT
case 'f': { case 'f': {
double *f; double *f;
@ -184,6 +185,7 @@ pic_get_args(pic_state *pic, const char *format, ...)
} }
break; break;
} }
#endif
case 'i': { case 'i': {
int *k; int *k;
@ -192,9 +194,11 @@ pic_get_args(pic_state *pic, const char *format, ...)
v = GET_OPERAND(pic, i); v = GET_OPERAND(pic, i);
switch (pic_type(v)) { switch (pic_type(v)) {
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
*k = (int)pic_float(v); *k = (int)pic_float(v);
break; break;
#endif
case PIC_TT_INT: case PIC_TT_INT:
*k = pic_int(v); *k = pic_int(v);
break; break;
@ -1060,10 +1064,31 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
NEXT; \ 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_ADD, +, true);
DEFINE_ARITH_OP(OP_SUB, -, true); DEFINE_ARITH_OP(OP_SUB, -, true);
DEFINE_ARITH_OP(OP_MUL, *, true); DEFINE_ARITH_OP(OP_MUL, *, true);
DEFINE_ARITH_OP(OP_DIV, /, f == round(f)); 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) { CASE(OP_MINUS) {
pic_value n; pic_value n;
@ -1071,9 +1096,11 @@ pic_apply(pic_state *pic, struct pic_proc *proc, pic_value args)
if (pic_int_p(n)) { if (pic_int_p(n)) {
PUSH(pic_int_value(-pic_int(n))); PUSH(pic_int_value(-pic_int(n)));
} }
#if PIC_ENABLE_FLOAT
else if (pic_float_p(n)) { else if (pic_float_p(n)) {
PUSH(pic_float_value(-pic_float(n))); PUSH(pic_float_value(-pic_float(n)));
} }
#endif
else { else {
pic_errorf(pic, "unary - got a non-number operand"); 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; \ 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_EQ, ==);
DEFINE_COMP_OP(OP_LT, <); DEFINE_COMP_OP(OP_LT, <);
DEFINE_COMP_OP(OP_LE, <=); 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) { 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; size_t i;
xh_entry *e, *it; xh_entry *e, *it;
int c; int c;
#if PIC_ENABLE_FLOAT
double f; double f;
#endif
/* shared objects */ /* shared objects */
if (pic_vtype(obj) == PIC_VTYPE_HEAP 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; case '\t': xfprintf(file, "#\\tab"); break;
} }
break; break;
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT: case PIC_TT_FLOAT:
f = pic_float(obj); f = pic_float(obj);
if (isnan(f)) { if (isnan(f)) {
@ -295,6 +298,7 @@ write_core(struct writer_control *p, pic_value obj)
xfprintf(file, "%f", pic_float(obj)); xfprintf(file, "%f", pic_float(obj));
} }
break; break;
#endif
case PIC_TT_INT: case PIC_TT_INT:
xfprintf(file, "%d", pic_int(obj)); xfprintf(file, "%d", pic_int(obj));
break; break;