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

Merge branch 'enable-float-by-default'

This commit is contained in:
Yuichi Nishiwaki 2015-07-20 03:34:21 +09:00
parent 0f9c7f0c2c 3a96d093ed
commit c2b41b6d0c
17 changed files with 528 additions and 910 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile
View File

@ -67,7 +67,7 @@ test: test-contribs test-nostdlib
test-contribs: bin/picrin $(CONTRIB_TESTS)
test-nostdlib:
$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -nostdlib -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
$(CC) -I extlib/benz/include -D'PIC_ENABLE_LIBC=0' -D'PIC_ENABLE_FLOAT=0' -D'PIC_ENABLE_STDIO=0' -ffreestanding -nostdlib -fPIC -shared -std=c89 -pedantic -Wall -Wextra -Werror -o lib/libbenz.so $(BENZ_SRCS) etc/libc_polyfill.c -fno-stack-protector
rm -f lib/libbenz.so
install: all

310
contrib/10.math/math.c Normal file
View File

@ -0,0 +1,310 @@
#include "picrin.h"
#include <math.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)
{
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)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(exp(f));
}
static pic_value
pic_number_log(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
return pic_float_value(log(f));
}
else {
return pic_float_value(log(f) / log(g));
}
}
static pic_value
pic_number_sin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = sin(f);
return pic_float_value(f);
}
static pic_value
pic_number_cos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = cos(f);
return pic_float_value(f);
}
static pic_value
pic_number_tan(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = tan(f);
return pic_float_value(f);
}
static pic_value
pic_number_acos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = acos(f);
return pic_float_value(f);
}
static pic_value
pic_number_asin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = asin(f);
return pic_float_value(f);
}
static pic_value
pic_number_atan(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
f = atan(f);
return pic_float_value(f);
}
else {
return pic_float_value(atan2(f,g));
}
}
static pic_value
pic_number_sqrt(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(sqrt(f));
}
static pic_value
pic_number_abs(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value(f < 0 ? -f : f);
}
else {
return pic_float_value(fabs(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);
}
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);
pic_defun(pic, "sqrt", pic_number_sqrt);
pic_defun(pic, "exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log);
pic_defun(pic, "sin", pic_number_sin);
pic_defun(pic, "cos", pic_number_cos);
pic_defun(pic, "tan", pic_number_tan);
pic_defun(pic, "acos", pic_number_acos);
pic_defun(pic, "asin", pic_number_asin);
pic_defun(pic, "atan", pic_number_atan);
pic_defun(pic, "abs", pic_number_abs);
pic_defun(pic, "expt", pic_number_expt);
}
}

3
contrib/10.math/nitro.mk Normal file
View File

@ -0,0 +1,3 @@
CONTRIB_INITS += math
CONTRIB_SRCS += contrib/10.math/math.c

22
contrib/20.r7rs/scheme/base.scm
View File

