From db04688faa20f3576257c0fe41752ec435beab9a Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5c3 --- subr.c | 168 ++++++++++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 130 insertions(+), 38 deletions(-) (limited to 'subr.c') 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<= 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); } -- cgit v1.2.3