summaryrefslogtreecommitdiffstats
path: root/subr.c
diff options
context:
space:
mode:
authorBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:25 -0800
commit3278b75942bdbe706f7a0fba87729bb1e935b68b (patch)
treedcad4048dfc0b38367047426b2b14501bf5ff257 /subr.c
parentdb04688faa20f3576257c0fe41752ec435beab9a (diff)
downloadscm-3278b75942bdbe706f7a0fba87729bb1e935b68b.tar.gz
scm-3278b75942bdbe706f7a0fba87729bb1e935b68b.zip
Import Upstream version 5d2upstream/5d2
Diffstat (limited to 'subr.c')
-rw-r--r--subr.c76
1 files changed, 26 insertions, 50 deletions
diff --git a/subr.c b/subr.c
index 5612c1a..e55bf17 100644
--- a/subr.c
+++ b/subr.c
@@ -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},