@ -1,5 +1,17 @@
(define-library (scheme base)
(import (picrin base)
(only (picrin math)
abs
expt
floor/
truncate/
floor
ceiling
truncate
round
sqrt
nan?
infinite?)
(picrin macro)
(picrin string)
(scheme file))
@ -460,6 +472,16 @@
;; 6.2. Numbers
(define complex? number?)
(define real? number?)
(define rational? number?)
(define (integer? o)
(or (exact? o)
(and (inexact? o)
(not (nan? o))
(not (infinite? o))
(= o (floor o)))))
(define (exact-integer? x)
(and (exact? x)
(integer? x)))

3
contrib/20.r7rs/scheme/inexact.scm
View File

@ -1,5 +1,6 @@
(define-library (scheme inexact)
(import (picrin base))
(import (picrin base)
(picrin math))
(export acos
asin

2
extlib/benz/error.c
View File

@ -7,7 +7,7 @@
void
pic_panic(pic_state PIC_UNUSED(*pic), const char *msg)
{
extern void abort();
extern PIC_NORETURN void abort();
#if DEBUG
fprintf(stderr, "abort: %s\n", msg);

28
extlib/benz/file.c
View File

@ -345,38 +345,38 @@ int xvfprintf(pic_state *pic, xFILE *stream, const char *fmt, va_list ap) {
ival = va_arg(ap, int);
cnt += print_int(pic, stream, ival, 10);
break;
#if PIC_ENABLE_FLOAT
# if PIC_ENABLE_LIBC
#if PIC_ENABLE_LIBC
case 'f': {
char buf[100];
sprintf(buf, "%g", va_arg(ap, double));
xfputs(pic, buf, stream);
break;
}
# else
#else
# define fabs(x) ((x) >= 0 ? (x) : -(x))
case 'f': {
double dval, dint;
dval = modf(va_arg(ap, double), &dint);
if (dint < 0 || dval < 0) { /* either may be zero */
double dval = va_arg(ap, double);
long lval;
if (dval < 0) {
dval = -dval;
xputc(pic, '-', stream);
cnt++;
}
cnt += print_int(pic, stream, (long)fabs(dint), 10);
lval = (long)dval;
cnt += print_int(pic, stream, lval, 10);
xputc(pic, '.', stream);
cnt++;
if ((ival = fabs(fabs(dval) * 1e4) + 0.5) == 0) {
dval -= lval;
if ((ival = fabs(dval) * 1e4 + 0.5) == 0) {
cnt += xfputs(pic, "0000", stream);
} else {
int i;
for (i = 0; i < 3 - (int)log10(ival); ++i) {
xputc(pic, '0', stream);
cnt++;
}
if (ival < 1000) xputc(pic, '0', stream); cnt++;
if (ival < 100) xputc(pic, '0', stream); cnt++;
if (ival < 10) xputc(pic, '0', stream); cnt++;
cnt += print_int(pic, stream, ival, 10);
}
break;
}
# endif
#endif
case 's':
sval = va_arg(ap, char*);

4
extlib/benz/gc.c
View File

@ -439,9 +439,7 @@ 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:
@ -679,9 +677,7 @@ 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:

4
extlib/benz/include/picrin/compat.h
View File

@ -205,10 +205,6 @@ strcpy(char *dst, const char *src)
#endif
#if PIC_ENABLE_FLOAT
# include <math.h>
#endif
#if PIC_ENABLE_STDIO
# include <stdio.h>
#endif

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

@ -11,9 +11,6 @@
/** enable word boxing */
/* #define PIC_WORD_BOXING 0 */
/** enable floating point number support */
/* #define PIC_ENABLE_FLOAT 1 */
/** no dependency on libc */
/* #define PIC_ENABLE_LIBC 1 */
@ -68,10 +65,6 @@
# 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
@ -84,20 +77,10 @@
# endif
#endif
#ifndef PIC_ENABLE_FLOAT
# if ! PIC_WORD_BOXING
# define PIC_ENABLE_FLOAT 1
# endif
#endif
#ifndef PIC_ENABLE_LIBC
# define PIC_ENABLE_LIBC 1
#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_ENABLE_STDIO
# define PIC_ENABLE_STDIO 1
#endif

73
extlib/benz/include/picrin/type.h
View File

@ -20,9 +20,7 @@ enum pic_vtype {
PIC_VTYPE_FALSE,
PIC_VTYPE_UNDEF,
PIC_VTYPE_INVALID,
#if PIC_ENABLE_FLOAT
PIC_VTYPE_FLOAT,
#endif
PIC_VTYPE_INT,
PIC_VTYPE_CHAR,
PIC_VTYPE_EOF,
@ -116,9 +114,7 @@ typedef struct {
enum pic_vtype type;
union {
void *data;
#if PIC_ENABLE_FLOAT
double f;
#endif
int i;
char c;
} u;
@ -128,9 +124,7 @@ typedef struct {
#define pic_vtype(v) ((v).type)
#define pic_init_value(v,vtype) ((v).type = (vtype), (v).u.data = NULL)
#if PIC_ENABLE_FLOAT
# define pic_float(v) ((v).u.f)
#endif
#define pic_float(v) ((v).u.f)
#define pic_int(v) ((v).u.i)
#define pic_char(v) ((v).u.c)
@ -140,9 +134,7 @@ 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,
@ -218,21 +210,12 @@ PIC_INLINE const char *pic_type_repr(enum pic_tt);
pic_errorf(pic, "expected " #type ", but got ~s", v); \
}
#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 PIC_UNUSED(v))
{
return true;
}
#endif
PIC_INLINE pic_value pic_nil_value();
PIC_INLINE pic_value pic_true_value();
PIC_INLINE pic_value pic_false_value();
@ -240,9 +223,7 @@ PIC_INLINE pic_value pic_bool_value(bool);
PIC_INLINE pic_value pic_undef_value();
PIC_INLINE pic_value pic_invalid_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);
@ -264,10 +245,8 @@ pic_type(pic_value v)
return PIC_TT_UNDEF;
case PIC_VTYPE_INVALID:
return PIC_TT_INVALID;
#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:
@ -289,10 +268,8 @@ 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:
@ -382,13 +359,11 @@ 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);
}
@ -472,8 +447,6 @@ pic_obj_value(void *ptr)
return v;
}
#if PIC_ENABLE_FLOAT
PIC_INLINE pic_value
pic_float_value(double f)
{
@ -484,8 +457,6 @@ pic_float_value(double f)
return v;
}
#endif
PIC_INLINE pic_value
pic_int_value(int i)
{
@ -569,10 +540,8 @@ 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,12 +551,11 @@ pic_eqv_p(pic_value x, pic_value y)
#endif
#if PIC_ENABLE_FLOAT
# define pic_define_aop(name, op, guard) \
#define pic_define_aop(name, op, guard) \
PIC_INLINE pic_value \
name(pic_state *pic, pic_value a, pic_value b) \
{ \
extern PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
double f; \
if (pic_int_p(a) && pic_int_p(b)) { \
f = (double)pic_int(a) op (double)pic_int(b); \
@ -605,32 +573,17 @@ pic_eqv_p(pic_value x, pic_value y)
} \
PIC_UNREACHABLE(); \
}
#else
# define pic_define_aop(name, op, guard) \
PIC_INLINE pic_value \
name(pic_state *pic, pic_value a, pic_value b) \
{ \
extern PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
if (pic_int_p(a) && pic_int_p(b)) { \
return pic_int_value(pic_int(a) op pic_int(b)); \
} else { \
pic_errorf(pic, #name ": non-number operand given"); \
} \
PIC_UNREACHABLE(); \
}
#endif
pic_define_aop(pic_add, +, true)
pic_define_aop(pic_sub, -, true)
pic_define_aop(pic_mul, *, true)
pic_define_aop(pic_div, /, f == round(f))
pic_define_aop(pic_div, /, f == (int)f)
#if PIC_ENABLE_FLOAT
# define pic_define_cmp(name, op) \
#define pic_define_cmp(name, op) \
PIC_INLINE bool \
name(pic_state *pic, pic_value a, pic_value b) \
{ \
extern PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
if (pic_int_p(a) && pic_int_p(b)) { \
return pic_int(a) op pic_int(b); \
} else if (pic_float_p(a) && pic_float_p(b)) { \
@ -644,20 +597,6 @@ pic_define_aop(pic_div, /, f == round(f))
} \
PIC_UNREACHABLE(); \
}
#else
# define pic_define_cmp(name, op) \
PIC_INLINE bool \
name(pic_state *pic, pic_value a, pic_value b) \
{ \
extern PIC_NORETURN void pic_errorf(pic_state *, const char *, ...); \
if (pic_int_p(a) && pic_int_p(b)) { \
return pic_int(a) op pic_int(b); \
} else { \
pic_errorf(pic, #name ": non-number operand given"); \
} \
PIC_UNREACHABLE(); \
}
#endif
pic_define_cmp(pic_eq, ==)
pic_define_cmp(pic_lt, <)

848
extlib/benz/number.c
View File

@ -4,23 +4,119 @@
#include "picrin.h"
#if ! PIC_ENABLE_FLOAT
static pic_value
pic_number_id(pic_state *pic)
pic_number_number_p(pic_state *pic)
{
int i;
pic_value v;
pic_get_args(pic, "i", &i);
pic_get_args(pic, "o", &v);
return pic_int_value(i);
return pic_bool_value(pic_float_p(v) || pic_int_p(v));
}
#endif
/**
* Returns the length of string representing val.
* radix is between 2 and 36 (inclusive).
* No error checks are performed in this function.
*/
static pic_value
pic_number_exact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_int_p(v));
}
static pic_value
pic_number_inexact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_float_p(v));
}
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)f);
}
#define DEFINE_CMP(op) \
static pic_value \
pic_number_##op(pic_state *pic) \
{ \
size_t argc, i; \
pic_value *argv; \
\
pic_get_args(pic, "*", &argc, &argv); \
\
if (argc < 2) { \
return pic_true_value(); \
} \
\
for (i = 1; i < argc; ++i) { \
if (! pic_##op(pic, argv[i - 1], argv[i])) { \
return pic_false_value(); \
} \
} \
return pic_true_value(); \
}
DEFINE_CMP(eq)
DEFINE_CMP(lt)
DEFINE_CMP(le)
DEFINE_CMP(gt)
DEFINE_CMP(ge)
#define DEFINE_AOP(op, v1, c0) \
static pic_value \
pic_number_##op(pic_state *pic) \
{ \
size_t argc, i; \
pic_value *argv, tmp; \
\
pic_get_args(pic, "*", &argc, &argv); \
\
if (argc == 0) { \
c0; \
} \
else if (argc == 1) { \
return v1; \
} \
\
tmp = argv[0]; \
for (i = 1; i < argc; ++i) { \
tmp = pic_##op(pic, tmp, argv[i]); \
} \
return tmp; \
}
DEFINE_AOP(add, argv[0], do {
return pic_int_value(0);
} while (0))
DEFINE_AOP(mul, argv[0], do {
return pic_int_value(1);
} while (0))
DEFINE_AOP(sub, pic_sub(pic, pic_int_value(0), argv[0]), do {
pic_errorf(pic, "-: at least one argument required");
} while (0))
DEFINE_AOP(div, pic_div(pic, pic_int_value(1), argv[0]), do {
pic_errorf(pic, "/: at least one argument required");
} while (0))
static int
number_string_length(int val, int radix)
{
@ -40,12 +136,6 @@ number_string_length(int val, int radix)
return count;
}
/**
* Returns the string representing val.
* radix is between 2 and 36 (inclusive).
* This function overwrites buffer and stores the result.
* No error checks are performed in this function. It is caller's responsibility to avoid buffer-overrun.
*/
static void
number_string(int val, int radix, int length, char *buffer) {
const char digits[37] = "0123456789abcdefghijklmnopqrstuvwxyz";
@ -69,485 +159,9 @@ number_string(int val, int radix, int length, char *buffer) {
return;
}
static pic_value
pic_number_real_p(pic_state *pic)
{
pic_value v;
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
pic_number_integer_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
if (pic_int_p(v)) {
return pic_true_value();
}
#if PIC_ENABLE_FLOAT
if (pic_float_p(v)) {
double f = pic_float(v);
if (isinf(f)) {
return pic_false_value();
}
if (f == round(f)) {
return pic_true_value();
}
}
#endif
return pic_false_value();
}
static pic_value
pic_number_exact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_int_p(v));
}
static pic_value
pic_number_inexact_p(pic_state *pic)
{
pic_value v;
pic_get_args(pic, "o", &v);
#if PIC_ENABLE_FLOAT
return pic_bool_value(pic_float_p(v));
#else
return pic_false_value();
#endif
}
#define DEFINE_ARITH_CMP(op, name) \
static pic_value \
pic_number_##name(pic_state *pic) \
{ \
size_t argc, i; \
pic_value *argv; \
double f,g; \
\
pic_get_args(pic, "ff*", &f, &g, &argc, &argv); \
\
if (! (f op g)) \
return pic_false_value(); \
\
for (i = 0; i < argc; ++i) { \
f = g; \
if (pic_float_p(argv[i])) \
g = pic_float(argv[i]); \
else 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(); \
}
#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 \
pic_number_##name(pic_state *pic) \
{ \
size_t argc, i; \
pic_value *argv; \
double f; \
bool e = true; \
\
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 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); \
}
#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 = true; \
\
pic_get_args(pic, "F*", &f, &e, &argc, &argv); \
\
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"); \
} \
} \
\
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(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;
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)
{
#if PIC_ENABLE_FLOAT
double f;
bool e;
int radix = 10;
@ -582,46 +196,16 @@ pic_number_number_to_string(pic_state *pic)
}
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_value flo;
pic_get_args(pic, "z|i", &str, &radix);
@ -632,188 +216,30 @@ pic_number_string_to_number(pic_state *pic)
: pic_float_value(num);
}
flo = strtod(str, &eptr);
if (*eptr == '\0') {
return pic_float_value(flo);
flo = pic_read_cstr(pic, str);
if (pic_int_p(flo) || pic_float_p(flo)) {
return 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)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(exp(f));
}
static pic_value
pic_number_log(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
return pic_float_value(log(f));
}
else {
return pic_float_value(log(f) / log(g));
}
}
static pic_value
pic_number_sin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = sin(f);
return pic_float_value(f);
}
static pic_value
pic_number_cos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = cos(f);
return pic_float_value(f);
}
static pic_value
pic_number_tan(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = tan(f);
return pic_float_value(f);
}
static pic_value
pic_number_acos(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = acos(f);
return pic_float_value(f);
}
static pic_value
pic_number_asin(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
f = asin(f);
return pic_float_value(f);
}
static pic_value
pic_number_atan(pic_state *pic)
{
double f,g;
int argc;
argc = pic_get_args(pic, "f|f", &f, &g);
if (argc == 1) {
f = atan(f);
return pic_float_value(f);
}
else {
return pic_float_value(atan2(f,g));
}
}
static pic_value
pic_number_sqrt(pic_state *pic)
{
double f;
pic_get_args(pic, "f", &f);
return pic_float_value(sqrt(f));
}
#endif
void
pic_init_number(pic_state *pic)
{
size_t ai = pic_gc_arena_preserve(pic);
pic_defun(pic, "number?", pic_number_real_p);
pic_defun(pic, "complex?", pic_number_real_p);
pic_defun(pic, "real?", pic_number_real_p);
pic_defun(pic, "rational?", pic_number_real_p);
pic_defun(pic, "integer?", pic_number_integer_p);
pic_defun(pic, "number?", pic_number_number_p);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "exact?", pic_number_exact_p);
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);
@ -827,49 +253,7 @@ 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_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_defun(pic, "sqrt", pic_number_sqrt);
pic_defun(pic, "exp", pic_number_exp);
pic_defun(pic, "log", pic_number_log);
pic_defun(pic, "sin", pic_number_sin);
pic_defun(pic, "cos", pic_number_cos);
pic_defun(pic, "tan", pic_number_tan);
pic_defun(pic, "acos", pic_number_acos);
pic_defun(pic, "asin", pic_number_asin);
pic_defun(pic, "atan", pic_number_atan);
pic_gc_arena_restore(pic, ai);
#endif
}

