diff options
| -rw-r--r-- | ChangeLog | 14 | ||||
| -rw-r--r-- | arith.c | 89 | ||||
| -rw-r--r-- | eval.c | 3 | ||||
| -rw-r--r-- | lib.c | 19 | ||||
| -rw-r--r-- | lib.h | 3 | ||||
| -rw-r--r-- | txr.1 | 4 |
6 files changed, 130 insertions, 2 deletions
@@ -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 @@ -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); @@ -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)); @@ -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); @@ -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. */ @@ -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 |