summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--arith.c63
-rw-r--r--tests/016/ud-arith.expected0
-rw-r--r--tests/016/ud-arith.tl132
-rw-r--r--txr.18
4 files changed, 170 insertions, 33 deletions
diff --git a/arith.c b/arith.c
index c67dc1d5..dbbc041c 100644
--- a/arith.c
+++ b/arith.c
@@ -1683,7 +1683,7 @@ val divi(val anum, val bnum)
val self = div_s;
if (missingp(bnum)) {
- if (cobjp(bnum)) {
+ if (cobjp(anum)) {
return do_unary_method(self, recip_s, anum);
} else {
double b = c_flo(to_float(self, anum), self);
@@ -3099,7 +3099,7 @@ val logtrunc(val a, val bits)
do_mp_error(self, mpe);
return normalize(b);
case COBJ:
- return do_binary_method(self, r_logtrunc_s, bits, a);
+ return do_binary_method(self, self, a, bits);
default:
goto bad3;
}
@@ -3121,35 +3121,40 @@ bad4:;
val sign_extend(val n, val nbits)
{
val self = sign_extend_s;
- val msb = minus(nbits, one);
- val ntrunc = logtrunc(n, nbits);
- if (bit(ntrunc, msb)) {
- switch (type(ntrunc)) {
- case NUM:
- {
- cnum cn = c_n(ntrunc);
- cnum nb = c_n(nbits);
- return num(cn | (INT_PTR_MAX << nb));
- }
- case BGNUM:
- {
- val out = make_ubignum();
- mp_err mpe;
- mp_2comp(mp(ntrunc), mp(out), mp(ntrunc)->used);
- if ((mpe = mp_trunc(mp(out), mp(out), c_n(nbits))) != MP_OKAY)
- do_mp_error(self, mpe);
- mp_neg(mp(out), mp(out));
- return normalize(out);
+ if (cobjp(n)) {
+ return do_binary_method(self, self, n, nbits);
+ } else {
+ val msb = minus(nbits, one);
+ val ntrunc = logtrunc(n, nbits);
+
+ if (bit(ntrunc, msb)) {
+ switch (type(ntrunc)) {
+ case NUM:
+ {
+ cnum cn = c_n(ntrunc);
+ cnum nb = c_n(nbits);
+ return num(cn | (INT_PTR_MAX << nb));
+ }
+ case BGNUM:
+ {
+ val out = make_ubignum();
+ mp_err mpe;
+ mp_2comp(mp(ntrunc), mp(out), mp(ntrunc)->used);
+ if ((mpe = mp_trunc(mp(out), mp(out), c_n(nbits))) != MP_OKAY)
+ do_mp_error(self, mpe);
+ mp_neg(mp(out), mp(out));
+ return normalize(out);
+ }
+ case COBJ:
+ ntrunc = do_binary_method(self, self, ntrunc, nbits);
+ break;
+ default:
+ internal_error("impossible case");
}
- case COBJ:
- ntrunc = do_binary_method(self, self, ntrunc, nbits);
- break;
- default:
- internal_error("impossible case");
}
+ return ntrunc;
}
- return ntrunc;
}
val ash(val a, val bits)
@@ -3990,7 +3995,7 @@ val divv(val dividend, struct args *nlist)
cnum index = 0;
if (!args_more(nlist, index))
- return divi(one, acc);
+ return divi(acc, colon_k);
do {
next = args_get(nlist, &index);
@@ -4224,7 +4229,7 @@ void arith_init(void)
logxor_s = intern(lit("logxor"), user_package);
lognot1_s = intern(lit("lognot1"), user_package);
lognot_s = intern(lit("lognot"), user_package);
- r_lognot_s = intern(lit("r-logtruncnot"), user_package);
+ r_lognot_s = intern(lit("r-lognot"), user_package);
logtrunc_s = intern(lit("logtrunc"), user_package);
r_logtrunc_s = intern(lit("r-logtrunc"), user_package);
sign_extend_s = intern(lit("sign-extend"), user_package);
diff --git a/tests/016/ud-arith.expected b/tests/016/ud-arith.expected
new file mode 100644
index 00000000..e69de29b
--- /dev/null
+++ b/tests/016/ud-arith.expected
diff --git a/tests/016/ud-arith.tl b/tests/016/ud-arith.tl
new file mode 100644
index 00000000..d086b9e6
--- /dev/null
+++ b/tests/016/ud-arith.tl
@@ -0,0 +1,132 @@
+(load "../common.tl")
+
+(defstruct numbase nil
+ v
+ (:method + (me arg) ^(+ ,me.v ,arg))
+ (:method - (me arg) ^(- ,me.v ,arg))
+ (:method -- (me arg) ^(- ,arg ,me.v))
+ (:method neg (me) ^(- ,me.v))
+ (:method * (me arg) ^(* ,me.v ,arg))
+ (:method / (me arg) ^(/ ,me.v ,arg))
+ (:method // (me arg) ^(/ ,arg ,me.v))
+ (:method recip (me) ^(/ ,me.v))
+ (:method abs (me) ^(abs ,me.v))
+ (:method signum (me) ^(signum ,me.v))
+ (:method trunc (me arg) ^(trunc ,me.v ,arg))
+ (:method r-trunc (me arg) ^(trunc ,arg ,me.v))
+ (:method trunc1 (me) ^(trunc ,me.v))
+ (:method mod (me arg) ^(mod ,me.v ,arg))
+ (:method r-mod (me arg) ^(mod ,arg ,me.v))
+ (:method expt (me arg) ^(expt ,me.v ,arg))
+ (:method r-expt (me arg) ^(expt ,arg ,me.v))
+ (:method exptmod (me arg1 arg2) ^(exptmod ,me.v ,arg1 ,arg2))
+ (:method isqrt (me) ^(isqrt ,me.v))
+ (:method square (me) ^(square ,me.v))
+ (:method > (me arg) ^(> ,me.v ,arg))
+ (:method < (me arg) ^(< ,me.v ,arg))
+ (:method >= (me arg) ^(>= ,me.v ,arg))
+ (:method <= (me arg) ^(<= ,me.v ,arg))
+ (:method = (me arg) ^(= ,me.v ,arg))
+ (:method zerop (me) ^(zerop ,me.v))
+ (:method plusp (me) ^(plusp ,me.v))
+ (:method minusp (me) ^(minusp ,me.v))
+ (:method evenp (me) ^(evenp ,me.v))
+ (:method oddp (me) ^(oddp ,me.v))
+ (:method floor (me arg) ^(floor ,me.v ,arg))
+ (:method r-floor (me arg) ^(floor ,arg ,me.v))
+ (:method floor1 (me) ^(floor ,me.v))
+ (:method round1 (me) ^(round ,me.v))
+ (:method ceil1 (me) ^(ceil ,me.v))
+ (:method sin (me) ^(sin ,me.v))
+ (:method cos (me) ^(cos ,me.v))
+ (:method tan (me) ^(tan ,me.v))
+ (:method asin (me) ^(asin ,me.v))
+ (:method acos (me) ^(acos ,me.v))
+ (:method atan (me) ^(atan ,me.v))
+ (:method atan2 (me arg) ^(atan2 ,me.v ,arg))
+ (:method r-atan2 (me arg) ^(atan2 ,arg ,me.v))
+ (:method log (me) ^(log ,me.v))
+ (:method log2 (me) ^(log2 ,me.v))
+ (:method log10 (me) ^(log10 ,me.v))
+ (:method exp (me) ^(exp ,me.v))
+ (:method sqrt (me) ^(sqrt ,me.v))
+ (:method logand (me arg) ^(logand ,me.v ,arg))
+ (:method logior (me arg) ^(logior ,me.v ,arg))
+ (:method lognot (me arg) ^(lognot ,me.v ,arg))
+ (:method r-lognot (me arg) ^(lognot ,arg ,me.v))
+ (:method lognot1 (me) ^(lognot ,me.v))
+ (:method logtrunc (me arg) ^(logtrunc ,me.v ,arg))
+ (:method r-logtrunc (me arg) ^(logtrunc ,arg ,me.v))
+ (:method sign-extend (me arg) ^(sign-extend ,me.v ,arg))
+ (:method ash (me arg) ^(ash ,me.v ,arg))
+ (:method bit (me arg) ^(bit ,me.v ,arg))
+ (:method width (me) ^(width ,me.v))
+ (:method logcount (me) ^(logcount ,me.v)))
+
+(defvarl n (new numbase v 1))
+
+(test (+ n 0) (+ 1 0))
+(test (+ 0 n) (+ 1 0))
+(test (- n) (- 1))
+(test (- n 0) (- 1 0))
+(test (- 0 n) (- 0 1))
+(test (* n 0) (* 1 0))
+(test (* 0 n) (* 1 0))
+(test (/ n 0) (/ 1 0))
+(test (/ 0 n) (/ 0 1))
+(test (/ n) (/ 1))
+(test (abs n) (abs 1))
+(test (signum n) (signum 1))
+(test (trunc n 0) (trunc 1 0))
+(test (trunc 0 n) (trunc 0 1))
+(test (trunc n) (trunc 1))
+(test (mod n 0) (mod 1 0))
+(test (mod 0 n) (mod 0 1))
+(test (expt n 0) (expt 1 0))
+(test (expt 0 n) (expt 0 1))
+(test (exptmod n 2 3) (exptmod 1 2 3))
+(test (isqrt n) (isqrt 1))
+(test (square n) (square 1))
+(test (sys:b> n 0) (> 1 0))
+(test (sys:b> 0 n) (< 1 0))
+(test (sys:b< n 0) (< 1 0))
+(test (sys:b< 0 n) (> 1 0))
+(test (sys:b< 0 n) (> 1 0))
+(test (sys:b= n 0) (= 1 0))
+(test (sys:b= 0 n) (= 1 0))
+(test (zerop n) (zerop 1))
+(test (plusp n) (plusp 1))
+(test (minusp n) (minusp 1))
+(test (evenp n) (evenp 1))
+(test (oddp n) (oddp 1))
+(test (floor n 0) (floor 1 0))
+(test (floor 0 n) (floor 0 1))
+(test (floor n) (floor 1))
+(test (round n) (round 1))
+(test (ceil n) (ceil 1))
+(test (sin n) (sin 1))
+(test (cos n) (cos 1))
+(test (tan n) (tan 1))
+(test (asin n) (asin 1))
+(test (acos n) (acos 1))
+(test (atan n) (atan 1))
+(test (atan2 n 0) (atan2 1 0))
+(test (atan2 0 n) (atan2 0 1))
+(test (log n) (log 1))
+(test (log2 n) (log2 1))
+(test (log10 n) (log10 1))
+(test (exp n) (exp 1))
+(test (sqrt n) (sqrt 1))
+(test (logand n 0) (logand 1 0))
+(test (logand 0 n) (logand 1 0))
+(test (logior n 0) (logior 1 0))
+(test (logior 0 n) (logior 1 0))
+(test (lognot n 0) (lognot 1 0))
+(test (lognot 0 n) (lognot 0 1))
+(test (lognot n) (lognot 1))
+(test (logtrunc n 0) (logtrunc 1 0))
+(test (logtrunc 0 n) (logtrunc 0 1))
+(test (sign-extend n 2) (sign-extend 1 2))
+(test (ash n 0) (ash 1 0))
+(test (width n) (width 1))
+(test (logcount n) (logcount 1))
diff --git a/txr.1 b/txr.1
index 377584c0..8e8273a8 100644
--- a/txr.1
+++ b/txr.1
@@ -38241,7 +38241,7 @@ and
.code floor
methods are required.
-.umv round
+.umv round1 round
Note: the two-argument version of the
.code round
@@ -38266,8 +38266,8 @@ above functions are required.
.um asin
.um acos
.um atan
-.bmnl atan
-.bmnr r-atan atan
+.bmnl atan2
+.bmnr r-atan2 atan2
.um log
.um log2
.um log10
@@ -38276,7 +38276,7 @@ above functions are required.
.bmcv logand
.bmcv logior
.bmnl lognot
-.bmnr lognot-r lognot
+.bmnr r-lognot lognot
.umv lognot1 lognot
.bmnl logtrunc
.bmnr r-logtrunc logtrunc
generated by cgit v1.2.3 (git 2.25.1) at 2025-03-10 16:24:43 +0000