diff options
Diffstat (limited to 'subr.c')
| -rw-r--r-- | subr.c | 76 |
1 files changed, 26 insertions, 50 deletions
@@ -1,18 +1,18 @@ /* 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 * the Free Software Foundation; either version 2, or (at your option) * any later version. - * + * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. - * + * * You should have received a copy of the GNU General Public License * along with this software; see the file COPYING. If not, write to - * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA. * * As a special exception, the Free Software Foundation gives permission * for additional uses of the text contained in its release of GUILE. @@ -36,7 +36,7 @@ * * If you write modifications of your own for GUILE, it is your choice * whether to permit this exception to apply to your modifications. - * If you do not wish that, delete this exception notice. + * If you do not wish that, delete this exception notice. */ /* "subr.c" integer and other Scheme procedures @@ -268,6 +268,13 @@ SCM assoc(x, alist) return BOOL_F; } +extern long tc16_promise; +SCM promisep(x) + SCM x; +{ + return NIMP(x) && (TYP16(x)==tc16_promise) ? BOOL_T : BOOL_F; +} + SCM symbolp(x) SCM x; { @@ -802,7 +809,6 @@ static char s_logand[] = "logand", s_lognot[] = "lognot", s_copybitfield[] = "copy-bit-field", s_ash[] = "ash", s_logcount[] = "logcount", s_intlength[] = "integer-length", - s_intexpt[] = "integer-expt", s_bitfield[] = "bit-field", s_bitif[] = "bitwise-if"; @@ -1042,28 +1048,6 @@ SCM scm_lognot(n) return difference(MAKINUM(-1L), n); } -SCM scm_intexpt(z1, z2) - SCM z1, z2; -{ - SCM acc = MAKINUM(1L); -#ifdef BIGDIG - if (INUM0==z1 || acc==z1) return z1; - else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; -#endif - ASSERT(INUMP(z2), z2, ARG2, s_intexpt); - z2 = INUM(z2); - if (z2 < 0) { - z2 = -z2; - z1 = divide(z1, UNDEFINED); - } - while(1) { - if (0==z2) return acc; - if (1==z2) return product(acc, z1); - if (z2 & 1) acc = product(acc, z1); - z1 = product(z1, z1); - z2 >>= 1; - } -} SCM scm_ash(n, cnt) SCM n, cnt; { @@ -1144,7 +1128,7 @@ SCM scm_copybitfield(to, start, rest) 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)), + return scm_logior(scm_logand(mask, scm_ash(from, start)), scm_logand(scm_lognot(mask), to)); } #else @@ -1576,12 +1560,16 @@ SCM make_vector(k, fill) SCM v; register long i; register SCM *velts; +#ifdef SHORT_SIZET ASSERT(INUMP(k), k, ARG1, s_make_vector); +#else + ASSERT(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector); +#endif 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); + v = must_malloc_cell(i?(long)(i*sizeof(SCM)):1L, + MAKE_LENGTH(i, tc7_vector), s_vector); velts = VELTS(v); while(--i >= 0) (velts)[i] = fill; ALLOW_INTS; @@ -1593,19 +1581,12 @@ SCM mkbig(nlen, sign) sizet nlen; int sign; { - SCM v = nlen; - if (((v << 16) >> 16) != nlen) - wta(MAKINUM(v), (char *)NALLOC, s_bignum); + SCM v; + if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), (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); + v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG), + MAKE_NUMDIGS(nlen, sign?tc16_bigneg:tc16_bigpos), + s_bignum); ALLOW_INTS; return v; } @@ -1631,14 +1612,8 @@ SCM adjbig(b, nlen) if (((nsiz << 16) >> 16) != nlen) wta(MAKINUM(nsiz), (char *)NALLOC, s_adjbig); DEFER_INTS; -#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; @@ -1954,6 +1929,7 @@ SCM divbigbig(x, nx, y, ny, sgn, modes) #endif static iproc cxrs[] = { + {"cr", 0}, {"car", 0}, {"cdr", 0}, {"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0}, {"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0}, @@ -1997,6 +1973,7 @@ static iproc subr1s[] = { {"vector?", vectorp}, {s_ve_length, vector_length}, {"procedure?", procedurep}, + {"promise?", promisep}, {0, 0}}; static char s_acons[] = "acons"; @@ -2015,7 +1992,6 @@ static iproc subr2s[] = { {s_logtest, scm_logtest}, {s_logbitp, scm_logbitp}, {s_ash, scm_ash}, - {s_intexpt, scm_intexpt}, {s_st_ref, st_ref}, {"string<=?", st_leqp}, {"string-ci<=?", stci_leqp}, |