From ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:31 -0800 Subject: Import Upstream version 5e2 --- subr.c | 165 ++++++++++++++++++++++++++++------------------------------------- 1 file changed, 71 insertions(+), 94 deletions(-) (limited to 'subr.c') 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}, -- cgit v1.2.3