summaryrefslogtreecommitdiffstats
path: root/subr.c
diff options
context:
space:
mode:
Diffstat (limited to 'subr.c')
-rw-r--r--subr.c2009
1 files changed, 2009 insertions, 0 deletions
diff --git a/subr.c b/subr.c
new file mode 100644
index 0000000..4b75e13
--- /dev/null
+++ b/subr.c
@@ -0,0 +1,2009 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996 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.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE. If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way. To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * 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.
+ */
+
+/* "subr.c" integer and other Scheme procedures
+ Author: Aubrey Jaffer */
+
+#include <ctype.h>
+#include "scm.h"
+
+#define s_length (s_st_length+7)
+#define s_append (s_st_append+7)
+
+char s_make_string[] = "make-string";
+char s_list[] = "list";
+
+static char s_setcar[] = "set-car!", s_setcdr[] = "set-cdr!",
+ s_reverse[] = "reverse", s_list_ref[] = "list-ref";
+static char s_memq[] = "memq", s_member[] = "member",
+ s_assq[] = "assq", s_assoc[] = "assoc";
+static char s_symbol2string[] = "symbol->string",
+ s_str2symbol[] = "string->symbol";
+extern char s_inexactp[];
+#define s_exactp (s_inexactp+2)
+static char s_oddp[] = "odd?", s_evenp[] = "even?";
+static char s_abs[] = "abs", s_quotient[] = "quotient",
+ s_remainder[] = "remainder", s_modulo[] = "modulo";
+static char s_gcd[] = "gcd";
+
+static char s_ci_eq[] = "char-ci=?",
+ s_ch_lessp[] = "char<?", s_ch_leqp[] = "char<=?",
+ s_ci_lessp[] = "char-ci<?", s_ci_leqp[] = "char-ci<=?",
+ s_ch_grp[] = "char>?", s_ch_geqp[] = "char>=?",
+ s_ci_grp[] = "char-ci>?", s_ci_geqp[] = "char-ci>=?";
+static char s_ch_alphap[] = "char-alphabetic?",
+ s_ch_nump[] = "char-numeric?",
+ s_ch_whitep[] = "char-whitespace?",
+ s_ch_upperp[] = "char-upper-case?",
+ s_ch_lowerp[] = "char-lower-case?";
+static char s_char2int[] = "char->integer", s_int2char[] = "integer->char",
+ s_ch_upcase[] = "char-upcase", s_ch_downcase[] = "char-downcase";
+
+static char s_st_length[] = "string-length",
+ s_st_ref[] = "string-ref", s_st_set[] = "string-set!";
+static char s_st_equal[] = "string=?", s_stci_equal[] = "string-ci=?",
+ s_st_lessp[] = "string<?", s_stci_lessp[] = "string-ci<?";
+static char s_substring[] = "substring", s_st_append[] = "string-append";
+
+static char s_ve_length[] = "vector-length",
+ s_ve_ref[] = "vector-ref", s_ve_set[] = "vector-set!";
+
+SCM lnot(x)
+ SCM x;
+{
+ return FALSEP(x) ? BOOL_T : BOOL_F;
+}
+SCM booleanp(obj)
+ SCM obj;
+{
+ if (BOOL_F==obj) return BOOL_T;
+ if (BOOL_T==obj) return BOOL_T;
+ return BOOL_F;
+}
+SCM eq(x, y)
+ SCM x, y;
+{
+ if (x==y) return BOOL_T;
+ else return BOOL_F;
+}
+
+SCM consp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return CONSP(x) ? BOOL_T : BOOL_F;
+}
+SCM setcar(pair, value)
+ SCM pair, value;
+{
+ ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
+ CAR(pair) = value;
+ return UNSPECIFIED;
+}
+SCM setcdr(pair, value)
+ SCM pair, value;
+{
+ ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
+ CDR(pair) = value;
+ return UNSPECIFIED;
+}
+SCM nullp(x)
+ SCM x;
+{
+ return NULLP(x) ? BOOL_T : BOOL_F;
+}
+long ilength(sx)
+ SCM sx;
+{
+ register long i = 0;
+ register SCM x = sx;
+ do {
+ if IMP(x) return NULLP(x) ? i : -1;
+ if NCONSP(x) return -2;
+ x = CDR(x);
+ i++;
+ if IMP(x) return NULLP(x) ? i : -1;
+ if NCONSP(x) return -2;
+ x = CDR(x);
+ i++;
+ sx = CDR(sx);
+ }
+ while (x != sx);
+ return -1;
+}
+SCM listp(x)
+ SCM x;
+{
+ if (ilength(x)<0) return BOOL_F;
+ else return BOOL_T;
+}
+SCM list(objs)
+ SCM objs;
+{
+ return objs;
+}
+SCM length(x)
+ SCM x;
+{
+ SCM i = MAKINUM(ilength(x));
+ ASSERT(i >= INUM0, x, ARG1, s_length);
+ return i;
+}
+SCM append(args)
+ SCM args;
+{
+ SCM res = EOL;
+ SCM *lloc = &res, arg;
+ if IMP(args) {
+ ASSERT(NULLP(args), args, ARGn, s_append);
+ return res;
+ }
+ ASSERT(CONSP(args), args, ARGn, s_append);
+ while (1) {
+ arg = CAR(args);
+ args = CDR(args);
+ if IMP(args) {
+ *lloc = arg;
+ ASSERT(NULLP(args), args, ARGn, s_append);
+ return res;
+ }
+ ASSERT(CONSP(args), args, ARGn, s_append);
+ for(;NIMP(arg);arg = CDR(arg)) {
+ ASSERT(CONSP(arg), arg, ARGn, s_append);
+ *lloc = cons(CAR(arg), EOL);
+ lloc = &CDR(*lloc);
+ }
+ ASSERT(NULLP(arg), arg, ARGn, s_append);
+ }
+}
+SCM reverse(lst)
+ SCM lst;
+{
+ SCM res = EOL;
+ SCM p = lst;
+ for(;NIMP(p);p = CDR(p)) {
+ ASSERT(CONSP(p), lst, ARG1, s_reverse);
+ res = cons(CAR(p), res);
+ }
+ ASSERT(NULLP(p), lst, ARG1, s_reverse);
+ return res;
+}
+SCM list_ref(lst, k)
+ SCM lst, k;
+{
+ register long i;
+ ASSERT(INUMP(k), k, ARG2, s_list_ref);
+ i = INUM(k);
+ ASSERT(i >= 0, k, ARG2, s_list_ref);
+ while (i-- > 0) {
+ ASRTGO(NIMP(lst) && CONSP(lst), erout);
+ lst = CDR(lst);
+ }
+erout: ASSERT(NIMP(lst) && CONSP(lst),
+ NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref);
+ return CAR(lst);
+}
+SCM memq(x, lst)
+ SCM x, lst;
+{
+ for(;NIMP(lst);lst = CDR(lst)) {
+ ASSERT(CONSP(lst), lst, ARG2, s_memq);
+ if (CAR(lst)==x) return lst;
+ }
+ ASSERT(NULLP(lst), lst, ARG2, s_memq);
+ return BOOL_F;
+}
+SCM member(x, lst)
+ SCM x, lst;
+{
+ for(;NIMP(lst);lst = CDR(lst)) {
+ ASSERT(CONSP(lst), lst, ARG2, s_member);
+ if NFALSEP(equal(CAR(lst), x)) return lst;
+ }
+ ASSERT(NULLP(lst), lst, ARG2, s_member);
+ return BOOL_F;
+}
+SCM assq(x, alist)
+ SCM x, alist;
+{
+ SCM tmp;
+ for(;NIMP(alist);alist = CDR(alist)) {
+ ASSERT(CONSP(alist), alist, ARG2, s_assq);
+ tmp = CAR(alist);
+ ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
+ if (CAR(tmp)==x) return tmp;
+ }
+ ASSERT(NULLP(alist), alist, ARG2, s_assq);
+ return BOOL_F;
+}
+SCM assoc(x, alist)
+ SCM x, alist;
+{
+ SCM tmp;
+ for(;NIMP(alist);alist = CDR(alist)) {
+ ASSERT(CONSP(alist), alist, ARG2, s_assoc);
+ tmp = CAR(alist);
+ ASSERT(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
+ if NFALSEP(equal(CAR(tmp), x)) return tmp;
+ }
+ ASSERT(NULLP(alist), alist, ARG2, s_assoc);
+ return BOOL_F;
+}
+
+SCM symbolp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return SYMBOLP(x) ? BOOL_T : BOOL_F;
+}
+SCM symbol2string(s)
+ SCM s;
+{
+ ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
+ return makfromstr(CHARS(s), (sizet)LENGTH(s));
+}
+SCM string2symbol(s)
+ SCM s;
+{
+ ASSERT(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol);
+ s = intern(CHARS(s), (sizet)LENGTH(s));
+ return CAR(s);
+}
+
+SCM exactp(x)
+ SCM x;
+{
+ if INUMP(x) return BOOL_T;
+#ifdef BIGDIG
+ if (NIMP(x) && BIGP(x)) return BOOL_T;
+#endif
+ return BOOL_F;
+}
+SCM oddp(n)
+ SCM n;
+{
+#ifdef BIGDIG
+ if NINUMP(n) {
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
+ return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F;
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_oddp);
+#endif
+ return (4 & (int)n) ? BOOL_T : BOOL_F;
+}
+SCM evenp(n)
+ SCM n;
+{
+#ifdef BIGDIG
+ if NINUMP(n) {
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
+ return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T;
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_evenp);
+#endif
+ return (4 & (int)n) ? BOOL_F : BOOL_T;
+}
+SCM absval(x)
+ SCM x;
+{
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_abs);
+ if (TYP16(x)==tc16_bigpos) return x;
+ return copybig(x, 0);
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_abs);
+#endif
+ if (INUM(x) >= 0) return x;
+ x = -INUM(x);
+ if (!POSFIXABLE(x))
+#ifdef BIGDIG
+ return long2big(x);
+#else
+ wta(MAKINUM(-x), (char *)OVFLOW, s_abs);
+#endif
+ return MAKINUM(x);
+}
+SCM lquotient(x, y)
+ SCM x, y;
+{
+ register long z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ long w;
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x) ^ BIGSIGN(y), 2);
+ }
+ z = INUM(y);
+ ASRTGO(z, ov);
+ if (1==z) return x;
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
+ divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z);
+ return normbig(w);
+ }
+# ifndef DIGSTOOBIG
+ w = pseudolong(z);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&w, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 2);
+# else
+ { BIGDIG zdigs[DIGSPERLONG];
+ longdigs(z, zdigs);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
+ BIGSIGN(x) ? (y>0) : (y<0), 2);
+ }
+# endif
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_quotient);
+# endif
+ return INUM0;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_quotient);
+ ASSERT(INUMP(y), y, ARG2, s_quotient);
+#endif
+ if ((z = INUM(y))==0)
+ ov: wta(y, (char *)OVFLOW, s_quotient);
+ z = INUM(x)/z;
+#ifdef BADIVSGNS
+ {
+# if (__TURBOC__==1)
+ long t = ((y<0) ? -INUM(x) : INUM(x))%INUM(y);
+# else
+ long t = INUM(x)%INUM(y);
+# endif
+ if (t==0) ;
+ else if (t < 0)
+ if (x < 0) ;
+ else z--;
+ else if (x < 0) z++;
+ }
+#endif
+ if (!FIXABLE(z))
+#ifdef BIGDIG
+ return long2big(z);
+#else
+ wta(x, (char *)OVFLOW, s_quotient);
+#endif
+ return MAKINUM(z);
+}
+SCM lremainder(x, y)
+ SCM x, y;
+{
+ register long z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(x), 0);
+ }
+ if (!(z = INUM(y))) goto ov;
+ return divbigint(x, z, BIGSIGN(x), 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_remainder);
+# endif
+ return x;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_remainder);
+ ASSERT(INUMP(y), y, ARG2, s_remainder);
+#endif
+ if (!(z = INUM(y)))
+ ov: wta(y, (char *)OVFLOW, s_remainder);
+#if (__TURBOC__==1)
+ if (z < 0) z = -z;
+#endif
+ z = INUM(x)%z;
+#ifdef BADIVSGNS
+ if (!z) ;
+ else if (z < 0)
+ if (x < 0) ;
+ else z += INUM(y);
+ else if (x < 0) z -= INUM(y);
+#endif
+ return MAKINUM(z);
+}
+SCM modulo(x, y)
+ SCM x, y;
+{
+ register long yy, z;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
+ if NINUMP(y) {
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
+ BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0);
+ }
+ if (!(z = INUM(y))) goto ov;
+ return divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_modulo);
+# endif
+ return (BIGSIGN(y) ? (x>0) : (x<0)) ? sum(x, y) : x;
+ }
+#else
+ ASSERT(INUMP(x), x, ARG1, s_modulo);
+ ASSERT(INUMP(y), y, ARG2, s_modulo);
+#endif
+ if (!(yy = INUM(y)))
+ ov: wta(y, (char *)OVFLOW, s_modulo);
+#if (__TURBOC__==1)
+ z = INUM(x);
+ z = ((yy<0) ? -z : z)%yy;
+#else
+ z = INUM(x)%yy;
+#endif
+ return MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z);
+}
+
+SCM lgcd(x, y)
+ SCM x, y;
+{
+ register long u, v, k, t;
+ tailrec:
+ if UNBNDP(y) return UNBNDP(x) ? INUM0 : x;
+#ifdef BIGDIG
+ if NINUMP(x) {
+ big_gcd:
+ ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
+ if BIGSIGN(x) x = copybig(x, 0);
+ newy:
+ if NINUMP(y) {
+ ASSERT(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
+ if BIGSIGN(y) y = copybig(y, 0);
+ switch (bigcomp(x, y)) {
+ case -1:
+ swaprec: t = lremainder(x, y); x = y; y = t; goto tailrec;
+ case 0: return x;
+ case 1: y = lremainder(y, x); goto newy;
+ }
+ /* instead of the switch, we could just return lgcd(y, modulo(x, y)); */
+ }
+ if (INUM0==y) return x; goto swaprec;
+ }
+ if NINUMP(y) { t=x; x=y; y=t; goto big_gcd;}
+#else
+ ASSERT(INUMP(x), x, ARG1, s_gcd);
+ ASSERT(INUMP(y), y, ARG2, s_gcd);
+#endif
+ u = INUM(x);
+ if (u<0) u = -u;
+ v = INUM(y);
+ if (v<0) v = -v;
+ else if (0==v) goto getout;
+ if (0==u) {u = v; goto getout;}
+ for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1);
+ if (1 & (int)u) t = -v;
+ else {
+ t = u;
+b3:
+ t = SRS(t, 1);
+ }
+ if (!(1 & (int)t)) goto b3;
+ if (t>0) u = t;
+ else v = -t;
+ if ((t = u-v)) goto b3;
+ u = u*k;
+getout:
+ if (!POSFIXABLE(u))
+#ifdef BIGDIG
+ return long2big(u);
+#else
+ wta(x, (char *)OVFLOW, s_gcd);
+#endif
+ return MAKINUM(u);
+}
+SCM llcm(n1, n2)
+ SCM n1, n2;
+{
+ SCM d;
+ if UNBNDP(n2) {
+ n2 = MAKINUM(1L);
+ if UNBNDP(n1) return n2;
+ }
+ d = lgcd(n1, n2);
+ if (INUM0==d) return d;
+ return absval(product(n1, lquotient(n2, d)));
+}
+
+/* Emulating 2's complement bignums with sign magnitude arithmetic:
+
+ Logand:
+ X Y Result Method:
+ (len)
+ + + + x (map digit:logand X Y)
+ + - + x (map digit:logand X (lognot (+ -1 Y)))
+ - + + y (map digit:logand (lognot (+ -1 X)) Y)
+ - - - (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
+
+ Logior:
+ X Y Result Method:
+
+ + + + (map digit:logior X Y)
+ + - - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
+ - + - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
+ - - - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
+
+ Logxor:
+ X Y Result Method:
+
+ + + + (map digit:logxor X Y)
+ + - - (+ 1 (map digit:logxor X (+ -1 Y)))
+ - + - (+ 1 (map digit:logxor (+ -1 X) Y))
+ - - + (map digit:logxor (+ -1 X) (+ -1 Y))
+
+ Logtest:
+ X Y Result
+
+ + + (any digit:logand X Y)
+ + - (any digit:logand X (lognot (+ -1 Y)))
+ - + (any digit:logand (lognot (+ -1 X)) Y)
+ - - #t
+
+*/
+
+#ifdef BIGDIG
+
+SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn));
+SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
+
+SCM scm_copy_big_dec(b, sign)
+ SCM b;
+ int sign;
+{
+ long num = -1;
+ sizet nx = NUMDIGS(b);
+ sizet i = 0;
+ SCM ans = mkbig(nx, sign);
+ BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
+ if BIGSIGN(b) do {
+ num += src[i];
+ if (num < 0) {dst[i] = num + BIGRAD; num = -1;}
+ else {dst[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else
+ while (nx--) dst[nx] = src[nx];
+ return ans;
+}
+
+SCM scm_copy_smaller(x, nx, zsgn)
+ BIGDIG *x;
+ sizet nx;
+ int zsgn;
+{
+ long num = -1;
+ sizet i = 0;
+ SCM z = mkbig(nx, zsgn);
+ BIGDIG *zds = BDIGITS(z);
+ if (zsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = x[i]; while (++i < nx);
+ return z;
+}
+
+SCM scm_big_ior(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = scm_copy_big_dec(bigy, xsgn & BIGSIGN(bigy));
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn) {
+ do {
+ num += x[i];
+ if (num < 0) {zds[i] |= num + BIGRAD; num = -1;}
+ else {zds[i] |= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ /* ========= Need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return z;
+ }
+ adjbig(z, 1 + ny); /* OOPS, overflowed into next digit. */
+ BDIGITS(z)[ny] = 1;
+ return z;
+ }
+ else do zds[i] = zds[i] | x[i]; while (++i < nx);
+ return z;
+}
+
+SCM scm_big_xor(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = scm_copy_big_dec(bigy, xsgn ^ BIGSIGN(bigy));
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] ^= num + BIGRAD; num = -1;}
+ else {zds[i] ^= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do {
+ zds[i] = zds[i] ^ x[i];
+ } while (++i < nx);
+
+ if (xsgn ^ BIGSIGN(bigy)) {
+ /* ========= Need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return normbig(z);
+ }
+ }
+ return normbig(z);
+}
+
+SCM scm_big_and(x, nx, xsgn, bigy, zsgn)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+ int zsgn; /* return sign equals either 0 or 0x0100 */
+{
+ long num = -1;
+ sizet i = 0;
+ SCM z;
+ BIGDIG *zds;
+ if (xsgn==zsgn) {
+ z = scm_copy_smaller(x, nx, zsgn);
+ x = BDIGITS(bigy);
+ xsgn = BIGSIGN(bigy);
+ }
+ else z = scm_copy_big_dec(bigy, zsgn);
+ zds = BDIGITS(z);
+
+ if (zsgn) {
+ if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
+ else {zds[i] &= BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = zds[i] & ~x[i]; while (++i < nx);
+ /* ========= need to increment zds now =========== */
+ i = 0; num = 1;
+ while (i < nx) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return normbig(z);
+ }
+ }
+ else if (xsgn) do {
+ num += x[i];
+ if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
+ else {zds[i] &= ~BIGLO(num); num = 0;}
+ } while (++i < nx);
+ else do zds[i] = zds[i] & x[i]; while (++i < nx);
+ return normbig(z);
+}
+
+SCM scm_big_test(x, nx, xsgn, bigy)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn; /* Assumes xsgn equals either 0 or 0x0100 */
+{
+ BIGDIG *y;
+ sizet i = 0;
+ long num = -1;
+ if (BIGSIGN(bigy) & xsgn) return BOOL_T;
+ if (NUMDIGS(bigy) != nx && xsgn) return BOOL_T;
+ y = BDIGITS(bigy);
+ if (xsgn)
+ do {
+ num += x[i];
+ if (num < 0) {
+ if (y[i] & ~(num + BIGRAD)) return BOOL_T;
+ num = -1;
+ }
+ else {
+ if (y[i] & ~BIGLO(num)) return BOOL_T;
+ num = 0;
+ }
+ } while (++i < nx);
+ else if BIGSIGN(bigy)
+ do {
+ num += y[i];
+ if (num < 0) {
+ if (x[i] & ~(num + BIGRAD)) return BOOL_T;
+ num = -1;
+ }
+ else {
+ if (x[i] & ~BIGLO(num)) return BOOL_T;
+ num = 0;
+ }
+ } while (++i < nx);
+ else
+ do if (x[i] & y[i]) return BOOL_T;
+ while (++i < nx);
+ return BOOL_F;
+}
+
+#endif
+
+static char s_logand[] = "logand", s_lognot[] = "lognot",
+ s_logior[] = "logior", s_logxor[] = "logxor",
+ s_logtest[] = "logtest", s_logbitp[] = "logbit?",
+ s_ash[] = "ash", s_logcount[] = "logcount",
+ s_intlength[] = "integer-length",
+ s_intexpt[] = "integer-expt",
+ s_bitextract[] = "bit-extract";
+
+SCM scm_logior(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return INUM0;
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logior);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ if ((!BIGSIGN(x)) && !BIGSIGN(y))
+ return scm_big_ior(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logior);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ if ((!(x < 0)) && !BIGSIGN(y))
+ return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+ return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
+ 0x0100);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ if ((!(x < 0)) && !BIGSIGN(y))
+ return scm_big_ior(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+ return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logior);
+#endif
+ return MAKINUM(INUM(x) | INUM(y));
+}
+
+SCM scm_logand(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return MAKINUM(-1);
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logand);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ if ((BIGSIGN(x)) && BIGSIGN(y))
+ return scm_big_ior(BDIGITS(x), NUMDIGS(x), 0x0100, y);
+ return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logand);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ if ((x < 0) && BIGSIGN(y))
+ return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, 0x0100, y);
+ return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
+ 0);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ if ((x < 0) && BIGSIGN(y))
+ return scm_big_ior(zdigs, DIGSPERLONG, 0x0100, y);
+ return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logand);
+#endif
+ return MAKINUM(INUM(x) & INUM(y));
+}
+
+SCM scm_logxor(x, y)
+ SCM x, y;
+{
+ if UNBNDP(y) {
+ if UNBNDP(x) return INUM0;
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logxor);
+#endif
+ return x;
+ }
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return scm_big_xor(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logxor);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return scm_big_xor((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return scm_big_xor(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logxor);
+#endif
+ return (x ^ y) + INUM0;
+}
+
+SCM scm_logtest(x, y)
+ SCM x, y;
+{
+#ifndef RECKLESS
+ if (!(NUMBERP(x)))
+ badx: wta(x, (char *)ARG1, s_logtest);
+#endif
+#ifdef BIGDIG
+ if NINUMP(x) {
+ SCM t;
+ ASRTGO(NIMP(x) && BIGP(x), badx);
+ if INUMP(y) {t = x; x = y; y = t; goto intbig;}
+ ASRTGO(NIMP(y) && BIGP(y), bady);
+ if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
+ return scm_big_test(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
+ }
+ if NINUMP(y) {
+# ifndef RECKLESS
+ if (!(NIMP(y) && BIGP(y)))
+ bady: wta(y, (char *)ARG2, s_logtest);
+# endif
+ intbig: {
+# ifndef DIGSTOOBIG
+ long z = pseudolong(INUM(x));
+ return scm_big_test((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# else
+ BIGDIG zdigs[DIGSPERLONG];
+ longdigs(INUM(x), zdigs);
+ return scm_big_test(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
+# endif
+ }}
+#else
+ ASRTGO(INUMP(x), badx);
+ ASSERT(INUMP(y), y, ARG2, s_logtest);
+#endif
+ return (INUM(x) & INUM(y)) ? BOOL_T : BOOL_F;
+}
+
+SCM scm_logbitp(index, j1)
+ SCM index, j1;
+{
+ ASSERT(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
+#ifdef BIGDIG
+ if NINUMP(j1) {
+ ASSERT(NIMP(j1) && BIGP(j1), j1, (char *)ARG2, s_logbitp);
+ if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
+ else if BIGSIGN(j1) {
+ long num = -1;
+ sizet i = 0;
+ BIGDIG *x = BDIGITS(j1);
+ sizet nx = INUM(index)/BITSPERDIG;
+ while (!0) {
+ num += x[i];
+ if (nx==i++)
+ return ((1L << (INUM(index)%BITSPERDIG)) & num) ? BOOL_F : BOOL_T;
+ if (num < 0) num = -1;
+ else num = 0;
+ }
+ }
+ else return (BDIGITS(j1)[INUM(index)/BITSPERDIG] &
+ (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F;
+ }
+#else
+ ASSERT(INUMP(j1), j1, (char *)ARG2, s_logbitp);
+#endif
+ return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
+}
+
+SCM scm_lognot(n)
+ SCM 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;
+{
+ SCM res = INUM(n);
+ ASSERT(INUMP(cnt), cnt, ARG2, s_ash);
+#ifdef BIGDIG
+ if(cnt < 0) {
+ res = scm_intexpt(MAKINUM(2), MAKINUM(-INUM(cnt)));
+ if NFALSEP(negativep(n))
+ return sum(MAKINUM(-1L), lquotient(sum(MAKINUM(1L), n), res));
+ else return lquotient(n, res);
+ }
+ else return product(n, scm_intexpt(MAKINUM(2), cnt));
+#else
+ ASSERT(INUMP(n), n, ARG1, s_ash);
+ cnt = INUM(cnt);
+ if (cnt < 0) return MAKINUM(SRS(res, -cnt));
+ res = MAKINUM(res<<cnt);
+ if (INUM(res)>>cnt != INUM(n)) wta(n, (char *)OVFLOW, s_ash);
+ return res;
+#endif
+}
+
+SCM scm_bitextract(n, start, end)
+ SCM n, start, end;
+{
+ ASSERT(INUMP(start), start, ARG2, s_bitextract);
+ ASSERT(INUMP(end), end, ARG3, s_bitextract);
+ start = INUM(start); end = INUM(end);
+ ASSERT(end >= start, MAKINUM(end), OUTOFRANGE, s_bitextract);
+#ifdef BIGDIG
+ if NINUMP(n)
+ 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);
+#endif
+ return MAKINUM((INUM(n)>>start) & ((1L<<(end-start))-1));
+}
+
+char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
+SCM scm_logcount(n)
+ SCM n;
+{
+ register unsigned long c = 0;
+ register long nn;
+#ifdef BIGDIG
+ if NINUMP(n) {
+ sizet i; BIGDIG *ds, d;
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
+ if BIGSIGN(n) return scm_logcount(difference(MAKINUM(-1L), n));
+ ds = BDIGITS(n);
+ for(i = NUMDIGS(n); i--; )
+ for(d = ds[i]; d; d >>= 4) c += logtab[15 & d];
+ return MAKINUM(c);
+ }
+#else
+ ASSERT(INUMP(n), n, ARG1, s_logcount);
+#endif
+ if ((nn = INUM(n)) < 0) nn = -1 - nn;
+ for(; nn; nn >>= 4) c += logtab[15 & nn];
+ return MAKINUM(c);
+}
+
+char ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
+SCM scm_intlength(n)
+ SCM n;
+{
+ register unsigned long c = 0;
+ register long nn;
+ unsigned int l = 4;
+#ifdef BIGDIG
+ if NINUMP(n) {
+ BIGDIG *ds, d;
+ ASSERT(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
+ 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];}
+ return MAKINUM(c - 4 + l);
+ }
+#else
+ ASSERT(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];}
+ return MAKINUM(c - 4 + l);
+}
+
+SCM charp(x)
+ SCM x;
+{
+ return ICHRP(x) ? BOOL_T : BOOL_F;
+}
+SCM char_lessp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_lessp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_lessp);
+ return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_leqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_leqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_leqp);
+ return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_grp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_grp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_grp);
+ return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM char_geqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ch_geqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ch_geqp);
+ return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F;
+}
+SCM chci_eq(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_eq);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_eq);
+ return (upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_lessp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_lessp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_lessp);
+ return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_leqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_leqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_leqp);
+ return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_grp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_grp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_grp);
+ return (upcase[ICHR(x)] > upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM chci_geqp(x, y)
+ SCM x, y;
+{
+ ASSERT(ICHRP(x), x, ARG1, s_ci_geqp);
+ ASSERT(ICHRP(y), y, ARG2, s_ci_geqp);
+ return (upcase[ICHR(x)] >= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
+}
+SCM char_alphap(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_alphap);
+ return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_nump(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_nump);
+ return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_whitep(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_whitep);
+ return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_upperp(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_upperp);
+ return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char_lowerp(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_lowerp);
+ return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F;
+}
+SCM char2int(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_char2int);
+ return MAKINUM(ICHR(chr));
+}
+SCM int2char(n)
+ SCM n;
+{
+ ASSERT(INUMP(n), n, ARG1, s_int2char);
+ ASSERT((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
+ n, OUTOFRANGE, s_int2char);
+ return MAKICHR(INUM(n));
+}
+SCM char_upcase(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_upcase);
+ return MAKICHR(upcase[ICHR(chr)]);
+}
+SCM char_downcase(chr)
+ SCM chr;
+{
+ ASSERT(ICHRP(chr), chr, ARG1, s_ch_downcase);
+ return MAKICHR(downcase[ICHR(chr)]);
+}
+
+SCM stringp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return STRINGP(x) ? BOOL_T : BOOL_F;
+}
+SCM string(chrs)
+ SCM chrs;
+{
+ SCM res;
+ register char *data;
+ long i = ilength(chrs);
+ ASSERT(i >= 0, chrs, ARG1, s_string);
+ res = makstr(i);
+ data = CHARS(res);
+ for(;NNULLP(chrs);chrs = CDR(chrs)) {
+ ASSERT(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
+ *data++ = ICHR(CAR(chrs));
+ }
+ return res;
+}
+SCM make_string(k, chr)
+ SCM k, chr;
+{
+ SCM res;
+ register char *dst;
+ register long i;
+ ASSERT(INUMP(k) && (k >= 0), k, ARG1, s_make_string);
+ i = INUM(k);
+ res = makstr(i);
+ dst = CHARS(res);
+ if (!UNBNDP(chr)) {
+ ASSERT(ICHRP(chr), chr, ARG2, s_make_string);
+ for(i--;i >= 0;i--) dst[i] = ICHR(chr);
+ }
+ return res;
+}
+SCM st_length(str)
+ SCM str;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_length);
+ return MAKINUM(LENGTH(str));
+}
+SCM st_ref(str, k)
+ SCM str, k;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref);
+ ASSERT(INUMP(k), k, ARG2, s_st_ref);
+ ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref);
+ return MAKICHR(CHARS(str)[INUM(k)]);
+}
+SCM st_set(str, k, chr)
+ SCM str, k, chr;
+{
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_set);
+ ASSERT(INUMP(k), k, ARG2, s_st_set);
+ ASSERT(ICHRP(chr), chr, ARG3, s_st_set);
+ ASSERT(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set);
+ CHARS(str)[INUM(k)] = ICHR(chr);
+ return UNSPECIFIED;
+}
+SCM st_equal(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i;
+ register char *c1, *c2;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal);
+ i = LENGTH(s2);
+ if (LENGTH(s1) != i) return BOOL_F;
+ c1 = CHARS(s1);
+ c2 = CHARS(s2);
+ while(0 != i--) if(*c1++ != *c2++) return BOOL_F;
+ return BOOL_T;
+}
+SCM stci_equal(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i;
+ register unsigned char *c1, *c2;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal);
+ i = LENGTH(s2);
+ if (LENGTH(s1) != i) return BOOL_F;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ while(0 != i--) if(upcase[*c1++] != upcase[*c2++]) return BOOL_F;
+ return BOOL_T;
+}
+SCM st_lessp(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i, len;
+ register unsigned char *c1, *c2;
+ register int c;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp);
+ len = LENGTH(s1);
+ i = LENGTH(s2);
+ if (len>i) i = len;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ for(i = 0;i<len;i++) {
+ c = (*c1++ - *c2++);
+ if (c>0) return BOOL_F;
+ if (c<0) return BOOL_T;
+ }
+ return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
+}
+SCM st_leqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(st_lessp(s2, s1));
+}
+SCM st_grp(s1, s2)
+ SCM s1, s2;
+{
+ return st_lessp(s2, s1);
+}
+SCM st_geqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(st_lessp(s1, s2));
+}
+SCM stci_lessp(s1, s2)
+ SCM s1, s2;
+{
+ register sizet i, len;
+ register unsigned char *c1, *c2;
+ register int c;
+ ASSERT(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp);
+ ASSERT(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp);
+ len = LENGTH(s1);
+ i = LENGTH(s2);
+ if (len>i) i=len;
+ c1 = UCHARS(s1);
+ c2 = UCHARS(s2);
+ for(i = 0;i<len;i++) {
+ c = (upcase[*c1++] - upcase[*c2++]);
+ if (c>0) return BOOL_F;
+ if (c<0) return BOOL_T;
+ }
+ return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
+}
+SCM stci_leqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(stci_lessp(s2, s1));
+}
+SCM stci_grp(s1, s2)
+ SCM s1, s2;
+{
+ return stci_lessp(s2, s1);
+}
+SCM stci_geqp(s1, s2)
+ SCM s1, s2;
+{
+ return BOOL_NOT(stci_lessp(s1, s2));
+}
+SCM substring(str, start, end)
+ SCM str, start, end;
+{
+ long l;
+ ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_substring);
+ ASSERT(INUMP(start), start, ARG2, s_substring);
+ ASSERT(INUMP(end), end, ARG3, s_substring);
+ ASSERT(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring);
+ ASSERT(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring);
+ l = INUM(end)-INUM(start);
+ ASSERT(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring);
+ return makfromstr(&CHARS(str)[INUM(start)], (sizet)l);
+}
+SCM st_append(args)
+ SCM args;
+{
+ SCM res;
+ register long i = 0;
+ register SCM l, s;
+ register char *data;
+ for(l = args;NIMP(l);) {
+ ASSERT(CONSP(l), l, ARGn, s_st_append);
+ s = CAR(l);
+ ASSERT(NIMP(s) && STRINGP(s), s, ARGn, s_st_append);
+ i += LENGTH(s);
+ l = CDR(l);
+ }
+ ASSERT(NULLP(l), args, ARGn, s_st_append);
+ res = makstr(i);
+ data = CHARS(res);
+ for(l = args;NIMP(l);l = CDR(l)) {
+ s = CAR(l);
+ for(i = 0;i<LENGTH(s);i++) *data++ = CHARS(s)[i];
+ }
+ return res;
+}
+
+SCM vectorp(x)
+ SCM x;
+{
+ if IMP(x) return BOOL_F;
+ return VECTORP(x) ? BOOL_T : BOOL_F;
+}
+SCM vector_length(v)
+ SCM v;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
+ return MAKINUM(LENGTH(v));
+}
+SCM vector(l)
+ SCM l;
+{
+ SCM res;
+ register SCM *data;
+ long i = ilength(l);
+ ASSERT(i >= 0, l, ARG1, s_vector);
+ res = make_vector(MAKINUM(i), UNSPECIFIED);
+ data = VELTS(res);
+ for(;NIMP(l);l = CDR(l)) *data++ = CAR(l);
+ return res;
+}
+SCM vector_ref(v, k)
+ SCM v, k;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref);
+ ASSERT(INUMP(k), k, ARG2, s_ve_ref);
+ ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref);
+ return VELTS(v)[((long) INUM(k))];
+}
+SCM vector_set(v, k, obj)
+ SCM v, k, obj;
+{
+ ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set);
+ ASSERT(INUMP(k), k, ARG2, s_ve_set);
+ ASSERT((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set);
+ VELTS(v)[((long) INUM(k))] = obj;
+ return UNSPECIFIED;
+}
+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;
+}
+#ifdef BIGDIG
+char s_bignum[] = "bignum";
+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 big2inum(b, l)
+ SCM b;
+ sizet l;
+{
+ unsigned long num = 0;
+ BIGDIG *tmp = BDIGITS(b);
+ while (l--) num = BIGUP(num) + tmp[l];
+ if (TYP16(b)==tc16_bigpos) {
+ if POSFIXABLE(num) return MAKINUM(num);
+ }
+ else if UNEGFIXABLE(num) return MAKINUM(-num);
+ return b;
+}
+char s_adjbig[] = "adjbig";
+SCM adjbig(b, nlen)
+ SCM b;
+ sizet nlen;
+{
+ long nsiz = nlen;
+ 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));
+ SETNUMDIGS(b, nsiz, TYP16(b));
+ ALLOW_INTS;
+ return b;
+}
+SCM normbig(b)
+ SCM b;
+{
+# ifndef _UNICOS
+ sizet nlen = NUMDIGS(b);
+# else
+ int nlen = NUMDIGS(b); /* unsigned nlen breaks on Cray when nlen => 0 */
+# endif
+ BIGDIG *zds = BDIGITS(b);
+ while (nlen-- && !zds[nlen]); nlen++;
+ if (nlen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
+ if INUMP(b = big2inum(b, (sizet)nlen)) return b;
+ if (NUMDIGS(b)==nlen) return b;
+ return adjbig(b, (sizet)nlen);
+}
+SCM copybig(b, sign)
+ SCM b;
+ int sign;
+{
+ sizet i = NUMDIGS(b);
+ SCM ans = mkbig(i, sign);
+ BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
+ while (i--) dst[i] = src[i];
+ return ans;
+}
+SCM long2big(n)
+ long n;
+{
+ sizet i = 0;
+ BIGDIG *digits;
+ SCM ans = mkbig(DIGSPERLONG, n<0);
+ digits = BDIGITS(ans);
+ if (n < 0) n = -n;
+ while (i < DIGSPERLONG) {
+ digits[i++] = BIGLO(n);
+ n = BIGDN((unsigned long)n);
+ }
+ return ans;
+}
+SCM ulong2big(n)
+ unsigned long n;
+{
+ sizet i = 0;
+ BIGDIG *digits;
+ SCM ans = mkbig(DIGSPERLONG, 0);
+ digits = BDIGITS(ans);
+ while (i < DIGSPERLONG) {
+ digits[i++] = BIGLO(n);
+ n = BIGDN(n);
+ }
+ return ans;
+}
+
+int bigcomp(x, y)
+ SCM x, y;
+{
+ int xsign = BIGSIGN(x);
+ int ysign = BIGSIGN(y);
+ sizet xlen, ylen;
+ if (ysign < xsign) return 1;
+ if (ysign > xsign) return -1;
+ if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
+ if (ylen < xlen) return (xsign) ? 1 : -1;
+ while(xlen-- && (BDIGITS(y)[xlen]==BDIGITS(x)[xlen]));
+ if (-1==xlen) return 0;
+ return (BDIGITS(y)[xlen] > BDIGITS(x)[xlen]) ?
+ (xsign ? -1 : 1) : (xsign ? 1 : -1);
+}
+
+# ifndef DIGSTOOBIG
+long pseudolong(x)
+ long x;
+{
+ union {
+ long l;
+ BIGDIG bd[DIGSPERLONG];
+ } p;
+ sizet i = 0;
+ if (x < 0) x = -x;
+ while (i < DIGSPERLONG) {p.bd[i++] = BIGLO(x); x = BIGDN(x);}
+/* p.bd[0] = BIGLO(x); p.bd[1] = BIGDN(x); */
+ return p.l;
+}
+# else
+void longdigs(x, digs)
+ long x;
+ BIGDIG digs[DIGSPERLONG];
+{
+ sizet i = 0;
+ if (x < 0) x = -x;
+ while (i < DIGSPERLONG) {digs[i++] = BIGLO(x); x = BIGDN(x);}
+}
+# endif
+
+SCM addbig(x, nx, xsgn, bigy, sgny)
+ BIGDIG *x;
+ SCM bigy;
+ sizet nx; /* Assumes nx <= NUMDIGS(bigy) */
+ int xsgn, sgny; /* Assumes xsgn and sgny equal either 0 or 0x0100 */
+{
+ long num = 0;
+ sizet i = 0, ny = NUMDIGS(bigy);
+ SCM z = copybig(bigy, BIGSIGN(bigy) ^ sgny);
+ BIGDIG *zds = BDIGITS(z);
+ if (xsgn ^ BIGSIGN(z)) {
+ do {
+ num += (long) zds[i] - x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = BIGLO(num); num = 0;}
+ } while (++i < nx);
+ if (num && nx==ny) {
+ num = 1; i = 0;
+ CAR(z) ^= 0x0100;
+ do {
+ num += (BIGRAD-1) - zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ } while (i < ny);
+ }
+ else while (i < ny) {
+ num += zds[i];
+ if (num < 0) {zds[i++] = num + BIGRAD; num = -1;}
+ else {zds[i++] = BIGLO(num); num = 0;}
+ }
+ } else {
+ do {
+ num += (long) zds[i] + x[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ } while (i < nx);
+ if (!num) return z;
+ while (i < ny) {
+ num += zds[i];
+ zds[i++] = BIGLO(num);
+ num = BIGDN(num);
+ if (!num) return z;
+ }
+ if (num) {z = adjbig(z, ny+1); BDIGITS(z)[ny] = num; return z;}
+ }
+ return normbig(z);
+}
+
+SCM mulbig(x, nx, y, ny, sgn)
+ BIGDIG *x, *y;
+ sizet nx, ny;
+ int sgn;
+{
+ sizet i = 0, j = nx + ny;
+ unsigned long n = 0;
+ SCM z = mkbig(j, sgn);
+ BIGDIG *zds = BDIGITS(z);
+ while (j--) zds[j] = 0;
+ do {
+ j = 0;
+ if (x[i]) {
+ do {
+ n += zds[i + j] + ((unsigned long) x[i] * y[j]);
+ zds[i + j++] = BIGLO(n);
+ n = BIGDN(n);
+ } while (j < ny);
+ if (n) {zds[i + j] = n; n = 0;}
+ }
+ } while (++i < nx);
+ return normbig(z);
+}
+unsigned int divbigdig(ds, h, div)
+ BIGDIG *ds;
+ sizet h;
+ BIGDIG div;
+{
+ register unsigned long t2 = 0;
+ while(h--) {
+ t2 = BIGUP(t2) + ds[h];
+ ds[h] = t2 / div;
+ t2 %= div;
+ }
+ return t2;
+}
+SCM divbigint(x, z, sgn, mode)
+ SCM x;
+ long z;
+ int sgn, mode;
+{
+ if (z < 0) z = -z;
+ if (z < BIGRAD) {
+ register unsigned long t2 = 0;
+ register BIGDIG *ds = BDIGITS(x);
+ sizet nd = NUMDIGS(x);
+ while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z;
+ if (mode && t2) t2 = z - t2;
+ return MAKINUM(sgn ? -t2 : t2);
+ }
+ {
+# ifndef DIGSTOOBIG
+ unsigned long t2 = pseudolong(z);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&t2,
+ DIGSPERLONG, sgn, mode);
+# else
+ BIGDIG t2[DIGSPERLONG];
+ longdigs(z, t2);
+ return divbigbig(BDIGITS(x), NUMDIGS(x), t2, DIGSPERLONG, sgn, mode);
+# endif
+ }
+}
+SCM divbigbig(x, nx, y, ny, sgn, modes)
+ BIGDIG *x, *y;
+ sizet nx, ny;
+ int sgn, modes;
+ /* modes description
+ 0 remainder
+ 1 modulo
+ 2 quotient
+ 3 quotient but returns 0 if division is not exact. */
+{
+ sizet i = 0, j = 0;
+ long num = 0;
+ unsigned long t2 = 0;
+ SCM z, newy;
+ BIGDIG d = 0, qhat, *zds, *yds;
+ /* algorithm requires nx >= ny */
+ if (nx < ny)
+ switch (modes) {
+ case 0: /* remainder -- just return x */
+ z = mkbig(nx, sgn); zds = BDIGITS(z);
+ do {zds[i] = x[i];} while (++i < nx);
+ return z;
+ case 1: /* modulo -- return y-x */
+ z = mkbig(ny, sgn); zds = BDIGITS(z);
+ do {
+ num += (long) y[i] - x[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = num; num = 0;}
+ } while (++i < nx);
+ while (i < ny) {
+ num += y[i];
+ if (num < 0) {zds[i++] = num + BIGRAD; num = -1;}
+ else {zds[i++] = num; num = 0;}
+ }
+ goto doadj;
+ case 2: return INUM0; /* quotient is zero */
+ case 3: return 0; /* the division is not exact */
+ }
+
+ z = mkbig(nx==ny ? nx+2 : nx+1, sgn); zds = BDIGITS(z);
+ if (nx==ny) zds[nx+1] = 0;
+ while(!y[ny-1]) ny--; /* in case y came in as a psuedolong */
+ if (y[ny-1] < (BIGRAD>>1)) { /* normalize operands */
+ d = BIGRAD/(y[ny-1]+1);
+ newy = mkbig(ny, 0); yds = BDIGITS(newy);
+ while(j < ny)
+ {t2 += (unsigned long) y[j]*d; yds[j++] = BIGLO(t2); t2 = BIGDN(t2);}
+ y = yds; j = 0; t2 = 0;
+ while(j < nx)
+ {t2 += (unsigned long) x[j]*d; zds[j++] = BIGLO(t2); t2 = BIGDN(t2);}
+ zds[j] = t2;
+ }
+ else {zds[j = nx] = 0; while (j--) zds[j] = x[j];}
+ j = nx==ny ? nx+1 : nx; /* dividend needs more digits than divisor */
+ do { /* loop over digits of quotient */
+ if (zds[j]==y[ny-1]) qhat = BIGRAD-1;
+ else qhat = (BIGUP(zds[j]) + zds[j-1])/y[ny-1];
+ if (!qhat) continue;
+ i = 0; num = 0; t2 = 0;
+ do { /* multiply and subtract */
+ t2 += (unsigned long) y[i] * qhat;
+ num += zds[j - ny + i] - BIGLO(t2);
+ if (num < 0) {zds[j - ny + i] = num + BIGRAD; num = -1;}
+ else {zds[j - ny + i] = num; num = 0;}
+ t2 = BIGDN(t2);
+ } while (++i < ny);
+ num += zds[j - ny + i] - t2; /* borrow from high digit; don't update */
+ while (num) { /* "add back" required */
+ i = 0; num = 0; qhat--;
+ do {
+ num += (long) zds[j - ny + i] + y[i];
+ zds[j - ny + i] = BIGLO(num);
+ num = BIGDN(num);
+ } while (++i < ny);
+ num--;
+ }
+ if (modes & 2) zds[j] = qhat;
+ } while (--j >= ny);
+ switch (modes) {
+ case 3: /* check that remainder==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];
+ ny = i;
+ break;
+ case 1: /* subtract for modulo */
+ i = 0; num = 0; j = 0;
+ do {num += y[i] - zds[i];
+ j = j | zds[i];
+ if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
+ else {zds[i] = num; num = 0;}
+ } while (++i < ny);
+ if (!j) return INUM0;
+ case 0: /* just normalize remainder */
+ if (d) divbigdig(zds, ny, d);
+ }
+ doadj:
+ 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);
+}
+#endif
+
+static iproc cxrs[] = {
+ {"car", 0}, {"cdr", 0},
+ {"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0},
+ {"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0},
+ {"cdaar", 0}, {"cdadr", 0}, {"cddar", 0}, {"cdddr", 0},
+ {"caaaar", 0}, {"caaadr", 0}, {"caadar", 0}, {"caaddr", 0},
+ {"cadaar", 0}, {"cadadr", 0}, {"caddar", 0}, {"cadddr", 0},
+ {"cdaaar", 0}, {"cdaadr", 0}, {"cdadar", 0}, {"cdaddr", 0},
+ {"cddaar", 0}, {"cddadr", 0}, {"cdddar", 0}, {"cddddr", 0},
+ {0, 0}};
+
+static iproc subr1s[] = {
+ {"not", lnot},
+ {"boolean?", booleanp},
+ {"pair?", consp},
+ {"null?", nullp},
+ {"list?", listp},
+ {s_length, length},
+ {s_reverse, reverse},
+ {"symbol?", symbolp},
+ {s_symbol2string, symbol2string},
+ {s_str2symbol, string2symbol},
+ {s_exactp, exactp},
+ {s_oddp, oddp},
+ {s_evenp, evenp},
+ {s_abs, absval},
+ {s_lognot, scm_lognot},
+ {s_logcount, scm_logcount},
+ {s_intlength, scm_intlength},
+ {"char?", charp},
+ {s_ch_alphap, char_alphap},
+ {s_ch_nump, char_nump},
+ {s_ch_whitep, char_whitep},
+ {s_ch_upperp, char_upperp},
+ {s_ch_lowerp, char_lowerp},
+ {s_char2int, char2int},
+ {s_int2char, int2char},
+ {s_ch_upcase, char_upcase},
+ {s_ch_downcase, char_downcase},
+ {"string?", stringp},
+ {s_st_length, st_length},
+ {"vector?", vectorp},
+ {s_ve_length, vector_length},
+ {"procedure?", procedurep},
+ {0, 0}};
+
+static char s_acons[] = "acons";
+static iproc subr2s[] = {
+ {&s_acons[1], cons},
+ {s_setcar, setcar},
+ {s_setcdr, setcdr},
+ {s_list_ref, list_ref},
+ {s_memq, memq},
+ {s_member, member},
+ {s_assq, assq},
+ {s_assoc, assoc},
+ {s_quotient, lquotient},
+ {s_remainder, lremainder},
+ {s_modulo, modulo},
+ {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},
+ {s_ve_ref, vector_ref},
+ {0, 0}};
+
+static iproc lsubrs[] = {
+ {s_list, list},
+ {s_append, append},
+ {s_string, string},
+ {s_st_append, st_append},
+ {s_vector, vector},
+ {0, 0}};
+
+static iproc subr2os[] = {
+ {s_make_string, make_string},
+ {s_make_vector, make_vector},
+ {0, 0}};
+
+static iproc asubrs[] = {
+ {s_gcd, lgcd},
+ {"lcm", llcm},
+ {s_logand, scm_logand},
+ {s_logior, scm_logior},
+ {s_logxor, scm_logxor},
+ {0, 0}};
+
+static iproc rpsubrs[] = {
+ {"eq?", eq},
+ {"equal?", equal},
+ {"char=?", eq},
+ {s_ch_lessp, char_lessp},
+ {s_ci_eq, chci_eq},
+ {s_ci_lessp, chci_lessp},
+ {s_ch_leqp, char_leqp},
+ {s_ci_leqp, chci_leqp},
+ {s_ch_grp, char_grp},
+ {s_ci_grp, chci_grp},
+ {s_ch_geqp, char_geqp},
+ {s_ci_geqp, chci_geqp},
+
+ {s_st_equal, st_equal},
+ {s_stci_equal, stci_equal},
+ {s_st_lessp, st_lessp},
+ {s_stci_lessp, stci_lessp},
+ {"string>?", st_grp},
+ {"string-ci>?", stci_grp},
+ {"string>=?", st_geqp},
+ {"string-ci>=?", stci_geqp},
+ {0, 0}};
+
+static iproc subr3s[] = {
+ {s_bitextract, scm_bitextract},
+ {s_substring, substring},
+ {s_acons, acons},
+ {s_st_set, st_set},
+ {s_ve_set, vector_set},
+ {0, 0}};
+
+void init_iprocs(subra, type)
+ iproc *subra;
+ int type;
+{
+ for(;subra->string; subra++)
+ make_subr(subra->string,
+ type,
+ subra->cproc);
+}
+
+void init_subrs()
+{
+ init_iprocs(cxrs, tc7_cxr);
+ init_iprocs(subr1s, tc7_subr_1);
+ init_iprocs(subr2s, tc7_subr_2);
+ init_iprocs(subr2os, tc7_subr_2o);
+ init_iprocs(rpsubrs, tc7_rpsubr);
+ init_iprocs(lsubrs, tc7_lsubr);
+ init_iprocs(asubrs, tc7_asubr);
+ init_iprocs(subr3s, tc7_subr_3);
+}
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-22 15:13:19 +0000