* arith.c (zerop, gt, lt, ge, le): Functions from lib.c reimplemented

with bignum support.

* eval.c (eval_init): Added bignump and zerop as intrinsic function.
Renamed numberp to fixnump.

* lib.c (zerop, gt, lt, ge, le): Functions removed.
(numeq): Unused function removed.

* lib.h (numeq): Declaration removed.

* txr.1: Sections for zerop and bignump created. Changed reference
to numberp to fixnump.

6 files changed, 135 insertions, 34 deletions

diff --git a/ChangeLog b/ChangeLog
index 390405a9..a18215d4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,21 @@
 2011-12-11  Kaz Kylheku  <kaz@kylheku.com>
 
+	* arith.c (zerop, gt, lt, ge, le): Functions from lib.c reimplemented
+	with bignum support.
+
+	* eval.c (eval_init): Added bignump and zerop as intrinsic function.
+	Renamed numberp to fixnump.
+
+	* lib.c (zerop, gt, lt, ge, le): Functions removed.
+	(numeq): Unused function removed.
+
+	* lib.h (numeq): Declaration removed.
+
+	* txr.1: Sections for zerop and bignump created. Changed reference
+	to numberp to fixnump.
+
+2011-12-11  Kaz Kylheku  <kaz@kylheku.com>
+
 	* arith.c (plus, mul): Plugged mpi_int memory leaks.
 	(trunc): Plugged memory leaks. Straightened out semantics
 	with negative modulus. (Residue comes out negative).
diff --git a/arith.c b/arith.c
index bd9a5d2c..e1ee9fe1 100644
--- a/arith.c
+++ b/arith.c
@@ -689,6 +689,118 @@ val mod(val anum, val bnum)
   abort();
 }
 
+val zerop(val num)
+{
+  if (num == zero)
+    return t;
+
+  if (!fixnump(num) && !bignump(num))
+    uw_throwf(error_s, lit("zerof: ~s is not a number"), num, nao);
+  return nil;
+}
+
+val gt(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):
+    return c_num(anum) > c_num(bnum) ? t : nil;
+  case TAG_PAIR(TAG_NUM, TAG_PTR):
+    type_check(bnum, BGNUM);
+    return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_NUM):
+    type_check(anum, BGNUM);
+    return mp_cmp_z(mp(anum)) == MP_GT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_PTR):
+    type_check(anum, BGNUM);
+    return mp_cmp(mp(anum), mp(bnum)) == MP_GT ? t : nil;
+  }
+
+  uw_throwf(error_s, lit("gt: invalid operands ~s ~s"), anum, bnum, nao);
+  abort();
+}
+
+val lt(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):
+    return c_num(anum) < c_num(bnum) ? t : nil;
+  case TAG_PAIR(TAG_NUM, TAG_PTR):
+    type_check(bnum, BGNUM);
+    return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_NUM):
+    type_check(anum, BGNUM);
+    return mp_cmp_z(mp(anum)) == MP_LT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_PTR):
+    type_check(anum, BGNUM);
+    return mp_cmp(mp(anum), mp(bnum)) == MP_LT ? t : nil;
+  }
+
+  uw_throwf(error_s, lit("lt: invalid operands ~s ~s"), anum, bnum, nao);
+  abort();
+}
+
+val ge(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):
+    return c_num(anum) >= c_num(bnum) ? t : nil;
+  case TAG_PAIR(TAG_NUM, TAG_PTR):
+    type_check(bnum, BGNUM);
+    return mp_cmp_z(mp(bnum)) == MP_LT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_NUM):
+    type_check(anum, BGNUM);
+    return mp_cmp_z(mp(anum)) == MP_GT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_PTR):
+    type_check(anum, BGNUM);
+    switch (mp_cmp(mp(anum), mp(bnum))) {
+    case MP_GT: case MP_EQ:
+      return t;
+    default:
+      return nil;
+    }
+  }
+
+  uw_throwf(error_s, lit("ge: invalid operands ~s ~s"), anum, bnum, nao);
+  abort();
+}
+
+val le(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):
+    return c_num(anum) <= c_num(bnum) ? t : nil;
+  case TAG_PAIR(TAG_NUM, TAG_PTR):
+    type_check(bnum, BGNUM);
+    return mp_cmp_z(mp(bnum)) == MP_GT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_NUM):
+    type_check(anum, BGNUM);
+    return mp_cmp_z(mp(anum)) == MP_LT ? t : nil;
+  case TAG_PAIR(TAG_PTR, TAG_PTR):
+    type_check(anum, BGNUM);
+    switch (mp_cmp(mp(anum), mp(bnum))) {
+    case MP_LT: case MP_EQ:
+      return t;
+    default:
+      return nil;
+    }
+  }
+
+  uw_throwf(error_s, lit("lt: invalid operands ~s ~s"), anum, bnum, nao);
+  abort();
+}
+
 void arith_init(void)
 {
   mp_init(&NUM_MAX_MP);
diff --git a/eval.c b/eval.c
index 9f9ce124..81ece344 100644
--- a/eval.c
+++ b/eval.c
@@ -1157,7 +1157,9 @@ void eval_init(void)
   reg_fun(intern(lit("trunc"), user_package), func_n2(trunc));
   reg_fun(intern(lit("mod"), user_package), func_n2(mod));
   reg_fun(intern(lit("fixnump"), user_package), func_n1(fixnump));
+  reg_fun(intern(lit("bignump"), user_package), func_n1(bignump));
 
+  reg_fun(intern(lit("zerop"), user_package), func_n1(zerop));
   reg_fun(intern(lit(">"), user_package), func_n1v(gtv));
   reg_fun(intern(lit("<"), user_package), func_n1v(ltv));
   reg_fun(intern(lit(">="), user_package), func_n1v(gev));
diff --git a/lib.c b/lib.c
index 9432111d..01f1569a 100644
--- a/lib.c
+++ b/lib.c
@@ -857,31 +857,6 @@ val mulv(val nlist)
   return reduce_left(func_n2(mul), cdr(nlist), car(nlist), nil);
 }
 
