From 770b69a7495f5e1f83eaf0c5de5782a3db90ad7b Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 11 Dec 2011 23:16:44 -0800 Subject: * 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. --- ChangeLog | 16 +++++++++ arith.c | 112 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ eval.c | 2 ++ lib.c | 34 ++----------------- lib.h | 1 - txr.1 | 4 ++- 6 files changed, 135 insertions(+), 34 deletions(-) diff --git a/ChangeLog b/ChangeLog index 390405a9..a18215d4 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,19 @@ +2011-12-11 Kaz Kylheku + + * 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 * arith.c (plus, mul): Plugged mpi_int memory leaks. 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 <= -- cgit v1.2.3