diff --git a/lisp/kernel.gl b/lisp/kernel.gl index d253427..5388fe7 100644 --- a/lisp/kernel.gl +++ b/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)) diff --git a/src/lisp_math.c b/src/lisp_math.c index 28a4bcf..6a54cc2 100644 --- a/src/lisp_math.c +++ b/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, - LispVal *nums) { +static LispVal *float_math_driver(enum Operator op, bool first, + 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, - LispVal *nums) { +static LispVal *gmp_math_driver(enum Operator op, bool first, + 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"); diff --git a/src/lisp_math.h b/src/lisp_math.h index 8f2cf1b..7f62757 100644 --- a/src/lisp_math.h +++ b/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);