-val zerop(val num)
-{
-  return c_num(num) == 0 ? t : nil;
-}
-
-val gt(val anum, val bnum)
-{
-  return c_num(anum) > c_num(bnum) ? t : nil;
-}
-
-val lt(val anum, val bnum)
-{
-  return c_num(anum) < c_num(bnum) ? t : nil;
-}
-
-val ge(val anum, val bnum)
-{
-  return c_num(anum) >= c_num(bnum) ? t : nil;
-}
-
-val le(val anum, val bnum)
-{
-  return c_num(anum) <= c_num(bnum) ? t : nil;
-}
-
 val gtv(val first, val rest)
 {
   val iter;
@@ -938,19 +913,14 @@ val lev(val first, val rest)
   return t;
 }
 
-val numeq(val anum, val bnum)
-{
-  return c_num(anum) == c_num(bnum) ? t : nil;
-}
-
 val max2(val anum, val bnum)
 {
-  return c_num(anum) > c_num(bnum) ? anum : bnum;
+  return if3(gt(anum, bnum), anum, bnum);
 }
 
 val min2(val anum, val bnum)
 {
-  return c_num(anum) < c_num(bnum) ? anum : bnum;
+  return if3(lt(anum, bnum), anum, bnum);
 }
 
 val maxv(val first, val rest)
diff --git a/lib.h b/lib.h
index 9c4fe339..c261fc04 100644
--- a/lib.h
+++ b/lib.h
@@ -381,7 +381,6 @@ val gtv(val first, val rest);
 val ltv(val first, val rest);
 val gev(val first, val rest);
 val lev(val first, val rest);
-val numeq(val anum, val bnum);
 val max2(val anum, val bnum);
 val min2(val anum, val bnum);
 val maxv(val first, val rest);
diff --git a/txr.1 b/txr.1
index 1cb30487..c01819a6 100644
--- a/txr.1
+++ b/txr.1
@@ -4809,7 +4809,9 @@ The following are Lisp functions and variables built-in to TXR.
 
 .SS Arithmetic functions +, -, *, trunc, mod
 
-.SS Function numberp
+.SS Functions fixnump, bignump
+
+.SS Function zerop
 
 .SS Relational functions >, <, >= and <=