* arith.c (expt): New function.

* eval.c (eval_init): Registering new intrinsic functions,
reduce-left, reduce-right and expt.

* lib.c (minusv): Return one instead of num(1).
(exptv, reduce_right): New functions.

* lib.h (expt, exptv, reduce_right): Declared.

* txr.1: Blank sections for new functions.

6 files changed, 130 insertions, 2 deletions

diff --git a/ChangeLog b/ChangeLog
index c695c92c..39e6fc2e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,19 @@
 2011-12-12  Kaz Kylheku  <kaz@kylheku.com>
 
+	* arith.c (expt): New function.
+
+	* eval.c (eval_init): Registering new intrinsic functions,
+	reduce-left, reduce-right and expt.
+
+	* lib.c (minusv): Return one instead of num(1).
+	(exptv, reduce_right): New functions.
+
+	* lib.h (expt, exptv, reduce_right): Declared.
+
+	* txr.1: Blank sections for new functions.
+
+2011-12-12  Kaz Kylheku  <kaz@kylheku.com>
+
 	* mpi-patches/fix-mult-bug: One more flaw discovered in
 	s_mp_mul_d and added to patch. This one caused malloc corruption and
 	crashes, because the incorrect arithmetic causes the function
diff --git a/arith.c b/arith.c
index e1ee9fe1..edbd71d8 100644
--- a/arith.c
+++ b/arith.c
@@ -801,6 +801,95 @@ val le(val anum, val bnum)
   abort();
 }
 
