summaryrefslogtreecommitdiffstats
path: root/subr.c
diff options
context:
space:
mode:
authorDavid N. Welton <davidw@efn.org>1998-12-11 20:21:49 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commita47af30d2f0e96afcd1f14b1984575c359faa3d6 (patch)
tree2ed08ce2d757f917de7c3c7c04fd7e309f454c83 /subr.c
parentf64b2806c1d66a1341bb8b1491f384169ab1d65f (diff)
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.tar.gz
scm-a47af30d2f0e96afcd1f14b1984575c359faa3d6.zip
Import Debian changes 5c3-5debian/5c3-5
scm (5c3-5) frozen unstable; urgency=low * debian/rules chmod +x's bld.scm. Fixes #30521. scm (5c3-4) frozen unstable; urgency=low * Made bld.scm executable. Fixes #29578. scm (5c3-3) frozen unstable; urgency=low * -nw * Fixes #16762. * Fixes #18163. * Fixes #18164. * Fixes #23743. * Fixes #24098. * Fixes #24099. * Fixes #24547. scm (5c3-2) frozen unstable; urgency=low * Re-uploading for slink freeze. scm (5c3-1) unstable; urgency=low * New upstream version.
Diffstat (limited to 'subr.c')
-rw-r--r--subr.c168
1 files changed, 130 insertions, 38 deletions
diff --git a/subr.c b/subr.c
index f9552c2..5612c1a 100644
--- a/subr.c
+++ b/subr.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc.
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
@@ -798,10 +798,13 @@ SCM scm_big_test(x, nx, xsgn, bigy)
static char s_logand[] = "logand", s_lognot[] = "lognot",
s_logior[] = "logior", s_logxor[] = "logxor",
s_logtest[] = "logtest", s_logbitp[] = "logbit?",
+ s_copybit[] = "copy-bit",
+ s_copybitfield[] = "copy-bit-field",
s_ash[] = "ash", s_logcount[] = "logcount",
s_intlength[] = "integer-length",
s_intexpt[] = "integer-expt",
- s_bitextract[] = "bit-extract";
+ s_bitfield[] = "bit-field",
+ s_bitif[] = "bitwise-if";
SCM scm_logior(x, y)
SCM x, y;
@@ -1011,6 +1014,28 @@ SCM scm_logbitp(index, j1)
return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
}
+SCM scm_copybit(index, j1, bit)
+ SCM index, j1, bit;
+{
+ ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit);
+#ifdef BIGDIG
+ if (NINUMP(j1) || (INUM(index) >= LONG_BIT - 3))
+ /* This function makes more bignums than it needs to. */
+ if NFALSEP(bit)
+ return scm_logior(j1, scm_ash(MAKINUM(1), index));
+ else
+ return scm_logand(j1, difference(MAKINUM(-1L),
+ scm_ash(MAKINUM(1), index)));
+#else
+ ASSERT(INUMP(j1), j1, ARG2, s_copybit);
+ ASSERT(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
+#endif
+ if NFALSEP(bit)
+ return MAKINUM(INUM(j1) | (1L << INUM(index)));
+ else
+ return MAKINUM(INUM(j1) & (~(1L << INUM(index))));
+}
+
SCM scm_lognot(n)
SCM n;
{
@@ -1062,23 +1087,75 @@ SCM scm_ash(n, cnt)
#endif
}
-SCM scm_bitextract(n, start, end)
+SCM scm_bitfield(n, start, end)
SCM n, start, end;
{
- ASSERT(INUMP(start), start, ARG2, s_bitextract);
- ASSERT(INUMP(end), end, ARG3, s_bitextract);
+ ASSERT(INUMP(start), start, ARG2, s_bitfield);
+ ASSERT(INUMP(end), end, ARG3, s_bitfield);
start = INUM(start); end = INUM(end);
- ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitextract);
+ ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitfield);
#ifdef BIGDIG
- if NINUMP(n)
+ if (NINUMP(n) || end >= LONG_BIT - 2)
return
scm_logand(difference(scm_intexpt(MAKINUM(2), MAKINUM(end - start)),
MAKINUM(1L)),
scm_ash(n, MAKINUM(-start)));
#else
- ASSERT(INUMP(n), n, ARG1, s_bitextract);
+ ASSERT(INUMP(n), n, ARG1, s_bitfield);
+ ASSERT(end < LONG_BIT - 2, MAKINUM(end), OUTOFRANGE, s_bitfield);
+#endif
+ return MAKINUM((INUM(n)>>start) & ((1L<<(end - start)) - 1));
+}
+
+SCM scm_bitif(mask, n0, n1)
+ SCM mask, n0, n1;
+{
+#ifdef BIGDIG
+ if (NINUMP(mask) || NINUMP(n0) || NINUMP(n1))
+ return scm_logior(scm_logand(mask, n0),
+ scm_logand(scm_lognot(mask), n1));
+#else
+ ASSERT(INUMP(mask), mask, ARG1, s_bitif);
+ ASSERT(INUMP(n0), n0, ARG2, s_bitif);
+ ASSERT(INUMP(n1), n1, ARG3, s_bitif);
#endif
- return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1));
+ return MAKINUM((INUM(mask) & INUM(n0)) | (~(INUM(mask)) & INUM(n1)));
+}
+
+SCM scm_copybitfield(to, start, rest)
+ SCM to, start, rest;
+{
+ long len;
+ SCM end, from;
+#ifndef RECKLESS
+ if (!(NIMP(rest) && CONSP(rest)))
+ wna: wta(UNDEFINED, (char *)WNA, s_copybitfield);
+#endif
+ end = CAR(rest);
+ rest = CDR(rest);
+ ASRTGO(NIMP(rest) && CONSP(rest), wna);
+ from = CAR(rest);
+ ASRTGO(NULLP(CDR(rest)), wna);
+ ASSERT(INUMP(start) && INUM(start)>=0, start, ARG2, s_copybitfield);
+ len = INUM(end) - INUM(start);
+ ASSERT(INUMP(end), end, ARG3, s_copybitfield);
+ ASSERT(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield);
+#ifdef BIGDIG
+ if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) {
+ SCM mask = difference(scm_intexpt(MAKINUM(2), MAKINUM(len)), MAKINUM(1L));
+ mask = scm_ash(mask, start);
+ return scm_logior(scm_logand(mask, scm_ash(from, start)),
+ scm_logand(scm_lognot(mask), to));
+ }
+#else
+ ASSERT(INUMP(to), to, ARG1, s_copybitfield);
+ ASSERT(INUMP(from), from, ARG4, s_copybitfield);
+ ASSERT(INUM(end) < LONG_BIT - 2, end, OUTOFRANGE, s_copybitfield);
+#endif
+ {
+ long mask = ((1L<<len) - 1)<<INUM(start);
+ return MAKINUM((mask & (INUM(from)<<INUM(start))) | ((~mask) & INUM(to)));
+ }
}
char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
@@ -1496,20 +1573,19 @@ char s_make_vector[] = "make-vector";
SCM make_vector(k, fill)
SCM k, fill;
{
- SCM v;
- register long i;
- register SCM *velts;
- ASSERT(INUMP(k), k, ARG1, s_make_vector);
- if UNBNDP(fill) fill = UNSPECIFIED;
- i = INUM(k);
- NEWCELL(v);
- DEFER_INTS;
- SETCHARS(v, must_malloc(i?(long)(i*sizeof(SCM)):1L, s_vector));
- SETLENGTH(v, i, tc7_vector);
- velts = VELTS(v);
- while(--i >= 0) (velts)[i] = fill;
- ALLOW_INTS;
- return v;
+ SCM v;
+ register long i;
+ register SCM *velts;
+ ASSERT(INUMP(k), k, ARG1, s_make_vector);
+ if UNBNDP(fill) fill = UNSPECIFIED;
+ i = INUM(k);
+ DEFER_INTS;
+ v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, s_vector);
+ SETLENGTH(v, i, tc7_vector);
+ velts = VELTS(v);
+ while(--i >= 0) (velts)[i] = fill;
+ ALLOW_INTS;
+ return v;
}
#ifdef BIGDIG
char s_bignum[] = "bignum";
@@ -1517,15 +1593,21 @@ SCM mkbig(nlen, sign)
sizet nlen;
int sign;
{
- SCM v = nlen;
- if (((v << 16) >> 16) != nlen)
- wta(MAKINUM(v), (char *)NALLOC, s_bignum);
- NEWCELL(v);
- DEFER_INTS;
- SETCHARS(v, must_malloc((long)(nlen*sizeof(BIGDIG)), s_bignum));
- SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
- ALLOW_INTS;
- return v;
+ SCM v = nlen;
+ if (((v << 16) >> 16) != nlen)
+ wta(MAKINUM(v), (char *)NALLOC, s_bignum);
+ DEFER_INTS;
+#ifdef NUM_HP
+ if (nlen*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
+ NEWCELL(v);
+ SETCHARS(v, num_hp_alloc(nlen*sizeof(BIGDIG)));
+ }
+ else
+#endif
+ v = must_malloc_cell((long)(nlen*sizeof(BIGDIG)), s_bignum);
+ SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
+ ALLOW_INTS;
+ return v;
}
SCM big2inum(b, l)
SCM b;
@@ -1546,11 +1628,17 @@ SCM adjbig(b, nlen)
sizet nlen;
{
long nsiz = nlen;
- if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
+ if (((nsiz << 16) >> 16) != nlen)
+ wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig);
DEFER_INTS;
- SETCHARS(b, (BIGDIG *)must_realloc((char *)CHARS(b),
- (long)(NUMDIGS(b)*sizeof(BIGDIG)),
- (long)(nsiz*sizeof(BIGDIG)), s_adjbig));
+#ifdef NUM_HP
+ SETCHARS(b, (BIGDIG *)num_hp_realloc((char *)CHARS(b),
+ (long)NUMDIGS(b)*sizeof(BIGDIG),
+ nsiz*sizeof(BIGDIG), s_adjbig));
+#else
+ must_realloc_cell(b, (long)(NUMDIGS(b)*sizeof(BIGDIG)),
+ (long)(nsiz*sizeof(BIGDIG)), s_adjbig);
+#endif
SETNUMDIGS(b, nsiz, TYP16(b));
ALLOW_INTS;
return b;
@@ -1613,7 +1701,8 @@ int bigcomp(x, y)
{
int xsign = BIGSIGN(x);
int ysign = BIGSIGN(y);
- sizet xlen, ylen;
+ long xlen;
+ sizet ylen;
if (ysign < xsign) return 1;
if (ysign > xsign) return -1;
if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
@@ -1979,7 +2068,9 @@ static iproc rpsubrs[] = {
{0, 0}};
static iproc subr3s[] = {
- {s_bitextract, scm_bitextract},
+ {s_bitfield, scm_bitfield},
+ {s_bitif, scm_bitif},
+ {s_copybit, scm_copybit},
{s_substring, substring},
{s_acons, acons},
{s_st_set, st_set},
@@ -2006,4 +2097,5 @@ void init_subrs()
init_iprocs(lsubrs, tc7_lsubr);
init_iprocs(asubrs, tc7_asubr);
init_iprocs(subr3s, tc7_subr_3);
+ make_subr(s_copybitfield, tc7_lsubr_2, scm_copybitfield);
}