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

support exact integer

This commit is contained in:
Yuichi Nishiwaki 2013-10-28 00:21:24 +09:00
parent 63c05209f8
commit d3df6dcbf2
11 changed files with 294 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
include/picrin/irep.h
View File

@ -6,7 +6,8 @@ enum pic_opcode {
OP_PUSHNIL,
OP_PUSHTRUE,
OP_PUSHFALSE,
OP_PUSHNUM,
OP_PUSHFLOAT,
OP_PUSHINT,
OP_PUSHCONST,
OP_GREF,
OP_GSET,

6
include/picrin/value.h
View File

@ -7,6 +7,7 @@ enum pic_vtype {
PIC_VTYPE_FALSE,
PIC_VTYPE_UNDEF,
PIC_VTYPE_FLOAT,
PIC_VTYPE_INT,
PIC_VTYPE_EOF,
PIC_VTYPE_HEAP
};
@ -16,6 +17,7 @@ typedef struct {
union {
void *data;
double f;
int i;
} u;
} pic_value;
@ -24,6 +26,7 @@ enum pic_tt {
PIC_TT_NIL,
PIC_TT_BOOL,
PIC_TT_FLOAT,
PIC_TT_INT,
PIC_TT_EOF,
PIC_TT_UNDEF,
/* heap */
@ -76,14 +79,17 @@ pic_value pic_bool_value(bool);
pic_value pic_undef_value();
pic_value pic_obj_value(void *);
pic_value pic_float_value(double);
pic_value pic_int_value(int);
#define pic_float(v) ((v).u.f)
#define pic_int(v) ((v).u.i)
#define pic_nil_p(v) ((v).type == PIC_VTYPE_NIL)
#define pic_true_p(v) ((v).type == PIC_VTYPE_TRUE)
#define pic_false_p(v) ((v).type == PIC_VTYPE_FALSE)
#define pic_undef_p(v) ((v).type == PIC_VTYPE_UNDEF)
#define pic_float_p(v) ((v).type == PIC_VTYPE_FLOAT)
#define pic_int_p(v) ((v).type == PIC_VTYPE_INT)
#define pic_pair_p(v) (pic_type(v) == PIC_TT_PAIR)
#define pic_symbol_p(v) (pic_type(v) == PIC_TT_SYMBOL)

15
src/codegen.c
View File

@ -475,11 +475,17 @@ codegen(codegen_state *state, pic_value obj)
break;
}
case PIC_TT_FLOAT: {
irep->code[irep->clen].insn = OP_PUSHNUM;
irep->code[irep->clen].insn = OP_PUSHFLOAT;
irep->code[irep->clen].u.f = pic_float(obj);
irep->clen++;
break;
}
case PIC_TT_INT: {
irep->code[irep->clen].insn = OP_PUSHINT;
irep->code[irep->clen].u.i = pic_int(obj);
irep->clen++;
break;
}
case PIC_TT_NIL: {
irep->code[irep->clen].insn = OP_PUSHNIL;
irep->clen++;
@ -675,8 +681,11 @@ print_irep(pic_state *pic, struct pic_irep *irep)
case OP_PUSHFALSE:
puts("OP_PUSHFALSE");
break;
case OP_PUSHNUM:
printf("OP_PUSHNUM\t%g\n", irep->code[i].u.f);
case OP_PUSHFLOAT:
printf("OP_PUSHFLOAT\t%f\n", irep->code[i].u.f);
break;
case OP_PUSHINT:
printf("OP_PUSHINT\t%d\n", irep->code[i].u.i);
break;
case OP_PUSHCONST:
printf("OP_PUSHCONST\t");

2
src/gc.c
View File

@ -185,6 +185,7 @@ gc_mark_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
pic_abort(pic, "logic flaw");
@ -309,6 +310,7 @@ gc_finalize_object(pic_state *pic, struct pic_object *obj)
case PIC_TT_NIL:
case PIC_TT_BOOL:
case PIC_TT_FLOAT:
case PIC_TT_INT:
case PIC_TT_EOF:
case PIC_TT_UNDEF:
pic_abort(pic, "logic flaw");

178
src/number.c
View File

@ -1,4 +1,5 @@
#include <math.h>
#include <limits.h>
#include "picrin.h"
@ -9,7 +10,7 @@ pic_number_real_p(pic_state *pic)
pic_get_args(pic, "o", &v);
return pic_bool_value(pic_float_p(v));
return pic_bool_value(pic_float_p(v) || pic_int_p(v));
}
static pic_value
@ -19,6 +20,9 @@ pic_number_integer_p(pic_state *pic)
pic_get_args(pic, "o", &v);
if (pic_int_p(v)) {
return pic_true_value();
}
if (pic_float_p(v)) {
double f = pic_float(v);
@ -29,6 +33,26 @@ pic_number_integer_p(pic_state *pic)
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);
return pic_bool_value(pic_float_p(v));
}
static pic_value
pic_number_infinite_p(pic_state *pic)
{
@ -59,89 +83,146 @@ static pic_value
pic_number_abs(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "f", &f);
return pic_float_value(fabs(f));
pic_get_args(pic, "F", &f, &e);
if (e) {
return pic_int_value(fabs(f));
}
else {
return pic_float_value(fabs(f));
}
}
static pic_value
pic_number_floor_quotient(pic_state *pic)
{
double f,g;
int i,j;
bool e1, e2;
pic_get_args(pic, "ff", &f, &g);
return pic_float_value(floor(f/g));
pic_get_args(pic, "II", &i, &e1, &j, &e2);
if (e1 && e2) {
return pic_int_value((int)floor((double)i/j));
}
else {
return pic_float_value(floor((double)i/j));
}
}
static pic_value
pic_number_floor_remainder(pic_state *pic)
{
double f,g,q;
int i,j,q;
bool e1, e2;
pic_get_args(pic, "ff", &f, &g);
pic_get_args(pic, "II", &i, &e1, &j, &e2);
q = floor(f/g);
return pic_float_value(f - g * q);
q = (int)floor((double)i/j);
if (e1 && e2) {
return pic_int_value(i - j * q);
}
else {
return pic_float_value(i - j * q);
}
}
static pic_value
pic_number_truncate_quotient(pic_state *pic)
pic_number_trunc_quotient(pic_state *pic)
{
double f,g;
int i,j;
bool e1, e2;
pic_get_args(pic, "ff", &f, &g);
return pic_float_value(trunc(f/g));
pic_get_args(pic, "II", &i, &e1, &j, &e2);
if (e1 && e2) {
return pic_int_value((int)trunc((double)i/j));
}
else {
return pic_float_value(trunc((double)i/j));
}
}
static pic_value
pic_number_truncate_remainder(pic_state *pic)
pic_number_trunc_remainder(pic_state *pic)
{
double f,g,q;
int i,j,q;
bool e1, e2;
pic_get_args(pic, "ff", &f, &g);
pic_get_args(pic, "II", &i, &e1, &j, &e2);
q = trunc(f/g);
return pic_float_value(f - g * q);
q = (int)trunc((double)i/j);
if (e1 && e2) {
return pic_int_value(i - j * q);
}
else {
return pic_float_value(i - j * q);
}
}
static pic_value
pic_number_floor(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "f", &f);
pic_get_args(pic, "F", &f, &e);
return pic_float_value(floor(f));
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(floor(f));
}
}
static pic_value
pic_number_ceiling(pic_state *pic)
pic_number_ceil(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "f", &f);
pic_get_args(pic, "F", &f, &e);
return pic_float_value(ceil(f));
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(ceil(f));
}
}
static pic_value
pic_number_truncate(pic_state *pic)
pic_number_trunc(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "f", &f);
pic_get_args(pic, "F", &f, &e);
return pic_float_value(trunc(f));
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);
pic_get_args(pic, "F", &f, &e);
return pic_float_value(round(f));
if (e) {
return pic_int_value((int)f);
}
else {
return pic_float_value(round(f));
}
}
static pic_value
@ -238,9 +319,17 @@ static pic_value
pic_number_square(pic_state *pic)
{
double f;
bool e;
pic_get_args(pic, "f", &f);
pic_get_args(pic, "F", &f, &e);
if (e) {
long long i = (long long)f;
if (i * i <= INT_MAX) {
return pic_int_value(i * i);
}
}
return pic_float_value(f * f);
}
@ -250,17 +339,25 @@ pic_number_sqrt(pic_state *pic)
double f;
pic_get_args(pic, "f", &f);
f = sqrt(f);
return pic_float_value(f);
return pic_float_value(sqrt(f));
}
static pic_value
pic_number_expt(pic_state *pic)
{
double f,g;
double f, g, h;
bool e1, e2;
pic_get_args(pic, "ff", &f, &g);
return pic_float_value(pow(f,g));
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
@ -275,6 +372,9 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "integer?", pic_number_integer_p);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "exact?", pic_number_exact_p);
pic_defun(pic, "inexact?", pic_number_inexact_p);
pic_defun(pic, "exact-integer?", pic_number_exact_p);
pic_defun(pic, "infinite?", pic_number_infinite_p);
pic_defun(pic, "nan?", pic_number_nan_p);
pic_gc_arena_restore(pic, ai);
@ -283,13 +383,13 @@ pic_init_number(pic_state *pic)
pic_defun(pic, "floor-quotient", pic_number_floor_quotient);
pic_defun(pic, "floor-remainder", pic_number_floor_remainder);
pic_defun(pic, "truncate-quotient", pic_number_truncate_quotient);
pic_defun(pic, "truncate-remainder", pic_number_truncate_remainder);
pic_defun(pic, "truncate-quotient", pic_number_trunc_quotient);
pic_defun(pic, "truncate-remainder", pic_number_trunc_remainder);
pic_gc_arena_restore(pic, ai);
pic_defun(pic, "floor", pic_number_floor);
pic_defun(pic, "ceiling", pic_number_ceiling);
pic_defun(pic, "truncate", pic_number_truncate);
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);

