Math comparisons

lisp/kernel.gl

@@ -23,4 +23,4 @@
   (princ datum print-char-fun)
   (funcall (or print-char-fun 'write-byte) ?\n))
 
-(princln (type-of (+ 1 most-positive-fixnum)))
+(princln (= 1.0 1))

src/lisp_math.c

@@ -92,8 +92,8 @@ static inline LispVal *type_for_operator(enum Operator op) {
     }
 }
 
-LispVal *float_math_driver(enum Operator op, bool first, lisp_float_t acc,
+static LispVal *float_math_driver(enum Operator op, bool first,
-                           LispVal *nums) {
+                                  lisp_float_t acc, LispVal *nums) {
     assert(!first || LISP_FLOAT_P(XCAR(nums)));
     switch (op) {
     case OPERATOR_AND:
@@ -139,8 +139,8 @@ LispVal *float_math_driver(enum Operator op, bool first, lisp_float_t acc,
     return MAKE_LISP_FLOAT(acc);
 }
 
-LispVal *gmp_math_driver(enum Operator op, bool first, fixnum_t fixnum_acc,
+static LispVal *gmp_math_driver(enum Operator op, bool first,
-                         LispVal *nums) {
+                                fixnum_t fixnum_acc, LispVal *nums) {
     assert(!first || LISP_GMP_P(XCAR(nums)));
     LispGmp *acc = make_gmp(fixnum_acc);
     if (first) {
@@ -239,7 +239,7 @@ LispVal *gmp_math_driver(enum Operator op, bool first, fixnum_t fixnum_acc,
     return acc;
 }
 
-LispVal *math_driver(enum Operator op, LispVal *nums) {
+static LispVal *math_driver(enum Operator op, LispVal *nums) {
     assert(!NILP(nums));
     bool first = true;
     fixnum_t acc;
@@ -382,6 +382,148 @@ DEFUN(logxor, "logxor", (LispVal * nums), "(&rest nums)", "") {
     return math_driver(OPERATOR_XOR, nums);
 }
 
+enum CompResult {
+    CR_UNORDERED = 0,
+    CR_LT = 1,
+    CR_EQ = 2,
+    CR_GT = 4,
+};
+
+enum Comparison {
+    COMP_EQ = CR_EQ,
+    COMP_GT = CR_GT,
+    COMP_LT = CR_LT,
+    COMP_GE = CR_GT | CR_EQ,
+    COMP_LE = CR_LT | CR_EQ,
+};
+
+static inline enum CompResult do_float_comparison(lisp_float_t f1,
+                                                  LispVal *cur) {
+    if (isnan(f1)) {
+        return CR_UNORDERED;
+    }
+    if (LISP_FLOAT_P(cur)) {
+        lisp_float_t f2 = XLISP_FLOAT(cur);
+        if (isnan(f2)) {
+            return CR_UNORDERED;
+        }
+        return f1 < f2 ? CR_LT : (f1 > f2 ? CR_GT : CR_EQ);
+    } else if (FIXNUMP(cur)) {
+        fixnum_t fn = XFIXNUM(cur);
+        return f1 < fn ? CR_LT : (f1 > fn ? CR_GT : CR_EQ);
+    } else if (LISP_GMP_P(cur)) {
+        mpz_srcptr g = ((LispGmp *) cur)->val;
+        switch (mpz_cmp_d(g, f1)) {
+        case -1:
+            return CR_GT;
+        case 0:
+            return CR_EQ;
+        case 1:
+            return CR_LT;
+        default:
+            abort();
+        }
+    }
+    signal_type_error(cur, Qnumber);
+}
+
+static inline enum CompResult do_gmp_comparison(mpz_srcptr n1, LispVal *cur) {
+    int res;
+    if (LISP_FLOAT_P(cur)) {
+        lisp_float_t f = XLISP_FLOAT(cur);
+        if (isnan(f)) {
+            return CR_UNORDERED;
+        }
+        res = mpz_cmp_d(n1, f);
+    } else if (FIXNUMP(cur)) {
+        res = mpz_cmp_si(n1, XFIXNUM(cur));
+    } else if (LISP_GMP_P(cur)) {
+        mpz_srcptr n2 = ((LispGmp *) cur)->val;
+        res = mpz_cmp(n1, n2);
+    } else {
+        signal_type_error(cur, Qnumber);
+    }
+    switch (res) {
+    case -1:
+        return CR_LT;
+    case 0:
+        return CR_EQ;
+    case 1:
+        return CR_GT;
+    default:
+        abort();
+    }
+}
+
+static inline enum CompResult do_fixnum_comparison(fixnum_t n1, LispVal *cur) {
+    if (LISP_FLOAT_P(cur)) {
+        lisp_float_t n2 = XLISP_FLOAT(cur);
+        if (isnan(n2)) {
+            return CR_UNORDERED;
+        }
+        return n1 < n2 ? CR_LT : (n1 > n2 ? CR_GT : CR_EQ);
+    } else if (FIXNUMP(cur)) {
+        fixnum_t n2 = XFIXNUM(cur);
+        return n1 < n2 ? CR_LT : (n1 > n2 ? CR_GT : CR_EQ);
+    } else if (LISP_GMP_P(cur)) {
+        mpz_srcptr g = ((LispGmp *) cur)->val;
+        switch (mpz_cmp_si(g, n1)) {
+        case -1:
+            return CR_GT;
+        case 0:
+            return CR_EQ;
+        case 1:
+            return CR_LT;
+        default:
+            abort();
+        }
+    }
+    signal_type_error(cur, Qnumber);
+}
+
+static bool comp_driver(enum Comparison c, LispVal *first, LispVal *rest) {
+    if (NILP(rest)) {
+        return true;
+    }
+    DOLIST(cur, rest) {
+        enum CompResult res;
+        if (LISP_FLOAT_P(first)) {
+            res = do_float_comparison(XLISP_FLOAT(first), cur);
+        } else if (LISP_GMP_P(first)) {
+            res = do_gmp_comparison(((LispGmp *) first)->val, cur);
+        } else if (FIXNUMP(first)) {
+            res = do_fixnum_comparison(XFIXNUM(first), cur);
+        } else {
+            signal_type_error(first, Qnumber);
+        }
+        if ((c & res) == 0) {
+            return false;
+        }
+        first = cur;
+    }
+    return true;
+}
+
+DEFUN(math_eq, "=", (LispVal * num, LispVal *nums), "(num &rest nums)", "") {
+    return comp_driver(COMP_EQ, num, nums) ? Qt : Qnil;
+}
+
+DEFUN(gt, ">", (LispVal * num, LispVal *nums), "(num &rest nums)", "") {
+    return comp_driver(COMP_GT, num, nums) ? Qt : Qnil;
+}
+
+DEFUN(lt, "<", (LispVal * num, LispVal *nums), "(num &rest nums)", "") {
+    return comp_driver(COMP_LT, num, nums) ? Qt : Qnil;
+}
+
+DEFUN(ge, ">=", (LispVal * num, LispVal *nums), "(num &rest nums)", "") {
+    return comp_driver(COMP_GE, num, nums) ? Qt : Qnil;
+}
+
+DEFUN(le, "<=", (LispVal * num, LispVal *nums), "(num &rest nums)", "") {
+    return comp_driver(COMP_LE, num, nums) ? Qt : Qnil;
+}
+
 DEFINE_SYMBOL(integer, "integer");
 DEFINE_SYMBOL(number, "number");
 

src/lisp_math.h

@@ -44,6 +44,12 @@ DECLARE_FUNCTION(logand, (LispVal * nums));
 DECLARE_FUNCTION(logior, (LispVal * nums));
 DECLARE_FUNCTION(logxor, (LispVal * nums));
 
+DECLARE_FUNCTION(math_eq, (LispVal * num, LispVal *nums));
+DECLARE_FUNCTION(gt, (LispVal * num, LispVal *nums));
+DECLARE_FUNCTION(lt, (LispVal * num, LispVal *nums));
+DECLARE_FUNCTION(ge, (LispVal * num, LispVal *nums));
+DECLARE_FUNCTION(le, (LispVal * num, LispVal *nums));
+
 DECLARE_SYMBOL(integer);
 DECLARE_SYMBOL(number);