summaryrefslogtreecommitdiffstats
path: root/subr.c
diff options
context:
space:
mode:
Diffstat (limited to 'subr.c')
-rw-r--r--subr.c165
1 files changed, 71 insertions, 94 deletions
diff --git a/subr.c b/subr.c
index 6c6bde9..06829b7 100644
--- a/subr.c
+++ b/subr.c
@@ -60,7 +60,7 @@ static char s_symbol2string[] = "symbol->string",
extern char s_inexactp[];
#define s_exactp (s_inexactp+2)
static char s_oddp[] = "odd?", s_evenp[] = "even?";
-static char s_abs[] = "abs", s_quotient[] = "quotient",
+static char s_quotient[] = "quotient",
s_remainder[] = "remainder", s_modulo[] = "modulo";
static char s_gcd[] = "gcd";
@@ -108,7 +108,7 @@ SCM eq(x, y)
SCM consp(x)
SCM x;
{
- if IMP(x) return BOOL_F;
+ if (IMP(x)) return BOOL_F;
return CONSP(x) ? BOOL_T : BOOL_F;
}
SCM setcar(pair, value)
@@ -136,12 +136,12 @@ long ilength(sx)
register long i = 0;
register SCM x = sx;
do {
- if IMP(x) return NULLP(x) ? i : -1;
- if NCONSP(x) return -2;
+ if (IMP(x)) return NULLP(x) ? i : -1;
+ if (NCONSP(x)) return -2;
x = CDR(x);
i++;
- if IMP(x) return NULLP(x) ? i : -1;
- if NCONSP(x) return -2;
+ if (IMP(x)) return NULLP(x) ? i : -1;
+ if (NCONSP(x)) return -2;
x = CDR(x);
i++;
sx = CDR(sx);
@@ -172,7 +172,7 @@ SCM append(args)
{
SCM res = EOL;
SCM *lloc = &res, arg;
- if IMP(args) {
+ if (IMP(args)) {
ASRTER(NULLP(args), args, ARGn, s_append);
return res;
}
@@ -180,7 +180,7 @@ SCM append(args)
while (1) {
arg = CAR(args);
args = CDR(args);
- if IMP(args) {
+ if (IMP(args)) {
*lloc = arg;
ASRTER(NULLP(args), args, ARGn, s_append);
return res;
@@ -236,7 +236,7 @@ SCM member(x, lst)
{
for(;NIMP(lst);lst = CDR(lst)) {
ASRTER(CONSP(lst), lst, ARG2, s_member);
- if NFALSEP(equal(CAR(lst), x)) return lst;
+ if (NFALSEP(equal(CAR(lst), x))) return lst;
}
ASRTER(NULLP(lst), lst, ARG2, s_member);
return BOOL_F;
@@ -262,7 +262,7 @@ SCM assoc(x, alist)
ASRTER(CONSP(alist), alist, ARG2, s_assoc);
tmp = CAR(alist);
ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
- if NFALSEP(equal(CAR(tmp), x)) return tmp;
+ if (NFALSEP(equal(CAR(tmp), x))) return tmp;
}
ASRTER(NULLP(alist), alist, ARG2, s_assoc);
return BOOL_F;
@@ -278,7 +278,7 @@ SCM promisep(x)
SCM symbolp(x)
SCM x;
{
- if IMP(x) return BOOL_F;
+ if (IMP(x)) return BOOL_F;
return SYMBOLP(x) ? BOOL_T : BOOL_F;
}
SCM symbol2string(s)
@@ -298,7 +298,7 @@ SCM string2symbol(s)
SCM exactp(x)
SCM x;
{
- if INUMP(x) return BOOL_T;
+ if (INUMP(x)) return BOOL_T;
#ifdef BIGDIG
if (NIMP(x) && BIGP(x)) return BOOL_T;
#endif
@@ -308,7 +308,7 @@ SCM oddp(n)
SCM n;
{
#ifdef BIGDIG
- if NINUMP(n) {
+ if (NINUMP(n)) {
ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F;
}
@@ -321,7 +321,7 @@ SCM evenp(n)
SCM n;
{
#ifdef BIGDIG
- if NINUMP(n) {
+ if (NINUMP(n)) {
ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T;
}
@@ -330,37 +330,15 @@ SCM evenp(n)
#endif
return (4 & (int)n) ? BOOL_F : BOOL_T;
}
-SCM absval(x)
- SCM x;
-{
-#ifdef BIGDIG
- if NINUMP(x) {
- ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_abs);
- if (TYP16(x)==tc16_bigpos) return x;
- return copybig(x, 0);
- }
-#else
- ASRTER(INUMP(x), x, ARG1, s_abs);
-#endif
- if (INUM(x) >= 0) return x;
- x = -INUM(x);
- if (!POSFIXABLE(x))
-#ifdef BIGDIG
- return long2big(x);
-#else
- wta(MAKINUM(-x), (char *)OVFLOW, s_abs);
-#endif
- return MAKINUM(x);
-}
SCM lquotient(x, y)
SCM x, y;
{
register long z;
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
long w;
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
- if NINUMP(y) {
+ if (NINUMP(y)) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x) ^ BIGSIGN(y), 2);
@@ -386,7 +364,7 @@ SCM lquotient(x, y)
}
# endif
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_quotient);
@@ -427,9 +405,9 @@ SCM lremainder(x, y)
{
register long z;
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
- if NINUMP(y) {
+ if (NINUMP(y)) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(x), 0);
@@ -437,7 +415,7 @@ SCM lremainder(x, y)
if (!(z = INUM(y))) goto ov;
return divbigint(x, z, BIGSIGN(x), 0);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_remainder);
@@ -468,9 +446,9 @@ SCM modulo(x, y)
{
register long yy, z;
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
- if NINUMP(y) {
+ if (NINUMP(y)) {
ASRTGO(NIMP(y) && BIGP(y), bady);
return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0);
@@ -478,7 +456,7 @@ SCM modulo(x, y)
if (!(z = INUM(y))) goto ov;
return divbigint(x, z, z < 0, (BIGSIGN(x) ? (z > 0) : (z < 0)) ? 1 : 0);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_modulo);
@@ -505,16 +483,16 @@ SCM lgcd(x, y)
{
register long u, v, k, t;
tailrec:
- if UNBNDP(y) return UNBNDP(x) ? INUM0 : x;
+ if (UNBNDP(y)) return UNBNDP(x) ? INUM0 : x;
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
big_gcd:
ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
- if BIGSIGN(x) x = copybig(x, 0);
+ if (BIGSIGN(x)) x = copybig(x, 0);
newy:
- if NINUMP(y) {
+ if (NINUMP(y)) {
ASRTER(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
- if BIGSIGN(y) y = copybig(y, 0);
+ if (BIGSIGN(y)) y = copybig(y, 0);
switch (bigcomp(x, y)) {
case -1:
swaprec: t = lremainder(x, y); x = y; y = t; goto tailrec;
@@ -525,7 +503,7 @@ SCM lgcd(x, y)
}
if (INUM0==y) return x; goto swaprec;
}
- if NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
+ if (NINUMP(y)) { t=x; x=y; y=t; goto big_gcd;}
#else
ASRTER(INUMP(x), x, ARG1, s_gcd);
ASRTER(INUMP(y), y, ARG2, s_gcd);
@@ -562,13 +540,13 @@ SCM llcm(n1, n2)
SCM n1, n2;
{
SCM d;
- if UNBNDP(n2) {
+ if (UNBNDP(n2)) {
n2 = MAKINUM(1L);
- if UNBNDP(n1) return n2;
+ if (UNBNDP(n1)) return n2;
}
d = lgcd(n1, n2);
if (INUM0==d) return d;
- return absval(product(n1, lquotient(n2, d)));
+ return scm_iabs(product(n1, lquotient(n2, d)));
}
/* Emulating 2's complement bignums with sign magnitude arithmetic:
@@ -624,7 +602,7 @@ SCM scm_copy_big_dec(b, sign)
sizet i = 0;
SCM ans = mkbig(nx, sign);
BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
- if BIGSIGN(b) do {
+ if (BIGSIGN(b)) do {
num += src[i];
if (num < 0) {dst[i] = num + BIGRAD; num = -1;}
else {dst[i] = BIGLO(num); num = 0;}
@@ -784,7 +762,7 @@ SCM scm_big_test(x, nx, xsgn, bigy)
num = 0;
}
} while (++i < nx);
- else if BIGSIGN(bigy)
+ else if (BIGSIGN(bigy))
do {
num += y[i];
if (num < 0) {
@@ -814,7 +792,7 @@ static SCM scm_copy_big_2scomp(x, blen, sign)
BIGDIG *rds;
long num = 0;
sizet i;
- if INUMP(x) {
+ if (INUMP(x)) {
long lx = INUM(x);
if (nres < (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG)
nres = (LONG_BIT + BITSPERDIG - 1)/BITSPERDIG;
@@ -849,7 +827,7 @@ static SCM scm_copy_big_2scomp(x, blen, sign)
nres = nx;
res = mkbig(nres, sign);
rds = BDIGITS(res);
- if BIGSIGN(x) {
+ if (BIGSIGN(x)) {
for (i = 0; i < nx; i++) {
num -= xds[i];
if (num < 0) {
@@ -901,7 +879,7 @@ SCM scm_big_ash(x, cnt)
unsigned long d;
int sign, ishf;
long i, fshf, blen, n;
- if INUMP(x) {
+ if (INUMP(x)) {
blen = LONG_BIT;
sign = INUM(x) < 0 ? 0x0100 : 0;
}
@@ -962,8 +940,8 @@ static char s_logand[] = "logand", s_lognot[] = "lognot",
SCM scm_logior(x, y)
SCM x, y;
{
- if UNBNDP(y) {
- if UNBNDP(x) return INUM0;
+ if (UNBNDP(y)) {
+ if (UNBNDP(x)) return INUM0;
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_logior);
@@ -971,17 +949,17 @@ SCM scm_logior(x, y)
return x;
}
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
SCM t;
ASRTGO(NIMP(x) && BIGP(x), badx);
- if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
if ((!BIGSIGN(x)) && !BIGSIGN(y))
return scm_big_ior(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_logior);
@@ -1011,8 +989,8 @@ SCM scm_logior(x, y)
SCM scm_logand(x, y)
SCM x, y;
{
- if UNBNDP(y) {
- if UNBNDP(x) return MAKINUM(-1);
+ if (UNBNDP(y)) {
+ if (UNBNDP(x)) return MAKINUM(-1);
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_logand);
@@ -1020,17 +998,17 @@ SCM scm_logand(x, y)
return x;
}
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
SCM t;
ASRTGO(NIMP(x) && BIGP(x), badx);
- if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
if ((BIGSIGN(x)) && BIGSIGN(y))
return scm_big_ior(BDIGITS(x), NUMDIGS(x), 0x0100, y);
return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_logand);
@@ -1060,8 +1038,8 @@ SCM scm_logand(x, y)
SCM scm_logxor(x, y)
SCM x, y;
{
- if UNBNDP(y) {
- if UNBNDP(x) return INUM0;
+ if (UNBNDP(y)) {
+ if (UNBNDP(x)) return INUM0;
#ifndef RECKLESS
if (!(NUMBERP(x)))
badx: wta(x, (char *)ARG1, s_logxor);
@@ -1069,15 +1047,15 @@ SCM scm_logxor(x, y)
return x;
}
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
SCM t;
ASRTGO(NIMP(x) && BIGP(x), badx);
- if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
return scm_big_xor(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_logxor);
@@ -1107,15 +1085,15 @@ SCM scm_logtest(x, y)
badx: wta(x, (char *)ARG1, s_logtest);
#endif
#ifdef BIGDIG
- if NINUMP(x) {
+ if (NINUMP(x)) {
SCM t;
ASRTGO(NIMP(x) && BIGP(x), badx);
- if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
ASRTGO(NIMP(y) && BIGP(y), bady);
if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
return scm_big_test(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
}
- if NINUMP(y) {
+ if (NINUMP(y)) {
# ifndef RECKLESS
if (!(NIMP(y) && BIGP(y)))
bady: wta(y, (char *)ARG2, s_logtest);
@@ -1142,10 +1120,10 @@ SCM scm_logbitp(index, j1)
{
ASRTER(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
#ifdef BIGDIG
- if NINUMP(j1) {
+ if (NINUMP(j1)) {
ASRTER(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp);
if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
- else if BIGSIGN(j1) {
+ else if (BIGSIGN(j1)) {
long num = -1;
sizet i = 0;
BIGDIG *x = BDIGITS(j1);
@@ -1200,7 +1178,7 @@ SCM scm_copybit(index, j1, bit)
ASRTER(INUMP(j1), j1, ARG2, s_copybit);
ASRTER(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
#endif
- if NFALSEP(bit)
+ if (NFALSEP(bit))
return MAKINUM(INUM(j1) | (1L << INUM(index)));
else
return MAKINUM(INUM(j1) & (~(1L << INUM(index))));
@@ -1340,10 +1318,10 @@ SCM scm_logcount(n)
register unsigned long c = 0;
register long nn;
#ifdef BIGDIG
- if NINUMP(n) {
+ if (NINUMP(n)) {
sizet i; BIGDIG *ds, d;
ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
- if BIGSIGN(n) return scm_logcount(difference(MAKINUM(-1L), n));
+ if (BIGSIGN(n)) return scm_logcount(difference(MAKINUM(-1L), n));
ds = BDIGITS(n);
for(i = NUMDIGS(n); i--; )
for(d = ds[i]; d; d >>= 4) c += logtab[15 & d];
@@ -1365,10 +1343,10 @@ SCM scm_intlength(n)
register long nn;
unsigned int l = 4;
#ifdef BIGDIG
- if NINUMP(n) {
+ if (NINUMP(n)) {
BIGDIG *ds, d;
ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
- if BIGSIGN(n) return scm_intlength(difference(MAKINUM(-1L), n));
+ if (BIGSIGN(n)) return scm_intlength(difference(MAKINUM(-1L), n));
ds = BDIGITS(n);
d = ds[c = NUMDIGS(n)-1];
for(c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];}
@@ -1510,7 +1488,7 @@ SCM char_downcase(chr)
SCM stringp(x)
SCM x;
{
- if IMP(x) return BOOL_F;
+ if (IMP(x)) return BOOL_F;
return STRINGP(x) ? BOOL_T : BOOL_F;
}
SCM string(chrs)
@@ -1579,7 +1557,7 @@ SCM st_equal(s1, s2)
if (LENGTH(s1) != i) return BOOL_F;
c1 = UCHARS(s1);
c2 = UCHARS(s2);
- while(0 != i--) if(*c1++ != *c2++) return BOOL_F;
+ while(0 != i--) if (*c1++ != *c2++) return BOOL_F;
return BOOL_T;
}
SCM stci_equal(s1, s2)
@@ -1593,7 +1571,7 @@ SCM stci_equal(s1, s2)
if (LENGTH(s1) != i) return BOOL_F;
c1 = UCHARS(s1);
c2 = UCHARS(s2);
- while(0 != i--) if(upcase[*c1++] != upcase[*c2++]) return BOOL_F;
+ while(0 != i--) if (upcase[*c1++] != upcase[*c2++]) return BOOL_F;
return BOOL_T;
}
SCM st_lessp(s1, s2)
@@ -1706,7 +1684,7 @@ SCM st_append(args)
SCM vectorp(x)
SCM x;
{
- if IMP(x) return BOOL_F;
+ if (IMP(x)) return BOOL_F;
return VECTORP(x) ? BOOL_T : BOOL_F;
}
SCM vector_length(v)
@@ -1756,7 +1734,7 @@ SCM make_vector(k, fill)
#else
ASRTER(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector);
#endif
- if UNBNDP(fill) fill = UNSPECIFIED;
+ if (UNBNDP(fill)) fill = UNSPECIFIED;
i = INUM(k);
DEFER_INTS;
v = must_malloc_cell(i ? i*sizeof(SCM) : 1L,
@@ -1789,9 +1767,9 @@ SCM big2inum(b, l)
BIGDIG *tmp = BDIGITS(b);
while (l--) num = BIGUP(num) + tmp[l];
if (TYP16(b)==tc16_bigpos) {
- if POSFIXABLE(num) return MAKINUM(num);
+ if (POSFIXABLE(num)) return MAKINUM(num);
}
- else if UNEGFIXABLE(num) return MAKINUM(-(long)num);
+ else if (UNEGFIXABLE(num)) return MAKINUM(-(long)num);
return b;
}
char s_adjbig[] = "adjbig";
@@ -1820,7 +1798,7 @@ SCM normbig(b)
BIGDIG *zds = BDIGITS(b);
while (nlen-- && !zds[nlen]); nlen++;
if (nlen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
- if INUMP(b = big2inum(b, (sizet)nlen)) return b;
+ if (INUMP(b = big2inum(b, (sizet)nlen))) return b;
if (NUMDIGS(b)==nlen) return b;
return adjbig(b, (sizet)nlen);
}
@@ -2114,7 +2092,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes)
doadj:
for(j = ny;j && !zds[j-1];--j) ;
if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT)
- if INUMP(z = big2inum(z, j)) return z;
+ if (INUMP(z = big2inum(z, j))) return z;
return adjbig(z, j);
}
#endif
@@ -2145,7 +2123,6 @@ static iproc subr1s[] = {
{s_exactp, exactp},
{s_oddp, oddp},
{s_evenp, evenp},
- {s_abs, absval},
{s_lognot, scm_lognot},
{s_logcount, scm_logcount},
{s_intlength, scm_intlength},
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 00:06:55 +0000