mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-07-11 15:07:34 +02:00
handling exact/inexact distinction better
This commit is contained in:
Alex Shinn
parent
553ac63a18
commit
26eacabad9
7 changed files with 126 additions and 56 deletions
11
debug.c
11
debug.c
|
|
@ -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
62
eval.c
|
|
@ -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
8
eval.h
|
|
@ -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,
|
||||
|
|
|
|||
85
init.scm
85
init.scm
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
5
sexp.c
|
|
@ -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
5
sexp.h
|
|
@ -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 **************************/
|
||||
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue