#include "lisp_math.h" #include "list.h" #include "stack.h" #include #include LispVal *copy_lisp_gmp(LispVal *gmp) { assert(LISP_GMP_P(gmp)); LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); mpz_init_set(n->val, ((LispGmp *) gmp)->val); return n; } LispVal *make_gmp(fixnum_t value) { LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); mpz_init_set_si(n->val, value); return n; } LispVal *make_gmp_unsigned(unsigned long value) { LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); mpz_init_set_ui(n->val, value); return n; } LispVal *parse_gmp(const char *str, int base) { LispGmp *n = lisp_alloc_object(sizeof(LispGmp), TYPE_GMP); mpz_init(n->val); int res = mpz_set_str(n->val, str, base); if (res != 0) { free(n); return NULL; } return n; } LispVal *parse_number(const char *str, int base) { char *endptr; errno = 0; intmax_t n = strtoimax(str, &endptr, base); if ((n == INTMAX_MIN || n == INTMAX_MAX) && errno == ERANGE) { return parse_gmp(str, base); } else if (n < MOST_NEGATIVE_FIXNUM || n > MOST_POSITIVE_FIXNUM) { return parse_gmp(str, base); } else if (*endptr) { // trailing garbage return NULL; } return MAKE_FIXNUM(n); } DEFUN(fixnump, "fixnump", (LispVal * val), "(val)", "") { return FIXNUMP(val) ? Qt : Qnil; } DEFUN(integerp, "integerp", (LispVal * val), "(val)", "") { return LISP_GMP_P(val) ? Qt : Qnil; } DEFUN(floatp, "floatp", (LispVal * val), "(val)", "") { return LISP_FLOAT_P(val) ? Qt : Qnil; } DEFUN(numberp, "numberp", (LispVal * val), "(val)", "") { return FIXNUMP(val) || LISP_FLOAT_P(val) || LISP_GMP_P(val) ? Qt : Qnil; } enum Operator { OPERATOR_ADD, OPERATOR_SUB, OPERATOR_MUL, OPERATOR_DIV, OPERATOR_AND, OPERATOR_IOR, OPERATOR_XOR, }; static inline LispVal *type_for_operator(enum Operator op) { switch (op) { case OPERATOR_ADD: case OPERATOR_SUB: case OPERATOR_MUL: case OPERATOR_DIV: return Qnumber; case OPERATOR_AND: case OPERATOR_IOR: case OPERATOR_XOR: return Qinteger; default: abort(); } } 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: case OPERATOR_IOR: case OPERATOR_XOR: signal_type_error(XCAR(nums), Qinteger); break; default: break; } if (first) { acc = XLISP_FLOAT(XCAR(nums)); nums = XCDR(nums); } DOLIST(cur, nums) { lisp_float_t n; if (FIXNUMP(cur)) { n = XFIXNUM(cur); } else if (LISP_FLOAT_P(cur)) { n = XLISP_FLOAT(cur); } else if (LISP_GMP_P(cur)) { n = mpz_get_d(((LispGmp *) cur)->val); } else { signal_type_error(cur, Qnumber); } switch (op) { case OPERATOR_ADD: acc += n; break; case OPERATOR_SUB: acc -= n; break; case OPERATOR_MUL: acc *= n; break; case OPERATOR_DIV: acc /= n; break; default: abort(); } } return MAKE_LISP_FLOAT(acc); } 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) { mpz_set(acc->val, ((LispGmp *) XCAR(nums))->val); nums = XCDR(nums); first = false; } DOTAILS(rest, nums) { LispVal *cur = XCAR(rest); if (FIXNUMP(cur)) { fixnum_t f = XFIXNUM(cur); switch (op) { case OPERATOR_ADD: if (f < 0) { mpz_sub_ui(acc->val, acc->val, -f); } else { mpz_add_ui(acc->val, acc->val, f); } break; case OPERATOR_SUB: if (f < 0) { mpz_add_ui(acc->val, acc->val, -f); } else { mpz_sub_ui(acc->val, acc->val, f); } break; case OPERATOR_MUL: mpz_mul_si(acc->val, acc->val, f); break; case OPERATOR_DIV: if (f == 0) { lisp_signal(Qdivision_by_zero, Qnil); } if (f > 0) { mpz_mul_si(acc->val, acc->val, -1); } mpz_tdiv_ui(acc->val, f); break; #define BITWISE(o) \ { \ mpz_t n; \ mpz_init_set_si(n, f); \ mpz_##o(acc->val, acc->val, n); \ mpz_clear(n); \ } case OPERATOR_AND: BITWISE(and); break; case OPERATOR_IOR: BITWISE(ior); break; case OPERATOR_XOR: BITWISE(xor); break; #undef BITWISE default: abort(); } } else if (LISP_GMP_P(cur)) { mpz_srcptr cv = ((LispGmp *) cur)->val; switch (op) { case OPERATOR_ADD: mpz_add(acc->val, acc->val, cv); break; case OPERATOR_SUB: mpz_sub(acc->val, acc->val, cv); break; case OPERATOR_MUL: mpz_mul(acc->val, acc->val, cv); break; case OPERATOR_DIV: mpz_tdiv_q(acc->val, acc->val, cv); break; case OPERATOR_AND: mpz_and(acc->val, acc->val, cv); break; case OPERATOR_IOR: mpz_ior(acc->val, acc->val, cv); break; case OPERATOR_XOR: mpz_xor(acc->val, acc->val, cv); break; default: abort(); } } else if (LISP_FLOAT_P(cur)) { return float_math_driver(op, first, mpz_get_d(acc->val), rest); } else { signal_type_error(cur, type_for_operator(op)); } } if (mpz_cmp_si(acc->val, MOST_POSITIVE_FIXNUM) <= 0 && mpz_cmp_si(acc->val, MOST_NEGATIVE_FIXNUM) >= 0) { return MAKE_FIXNUM(mpz_get_si(acc->val)); } return acc; } LispVal *math_driver(enum Operator op, LispVal *nums) { assert(!NILP(nums)); bool first = true; fixnum_t acc; LispVal *rest; if (FIXNUMP(XCAR(nums))) { rest = XCDR(nums); acc = XFIXNUM(XCAR(nums)); first = false; } else { rest = nums; acc = 0; goto change_type; } while (FIXNUMP(XCAR(rest))) { bool did_overflow = false; fixnum_t cur = XFIXNUM(XCAR(rest)); fixnum_t out; switch (op) { case OPERATOR_ADD: did_overflow = ckd_add(&out, acc, cur); break; case OPERATOR_SUB: did_overflow = ckd_sub(&out, acc, cur); break; case OPERATOR_MUL: did_overflow = ckd_mul(&out, acc, cur); break; case OPERATOR_DIV: if (cur == 0) { lisp_signal(Qdivision_by_zero, Qnil); } out = acc / cur; break; case OPERATOR_AND: out = acc & cur; break; case OPERATOR_IOR: out = acc | cur; break; case OPERATOR_XOR: out = acc ^ cur; break; default: abort(); } if (did_overflow || out > MOST_POSITIVE_FIXNUM || out < MOST_NEGATIVE_FIXNUM) { break; } acc = out; rest = XCDR(rest); if (NILP(rest)) { return MAKE_FIXNUM(acc); } } change_type: return LISP_FLOAT_P(XCAR(rest)) ? float_math_driver(op, first, acc, rest) : gmp_math_driver(op, first, acc, rest); } DEFUN(plus, "+", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(0); } return math_driver(OPERATOR_ADD, nums); } DEFUN(minus, "-", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(0); } else if (NILP(XCDR(nums))) { LispVal *num = XCAR(nums); if (FIXNUMP(num)) { return MAKE_FIXNUM(-XFIXNUM(num)); } else if (LISP_FLOAT_P(num)) { return MAKE_LISP_FLOAT(-XLISP_FLOAT(num)); } else if (LISP_GMP_P(num)) { LispGmp *o = make_gmp(0); LispGmp *a = num; mpz_mul_si(o->val, a->val, -1); return o; } signal_type_error(num, Qnumber); } return math_driver(OPERATOR_SUB, nums); } DEFUN(times, "*", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(1); } return math_driver(OPERATOR_MUL, nums); } DEFUN(divide, "/", (LispVal * num, LispVal *nums), "(num &rest nums)", "") { if (NILP(nums)) { if (FIXNUMP(num)) { fixnum_t fv = XFIXNUM(num); if (fv == 0) { lisp_signal(Qdivision_by_zero, Qnil); } else if (fv == 1) { return MAKE_FIXNUM(1); } else if (fv == -1) { return MAKE_FIXNUM(-1); } return MAKE_FIXNUM(0); } else if (LISP_GMP_P(num)) { mpz_srcptr n = ((LispGmp *) num)->val; if (mpz_cmp_ui(n, 0) == 0) { lisp_signal(Qdivision_by_zero, Qnil); } else if (mpz_cmp_ui(n, 1) == 0) { return MAKE_FIXNUM(1); } else if (mpz_cmp_ui(n, -1) == 0) { return MAKE_FIXNUM(-1); } return MAKE_FIXNUM(0); } } return math_driver(OPERATOR_DIV, CONS(num, nums)); } DEFUN(logand, "logand", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(-1); } return math_driver(OPERATOR_AND, nums); } DEFUN(logior, "logior", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(0); } return math_driver(OPERATOR_IOR, nums); } DEFUN(logxor, "logxor", (LispVal * nums), "(&rest nums)", "") { if (NILP(nums)) { return MAKE_FIXNUM(0); } return math_driver(OPERATOR_XOR, nums); } DEFINE_SYMBOL(integer, "integer"); DEFINE_SYMBOL(number, "number"); DEFINE_SYMBOL(division_by_zero, "division-by-zero"); DEFINE_CONDITION_CLASS(division_by_zero, error);