handling exact/inexact distinction better

This commit is contained in:
Alex Shinn 2009-04-02 16:19:52 +09:00
parent 553ac63a18
commit 26eacabad9
7 changed files with 126 additions and 56 deletions

11
debug.c
View file

@ -6,11 +6,12 @@ static const char* reverse_opcode_names[] =
{"NOOP", "ERROR", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
"FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "EVAL", "JUMP-UNLESS",
"JUMP", "PUSH", "DROP", "STACK-REF", "LOCAL-REF", "LOCAL-SET",
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH",
"STRING-REF", "STRING-SET", "STRING-LENGTH",
"MAKE-PROCEDURE", "MAKE-VECTOR", "NULLP", "INTEGERP", "SYMBOLP", "CHARP",
"EOFP", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQV", "EQ",
"CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
"STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR", "NULL?",
"FIXNUM?", "SYMBOL?", "CHAR?",
"EOF?", "TYPEP", "CAR", "CDR", "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
"MUL", "DIV", "QUOT", "MOD", "NEG", "INV", "LT", "LE", "EQN", "EQ",
"EXACT->INEXACT", "INEXACT->EXACT",
"CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
"DISPLAY", "WRITE", "WRITE-CHAR",
"NEWLINE", "FLUSH-OUTPUT", "READ", "READ-CHAR", "RET", "DONE",

62
eval.c
View file

@ -1316,20 +1316,72 @@ sexp vm(sexp bc, sexp cp, sexp context, sexp* stack, sexp_sint_t top) {
else sexp_raise("/: not a number", sexp_list1(_ARG1));
break;
case OP_LT:
_ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1)
< sexp_unbox_integer(_ARG2));
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
i = _ARG1 < _ARG2;
#if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
i = sexp_flonum_value(_ARG1) < sexp_flonum_value(_ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
i = sexp_flonum_value(_ARG1) < (double)sexp_unbox_integer(_ARG2);
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) < sexp_flonum_value(_ARG2);
#endif
else sexp_raise("<: not a number", sexp_list2(_ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i);
top--;
break;
case OP_LE:
_ARG2 = sexp_make_boolean(sexp_unbox_integer(_ARG1)
<= sexp_unbox_integer(_ARG2));
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
i = _ARG1 <= _ARG2;
#if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
i = sexp_flonum_value(_ARG1) <= sexp_flonum_value(_ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
i = sexp_flonum_value(_ARG1) <= (double)sexp_unbox_integer(_ARG2);
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) <= sexp_flonum_value(_ARG2);
#endif
else sexp_raise("<=: not a number", sexp_list2(_ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i);
top--;
break;
case OP_EQN:
if (sexp_integerp(_ARG1) && sexp_integerp(_ARG2))
i = _ARG1 == _ARG2;
#if USE_FLONUMS
else if (sexp_flonump(_ARG1) && sexp_flonump(_ARG2))
i = sexp_flonum_value(_ARG1) == sexp_flonum_value(_ARG2);
else if (sexp_flonump(_ARG1) && sexp_integerp(_ARG2))
i = sexp_flonum_value(_ARG1) == (double)sexp_unbox_integer(_ARG2);
else if (sexp_integerp(_ARG1) && sexp_flonump(_ARG2))
i = (double)sexp_unbox_integer(_ARG1) == sexp_flonum_value(_ARG2);
#endif
else sexp_raise("=: not a number", sexp_list2(_ARG1, _ARG2));
_ARG2 = sexp_make_boolean(i);
top--;
break;
case OP_EQ:
case OP_EQV:
_ARG2 = sexp_make_boolean(_ARG1 == _ARG2);
top--;
break;
case OP_FIX2FLO:
if (sexp_integerp(_ARG1))
_ARG1 = sexp_integer_to_flonum(_ARG1);
else
#if USE_FLONUMS
if (! sexp_flonump(_ARG1))
#endif
sexp_raise("exact->inexact: not a number", sexp_list1(_ARG1));
break;
case OP_FLO2FIX:
#if USE_FLONUMS
if (sexp_flonump(_ARG1))
_ARG1 = sexp_make_integer((sexp_sint_t)sexp_flonum_value(_ARG1));
else
#endif
if (! sexp_integerp(_ARG1))
sexp_raise("inexact->exact: not a number", sexp_list1(_ARG1));
break;
case OP_CHAR2INT:
_ARG1 = sexp_make_integer(sexp_unbox_character(_ARG1));
break;

8
eval.h
View file

@ -7,10 +7,6 @@
#include "sexp.h"
#if USE_MATH
#include <math.h>
#endif
/************************* additional types ***************************/
#define INIT_BCODE_SIZE 128
@ -107,8 +103,10 @@ enum opcode_names {
OP_INV,
OP_LT,
OP_LE,
OP_EQV,
OP_EQN,
OP_EQ,
OP_FIX2FLO,
OP_FLO2FIX,
OP_CHAR2INT,
OP_INT2CHAR,
OP_CHAR_UPCASE,

View file

@ -1,8 +1,7 @@
;; let-syntax letrec-syntax syntax-rules
;; number? complex? real? rational? integer? exact? inexact?
;; remainder modulo
;; exact->inexact inexact->exact number->string string->number
;; number->string string->number
;; symbol->string string->symbol
;; char-alphabetic? char-numeric? char-whitespace?
;; char-upper-case? char-lower-case?
@ -15,16 +14,12 @@
;; with-input-from-file with-output-to-file
;; peek-char char-ready?
(define (not x) (if x #f #t))
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
;; provide c[ad]{2,4}r
(define (caar x) (car (car x)))
(define (cadr x) (car (cdr x)))
(define (cdar x) (cdr (car x)))
(define (cddr x) (cdr (cdr x)))
(define (caaar x) (car (car (car x))))
(define (caadr x) (car (car (cdr x))))
(define (cadar x) (car (cdr (car x))))
@ -33,23 +28,22 @@
(define (cdadr x) (cdr (car (cdr x))))
(define (cddar x) (cdr (cdr (car x))))
(define (cdddr x) (cdr (cdr (cdr x))))
;; (define (caaaar x) (car (car (car (car x)))))
;; (define (caaadr x) (car (car (car (cdr x)))))
;; (define (caadar x) (car (car (cdr (car x)))))
;; (define (caaddr x) (car (car (cdr (cdr x)))))
;; (define (cadaar x) (car (cdr (car (car x)))))
;; (define (cadadr x) (car (cdr (car (cdr x)))))
;; (define (caddar x) (car (cdr (cdr (car x)))))
;; (define (cadddr x) (car (cdr (cdr (cdr x)))))
;; (define (cdaaar x) (cdr (car (car (car x)))))
;; (define (cdaadr x) (cdr (car (car (cdr x)))))
;; (define (cdadar x) (cdr (car (cdr (car x)))))
;; (define (cdaddr x) (cdr (car (cdr (cdr x)))))
;; (define (cddaar x) (cdr (cdr (car (car x)))))
;; (define (cddadr x) (cdr (cdr (car (cdr x)))))
;; (define (cdddar x) (cdr (cdr (cdr (car x)))))
;; (define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (caaaar x) (car (car (car (car x)))))
(define (caaadr x) (car (car (car (cdr x)))))
(define (caadar x) (car (car (cdr (car x)))))
(define (caaddr x) (car (car (cdr (cdr x)))))
(define (cadaar x) (car (cdr (car (car x)))))
(define (cadadr x) (car (cdr (car (cdr x)))))
(define (caddar x) (car (cdr (cdr (car x)))))
(define (cadddr x) (car (cdr (cdr (cdr x)))))
(define (cdaaar x) (cdr (car (car (car x)))))
(define (cdaadr x) (cdr (car (car (cdr x)))))
(define (cdadar x) (cdr (car (cdr (car x)))))
(define (cdaddr x) (cdr (car (cdr (cdr x)))))
(define (cddaar x) (cdr (cdr (car (car x)))))
(define (cddadr x) (cdr (cdr (car (cdr x)))))
(define (cdddar x) (cdr (cdr (cdr (car x)))))
(define (cddddr x) (cdr (cdr (cdr (cdr x)))))
(define (list . args) args)
@ -60,7 +54,7 @@
(define (list-ref ls k) (car (list-tail ls k)))
(define eqv? equal?)
(define (eqv? a b) (if (eq? a b) #t (and (flonum? a) (flonum? b) (= a b))))
(define (member obj ls)
(if (null? ls)
@ -297,24 +291,29 @@
(define (force x) (if (procedure? x) (x) x))
;; booleans
(define (not x) (if x #f #t))
(define (boolean? x) (if (eq? x #t) #t (eq? x #f)))
;; char utils
;; (define (char=? a b) (= (char->integer a) (char->integer b)))
;; (define (char<? a b) (< (char->integer a) (char->integer b)))
;; (define (char>? a b) (> (char->integer a) (char->integer b)))
;; (define (char<=? a b) (<= (char->integer a) (char->integer b)))
;; (define (char>=? a b) (>= (char->integer a) (char->integer b)))
(define (char=? a b) (= (char->integer a) (char->integer b)))
(define (char<? a b) (< (char->integer a) (char->integer b)))
(define (char>? a b) (> (char->integer a) (char->integer b)))
(define (char<=? a b) (<= (char->integer a) (char->integer b)))
(define (char>=? a b) (>= (char->integer a) (char->integer b)))
;; (define (char-ci=? a b)
;; (= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci<? a b)
;; (< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci>? a b)
;; (> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci<=? a b)
;; (<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; (define (char-ci>=? a b)
;; (>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci=? a b)
(= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci<? a b)
(< (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci>? a b)
(> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci<=? a b)
(<= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci>=? a b)
(>= (char->integer (char-downcase a)) (char->integer (char-downcase b))))
;; string utils
@ -339,6 +338,14 @@
;; math utils
(define (number? x) (if (fixnum? x) #t (flonum? x)))
(define complex? number?)
(define rational? number?)
(define real? number?)
(define exact? fixnum?)
(define inexact? flonum?)
(define (integer? x) (if (fixnum? x) #t (and (flonum? x) (= x (truncate x)))))
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
(define (negative? x) (< x 0))

View file

@ -19,6 +19,8 @@ _OP(OPC_ACCESSOR, OP_VECTOR_LENGTH,1,0, SEXP_VECTOR, 0, 0,"vector-length", NULL,
_OP(OPC_ACCESSOR, OP_STRING_REF,2,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-ref", NULL, NULL),
_OP(OPC_ACCESSOR, OP_STRING_SET,3,0, SEXP_STRING, SEXP_FIXNUM, 0,"string-set!", NULL, NULL),
_OP(OPC_ACCESSOR, OP_STRING_LENGTH,1,0, SEXP_STRING, 0, 0,"string-length", NULL, NULL),
_OP(OPC_GENERIC, OP_FIX2FLO, 1, 0, 0, 0, 0, "exact->inexact", NULL, NULL),
_OP(OPC_GENERIC, OP_FLO2FIX, 1, 0, 0, 0, 0, "inexact->exact", NULL, NULL),
_OP(OPC_GENERIC, OP_CHAR2INT, 1, 0, SEXP_CHAR, 0, 0, "char->integer", NULL, NULL),
_OP(OPC_GENERIC, OP_INT2CHAR, 1, 0, SEXP_FIXNUM, 0, 0, "integer->char", NULL, NULL),
_OP(OPC_GENERIC, OP_CHAR_UPCASE, 1, 0, SEXP_CHAR, 0, 0, "char-upcase", NULL, NULL),
@ -33,7 +35,7 @@ _OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 0, "<", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 0, "<=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LT, 0, 1, SEXP_FIXNUM, 0, 1, ">", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_LE, 0, 1, SEXP_FIXNUM, 0, 1, ">=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_EQ, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL),
_OP(OPC_ARITHMETIC_CMP, OP_EQN, 0, 1, SEXP_FIXNUM, 0, 0, "=", NULL, NULL),
_OP(OPC_PREDICATE, OP_EQ, 2, 0, 0, 0, 0, "eq?", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_CONS, 2, 0, 0, 0, 0, "cons", NULL, NULL),
_OP(OPC_CONSTRUCTOR, OP_MAKE_VECTOR, 2, 0, SEXP_FIXNUM, 0, 0, "make-vector", NULL, NULL),
@ -42,9 +44,11 @@ _OP(OPC_TYPE_PREDICATE, OP_NULLP, 1, 0, 0, 0, 0, "null?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_EOFP, 1, 0, 0, 0, 0, "eof-object?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_SYMBOLP, 1, 0, 0, 0, 0, "symbol?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_CHARP, 1, 0, 0, 0, 0, "char?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_INTEGERP, 1, 0, 0, 0, 0, "fixnum?", NULL, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "pair?", (sexp)SEXP_PAIR, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "string?", (sexp)SEXP_STRING, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "vector?", (sexp)SEXP_VECTOR, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "flonum?", (sexp)SEXP_FLONUM, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "procedure?", (sexp)SEXP_PROCEDURE, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "input-port?", (sexp)SEXP_IPORT, NULL),
_OP(OPC_TYPE_PREDICATE, OP_TYPEP, 1, 0, 0, 0, 0, "output-port?", (sexp)SEXP_OPORT, NULL),

5
sexp.c
View file

@ -449,6 +449,7 @@ sexp sexp_make_output_port(FILE* out) {
void sexp_write (sexp obj, sexp out) {
unsigned long len, c, res;
long i=0;
double f;
sexp x, *elts;
char *str=NULL;
@ -485,7 +486,9 @@ void sexp_write (sexp obj, sexp out) {
}
break;
case SEXP_FLONUM:
sexp_printf(out, "%g", sexp_flonum_value(obj)); break;
f = sexp_flonum_value(obj);
sexp_printf(out, "%.15g%s", f, (f == trunc(f)) ? ".0" : "");
break;
case SEXP_PROCEDURE:
sexp_printf(out, "#<procedure: %p>", obj); break;
case SEXP_IPORT:

5
sexp.h
View file

@ -11,6 +11,7 @@
#include <string.h>
#include <stdarg.h>
#include <sysexits.h>
#include <math.h>
#include "config.h"
#include "defaults.h"
@ -230,7 +231,11 @@ struct sexp_struct {
#define sexp_flonum_value(f) ((f)->value.flonum)
#if USE_FLONUMS
#define sexp_integer_to_flonum(x) (sexp_make_flonum(sexp_unbox_integer(x)))
#else
#define sexp_integer_to_flonum(x) (x)
#endif
/*************************** field accessors **************************/