summaryrefslogtreecommitdiffstats
path: root/arith.txr
diff options
context:
space:
mode:
Diffstat (limited to 'arith.txr')
-rw-r--r--arith.txr115
1 files changed, 109 insertions, 6 deletions
diff --git a/arith.txr b/arith.txr
index 9c746802..fc1bc8f6 100644
--- a/arith.txr
+++ b/arith.txr
@@ -42,6 +42,7 @@
#include <dirent.h>
#include <setjmp.h>
#include <wchar.h>
+#include <limits.h>
#include "config.h"
#include "lib.h"
#include "unwind.h"
@@ -50,6 +51,7 @@
#define TAG_PAIR(A, B) ((A) << TAG_SHIFT | (B))
#define NOOP(A, B)
+#define CNUM_BIT ((int) sizeof (cnum) * CHAR_BIT)
static mp_int NUM_MAX_MP;
@@ -61,6 +63,20 @@ val make_bignum(void)
return n;
}
+static val bignum(cnum cn)
+{
+ val n = make_bignum();
+ mp_set_intptr(mp(n), cn);
+ return n;
+}
+
+static val bignum_dbl_ipt(double_intptr_t di)
+{
+ val n = make_bignum();
+ mp_set_double_intptr(mp(n), di);
+ return n;
+}
+
static val normalize(val bignum)
{
switch (mp_cmp_mag(mp(bignum), &NUM_MAX_MP)) {
@@ -89,12 +105,8 @@ val @{add-fname}(val anum, val bnum)
cnum b = c_num(bnum);
cnum sum = a @{add-c-op} b;
- if (sum < NUM_MIN || sum > NUM_MAX) {
- val n = make_bignum();
- mp_set_intptr(mp(n), sum);
- return n;
- }
-
+ if (sum < NUM_MIN || sum > NUM_MAX)
+ return bignum(sum);
return num(sum);
}
case TAG_PAIR(TAG_NUM, TAG_PTR):
@@ -155,6 +167,97 @@ val neg(val anum)
}
}
+val mul(val anum, val bnum)
+{
+ int tag_a = tag(anum);
+ int tag_b = tag(bnum);
+
+ switch (TAG_PAIR(tag_a, tag_b)) {
+ case TAG_PAIR(TAG_NUM, TAG_NUM):
+ {
+ cnum a = c_num(anum);
+ cnum b = c_num(bnum);
+#if HAVE_DOUBLE_INTPTR_T
+ double_intptr_t product = a * (double_intptr_t) b;
+ if (product < NUM_MIN || product > NUM_MAX)
+ return bignum_dbl_ipt(product);
+ return num(product);
+#else
+ cnum ap = (a < 0) ? -a : a;
+ cnum bp = (b < 0) ? -b : b;
+ int bit = CNUM_BIT - 3, amaxbit = 0, bmaxbit = 0;
+ cnum mask = (cnum) 1 << (CNUM_BIT - 4);
+ for (; mask && (ap || bp); mask >>= 1, bit--) {
+ if ((ap & mask)) {
+ amaxbit = bit;
+ ap = 0;
+ }
+ if ((bp & mask)) {
+ bmaxbit = bit;
+ bp = 0;
+ }
+ }
+ if (amaxbit + bmaxbit < CNUM_BIT - 1) {
+ cnum product = a * b;
+ if (product >= NUM_MIN && product <= NUM_MAX)
+ return num(a * b);
+ return bignum(a * b);
+ } else {
+ val n = make_bignum();
+ mp_int tmpb;
+ mp_init(&tmpb);
+ mp_set_intptr(&tmpb, b);
+ mp_set_intptr(mp(n), a);
+ mp_mul(mp(n), &tmpb, mp(n));
+ mp_clear(&tmpb);
+ return n;
+ }
+#endif
+ }
+ case TAG_PAIR(TAG_NUM, TAG_PTR):
+ {
+ val n;
+ type_check(bnum, BGNUM);
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ mp_mul_d(mp(bnum), c_num(anum), mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(anum));
+ mp_mul(mp(bnum), &tmp, mp(n));
+ }
+ return n;
+ }
+ case TAG_PAIR(TAG_PTR, TAG_NUM):
+ {
+ val n;
+ type_check(bnum, BGNUM);
+ n = make_bignum();
+ if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+ mp_mul_d(mp(anum), c_num(bnum), mp(n));
+ } else {
+ mp_int tmp;
+ mp_init(&tmp);
+ mp_set_intptr(&tmp, c_num(bnum));
+ mp_mul(mp(anum), &tmp, mp(n));
+ }
+ return n;
+ }
+ case TAG_PAIR(TAG_PTR, TAG_PTR):
+ {
+ val n;
+ type_check(anum, BGNUM);
+ type_check(bnum, BGNUM);
+ n = make_bignum();
+ mp_mul(mp(anum), mp(bnum), mp(n));
+ return n;
+ }
+ }
+ uw_throwf(error_s, lit("mul: invalid operands ~s ~s"), anum, bnum, nao);
+ abort();
+}
+
void arith_init(void)
{
mp_init(&NUM_MAX_MP);