From d3df6dcbf2a1e7c38b4cf4b97be7a42c43992ac2 Mon Sep 17 00:00:00 2001 From: Yuichi Nishiwaki Date: Mon, 28 Oct 2013 00:21:24 +0900 Subject: [PATCH] support exact integer --- include/picrin/irep.h | 3 +- include/picrin/value.h | 6 ++ src/codegen.c | 15 +++- src/gc.c | 2 + src/number.c | 178 ++++++++++++++++++++++++++++++++--------- src/port.c | 5 +- src/scan.l | 5 +- src/system.c | 6 ++ src/time.c | 4 +- src/value.c | 12 +++ src/vm.c | 151 +++++++++++++++++++++++----------- 11 files changed, 294 insertions(+), 93 deletions(-) diff --git a/include/picrin/irep.h b/include/picrin/irep.h index 37d20fb4..4f0ce8ba 100644 --- a/include/picrin/irep.h +++ b/include/picrin/irep.h @@ -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, diff --git a/include/picrin/value.h b/include/picrin/value.h index 903367a5..7181813e 100644 --- a/include/picrin/value.h +++ b/include/picrin/value.h @@ -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) diff --git a/src/codegen.c b/src/codegen.c index ac4063f1..cf2904a6 100644 --- a/src/codegen.c +++ b/src/codegen.c @@ -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"); diff --git a/src/gc.c b/src/gc.c index 9dee4aec..d3b5ce43 100644 --- a/src/gc.c +++ b/src/gc.c @@ -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"); diff --git a/src/number.c b/src/number.c index a7a0deb4..69c9ca03 100644 --- a/src/number.c +++ b/src/number.c @@ -1,4 +1,5 @@ #include +#include #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); diff --git a/src/port.c b/src/port.c index 3fcf6a0c..b44ee312 100644 --- a/src/port.c +++ b/src/port.c @@ -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("#"); diff --git a/src/scan.l b/src/scan.l index 469d9499..6df5a132 100644 --- a/src/scan.l +++ b/src/scan.l @@ -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); diff --git a/src/system.c b/src/system.c index 2a469440..ed3a9e29 100644 --- a/src/system.c +++ b/src/system.c @@ -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; } diff --git a/src/time.c b/src/time.c index 12f79f3d..e6076b24 100644 --- a/src/time.c +++ b/src/time.c @@ -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 diff --git a/src/value.c b/src/value.c index fff723d4..ad6e741d 100644 --- a/src/value.c +++ b/src/value.c @@ -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() { diff --git a/src/vm.c b/src/vm.c index 4848e79f..e42ab1c7 100644 --- a/src/vm.c +++ b/src/vm.c @@ -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;