5
src/port.c
View File

@ -30,7 +30,10 @@ write(pic_state *pic, pic_value obj)
printf("%s", pic_symbol_ptr(obj)->name);
break;
case PIC_TT_FLOAT:
printf("%.10g", pic_float(obj));
printf("%f", pic_float(obj));
break;
case PIC_TT_INT:
printf("%d", pic_int(obj));
break;
case PIC_TT_EOF:
printf("#<eof-object>");

5
src/scan.l
View File

@ -31,7 +31,9 @@ identifier [a-z0-9A-Z+/*!$%&:@^~?<=>_.-]+
/* number */
digit [0-9]
real {sign}{ureal}|{infnan}
ureal {digit}+|\.{digit}+|{digit}+\.{digit}*
ureal {uinteger}|\.{digit}+|{digit}+\.{digit}*
integer {sign}{uinteger}
uinteger {digit}+
sign [+-]?
infnan "+inf.0"|"-inf.0"|"+nan.0"|"-nan.0"
@ -49,6 +51,7 @@ infnan "+inf.0"|"-inf.0"|"+nan.0"|"-nan.0"
"," return tUNQUOTE;
",@" return tUNQUOTE_SPLICING;
{boolean} { yylvalp->datum = pic_bool_value(strcmp(yytext, "#t") == 0 || strcmp(yytext, "#true") == 0); return tBOOLEAN; }
{integer} { yylvalp->datum = pic_int_value(atoi(yytext)); return tNUMBER; }
{real} { yylvalp->datum = pic_float_value(atof(yytext)); return tNUMBER; }
{identifier} { yylvalp->datum = pic_intern_cstr(p->pic, yytext); return tSYMBOL; }
"\"" BEGIN(STRING);

6
src/system.c
View File

@ -33,6 +33,9 @@ pic_system_exit(pic_state *pic)
case PIC_TT_FLOAT:
status = (int)pic_float(v);
break;
case PIC_TT_INT:
status = pic_int(v);
break;
default:
break;
}
@ -53,6 +56,9 @@ pic_system_emergency_exit(pic_state *pic)
case PIC_TT_FLOAT:
status = (int)pic_float(v);
break;
case PIC_TT_INT:
status = pic_int(v);
break;
default:
break;
}