+val expt(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);
+      mp_int tmpa;
+      val n;
+      if (b < 0)
+        uw_throw(error_s, lit("expt: negative exponent"));
+      if (bnum == zero)
+        return one;
+      if (bnum == one)
+        return anum;
+      n = make_bignum();
+      mp_init(&tmpa);
+      mp_set_intptr(&tmpa, a);
+      if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+        mp_expt_d(&tmpa, b, mp(n));
+      } else {
+        mp_int tmpb;
+        mp_init(&tmpb);
+        mp_set_intptr(&tmpb, b);
+        mp_expt(&tmpa, &tmpb, mp(n));
+        mp_clear(&tmpb);
+      }
+      mp_clear(&tmpa);
+      return normalize(n);
+    }
+  case TAG_PAIR(TAG_NUM, TAG_PTR):
+    {
+      cnum a = c_num(anum);
+      mp_int tmpa;
+      val n;
+      type_check(bnum, BGNUM);
+      if (mp_cmp_z(mp(bnum)) == MP_LT)
+        uw_throw(error_s, lit("expt: negative exponent"));
+      n = make_bignum();
+      mp_init(&tmpa);
+      mp_set_intptr(&tmpa, a);
+      mp_expt(&tmpa, mp(bnum), mp(n));
+      mp_clear(&tmpa);
+      return normalize(n);
+    }
+  case TAG_PAIR(TAG_PTR, TAG_NUM):
+    {
+      cnum b = c_num(bnum);
+      val n;
+      type_check(anum, BGNUM);
+      if (b < 0)
+        uw_throw(error_s, lit("expt: negative exponent"));
+      if (bnum == zero)
+        return one;
+      if (bnum == one)
+        return anum;
+      n = make_bignum();
+      if (sizeof (int_ptr_t) <= sizeof (mp_digit)) {
+        mp_expt_d(mp(bnum), b, mp(n));
+      } else {
+        mp_int tmpb;
+        mp_init(&tmpb);
+        mp_set_intptr(&tmpb, b);
+        mp_expt(mp(anum), &tmpb, mp(n));
+        mp_clear(&tmpb);
+      }
+      return normalize(n);
+    }
+  case TAG_PAIR(TAG_PTR, TAG_PTR):
+    {
+      val n;
+      type_check(anum, BGNUM);
+      type_check(bnum, BGNUM);
+      if (mp_cmp_z(mp(bnum)) == MP_LT)
+        uw_throw(error_s, lit("expt: negative exponent"));
+      n = make_bignum();
+      mp_expt(mp(anum), mp(bnum), mp(n));
+      normalize(n);
+      return n;
+    }
+  }
+
+  uw_throwf(error_s, lit("expt: 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 81ece344..9c6cdf87 100644
--- a/eval.c
+++ b/eval.c
@@ -1130,6 +1130,8 @@ void eval_init(void)
   reg_fun(intern(lit("mapcar"), user_package), func_n1v(mapcarv));
   reg_fun(intern(lit("mappend"), user_package), func_n1v(mappendv));
   reg_fun(apply_s, func_n2(apply_intrinsic));
+  reg_fun(intern(lit("reduce-left"), user_package), func_n4(reduce_left));
+  reg_fun(intern(lit("reduce-right"), user_package), func_n4(reduce_right));
 
   reg_fun(intern(lit("second"), user_package), func_n1(second));
   reg_fun(intern(lit("third"), user_package), func_n1(third));
@@ -1156,6 +1158,7 @@ void eval_init(void)
   reg_fun(intern(lit("*"), user_package), func_n0v(mulv));
   reg_fun(intern(lit("trunc"), user_package), func_n2(trunc));
   reg_fun(intern(lit("mod"), user_package), func_n2(mod));
+  reg_fun(intern(lit("expt"), user_package), func_n0v(exptv));
   reg_fun(intern(lit("fixnump"), user_package), func_n1(fixnump));
   reg_fun(intern(lit("bignump"), user_package), func_n1(bignump));
 
diff --git a/lib.c b/lib.c
index 01f1569a..21cfb68c 100644
--- a/lib.c
+++ b/lib.c
@@ -851,7 +851,7 @@ val minusv(val minuend, val nlist)
 val mulv(val nlist)
 {
   if (!nlist)
-    return num(1);
+    return one;
   else if (!cdr(nlist))
     return car(nlist);
   return reduce_left(func_n2(mul), cdr(nlist), car(nlist), nil);
@@ -933,6 +933,11 @@ val minv(val first, val rest)
   return reduce_left(func_n2(min2), rest, first, nil);
 }
 
+val exptv(val nlist)
+{
+  return reduce_right(func_n2(expt), nlist, one, nil);
+}
+
 val string_own(wchar_t *str)
 {
   val obj = make_obj();
@@ -2073,6 +2078,18 @@ val reduce_left(val fun, val list, val init, val key)
   return init;
 }
 
+val reduce_right(val fun, val list, val init, val key)
+{
+  if (!key)
+    key = identity_f;
+
+  if (nullp(list))
+    return init;
+  return funcall2(fun, funcall1(key, car(list)),
+                       if3(cdr(list), reduce_right(fun, cdr(list), init, key),
+                                      init));
+}
+
 static val do_curry_12_2(val fcons, val arg2)
 {
   return funcall2(car(fcons), cdr(fcons), arg2);
diff --git a/lib.h b/lib.h
index c261fc04..4787e240 100644
--- a/lib.h
+++ b/lib.h
@@ -385,6 +385,8 @@ val max2(val anum, val bnum);
 val min2(val anum, val bnum);
 val maxv(val first, val rest);
 val minv(val first, val rest);
+val expt(val base, val exp);
+val exptv(val nlist);
 val string_own(wchar_t *str);
 val string(const wchar_t *str);
 val string_utf8(const char *str);
@@ -465,6 +467,7 @@ val funcall2(val fun, val arg1, val arg2);
 val funcall3(val fun, val arg1, val arg2, val arg3);
 val funcall4(val fun, val arg1, val arg2, val arg3, val arg4);
 val reduce_left(val fun, val list, val init, val key);
+val reduce_right(val fun, val list, val init, val key);
 /* The notation curry_12_2 means take some function f(arg1, arg2) and
    fix a value for argument 1 to create a g(arg2).
    Other variations follow by analogy. */
diff --git a/txr.1 b/txr.1
index 7f791af3..8049fe55 100644
--- a/txr.1
+++ b/txr.1
@@ -4791,6 +4791,8 @@ The following are Lisp functions and variables built-in to TXR.
 
 .SS Function apply
 
+.SS Functions reduce-left and reduce-right
+
 .SS Function copy-list
 
 .SS Functions reverse, nreverse
@@ -4807,7 +4809,7 @@ The following are Lisp functions and variables built-in to TXR.
 
 .SS Functions eq, eql and equal
 
-.SS Arithmetic functions +, -, *, trunc, mod
+.SS Arithmetic functions +, -, *, trunc, mod, expt
 
 .SS Functions fixnump, bignump