From 710a97992705d67c3ded0d4b270c5978ce29b11f Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:37 -0800 Subject: Import Upstream version 5e4 --- subr.c | 76 ++++++++++++++++++++++++++++++++++++++++++++---------------------- 1 file changed, 51 insertions(+), 25 deletions(-) (limited to 'subr.c') diff --git a/subr.c b/subr.c index 1399939..6703d7c 100644 --- a/subr.c +++ b/subr.c @@ -186,7 +186,7 @@ SCM append(args) return res; } ASRTER(CONSP(args), args, ARGn, s_append); - for(;NIMP(arg);arg = CDR(arg)) { + for (;NIMP(arg);arg = CDR(arg)) { ASRTER(CONSP(arg), arg, ARGn, s_append); *lloc = cons(CAR(arg), EOL); lloc = &CDR(*lloc); @@ -199,7 +199,7 @@ SCM reverse(lst) { SCM res = EOL; SCM p = lst; - for(;NIMP(p);p = CDR(p)) { + for (;NIMP(p);p = CDR(p)) { ASRTER(CONSP(p), lst, ARG1, s_reverse); res = cons(CAR(p), res); } @@ -224,7 +224,7 @@ erout: ASRTER(NIMP(lst) && CONSP(lst), SCM memq(x, lst) SCM x, lst; { - for(;NIMP(lst);lst = CDR(lst)) { + for (;NIMP(lst);lst = CDR(lst)) { ASRTER(CONSP(lst), lst, ARG2, s_memq); if (CAR(lst)==x) return lst; } @@ -234,7 +234,7 @@ SCM memq(x, lst) SCM member(x, lst) SCM x, lst; { - for(;NIMP(lst);lst = CDR(lst)) { + for (;NIMP(lst);lst = CDR(lst)) { ASRTER(CONSP(lst), lst, ARG2, s_member); if (NFALSEP(equal(CAR(lst), x))) return lst; } @@ -245,7 +245,7 @@ SCM assq(x, alist) SCM x, alist; { SCM tmp; - for(;NIMP(alist);alist = CDR(alist)) { + for (;NIMP(alist);alist = CDR(alist)) { ASRTER(CONSP(alist), alist, ARG2, s_assq); tmp = CAR(alist); ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq); @@ -258,7 +258,7 @@ SCM assoc(x, alist) SCM x, alist; { SCM tmp; - for(;NIMP(alist);alist = CDR(alist)) { + for (;NIMP(alist);alist = CDR(alist)) { ASRTER(CONSP(alist), alist, ARG2, s_assoc); tmp = CAR(alist); ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc); @@ -933,6 +933,7 @@ static char s_logand[] = "logand", s_lognot[] = "lognot", s_copybit[] = "copy-bit", s_copybitfield[] = "copy-bit-field", s_ash[] = "ash", s_logcount[] = "logcount", + s_bitwise_bit_count[] = "bitwise-bit-count", s_intlength[] = "integer-length", s_bitfield[] = "bit-field", s_bitif[] = "bitwise-if"; @@ -1312,7 +1313,7 @@ SCM scm_copybitfield(to, from, rest) } char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4}; -SCM scm_logcount(n) +SCM scm_bitwise_bit_count(n) SCM n; { register unsigned long c = 0; @@ -1320,18 +1321,42 @@ SCM scm_logcount(n) #ifdef BIGDIG 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)); + ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_bitwise_bit_count); + if (BIGSIGN(n)) + return scm_lognot(scm_bitwise_bit_count(difference(MAKINUM(-1L), n))); ds = BDIGITS(n); - for(i = NUMDIGS(n); i--; ) - for(d = ds[i]; d; d >>= 4) c += logtab[15 & d]; + for (i = NUMDIGS(n); i--; ) + for (d = ds[i]; d; d >>= 4) c += logtab[15 & d]; + if (BIGSIGN(n)) + return MAKINUM(-1 - c); return MAKINUM(c); } +#else + ASRTER(INUMP(n), n, ARG1, s_bitwise_bit_count); +#endif + if ((nn = INUM(n)) < 0) nn = -1 - nn; + for (; nn; nn >>= 4) c += logtab[15 & nn]; + if (n < 0) + return MAKINUM(-1 - c); + return MAKINUM(c); +} + +SCM scm_logcount(n) + SCM n; +{ + register unsigned long c = 0; + register long nn; +#ifdef BIGDIG + if (NINUMP(n)) { + ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount); + if (BIGSIGN(n)) return scm_bitwise_bit_count(difference(MAKINUM(-1L), n)); + return scm_bitwise_bit_count(n); + } #else ASRTER(INUMP(n), n, ARG1, s_logcount); #endif if ((nn = INUM(n)) < 0) nn = -1 - nn; - for(; nn; nn >>= 4) c += logtab[15 & nn]; + for (; nn; nn >>= 4) c += logtab[15 & nn]; return MAKINUM(c); } @@ -1349,14 +1374,14 @@ SCM scm_intlength(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];} + for (c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];} return MAKINUM(c - 4 + l); } #else ASRTER(INUMP(n), n, ARG1, s_intlength); #endif if ((nn = INUM(n)) < 0) nn = -1 - nn; - for(;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];} + for (;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];} return MAKINUM(c - 4 + l); } @@ -1500,7 +1525,7 @@ SCM string(chrs) ASRTER(i >= 0, chrs, ARG1, s_string); res = makstr(i); data = UCHARS(res); - for(;NNULLP(chrs);chrs = CDR(chrs)) { + for (;NNULLP(chrs);chrs = CDR(chrs)) { ASRTER(ICHRP(CAR(chrs)), chrs, ARG1, s_string); *data++ = ICHR(CAR(chrs)); } @@ -1518,7 +1543,7 @@ SCM make_string(k, chr) dst = UCHARS(res); if (!UNBNDP(chr)) { ASRTER(ICHRP(chr), chr, ARG2, s_make_string); - for(i--;i >= 0;i--) dst[i] = ICHR(chr); + for (i--;i >= 0;i--) dst[i] = ICHR(chr); } return res; } @@ -1587,7 +1612,7 @@ SCM st_lessp(s1, s2) if (len>i) i = len; c1 = UCHARS(s1); c2 = UCHARS(s2); - for(i = 0;i0) return BOOL_F; if (c<0) return BOOL_T; @@ -1622,7 +1647,7 @@ SCM stci_lessp(s1, s2) if (len>i) i=len; c1 = UCHARS(s1); c2 = UCHARS(s2); - for(i = 0;i0) return BOOL_F; if (c<0) return BOOL_T; @@ -1664,7 +1689,7 @@ SCM st_append(args) register long i = 0; register SCM l, s; register unsigned char *data; - for(l = args;NIMP(l);) { + for (l = args;NIMP(l);) { ASRTER(CONSP(l), l, ARGn, s_st_append); s = CAR(l); ASRTER(NIMP(s) && STRINGP(s), s, ARGn, s_st_append); @@ -1674,9 +1699,9 @@ SCM st_append(args) ASRTER(NULLP(l), args, ARGn, s_st_append); res = makstr(i); data = UCHARS(res); - for(l = args;NIMP(l);l = CDR(l)) { + for (l = args;NIMP(l);l = CDR(l)) { s = CAR(l); - for(i = 0;i= 0, l, ARG1, s_vector); res = make_vector(MAKINUM(i), UNSPECIFIED); data = VELTS(res); - for(;NIMP(l);l = CDR(l)) *data++ = CAR(l); + for (;NIMP(l);l = CDR(l)) *data++ = CAR(l); return res; } SCM vector_ref(v, k) @@ -2073,7 +2098,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) } while (--j >= ny); switch (modes) { case 3: /* check that remainder==0 */ - for(j = ny;j && !zds[j-1];--j) ; if (j) return 0; + for (j = ny;j && !zds[j-1];--j) ; if (j) return 0; case 2: /* move quotient down in z */ j = (nx==ny ? nx+2 : nx+1) - ny; for (i = 0;i < j;i++) zds[i] = zds[i+ny]; @@ -2091,7 +2116,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) if (d) divbigdig(zds, ny, d); } doadj: - for(j = ny;j && !zds[j-1];--j) ; + for (j = ny;j && !zds[j-1];--j) ; if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT) if (INUMP(z = big2inum(z, j))) return z; return adjbig(z, j); @@ -2126,6 +2151,7 @@ static iproc subr1s[] = { {s_evenp, evenp}, {s_lognot, scm_lognot}, {s_logcount, scm_logcount}, + {s_bitwise_bit_count, scm_bitwise_bit_count}, {s_intlength, scm_intlength}, {"char?", charp}, {s_ch_alphap, char_alphap}, @@ -2226,7 +2252,7 @@ void init_iprocs(subra, type) iproc *subra; int type; { - for(;subra->string; subra++) + for (;subra->string; subra++) make_subr(subra->string, type, subra->cproc); -- cgit v1.2.3