4
src/time.c
View File

@ -23,7 +23,7 @@ pic_current_jiffy(pic_state *pic)
pic_get_args(pic, "");
c = clock();
return pic_float_value((double)c);
return pic_int_value(c);
}
static pic_value
@ -31,7 +31,7 @@ pic_jiffies_per_second(pic_state *pic)
{
pic_get_args(pic, "");
return pic_float_value((double)CLOCKS_PER_SEC);
return pic_int_value(CLOCKS_PER_SEC);
}
void

12
src/value.c
View File

@ -17,6 +17,8 @@ pic_type(pic_value v)
return PIC_TT_UNDEF;
case PIC_VTYPE_FLOAT:
return PIC_TT_FLOAT;
case PIC_VTYPE_INT:
return PIC_TT_INT;
case PIC_VTYPE_EOF:
return PIC_TT_EOF;
case PIC_VTYPE_HEAP:
@ -86,6 +88,16 @@ pic_float_value(double f)
return v;
}
pic_value
pic_int_value(int i)
{
pic_value v;
v.type = PIC_VTYPE_INT;
v.u.i = i;
return v;
}
pic_value
pic_undef_value()
{

151
src/vm.c
View File

@ -58,6 +58,29 @@ pic_get_args(pic_state *pic, const char *format, ...)
}
}
break;
case 'F':
{
double *f;
bool *e;
f = va_arg(ap, double *);
e = va_arg(ap, bool *);
if (i < argc) {
pic_value v;
v = GET_OPERAND(pic, i);
if (pic_type(v) == PIC_TT_FLOAT) {
*f = pic_float(v);
*e = false;
}
else {
*f = pic_int(v);
*e = true;
}
i++;
}
}
break;
case 's':
{
pic_value str;
@ -117,10 +140,10 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args)
#if PIC_DIRECT_THREADED_VM
static void *oplabels[] = {
&&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHNUM,
&&L_OP_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF, &&L_OP_LSET,
&&L_OP_CREF, &&L_OP_CSET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL, &&L_OP_RET,
&&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_POP, &&L_OP_PUSHNIL, &&L_OP_PUSHTRUE, &&L_OP_PUSHFALSE, &&L_OP_PUSHFLOAT,
&&L_OP_PUSHINT, &&L_OP_PUSHCONST, &&L_OP_GREF, &&L_OP_GSET, &&L_OP_LREF,
&&L_OP_LSET, &&L_OP_CREF, &&L_OP_CSET, &&L_OP_JMP, &&L_OP_JMPIF, &&L_OP_CALL,
&&L_OP_RET, &&L_OP_LAMBDA, &&L_OP_CONS, &&L_OP_CAR, &&L_OP_CDR, &&L_OP_NILP,
&&L_OP_ADD, &&L_OP_SUB, &&L_OP_MUL, &&L_OP_DIV,
&&L_OP_EQ, &&L_OP_LT, &&L_OP_LE, &&L_OP_STOP
};
@ -159,10 +182,14 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args)
PUSH(pic_false_value());
NEXT;
}
CASE(OP_PUSHNUM) {
CASE(OP_PUSHFLOAT) {
PUSH(pic_float_value(pc->u.f));
NEXT;
}
CASE(OP_PUSHINT) {
PUSH(pic_int_value(pc->u.i));
NEXT;
}
CASE(OP_PUSHCONST) {
PUSH(pic->pool[pc->u.i]);
NEXT;
@ -330,55 +357,87 @@ pic_run(pic_state *pic, struct pic_proc *proc, pic_value args)
PUSH(pic_bool_value(pic_nil_p(p)));
NEXT;
}
CASE(OP_ADD) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_float_value(pic_float(a) + pic_float(b)));
NEXT;
}
CASE(OP_SUB) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_float_value(pic_float(a) - pic_float(b)));
NEXT;
}
CASE(OP_MUL) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_float_value(pic_float(a) * pic_float(b)));
NEXT;
#define DEFINE_ARITH_OP(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 if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_float_p(b)) { \
PUSH(pic_float_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_float_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_ARITH_OP(OP_ADD, +);
DEFINE_ARITH_OP(OP_SUB, -);
DEFINE_ARITH_OP(OP_MUL, *);
/* special care for (int / int) division */
CASE(OP_DIV) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_float_value(pic_float(a) / pic_float(b)));
if (pic_int_p(a) && pic_int_p(b)) {
PUSH(pic_float_value((double)pic_int(a) / pic_int(b)));
}
else if (pic_float_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_float(b)));
}
else if (pic_int_p(a) && pic_float_p(b)) {
PUSH(pic_float_value(pic_int(a) / pic_float(b)));
}
else if (pic_float_p(a) && pic_int_p(b)) {
PUSH(pic_float_value(pic_float(a) / pic_int(b)));
}
else {
pic->errmsg = "/ got non-number operands";
goto L_RAISE;
}
NEXT;
}
CASE(OP_EQ) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic_float(a) == pic_float(b)));
NEXT;
}
CASE(OP_LT) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic_float(a) < pic_float(b)));
NEXT;
}
CASE(OP_LE) {
pic_value a, b;
b = POP();
a = POP();
PUSH(pic_bool_value(pic_float(a) <= pic_float(b)));
NEXT;
#define DEFINE_COMP_OP(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 if (pic_float_p(a) && pic_float_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_float(b))); \
} \
else if (pic_int_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_int(a) op pic_float(b))); \
} \
else if (pic_float_p(a) && pic_int_p(b)) { \
PUSH(pic_bool_value(pic_float(a) op pic_int(b))); \
} \
else { \
pic->errmsg = #op " got non-number operands"; \
goto L_RAISE; \
} \
NEXT; \
}
DEFINE_COMP_OP(OP_EQ, ==);
DEFINE_COMP_OP(OP_LT, <);
DEFINE_COMP_OP(OP_LE, <=);
CASE(OP_STOP) {
pic_value val;