ref: 36a209cd5f648d4e7cdac062d8ecb321b561847d
parent: 81641a224004107240a3c7bb4e24b66bf92afb73
author: JeffBezanson <jeff.bezanson@gmail.com>
date: Wed Apr 15 19:54:43 EDT 2009
making = a builtin fixing = and eqv? to work properly on NaNs fixing other comparison predicates to be consistent
--- a/femtolisp/compiler.lsp
+++ b/femtolisp/compiler.lsp
@@ -17,7 +17,7 @@
:cons :list :car :cdr :set-car! :set-cdr!
:eval :apply
- :+ :- :* :/ :< :compare
+ :+ :- :* :/ := :< :compare
:vector :aref :aset! :for
@@ -40,7 +40,8 @@
:set-cdr! 2 :eval 1
:apply 2 :< 2
:for 3 :compare 2
- :aref 2 :aset! 3))
+ :aref 2 :aset! 3
+ := 2))
(define 1/Instructions (table.invert Instructions))
--- a/femtolisp/equal.c
+++ b/femtolisp/equal.c
@@ -34,17 +34,23 @@
}
// a is a fixnum, b is a cprim
-static value_t compare_num_cprim(value_t a, value_t b, int eq)
+static value_t compare_num_cprim(value_t a, value_t b, int eq, int swap)
{cprim_t *bcp = (cprim_t*)ptr(b);
numerictype_t bt = cp_numtype(bcp);
fixnum_t ia = numval(a);
void *bptr = cp_data(bcp);
- if (cmp_eq(&ia, T_FIXNUM, bptr, bt))
+ if (cmp_eq(&ia, T_FIXNUM, bptr, bt, 1))
return fixnum(0);
if (eq) return fixnum(1);
- if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
- return fixnum(-1);
+ if (swap) {+ if (cmp_lt(bptr, bt, &ia, T_FIXNUM))
+ return fixnum(-1);
+ }
+ else {+ if (cmp_lt(&ia, T_FIXNUM, bptr, bt))
+ return fixnum(-1);
+ }
return fixnum(1);
}
@@ -87,7 +93,7 @@
return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1);
}
if (iscprim(b)) {- return compare_num_cprim(a, b, eq);
+ return compare_num_cprim(a, b, eq, 0);
}
return fixnum(-1);
case TAG_SYM:
@@ -104,7 +110,7 @@
cprim_t *acp=(cprim_t*)ptr(a), *bcp=(cprim_t*)ptr(b);
numerictype_t at=cp_numtype(acp), bt=cp_numtype(bcp);
void *aptr=cp_data(acp), *bptr=cp_data(bcp);
- if (cmp_eq(aptr, at, bptr, bt))
+ if (cmp_eq(aptr, at, bptr, bt, 1))
return fixnum(0);
if (eq) return fixnum(1);
if (cmp_lt(aptr, at, bptr, bt))
@@ -112,7 +118,7 @@
return fixnum(1);
}
else if (isfixnum(b)) {- return fixnum(-numval(compare_num_cprim(b, a, eq)));
+ return compare_num_cprim(b, a, eq, 1);
}
break;
case TAG_CVALUE:
--- a/femtolisp/flisp.c
+++ b/femtolisp/flisp.c
@@ -68,7 +68,7 @@
"eval", "apply",
// arithmetic
- "+", "-", "*", "/", "<", "compare",
+ "+", "-", "*", "/", "=", "<", "compare",
// sequences
"vector", "aref", "aset!", "for",
@@ -649,6 +649,33 @@
return (isfixnum(v) || iscprim(v));
}
+static int numeric_equals(value_t a, value_t b)
+{+ value_t tmp;
+ if (isfixnum(b)) {+ tmp=a; a=b; b=tmp;
+ }
+ void *aptr, *bptr;
+ numerictype_t at, bt;
+ if (!iscprim(b)) type_error("=", "number", b);+ cprim_t *cp = (cprim_t*)ptr(b);
+ fixnum_t fv;
+ bt = cp_numtype(cp);
+ bptr = cp_data(cp);
+ if (isfixnum(a)) {+ fv = numval(a);
+ at = T_FIXNUM;
+ aptr = &fv;
+ }
+ else if (iscprim(a)) {+ cp = (cprim_t*)ptr(a);
+ at = cp_numtype(cp);
+ aptr = cp_data(cp);
+ }
+ else type_error("=", "number", a);+ return cmp_eq(aptr, at, bptr, bt, 0);
+}
+
// read -----------------------------------------------------------------------
#include "read.c"
@@ -1289,6 +1316,16 @@
argcount("compare", nargs, 2);v = compare(Stack[SP-2], Stack[SP-1]);
break;
+ case F_NUMEQ:
+ argcount("=", nargs, 2);+ v = Stack[SP-2]; e = Stack[SP-1];
+ if (bothfixnums(v, e)) {+ v = (v == e) ? FL_T : FL_F;
+ }
+ else {+ v = numeric_equals(v, e) ? FL_T : FL_F;
+ }
+ break;
case F_LT:
argcount("<", nargs, 2); if (bothfixnums(Stack[SP-2], Stack[SP-1])) {@@ -1856,6 +1893,17 @@
POPN(n);
PUSH(v);
}
+ break;
+ case F_NUMEQ:
+ v = Stack[SP-2]; e = Stack[SP-1];
+ if (bothfixnums(v, e)) {+ v = (v == e) ? FL_T : FL_F;
+ }
+ else {+ v = numeric_equals(v, e) ? FL_T : FL_F;
+ }
+ POPN(1);
+ Stack[SP-1] = v;
break;
case OP_LT:
if (bothfixnums(Stack[SP-2], Stack[SP-1])) {--- a/femtolisp/flisp.h
+++ b/femtolisp/flisp.h
@@ -125,7 +125,7 @@
F_CONS, F_LIST, F_CAR, F_CDR, F_SETCAR, F_SETCDR,
F_EVAL, F_APPLY,
- F_ADD, F_SUB, F_MUL, F_DIV, F_LT, F_COMPARE,
+ F_ADD, F_SUB, F_MUL, F_DIV, F_NUMEQ, F_LT, F_COMPARE,
F_VECTOR, F_AREF, F_ASET, F_FOR,
F_TRUE, F_FALSE, F_NIL,
--- a/femtolisp/opcodes.h
+++ b/femtolisp/opcodes.h
@@ -12,7 +12,7 @@
OP_CONS, OP_LIST, OP_CAR, OP_CDR, OP_SETCAR, OP_SETCDR,
OP_EVAL, OP_APPLY,
- OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_LT, OP_COMPARE,
+ OP_ADD, OP_SUB, OP_MUL, OP_DIV, OP_NUMEQ, OP_LT, OP_COMPARE,
OP_VECTOR, OP_AREF, OP_ASET, OP_FOR,
--- a/femtolisp/system.lsp
+++ b/femtolisp/system.lsp
@@ -86,11 +86,10 @@
((eqv? (caar lst) item) (car lst))
(#t (assv item (cdr lst)))))
-(define = eqv?)
-(define (/= a b) (not (eqv? a b)))
+(define (/= a b) (not (= a b)))
(define (> a b) (< b a))
-(define (<= a b) (not (< b a)))
-(define (>= a b) (not (< a b)))
+(define (<= a b) (or (< a b) (= a b)))
+(define (>= a b) (or (< b a) (= a b)))
(define (negative? x) (< x 0))
(define (zero? x) (= x 0))
(define (positive? x) (> x 0))
--- a/femtolisp/table.c
+++ b/femtolisp/table.c
@@ -171,7 +171,6 @@
htable_t *h = totable(args[2], "table.foldl");
size_t i, n = h->size;
void **table = h->table;
- value_t c;
for(i=0; i < n; i+=2) { if (table[i+1] != HT_NOTFOUND) {args[1] = applyn(3, args[0],
--- a/femtolisp/unittest.lsp
+++ b/femtolisp/unittest.lsp
@@ -69,6 +69,20 @@
(assert (equal (string 'sym #byte(65) #wchar(945) "blah") "symA\u03B1blah"))
+; NaNs
+(assert (equal? +nan.0 +nan.0))
+(assert (not (= +nan.0 +nan.0)))
+(assert (not (= +nan.0 -nan.0)))
+(assert (equal? (< +nan.0 3) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 3) (> (double 3) +nan.0)))
+(assert (equal? (< +nan.0 (double 3)) (> 3 +nan.0)))
+(assert (equal? (< +nan.0 3) (< +nan.0 (double 3))))
+(assert (equal? (> +nan.0 3) (> +nan.0 (double 3))))
+(assert (equal? (< 3 +nan.0) (> +nan.0 (double 3))))
+(assert (equal? (> 3 +nan.0) (> (double 3) +nan.0)))
+(assert (not (>= +nan.0 +nan.0)))
+
; this crashed once
(for 1 10 (lambda (i) 0))
--- a/llt/dtypes.h
+++ b/llt/dtypes.h
@@ -116,6 +116,7 @@
#define LABS(n) (((n)^((n)>>(NBITS-1))) - ((n)>>(NBITS-1)))
#define NBABS(n,nb) (((n)^((n)>>((nb)-1))) - ((n)>>((nb)-1)))
#define DFINITE(d) (((*(int64_t*)&(d))&0x7ff0000000000000LL)!=0x7ff0000000000000LL)
+#define DNAN(d) (((*(int64_t*)&(d))&0x7ff8000000000000LL)==0x7ff8000000000000LL)
extern double D_PNAN;
extern double D_NNAN;
--- a/llt/hashing.c
+++ b/llt/hashing.c
@@ -93,11 +93,11 @@
ios_init_stdstreams();
D_PNAN = strtod("+NaN",NULL);- D_NNAN = strtod("-NaN",NULL);+ D_NNAN = -strtod("+NaN",NULL); D_PINF = strtod("+Inf",NULL); D_NINF = strtod("-Inf",NULL); F_PNAN = strtof("+NaN",NULL);- F_NNAN = strtof("-NaN",NULL);+ F_NNAN = -strtof("+NaN",NULL); F_PINF = strtof("+Inf",NULL); F_NINF = strtof("-Inf",NULL);}
--- a/llt/operators.c
+++ b/llt/operators.c
@@ -235,16 +235,21 @@
return 0;
}
-int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag)
+int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
+ int equalnans)
{- if (atag==btag)
+ if (atag==btag && !equalnans)
return cmp_same_eq(a, b, atag);
double da = conv_to_double(a, atag);
double db = conv_to_double(b, btag);
- if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT)
+ if ((int)atag >= T_FLOAT && (int)btag >= T_FLOAT) {+ if (equalnans && DNAN(da)) {+ return *(uint64_t*)&da == *(uint64_t*)&db;
+ }
return (da == db);
+ }
if (da != db)
return 0;
@@ -339,8 +344,8 @@
assert(cmp_lt(&d, T_DOUBLE, &i64, T_INT64));
assert(!cmp_lt(&i64, T_INT64, &d, T_DOUBLE));
- assert(!cmp_eq(&d, T_DOUBLE, &i64, T_INT64));
+ assert(!cmp_eq(&d, T_DOUBLE, &i64, T_INT64, 0));
i64 = DBL_MAXINT;
- assert(cmp_eq(&d, T_DOUBLE, &i64, T_INT64));
+ assert(cmp_eq(&d, T_DOUBLE, &i64, T_INT64, 0));
}
#endif
--- a/llt/utils.h
+++ b/llt/utils.h
@@ -75,7 +75,8 @@
int cmp_same_lt(void *a, void *b, numerictype_t tag);
int cmp_same_eq(void *a, void *b, numerictype_t tag);
int cmp_lt(void *a, numerictype_t atag, void *b, numerictype_t btag);
-int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag);
+int cmp_eq(void *a, numerictype_t atag, void *b, numerictype_t btag,
+ int equalnans);
#ifdef ARCH_X86_64
# define LEGACY_REGS "=Q"