32
extlib/benz/read.c
View File

@ -64,7 +64,6 @@ 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)
{
@ -76,7 +75,6 @@ strcaseeq(const char *s1, const char *s2)
}
return a == b;
}
#endif
static int
case_fold(pic_state *pic, int c)
@ -271,8 +269,7 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
u = read_uinteger(pic, port, c);
switch (peek(pic, port)) {
#if PIC_ENABLE_FLOAT
# if PIC_ENABLE_LIBC
#if PIC_ENABLE_LIBC
case '.': {
char buf[256];
i = sprintf(buf, "%d", u);
@ -283,16 +280,20 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
sprintf(buf + i, "e%d", read_suffix(pic, port));
return pic_float_value(atof(buf));
}
# else
#else
case '.': {
double f, g;
double f, g, h;
next(pic, port);
g = 0, e = 0;
while (isdigit(c = peek(pic, port))) {
g = g * 10 + (next(pic, port) - '0');
e++;
}
f = u + g * pow(10, -e);
h = 1.0;
while (e-- > 0) {
h /= 10;
}
f = u + g * h;
exp = read_suffix(pic, port);
if (exp >= 0) {
@ -312,7 +313,6 @@ read_unsigned(pic_state *pic, struct pic_port *port, int c)
}
return pic_float_value(f);
}
# endif
#endif
default:
@ -346,15 +346,11 @@ 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
@ -367,14 +363,12 @@ 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);
return pic_float_value(-(1.0 / 0.0));
}
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "-nan.0")) {
return pic_float_value(-NAN);
return pic_float_value(-(0.0 / 0.0));
}
#endif
return sym;
}
}
@ -389,14 +383,12 @@ 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);
return pic_float_value(1.0 / 0.0);
}
if (strcaseeq(pic_symbol_name(pic, pic_sym_ptr(sym)), "+nan.0")) {
return pic_float_value(NAN);
return pic_float_value(0.0 / 0.0);
}
#endif
return sym;
}
}

2
extlib/benz/state.c
View File

@ -48,7 +48,7 @@ pic_init_features(pic_state *pic)
{
pic_add_feature(pic, "picrin");
#if PIC_ENABLE_FLOAT
#if __STDC_IEC_559__
pic_add_feature(pic, "ieee-float");
#endif

2
extlib/benz/string.c
View File

@ -316,11 +316,9 @@ pic_xvfformat(pic_state *pic, xFILE *file, const char *fmt, va_list ap)
case 'p':
xfprintf(pic, file, "%p", va_arg(ap, void *));
break;
#if PIC_ENABLE_FLOAT
case 'f':
xfprintf(pic, file, "%f", va_arg(ap, double));
break;
#endif
}
break;
case '~':

4
extlib/benz/vm.c
View File

@ -103,7 +103,6 @@ pic_get_args(pic_state *pic, const char *format, ...)
*p = GET_OPERAND(pic,i);
break;
}
#if PIC_ENABLE_FLOAT
case 'f': {
double *f;
pic_value v;
@ -169,7 +168,6 @@ pic_get_args(pic_state *pic, const char *format, ...)
}
break;
}
#endif
case 'i': {
int *k;
pic_value v;
@ -178,11 +176,9 @@ 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;

14
extlib/benz/write.c
View File

@ -101,19 +101,19 @@ write_str(pic_state *pic, pic_str *str, xFILE *file, int mode)
xfprintf(pic, file, "\"");
}
#if PIC_ENABLE_FLOAT
static void
write_float(pic_state *pic, double f, xFILE *file)
{
if (isnan(f)) {
xfprintf(pic, file, signbit(f) ? "-nan.0" : "+nan.0");
} else if (isinf(f)) {
xfprintf(pic, file, signbit(f) ? "-inf.0" : "+inf.0");
if (f != f) {
xfprintf(pic, file, "+nan.0");
} else if (f == 1.0 / 0.0) {
xfprintf(pic, file, "+inf.0");
} else if (f == -1.0 / 0.0) {
xfprintf(pic, file, "-inf.0");
} else {
xfprintf(pic, file, "%f", f);
}
}
#endif
static void write_core(struct writer_control *p, pic_value);
@ -291,11 +291,9 @@ write_core(struct writer_control *p, pic_value obj)
case PIC_TT_INT:
xfprintf(pic, file, "%d", pic_int(obj));
break;
#if PIC_ENABLE_FLOAT
case PIC_TT_FLOAT:
write_float(pic, pic_float(obj), file);
break;
#endif
case PIC_TT_SYMBOL:
xfprintf(pic, file, "%s", pic_symbol_name(pic, pic_sym_ptr(obj)));
break;