"Fossies" - the Fresh Open Source Software Archive

Member "scm/subr.c" (22 Oct 2017, 60745 Bytes) of package /linux/privat/scm-5f3.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "subr.c" see the Fossies "Dox" file reference documentation and the latest Fossies "Diffs" side-by-side code changes report: 5f2_vs_5f3.

    1 /* "subr.c" integer and other Scheme procedures
    2  * Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2013 Free Software Foundation, Inc.
    3  *
    4  * This program is free software: you can redistribute it and/or modify
    5  * it under the terms of the GNU Lesser General Public License as
    6  * published by the Free Software Foundation, either version 3 of the
    7  * License, or (at your option) any later version.
    8  *
    9  * This program is distributed in the hope that it will be useful, but
   10  * WITHOUT ANY WARRANTY; without even the implied warranty of
   11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
   12  * Lesser General Public License for more details.
   13  *
   14  * You should have received a copy of the GNU Lesser General Public
   15  * License along with this program.  If not, see
   16  * <http://www.gnu.org/licenses/>.
   17  */
   18 
   19 /* Author: Aubrey Jaffer */
   20 
   21 #include <ctype.h>
   22 #include "scm.h"
   23 
   24 #define s_length (s_st_length+7)
   25 #define s_append (s_st_append+7)
   26 
   27 char    s_make_string[] = "make-string";
   28 char    s_list[] = "list";
   29 
   30 static char s_setcar[] = "set-car!", s_setcdr[] = "set-cdr!",
   31     s_reverse[] = "reverse", s_list_ref[] = "list-ref";
   32 static char s_memq[] = "memq", s_member[] = "member",
   33     s_assq[] = "assq", s_assoc[] = "assoc";
   34 static char s_symbol2string[] = "symbol->string",
   35     s_str2symbol[] = "string->symbol";
   36 extern char s_inexactp[];
   37 #define s_exactp (s_inexactp+2)
   38 static char s_oddp[] = "odd?", s_evenp[] = "even?";
   39 static char s_rquotient[] = "round-quotient",
   40     s_remainder[] = "remainder", s_modulo[] = "modulo";
   41 static char s_gcd[] = "gcd";
   42 #define s_quotient (s_rquotient+6)
   43 
   44 static char s_ci_eq[] = "char-ci=?",
   45     s_ch_lessp[] = "char<?", s_ch_leqp[] = "char<=?",
   46     s_ci_lessp[] = "char-ci<?", s_ci_leqp[] = "char-ci<=?",
   47     s_ch_grp[] = "char>?", s_ch_geqp[] = "char>=?",
   48     s_ci_grp[] = "char-ci>?", s_ci_geqp[] = "char-ci>=?";
   49 static char s_ch_alphap[] = "char-alphabetic?",
   50     s_ch_nump[] = "char-numeric?",
   51     s_ch_whitep[] = "char-whitespace?",
   52     s_ch_upperp[] = "char-upper-case?",
   53     s_ch_lowerp[] = "char-lower-case?";
   54 static char s_char2int[] = "char->integer", s_int2char[] = "integer->char",
   55     s_ch_upcase[] = "char-upcase", s_ch_downcase[] = "char-downcase";
   56 
   57 static char s_st_length[] = "string-length",
   58     s_st_ref[] = "string-ref", s_st_set[] = "string-set!";
   59 static char s_st_equal[] = "string=?", s_stci_equal[] = "string-ci=?",
   60     s_st_lessp[] = "string<?", s_stci_lessp[] = "string-ci<?";
   61 static char s_substring[] = "substring", s_st_append[] = "string-append";
   62 
   63 static char s_ve_length[] = "vector-length",
   64     s_ve_ref[] = "vector-ref", s_ve_set[] = "vector-set!";
   65 
   66 SCM lnot(x)
   67      SCM x;
   68 {
   69     return FALSEP(x) ? BOOL_T : BOOL_F;
   70 }
   71 SCM booleanp(obj)
   72      SCM obj;
   73 {
   74     if (BOOL_F==obj) return BOOL_T;
   75     if (BOOL_T==obj) return BOOL_T;
   76     return BOOL_F;
   77 }
   78 SCM eq(x, y)
   79      SCM x, y;
   80 {
   81     if (x==y) return BOOL_T;
   82     else return BOOL_F;
   83 }
   84 
   85 SCM consp(x)
   86      SCM x;
   87 {
   88     if (IMP(x)) return BOOL_F;
   89     return CONSP(x) ? BOOL_T : BOOL_F;
   90 }
   91 SCM setcar(pair, value)
   92      SCM pair, value;
   93 {
   94     ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
   95     CAR(pair) = value;
   96     return UNSPECIFIED;
   97 }
   98 SCM setcdr(pair, value)
   99      SCM pair, value;
  100 {
  101     ASRTER(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
  102     CDR(pair) = value;
  103     return UNSPECIFIED;
  104 }
  105 SCM nullp(x)
  106      SCM x;
  107 {
  108     return NULLP(x) ? BOOL_T : BOOL_F;
  109 }
  110 long ilength(sx)
  111      SCM sx;
  112 {
  113     register long i = 0;
  114     register SCM x = sx;
  115     do {
  116         if (IMP(x)) return NULLP(x) ? i : -1;
  117         if (NCONSP(x)) return -2;
  118         x = CDR(x);
  119         i++;
  120         if (IMP(x)) return NULLP(x) ? i : -1;
  121         if (NCONSP(x)) return -2;
  122         x = CDR(x);
  123         i++;
  124         sx = CDR(sx);
  125     }
  126     while (x != sx);
  127     return -1;
  128 }
  129 SCM listp(x)
  130      SCM x;
  131 {
  132     if (ilength(x)<0) return BOOL_F;
  133     else return BOOL_T;
  134 }
  135 SCM list(objs)
  136      SCM objs;
  137 {
  138     return objs;
  139 }
  140 SCM length(x)
  141      SCM x;
  142 {
  143     SCM i = MAKINUM(ilength(x));
  144     ASRTER(i >= INUM0, x, ARG1, s_length);
  145     return i;
  146 }
  147 SCM append(args)
  148      SCM args;
  149 {
  150     SCM res = EOL;
  151     SCM *lloc = &res, arg;
  152     if (IMP(args)) {
  153         ASRTER(NULLP(args), args, ARGn, s_append);
  154         return res;
  155         }
  156     ASRTER(CONSP(args), args, ARGn, s_append);
  157     while (1) {
  158         arg = CAR(args);
  159         args = CDR(args);
  160         if (IMP(args)) {
  161             *lloc = arg;
  162             ASRTER(NULLP(args), args, ARGn, s_append);
  163             return res;
  164         }
  165         ASRTER(CONSP(args), args, ARGn, s_append);
  166         for (;NIMP(arg);arg = CDR(arg)) {
  167             ASRTER(CONSP(arg), arg, ARGn, s_append);
  168             *lloc = cons(CAR(arg), EOL);
  169             lloc = &CDR(*lloc);
  170         }
  171         ASRTER(NULLP(arg), arg, ARGn, s_append);
  172     }
  173 }
  174 SCM reverse(lst)
  175      SCM lst;
  176 {
  177     SCM res = EOL;
  178     SCM p = lst;
  179     for (;NIMP(p);p = CDR(p)) {
  180         ASRTER(CONSP(p), lst, ARG1, s_reverse);
  181         res = cons(CAR(p), res);
  182     }
  183     ASRTER(NULLP(p), lst, ARG1, s_reverse);
  184     return res;
  185 }
  186 SCM list_ref(lst, k)
  187      SCM lst, k;
  188 {
  189     register long i;
  190     ASRTER(INUMP(k), k, ARG2, s_list_ref);
  191     i = INUM(k);
  192     ASRTER(i >= 0, k, ARG2, s_list_ref);
  193     while (i-- > 0) {
  194         ASRTGO(NIMP(lst) && CONSP(lst), erout);
  195         lst = CDR(lst);
  196     }
  197 erout:  ASRTER(NIMP(lst) && CONSP(lst),
  198            NULLP(lst)?k:lst, NULLP(lst)?OUTOFRANGE:ARG1, s_list_ref);
  199     return CAR(lst);
  200 }
  201 SCM memq(x, lst)
  202      SCM x, lst;
  203 {
  204     for (;NIMP(lst);lst = CDR(lst)) {
  205         ASRTER(CONSP(lst), lst, ARG2, s_memq);
  206         if (CAR(lst)==x) return lst;
  207     }
  208     ASRTER(NULLP(lst), lst, ARG2, s_memq);
  209     return BOOL_F;
  210 }
  211 SCM member(x, lst)
  212      SCM x, lst;
  213 {
  214     for (;NIMP(lst);lst = CDR(lst)) {
  215         ASRTER(CONSP(lst), lst, ARG2, s_member);
  216         if (NFALSEP(equal(CAR(lst), x))) return lst;
  217     }
  218     ASRTER(NULLP(lst), lst, ARG2, s_member);
  219     return BOOL_F;
  220 }
  221 SCM assq(x, alist)
  222      SCM x, alist;
  223 {
  224     SCM tmp;
  225     for (;NIMP(alist);alist = CDR(alist)) {
  226         ASRTER(CONSP(alist), alist, ARG2, s_assq);
  227         tmp = CAR(alist);
  228         ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assq);
  229         if (CAR(tmp)==x) return tmp;
  230     }
  231     ASRTER(NULLP(alist), alist, ARG2, s_assq);
  232     return BOOL_F;
  233 }
  234 SCM assoc(x, alist)
  235      SCM x, alist;
  236 {
  237     SCM tmp;
  238     for (;NIMP(alist);alist = CDR(alist)) {
  239         ASRTER(CONSP(alist), alist, ARG2, s_assoc);
  240         tmp = CAR(alist);
  241         ASRTER(NIMP(tmp) && CONSP(tmp), alist, ARG2, s_assoc);
  242         if (NFALSEP(equal(CAR(tmp), x))) return tmp;
  243     }
  244     ASRTER(NULLP(alist), alist, ARG2, s_assoc);
  245     return BOOL_F;
  246 }
  247 
  248 extern long tc16_promise;
  249 SCM promisep(x)
  250      SCM x;
  251 {
  252        return NIMP(x) && (TYP16(x)==tc16_promise) ? BOOL_T : BOOL_F;
  253 }
  254 
  255 SCM symbolp(x)
  256      SCM x;
  257 {
  258     if (IMP(x)) return BOOL_F;
  259     return SYMBOLP(x) ? BOOL_T : BOOL_F;
  260 }
  261 SCM symbol2string(s)
  262      SCM s;
  263 {
  264     ASRTER(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
  265     return makfromstr(CHARS(s), (sizet)LENGTH(s));
  266 }
  267 SCM string2symbol(s)
  268      SCM s;
  269 {
  270     ASRTER(NIMP(s) && STRINGP(s), s, ARG1, s_str2symbol);
  271     s = intern(CHARS(s), (sizet)LENGTH(s));
  272     return CAR(s);
  273 }
  274 
  275 SCM exactp(x)
  276      SCM x;
  277 {
  278     if (INUMP(x)) return BOOL_T;
  279 #ifdef BIGDIG
  280     if (NIMP(x) && BIGP(x)) return BOOL_T;
  281 #endif
  282     return BOOL_F;
  283 }
  284 SCM oddp(n)
  285      SCM n;
  286 {
  287 #ifdef BIGDIG
  288     if (NINUMP(n)) {
  289       ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_oddp);
  290       return (1 & BDIGITS(n)[0]) ? BOOL_T : BOOL_F;
  291     }
  292 #else
  293     ASRTER(INUMP(n), n, ARG1, s_oddp);
  294 #endif
  295     return (4 & (int)n) ? BOOL_T : BOOL_F;
  296 }
  297 SCM evenp(n)
  298      SCM n;
  299 {
  300 #ifdef BIGDIG
  301     if (NINUMP(n)) {
  302       ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_evenp);
  303       return (1 & BDIGITS(n)[0]) ? BOOL_F : BOOL_T;
  304     }
  305 #else
  306     ASRTER(INUMP(n), n, ARG1, s_evenp);
  307 #endif
  308     return (4 & (int)n) ? BOOL_F : BOOL_T;
  309 }
  310 
  311 SCM scm_round_quotient(num, den)
  312      SCM num, den;
  313 {
  314   register long quo, rem;
  315   /* if (scm_verbose > 1) */
  316   /*   printf("%s / %s\n", */
  317   /*       CHARS(number2string(num, MAKINUM(10))), */
  318   /*       CHARS(number2string(den, MAKINUM(10)))); */
  319 #ifdef BIGDIG
  320   if (NINUMP(num)) {
  321     long w;
  322     ASRTER(NIMP(num) && BIGP(num), num, ARG1, s_rquotient);
  323     if (NINUMP(den)) {
  324       ASRTGO(NIMP(den) && BIGP(den), badden);
  325       return divbigbig(BDIGITS(num), NUMDIGS(num), BDIGITS(den), NUMDIGS(den),
  326                BIGSIGN(num) ^ BIGSIGN(den), 3);
  327     }
  328     if (!(quo = INUM(den))) goto ov;
  329     if (1==quo) return num;
  330     /* divbigdig() hasn't been extended to perform rounding */
  331     /* if (quo < 0) quo = -quo; */
  332     /* if (quo < BIGRAD) { */
  333     /*   w = copybig(num, BIGSIGN(num) ? (den>0) : (den<0)); */
  334     /*   divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)quo); */
  335     /*   return normbig(w); */
  336     /* } */
  337 # ifndef DIGSTOOBIG
  338     w = pseudolong(quo);
  339     return divbigbig(BDIGITS(num), NUMDIGS(num), (BIGDIG *)&w, DIGSPERLONG,
  340              BIGSIGN(num) ? (den>0) : (den<0), 3);
  341 # else
  342     { BIGDIG quodigs[DIGSPERLONG];
  343       longdigs(quo, quodigs);
  344       return divbigbig(BDIGITS(num), NUMDIGS(num), quodigs, DIGSPERLONG,
  345                BIGSIGN(num) ? (den>0) : (den<0), 3);
  346     }
  347 # endif
  348   }
  349   if (NINUMP(den)) {
  350 # ifndef RECKLESS
  351     if (!(NIMP(den) && BIGP(den)))
  352     badden: wta(den, (char *)ARG2, s_rquotient);
  353 # endif
  354     if (NUMDIGS(den) > DIGSPERLONG ||
  355     (NUMDIGS(den)==DIGSPERLONG && BDIGITS(den)[DIGSPERLONG-1] >= BIGRAD/2))
  356       return INUM0;
  357     quo = num2long(den, (char *)ARG2, s_rquotient);
  358     rem = INUM(num)%quo;
  359     if (labs(2*rem) > labs(quo))
  360       return MAKINUM(((INUM(num) < 0)==(quo < 0)) ? 1 : -1);
  361     else return INUM0;
  362   }
  363 #else
  364   ASRTER(INUMP(num), num, ARG1, s_rquotient);
  365   ASRTER(INUMP(den), den, ARG2, s_rquotient);
  366 #endif
  367   if ((quo = INUM(den))==0)
  368   ov: wta(den, (char *)OVFLOW, s_rquotient);
  369   quo = INUM(num)/quo;
  370   {
  371 # if (__TURBOC__==1)
  372     rem = ((den<0) ? -INUM(num) : INUM(num))%INUM(den);
  373 # else
  374     rem = INUM(num)%INUM(den);
  375 # endif
  376 #ifdef BADIVSGNS
  377     if (rem==0) ;
  378     else if (rem < 0) {
  379       if (num < 0) ;
  380       else quo--;
  381     } else if (num < 0) quo++;
  382 #endif
  383     if ((1 & quo)
  384     ? labs(2*rem) >= labs(INUM(den))
  385     : labs(2*rem) > labs(INUM(den)))
  386       quo = quo + (((INUM(num) < 0)==(INUM(den) < 0)) ? 1 : -1);
  387   }
  388   if (!FIXABLE(quo))
  389 #ifdef BIGDIG
  390     return long2big(quo);
  391 #else
  392   wta(num, (char *)OVFLOW, s_rquotient);
  393 #endif
  394   return MAKINUM(quo);
  395 }
  396 
  397 /* SCM scm_round_quotient(num, den) */
  398 /*      SCM num, den; */
  399 /* { */
  400 /*   SCM quo = lquotient(num, den); */
  401 /*   SCM rem = lremainder(num, den); */
  402 /*   if (BOOL_T==((BOOL_T==evenp(quo) ? greaterp : greqp) */
  403 /*         (scm_ash(scm_iabs(rem), MAKINUM(1L)), scm_iabs(den)))) */
  404 /*     quo = sum(quo, MAKINUM(negativep(num)==negativep(den) ? 1L : -1L)); */
  405 /*   return quo; */
  406 /* } */
  407 
  408 SCM lquotient(x, y)
  409      SCM x, y;
  410 {
  411   register long z;
  412 #ifdef BIGDIG
  413   if (NINUMP(x)) {
  414     long w;
  415     ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_quotient);
  416     if (NINUMP(y)) {
  417       ASRTGO(NIMP(y) && BIGP(y), bady);
  418       return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
  419                BIGSIGN(x) ^ BIGSIGN(y), 2);
  420     }
  421     if (!(z = INUM(y))) goto ov;
  422     if (1==z) return x;
  423     if (z < 0) z = -z;
  424     if (z < BIGRAD) {
  425       w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
  426       divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z);
  427       return normbig(w);
  428     }
  429 # ifndef DIGSTOOBIG
  430     w = pseudolong(z);
  431     return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&w, DIGSPERLONG,
  432              BIGSIGN(x) ? (y>0) : (y<0), 2);
  433 # else
  434     { BIGDIG zdigs[DIGSPERLONG];
  435       longdigs(z, zdigs);
  436       return divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
  437                BIGSIGN(x) ? (y>0) : (y<0), 2);
  438     }
  439 # endif
  440   }
  441   if (NINUMP(y)) {
  442 # ifndef RECKLESS
  443     if (!(NIMP(y) && BIGP(y)))
  444     bady: wta(y, (char *)ARG2, s_quotient);
  445 # endif
  446     return INUM0;
  447   }
  448 #else
  449   ASRTER(INUMP(x), x, ARG1, s_quotient);
  450   ASRTER(INUMP(y), y, ARG2, s_quotient);
  451 #endif
  452   if ((z = INUM(y))==0)
  453   ov: wta(y, (char *)OVFLOW, s_quotient);
  454   z = INUM(x)/z;
  455 #ifdef BADIVSGNS
  456   {
  457 # if (__TURBOC__==1)
  458     long t = ((y<0) ? -INUM(x) : INUM(x))%INUM(y);
  459 # else
  460     long t = INUM(x)%INUM(y);
  461 # endif
  462     if (t==0) ;
  463     else if (t < 0)
  464       if (x < 0) ;
  465       else z--;
  466     else if (x < 0) z++;
  467   }
  468 #endif
  469   if (!FIXABLE(z))
  470 #ifdef BIGDIG
  471     return long2big(z);
  472 #else
  473   wta(x, (char *)OVFLOW, s_quotient);
  474 #endif
  475   return MAKINUM(z);
  476 }
  477 SCM lremainder(x, y)
  478      SCM x, y;
  479 {
  480   register long z;
  481 #ifdef BIGDIG
  482   if (NINUMP(x)) {
  483     ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_remainder);
  484     if (NINUMP(y)) {
  485       ASRTGO(NIMP(y) && BIGP(y), bady);
  486       return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
  487                BIGSIGN(x), 0);
  488     }
  489     if (!(z = INUM(y))) goto ov;
  490     return divbigint(x, z, BIGSIGN(x), 0);
  491   }
  492   if (NINUMP(y)) {
  493 # ifndef RECKLESS
  494     if (!(NIMP(y) && BIGP(y)))
  495     bady: wta(y, (char *)ARG2, s_remainder);
  496 # endif
  497     return x;
  498   }
  499 #else
  500   ASRTER(INUMP(x), x, ARG1, s_remainder);
  501   ASRTER(INUMP(y), y, ARG2, s_remainder);
  502 #endif
  503   if (!(z = INUM(y)))
  504   ov: wta(y, (char *)OVFLOW, s_remainder);
  505 #if (__TURBOC__==1)
  506   if (z < 0) z = -z;
  507 #endif
  508   z = INUM(x)%z;
  509 #ifdef BADIVSGNS
  510   if (!z) ;
  511   else if (z < 0)
  512       if (x < 0) ;
  513       else z += INUM(y);
  514   else if (x < 0) z -= INUM(y);
  515 #endif
  516   return MAKINUM(z);
  517 }
  518 SCM modulo(x, y)
  519      SCM x, y;
  520 {
  521   register long yy, z;
  522 #ifdef BIGDIG
  523   if (NINUMP(x)) {
  524     ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_modulo);
  525     if (NINUMP(y)) {
  526       ASRTGO(NIMP(y) && BIGP(y), bady);
  527       return divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
  528                BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0);
  529     }
  530     if (!(z = INUM(y))) goto ov;
  531     return divbigint(x, z, z < 0, (BIGSIGN(x) ? (z > 0) : (z < 0)) ? 1 : 0);
  532   }
  533   if (NINUMP(y)) {
  534 # ifndef RECKLESS
  535     if (!(NIMP(y) && BIGP(y)))
  536     bady: wta(y, (char *)ARG2, s_modulo);
  537 # endif
  538     return (BIGSIGN(y) ? (INUM(x)>0) : (INUM(x)<0)) ? sum(x, y) : x;
  539   }
  540 #else
  541   ASRTER(INUMP(x), x, ARG1, s_modulo);
  542   ASRTER(INUMP(y), y, ARG2, s_modulo);
  543 #endif
  544   if (!(yy = INUM(y)))
  545   ov: wta(y, (char *)OVFLOW, s_modulo);
  546 #if (__TURBOC__==1)
  547   z = INUM(x);
  548   z = ((yy<0) ? -z : z)%yy;
  549 #else
  550   z = INUM(x)%yy;
  551 #endif
  552   return MAKINUM(((yy<0) ? (z>0) : (z<0)) ? z+yy : z);
  553 }
  554 
  555 SCM lgcd(x, y)
  556      SCM x, y;
  557 {
  558   register long u, v, k, t;
  559   if (UNBNDP(y)) return UNBNDP(x) ? INUM0 : x;
  560 #ifdef BIGDIG
  561  tailrec:
  562   if (NINUMP(x)) {
  563     big_gcd:
  564     ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_gcd);
  565     if (BIGSIGN(x)) x = copybig(x, 0);
  566   newy:
  567     if (NINUMP(y)) {
  568       ASRTER(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
  569       if (BIGSIGN(y)) y = copybig(y, 0);
  570       switch (bigcomp(x, y)) {
  571       case -1:
  572       swaprec: t = lremainder(x, y); x = y; y = t; goto tailrec;
  573       case  0: return x;
  574       case  1: y = lremainder(y, x); goto newy;
  575       }
  576       /* instead of the switch, we could just return lgcd(y, modulo(x, y)); */
  577     }
  578     if (INUM0==y) return x; goto swaprec;
  579   }
  580   if (NINUMP(y)) { t=x; x=y; y=t; goto big_gcd;}
  581 #else
  582   ASRTER(INUMP(x), x, ARG1, s_gcd);
  583   ASRTER(INUMP(y), y, ARG2, s_gcd);
  584 #endif
  585   u = INUM(x);
  586   if (u<0) u = -u;
  587   v = INUM(y);
  588   if (v<0) v = -v;
  589   else if (0==v) goto getout;
  590   if (0==u) {u = v; goto getout;}
  591   for (k = 1;!(1 & ((int)u|(int)v));k <<= 1, u >>= 1, v >>= 1);
  592   if (1 & (int)u) t = -v;
  593   else {
  594     t = u;
  595 b3:
  596     t = SRS(t, 1);
  597   }
  598   if (!(1 & (int)t)) goto b3;
  599   if (t>0) u = t;
  600   else v = -t;
  601   t = u-v;
  602   if (t) goto b3;
  603   u = u*k;
  604 getout:
  605   if (!POSFIXABLE(u))
  606 #ifdef BIGDIG
  607     return long2big(u);
  608 #else
  609     wta(x, (char *)OVFLOW, s_gcd);
  610 #endif
  611   return MAKINUM(u);
  612 }
  613 SCM llcm(n1, n2)
  614      SCM n1, n2;
  615 {
  616   SCM d;
  617   if (UNBNDP(n2)) {
  618     n2 = MAKINUM(1L);
  619     if (UNBNDP(n1)) return n2;
  620   }
  621   d = lgcd(n1, n2);
  622   if (INUM0==d) return d;
  623   return scm_iabs(product(n1, lquotient(n2, d)));
  624 }
  625 
  626 /* Emulating 2's complement bignums with sign magnitude arithmetic:
  627 
  628    Logand:
  629    X    Y   Result  Method:
  630          (len)
  631    +    +   + x (map digit:logand X Y)
  632    +    -   + x (map digit:logand X (lognot (+ -1 Y)))
  633    -    +   + y (map digit:logand (lognot (+ -1 X)) Y)
  634    -    -   -   (+ 1 (map digit:logior (+ -1 X) (+ -1 Y)))
  635 
  636    Logior:
  637    X    Y   Result  Method:
  638 
  639    +    +   +   (map digit:logior X Y)
  640    +    -   - y (+ 1 (map digit:logand (lognot X) (+ -1 Y)))
  641    -    +   - x (+ 1 (map digit:logand (+ -1 X) (lognot Y)))
  642    -    -   - x (+ 1 (map digit:logand (+ -1 X) (+ -1 Y)))
  643 
  644    Logxor:
  645    X    Y   Result  Method:
  646 
  647    +    +   +   (map digit:logxor X Y)
  648    +    -   -   (+ 1 (map digit:logxor X (+ -1 Y)))
  649    -    +   -   (+ 1 (map digit:logxor (+ -1 X) Y))
  650    -    -   +   (map digit:logxor (+ -1 X) (+ -1 Y))
  651 
  652    Logtest:
  653    X    Y   Result
  654 
  655    +    +   (any digit:logand X Y)
  656    +    -   (any digit:logand X (lognot (+ -1 Y)))
  657    -    +   (any digit:logand (lognot (+ -1 X)) Y)
  658    -    -   #t
  659 
  660 */
  661 
  662 #ifdef BIGDIG
  663 
  664 SCM scm_big_ior P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
  665 SCM scm_big_and P((BIGDIG *x, sizet nx, int xsgn, SCM bigy, int zsgn));
  666 SCM scm_big_xor P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
  667 SCM scm_big_test P((BIGDIG *x, sizet nx, int xsgn, SCM bigy));
  668 SCM scm_big_ash P((SCM x, int cnt));
  669 
  670 SCM scm_copy_big_dec(b, sign)
  671      SCM b;
  672      int sign;
  673 {
  674   long num = -1;
  675   sizet nx = NUMDIGS(b);
  676   sizet i = 0;
  677   SCM ans = mkbig(nx, sign);
  678   BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
  679   if (BIGSIGN(b)) do {
  680     num += src[i];
  681     if (num < 0) {dst[i] = num + BIGRAD; num = -1;}
  682     else {dst[i] = BIGLO(num); num = 0;}
  683   } while (++i < nx);
  684   else
  685     while (nx--) dst[nx] = src[nx];
  686   return ans;
  687 }
  688 
  689 SCM scm_copy_smaller(x, nx, zsgn)
  690      BIGDIG *x;
  691      sizet nx;
  692      int zsgn;
  693 {
  694   long num = -1;
  695   sizet i = 0;
  696   SCM z = mkbig(nx, zsgn);
  697   BIGDIG *zds = BDIGITS(z);
  698   if (zsgn) do {
  699     num += x[i];
  700     if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
  701     else {zds[i] = BIGLO(num); num = 0;}
  702   } while (++i < nx);
  703   else do zds[i] = x[i]; while (++i < nx);
  704   return z;
  705 }
  706 
  707 SCM scm_big_ior(x, nx, xsgn, bigy)
  708      BIGDIG *x;
  709      SCM bigy;
  710      sizet nx;      /* Assumes nx <= NUMDIGS(bigy) */
  711      int xsgn;      /* Assumes xsgn equals either 0 or 0x0100 */
  712 {
  713   long num = -1;
  714   sizet i = 0, ny = NUMDIGS(bigy);
  715   SCM z = scm_copy_big_dec(bigy, xsgn & BIGSIGN(bigy));
  716   BIGDIG *zds = BDIGITS(z);
  717   if (xsgn) {
  718     do {
  719       num += x[i];
  720       if (num < 0) {zds[i] |= num + BIGRAD; num = -1;}
  721       else {zds[i] |= BIGLO(num); num = 0;}
  722     } while (++i < nx);
  723     /* =========  Need to increment zds now =========== */
  724     i = 0; num = 1;
  725     while (i < ny) {
  726       num += zds[i];
  727       zds[i++] = BIGLO(num);
  728       num = BIGDN(num);
  729       if (!num) return z;
  730     }
  731     adjbig(z, 1 + ny);      /* OOPS, overflowed into next digit. */
  732     BDIGITS(z)[ny] = 1;
  733     return z;
  734   }
  735   else do zds[i] = zds[i] | x[i]; while (++i < nx);
  736   return z;
  737 }
  738 
  739 SCM scm_big_xor(x, nx, xsgn, bigy)
  740      BIGDIG *x;
  741      SCM bigy;
  742      sizet nx;      /* Assumes nx <= NUMDIGS(bigy) */
  743      int xsgn;      /* Assumes xsgn equals either 0 or 0x0100 */
  744 {
  745   long num = -1;
  746   sizet i = 0, ny = NUMDIGS(bigy);
  747   SCM z = scm_copy_big_dec(bigy, xsgn ^ BIGSIGN(bigy));
  748   BIGDIG *zds = BDIGITS(z);
  749   if (xsgn) do {
  750     num += x[i];
  751     if (num < 0) {zds[i] ^= num + BIGRAD; num = -1;}
  752     else {zds[i] ^= BIGLO(num); num = 0;}
  753   } while (++i < nx);
  754   else do {
  755     zds[i] = zds[i] ^ x[i];
  756   } while (++i < nx);
  757 
  758   if (xsgn ^ BIGSIGN(bigy)) {
  759     /* =========  Need to increment zds now =========== */
  760     i = 0; num = 1;
  761     while (i < ny) {
  762       num += zds[i];
  763       zds[i++] = BIGLO(num);
  764       num = BIGDN(num);
  765       if (!num) return normbig(z);
  766     }
  767   }
  768   return normbig(z);
  769 }
  770 
  771 SCM scm_big_and(x, nx, xsgn, bigy, zsgn)
  772      BIGDIG *x;
  773      SCM bigy;
  774      sizet nx;      /* Assumes nx <= NUMDIGS(bigy) */
  775      int xsgn;      /* Assumes xsgn equals either 0 or 0x0100 */
  776      int zsgn;      /* return sign equals either 0 or 0x0100 */
  777 {
  778   long num = -1;
  779   sizet i = 0;
  780   SCM z;
  781   BIGDIG *zds;
  782   if (xsgn==zsgn) {
  783     z = scm_copy_smaller(x, nx, zsgn);
  784     x = BDIGITS(bigy);
  785     xsgn = BIGSIGN(bigy);
  786   }
  787   else z = scm_copy_big_dec(bigy, zsgn);
  788   zds = BDIGITS(z);
  789 
  790   if (zsgn) {
  791     if (xsgn) do {
  792       num += x[i];
  793       if (num < 0) {zds[i] &= num + BIGRAD; num = -1;}
  794       else {zds[i] &= BIGLO(num); num = 0;}
  795     } while (++i < nx);
  796     else do zds[i] = zds[i] & ~x[i]; while (++i < nx);
  797     /* =========  need to increment zds now =========== */
  798     i = 0; num = 1;
  799     while (i < nx) {
  800       num += zds[i];
  801       zds[i++] = BIGLO(num);
  802       num = BIGDN(num);
  803       if (!num) return normbig(z);
  804     }
  805   }
  806   else if (xsgn) do {
  807     num += x[i];
  808     if (num < 0) {zds[i] &= ~(num + BIGRAD); num = -1;}
  809     else {zds[i] &= ~BIGLO(num); num = 0;}
  810   } while (++i < nx);
  811   else do zds[i] = zds[i] & x[i]; while (++i < nx);
  812   return normbig(z);
  813 }
  814 
  815 SCM scm_big_test(x, nx, xsgn, bigy)
  816      BIGDIG *x;
  817      SCM bigy;
  818      sizet nx;      /* Assumes nx <= NUMDIGS(bigy) */
  819      int xsgn;      /* Assumes xsgn equals either 0 or 0x0100 */
  820 {
  821   BIGDIG *y;
  822   sizet i = 0;
  823   long num = -1;
  824   if (BIGSIGN(bigy) & xsgn) return BOOL_T;
  825   if (NUMDIGS(bigy) != nx && xsgn) return BOOL_T;
  826   y = BDIGITS(bigy);
  827   if (xsgn)
  828     do {
  829       num += x[i];
  830       if (num < 0) {
  831     if (y[i] & ~(num + BIGRAD)) return BOOL_T;
  832     num = -1;
  833       }
  834       else {
  835     if (y[i] & ~BIGLO(num)) return BOOL_T;
  836     num = 0;
  837       }
  838     } while (++i < nx);
  839   else if (BIGSIGN(bigy))
  840     do {
  841       num += y[i];
  842       if (num < 0) {
  843     if (x[i] & ~(num + BIGRAD)) return BOOL_T;
  844     num = -1;
  845       }
  846       else {
  847     if (x[i] & ~BIGLO(num)) return BOOL_T;
  848     num = 0;
  849       }
  850     } while (++i < nx);
  851   else
  852     do if (x[i] & y[i]) return BOOL_T;
  853     while (++i < nx);
  854   return BOOL_F;
  855 }
  856 
  857 static SCM scm_copy_big_2scomp P((SCM x, sizet blen, int sign));
  858 static void scm_2scomp1 P((SCM b));
  859 static SCM scm_copy_big_2scomp(x, blen, sign)
  860      SCM x;
  861      sizet blen;
  862      int sign;
  863 {
  864   sizet nres = (blen + BITSPERDIG - 1)/BITSPERDIG;
  865   SCM res;
  866   BIGDIG *rds;
  867   long num = 0;
  868   sizet i;
  869   if (INUMP(x)) {
  870     long lx = INUM(x);
  871     res = mkbig(nres, sign);
  872     rds = BDIGITS(res);
  873     if (lx < 0) {
  874       lx = -lx;
  875       for (i = 0; i < nres; i++) {
  876     num -= BIGLO(lx);
  877     lx = BIGDN(lx);
  878     if (num < 0) {
  879       rds[i] = num + BIGRAD;
  880       num = -1;
  881     }
  882     else {
  883       rds[i] = num;
  884       num = 0;
  885     }
  886       }
  887     }
  888     else {
  889       for (i = 0; i < nres; i++) {
  890     rds[i] = BIGLO(lx);
  891     lx = BIGDN(lx);
  892       }
  893     }
  894   }
  895   else {
  896     BIGDIG *xds = BDIGITS(x);
  897     sizet nx = NUMDIGS(x);
  898     if (nres < nx)
  899       nres = nx;
  900     res = mkbig(nres, sign);
  901     rds = BDIGITS(res);
  902     if (BIGSIGN(x)) {
  903       for (i = 0; i < nx; i++) {
  904     num -= xds[i];
  905     if (num < 0) {
  906       rds[i] = num + BIGRAD;
  907       num = -1;
  908     }
  909     else {
  910       rds[i] = num;
  911       num = 0;
  912     }
  913       }
  914       for (; i < nres; i++)
  915     rds[i] = BIGRAD - 1;
  916     }
  917     else {
  918       for (i = 0; i < nx; i++)
  919     rds[i] = xds[i];
  920       for (; i < nres; i++)
  921     rds[i] = 0;
  922     }
  923   }
  924   return res;
  925 }
  926 static void scm_2scomp1(b)
  927      SCM b;
  928 {
  929   long num = 0;
  930   sizet i, n = NUMDIGS(b);
  931   BIGDIG *bds = BDIGITS(b);
  932   for (i = 0; i < n; i++) {
  933     num -= bds[i];
  934     if (num < 0) {
  935       bds[i] = num + BIGRAD;
  936       num = -1;
  937     }
  938     else {
  939       bds[i] = num;
  940       num = 0;
  941     }
  942   }
  943 }
  944 
  945 SCM scm_big_ash(x, cnt)
  946      SCM x;
  947      int cnt;
  948 {
  949   SCM res;
  950   BIGDIG *resds, d;
  951   int sign, i, ishf, fshf, blen, n;
  952   if (INUMP(x)) {
  953     blen = INUM(scm_intlength(x));
  954     sign = INUM(x) < 0 ? 0x0100 : 0;
  955   }
  956   else {
  957     blen = NUMDIGS(x)*BITSPERDIG;
  958     sign = BIGSIGN(x);
  959   }
  960   if (cnt < 0) {
  961     if (blen <= -cnt) return sign ? MAKINUM(-1) : INUM0;
  962     ishf = (-cnt) / BITSPERDIG;
  963     fshf = (-cnt) % BITSPERDIG;
  964     res = scm_copy_big_2scomp(x, blen, sign);
  965     resds = BDIGITS(res);
  966     n = NUMDIGS(res) - ishf - 1;
  967     for (i = 0; i < n; i++) {
  968       d = (resds[i + ishf]>>fshf);
  969       if (fshf)
  970     d |= ((resds[i + ishf + 1])<<(BITSPERDIG - fshf) & (BIGRAD - 1));
  971       resds[i] = d;
  972     }
  973     d = (resds[i + ishf]>>fshf);
  974     if (sign && fshf) d |= ((BIGRAD - 1)<<(BITSPERDIG - fshf) & (BIGRAD - 1));
  975     resds[i] = d;
  976     n = NUMDIGS(res);
  977     d = sign ? BIGRAD - 1 : 0;
  978     for (i++; i < n; i++)
  979       resds[i] = d;
  980   }
  981   else {
  982     ishf = cnt / BITSPERDIG;
  983     fshf = cnt % BITSPERDIG;
  984     res = scm_copy_big_2scomp(x, blen + cnt, sign);
  985     resds = BDIGITS(res);
  986     /* if (scm_verbose>1){for (i=NUMDIGS(res); i--;) printf(" %08x",resds[i]); printf("\n");} */
  987     for (i = NUMDIGS(res) - 1; i > ishf; i--)
  988       if (fshf) {
  989     d = (((resds[i - ishf])<<fshf) & (BIGRAD - 1))
  990       | ((resds[i - ishf - 1])>>(BITSPERDIG - fshf));
  991     resds[i] = d;
  992       } else resds[i] = resds[i - ishf];
  993     d = fshf ? (((resds[i - ishf])<<fshf) & (BIGRAD - 1)) : resds[i - ishf];
  994     resds[i] = d;
  995     for (i--; i >= 0; i--) resds[i] = 0;
  996   }
  997  /* if (scm_verbose>1){for (i=NUMDIGS(res); i--;) printf(" %08x",resds[i]); printf("\n");} */
  998   if (sign) scm_2scomp1(res);
  999   return normbig(res);
 1000 }
 1001 #endif
 1002 
 1003 static char s_logand[] = "logand", s_lognot[] = "lognot",
 1004         s_logior[] = "logior", s_logxor[] = "logxor",
 1005         s_logtest[] = "logtest", s_logbitp[] = "logbit?",
 1006             s_copybit[] = "copy-bit",
 1007             s_copybitfield[] = "copy-bit-field",
 1008         s_ash[] = "ash", s_logcount[] = "logcount",
 1009         s_bitwise_bit_count[] = "bitwise-bit-count",
 1010         s_intlength[] = "integer-length",
 1011         s_bitfield[] = "bit-field",
 1012             s_bitif[] = "bitwise-if";
 1013 
 1014 SCM scm_logior(x, y)
 1015      SCM x, y;
 1016 {
 1017   if (UNBNDP(y)) {
 1018     if (UNBNDP(x)) return INUM0;
 1019 #ifndef RECKLESS
 1020     if (!(NUMBERP(x)))
 1021     badx: wta(x, (char *)ARG1, s_logior);
 1022 #endif
 1023     return x;
 1024   }
 1025 #ifdef BIGDIG
 1026   if (NINUMP(x)) {
 1027     SCM t;
 1028     ASRTGO(NIMP(x) && BIGP(x), badx);
 1029     if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
 1030     ASRTGO(NIMP(y) && BIGP(y), bady);
 1031     if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
 1032     if ((!BIGSIGN(x)) && !BIGSIGN(y))
 1033       return scm_big_ior(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
 1034     return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100);
 1035   }
 1036   if (NINUMP(y)) {
 1037 # ifndef RECKLESS
 1038     if (!(NIMP(y) && BIGP(y)))
 1039     bady: wta(y, (char *)ARG2, s_logior);
 1040 # endif
 1041   intbig: {
 1042 # ifndef DIGSTOOBIG
 1043     long z = pseudolong(INUM(x));
 1044     if ((!(x < 0)) && !BIGSIGN(y))
 1045       return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1046     return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
 1047               0x0100);
 1048 # else
 1049     BIGDIG zdigs[DIGSPERLONG];
 1050     longdigs(INUM(x), zdigs);
 1051     if ((!(x < 0)) && !BIGSIGN(y))
 1052       return scm_big_ior(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1053     return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
 1054 # endif
 1055   }}
 1056 #else
 1057   ASRTGO(INUMP(x), badx);
 1058   ASRTER(INUMP(y), y, ARG2, s_logior);
 1059 #endif
 1060   return MAKINUM(INUM(x) | INUM(y));
 1061 }
 1062 
 1063 SCM scm_logand(x, y)
 1064      SCM x, y;
 1065 {
 1066   if (UNBNDP(y)) {
 1067     if (UNBNDP(x)) return MAKINUM(-1);
 1068 #ifndef RECKLESS
 1069     if (!(NUMBERP(x)))
 1070     badx: wta(x, (char *)ARG1, s_logand);
 1071 #endif
 1072     return x;
 1073   }
 1074 #ifdef BIGDIG
 1075   if (NINUMP(x)) {
 1076     SCM t;
 1077     ASRTGO(NIMP(x) && BIGP(x), badx);
 1078     if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
 1079     ASRTGO(NIMP(y) && BIGP(y), bady);
 1080     if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
 1081     if ((BIGSIGN(x)) && BIGSIGN(y))
 1082       return scm_big_ior(BDIGITS(x), NUMDIGS(x), 0x0100, y);
 1083     return scm_big_and(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
 1084   }
 1085   if (NINUMP(y)) {
 1086 # ifndef RECKLESS
 1087     if (!(NIMP(y) && BIGP(y)))
 1088     bady: wta(y, (char *)ARG2, s_logand);
 1089 # endif
 1090   intbig: {
 1091 # ifndef DIGSTOOBIG
 1092     long z = pseudolong(INUM(x));
 1093     if ((x < 0) && BIGSIGN(y))
 1094       return scm_big_ior((BIGDIG *)&z, DIGSPERLONG, 0x0100, y);
 1095     return scm_big_and((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y,
 1096               0);
 1097 # else
 1098     BIGDIG zdigs[DIGSPERLONG];
 1099     longdigs(INUM(x), zdigs);
 1100     if ((x < 0) && BIGSIGN(y))
 1101       return scm_big_ior(zdigs, DIGSPERLONG, 0x0100, y);
 1102     return scm_big_and(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
 1103 # endif
 1104   }}
 1105 #else
 1106   ASRTGO(INUMP(x), badx);
 1107   ASRTER(INUMP(y), y, ARG2, s_logand);
 1108 #endif
 1109   return MAKINUM(INUM(x) & INUM(y));
 1110 }
 1111 
 1112 SCM scm_logxor(x, y)
 1113      SCM x, y;
 1114 {
 1115   if (UNBNDP(y)) {
 1116     if (UNBNDP(x)) return INUM0;
 1117 #ifndef RECKLESS
 1118     if (!(NUMBERP(x)))
 1119     badx: wta(x, (char *)ARG1, s_logxor);
 1120 #endif
 1121     return x;
 1122   }
 1123 #ifdef BIGDIG
 1124   if (NINUMP(x)) {
 1125     SCM t;
 1126     ASRTGO(NIMP(x) && BIGP(x), badx);
 1127     if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
 1128     ASRTGO(NIMP(y) && BIGP(y), bady);
 1129     if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
 1130     return scm_big_xor(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
 1131   }
 1132   if (NINUMP(y)) {
 1133 # ifndef RECKLESS
 1134     if (!(NIMP(y) && BIGP(y)))
 1135     bady: wta(y, (char *)ARG2, s_logxor);
 1136 # endif
 1137   intbig: {
 1138 # ifndef DIGSTOOBIG
 1139     long z = pseudolong(INUM(x));
 1140     return scm_big_xor((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1141 # else
 1142     BIGDIG zdigs[DIGSPERLONG];
 1143     longdigs(INUM(x), zdigs);
 1144     return scm_big_xor(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1145 # endif
 1146   }}
 1147 #else
 1148   ASRTGO(INUMP(x), badx);
 1149   ASRTER(INUMP(y), y, ARG2, s_logxor);
 1150 #endif
 1151   return (x ^ y) + INUM0;
 1152 }
 1153 
 1154 SCM scm_logtest(x, y)
 1155      SCM x, y;
 1156 {
 1157 #ifndef RECKLESS
 1158     if (!(NUMBERP(x)))
 1159     badx: wta(x, (char *)ARG1, s_logtest);
 1160 #endif
 1161 #ifdef BIGDIG
 1162   if (NINUMP(x)) {
 1163     SCM t;
 1164     ASRTGO(NIMP(x) && BIGP(x), badx);
 1165     if (INUMP(y)) {t = x; x = y; y = t; goto intbig;}
 1166     ASRTGO(NIMP(y) && BIGP(y), bady);
 1167     if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
 1168     return scm_big_test(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y);
 1169   }
 1170   if (NINUMP(y)) {
 1171 # ifndef RECKLESS
 1172     if (!(NIMP(y) && BIGP(y)))
 1173     bady: wta(y, (char *)ARG2, s_logtest);
 1174 # endif
 1175   intbig: {
 1176 # ifndef DIGSTOOBIG
 1177     long z = pseudolong(INUM(x));
 1178     return scm_big_test((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1179 # else
 1180     BIGDIG zdigs[DIGSPERLONG];
 1181     longdigs(INUM(x), zdigs);
 1182     return scm_big_test(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y);
 1183 # endif
 1184   }}
 1185 #else
 1186   ASRTGO(INUMP(x), badx);
 1187   ASRTER(INUMP(y), y, ARG2, s_logtest);
 1188 #endif
 1189   return (INUM(x) & INUM(y)) ? BOOL_T : BOOL_F;
 1190 }
 1191 
 1192 SCM scm_logbitp(index, j1)
 1193      SCM index, j1;
 1194 {
 1195   ASRTER(INUMP(index) && INUM(index) >= 0, index, ARG1, s_logbitp);
 1196 #ifdef BIGDIG
 1197   if (NINUMP(j1)) {
 1198     ASRTER(NIMP(j1) && BIGP(j1), j1, ARG2, s_logbitp);
 1199     if (NUMDIGS(j1) * BITSPERDIG < INUM(index)) return BOOL_F;
 1200     else if (BIGSIGN(j1)) {
 1201       long num = -1;
 1202       sizet i = 0;
 1203       BIGDIG *x = BDIGITS(j1);
 1204       sizet nx = INUM(index)/BITSPERDIG;
 1205       while (!0) {
 1206     num += x[i];
 1207     if (nx==i++)
 1208       return ((1L << (INUM(index)%BITSPERDIG)) & num) ? BOOL_F : BOOL_T;
 1209     if (num < 0) num = -1;
 1210     else num = 0;
 1211       }
 1212     }
 1213     else return (BDIGITS(j1)[INUM(index)/BITSPERDIG] &
 1214          (1L << (INUM(index)%BITSPERDIG))) ? BOOL_T : BOOL_F;
 1215   }
 1216 #else
 1217   ASRTER(INUMP(j1), j1, ARG2, s_logbitp);
 1218 #endif
 1219   if (INUM(index) >= LONG_BIT) return j1 < 0 ? BOOL_T : BOOL_F;
 1220   return ((1L << INUM(index)) & INUM(j1)) ? BOOL_T : BOOL_F;
 1221 }
 1222 
 1223 SCM scm_copybit(index, j1, bit)
 1224      SCM index, j1, bit;
 1225 {
 1226   ASRTER(INUMP(index) && INUM(index) >= 0, index, ARG1, s_copybit);
 1227 #ifdef BIGDIG
 1228   {
 1229     SCM res;
 1230     BIGDIG *rds;
 1231     sizet i = INUM(index);
 1232     int sign;
 1233     if (!INUMP(j1)) {
 1234       ASRTER(NIMP(j1) && BIGP(j1), j1, ARG2, s_copybit);
 1235       sign = BIGSIGN(j1);
 1236     ovflow:
 1237       res = scm_copy_big_2scomp(j1, i + 1, sign);
 1238       rds = BDIGITS(res);
 1239       if (NFALSEP(bit))
 1240     rds[i / BITSPERDIG] |= 1 << (i % BITSPERDIG);
 1241       else
 1242     rds[i / BITSPERDIG] &= ~(1 << (i % BITSPERDIG));
 1243       if (sign) scm_2scomp1(res);
 1244       return normbig(res);
 1245     }
 1246     if (i >= LONG_BIT - 3) {
 1247       sign = INUM(j1) < 0 ? 0x0100 : 0;
 1248       goto ovflow;
 1249     }
 1250   }
 1251 #else
 1252   ASRTER(INUMP(j1), j1, ARG2, s_copybit);
 1253   ASRTER(INUM(index) < LONG_BIT - 3, index, OUTOFRANGE, s_copybit);
 1254 #endif
 1255   if (NFALSEP(bit))
 1256     return MAKINUM(INUM(j1) | (1L << INUM(index)));
 1257   else
 1258     return MAKINUM(INUM(j1) & (~(1L << INUM(index))));
 1259 }
 1260 
 1261 SCM scm_lognot(n)
 1262      SCM n;
 1263 {
 1264   return difference(MAKINUM(-1L), n);
 1265 }
 1266 
 1267 SCM scm_ash(n, cnt)
 1268      SCM n, cnt;
 1269 {
 1270   SCM res;
 1271   long ni = INUM(n);
 1272   int icnt = INUM(cnt);
 1273   ASRTER(INUMP(cnt), cnt, ARG2, s_ash);
 1274   if (INUMP(n)) {
 1275     if (icnt < 0) {
 1276       if (-icnt >= LONG_BIT) return ni<0 ? MAKINUM(-1L) : INUM0;
 1277       return MAKINUM(SRS(ni, -icnt));
 1278     }
 1279     if (icnt >= LONG_BIT) goto ovflow;
 1280     res = MAKINUM(ni<<icnt);
 1281     if (INUM(res)>>icnt != INUM(n))
 1282       goto ovflow;
 1283     else
 1284       return res;
 1285   }
 1286 #ifdef BIGDIG
 1287   ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_ash);
 1288  ovflow:
 1289   if (0==icnt) return n;
 1290   return scm_big_ash(n, icnt);
 1291 #else
 1292  ovflow:
 1293   wta(n, INUMP(n) ? (char *)OVFLOW : (char *)ARG1, s_ash);
 1294   return UNSPECIFIED;   /* kill warning */
 1295 #endif
 1296 }
 1297 
 1298 SCM scm_bitfield(n, start, end)
 1299      SCM n, start, end;
 1300 {
 1301   int sign;
 1302   int istart = INUM(start);
 1303   int iend = INUM(end);
 1304   ASRTER(INUMP(start), start, ARG2, s_bitfield);
 1305   ASRTER(INUMP(end), end, ARG3, s_bitfield);
 1306   ASRTER(iend >= istart, MAKINUM(iend), OUTOFRANGE, s_bitfield);
 1307 #ifdef BIGDIG
 1308   if (NINUMP(n)) {
 1309     BIGDIG *ds;
 1310     sizet i, nd;
 1311     ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_bitfield);
 1312     sign = BIGSIGN(n);
 1313   big:
 1314     if (sign) n = scm_copy_big_2scomp(n, (sizet)iend, 0);
 1315     n = scm_big_ash(n, -istart);
 1316     if (INUMP(n)) {
 1317       if (iend - istart >= LONG_BIT - 2) return n;
 1318       return MAKINUM(INUM(n) & ((1L<<(iend - istart)) - 1));
 1319     }
 1320     nd = NUMDIGS(n);
 1321     ds = BDIGITS(n);
 1322     i = (iend - istart) / BITSPERDIG;
 1323     if (i >= nd) return n;
 1324     ds[i] &= ((1 << ((iend - istart) % BITSPERDIG)) - 1);
 1325     for (++i; i < nd; i++) ds[i] = 0;
 1326     return normbig(n);
 1327   }
 1328   if (iend >= LONG_BIT - 2) {
 1329     sign = INUM(n) < 0;
 1330     goto big;
 1331   }
 1332 #else
 1333   ASRTER(INUMP(n), n, ARG1, s_bitfield);
 1334   ASRTER(iend < LONG_BIT - 2, MAKINUM(iend), OUTOFRANGE, s_bitfield);
 1335 #endif
 1336   return MAKINUM((INUM(n)>>istart) & ((1L<<(iend - istart)) - 1));
 1337 }
 1338 
 1339 SCM scm_bitif(mask, n0, n1)
 1340      SCM mask, n0, n1;
 1341 {
 1342 #ifdef BIGDIG
 1343   if (NINUMP(mask) || NINUMP(n0) || NINUMP(n1))
 1344     return scm_logior(scm_logand(mask, n0),
 1345               scm_logand(scm_lognot(mask), n1));
 1346 #else
 1347   ASRTER(INUMP(mask), mask, ARG1, s_bitif);
 1348   ASRTER(INUMP(n0), n0, ARG2, s_bitif);
 1349   ASRTER(INUMP(n1), n1, ARG3, s_bitif);
 1350 #endif
 1351   return MAKINUM((INUM(mask) & INUM(n0)) | (~(INUM(mask)) & INUM(n1)));
 1352 }
 1353 
 1354 SCM scm_copybitfield(to, from, rest)
 1355      SCM to, from, rest;
 1356 {
 1357   long len;
 1358   SCM start, end;
 1359 #ifndef RECKLESS
 1360   if (!(NIMP(rest) && CONSP(rest)))
 1361     wna: wta(UNDEFINED, (char *)WNA, s_copybitfield);
 1362 #endif
 1363   start = CAR(rest);
 1364   rest = CDR(rest);
 1365   ASRTGO(NIMP(rest) && CONSP(rest), wna);
 1366   end = CAR(rest);
 1367   ASRTGO(NULLP(CDR(rest)), wna);
 1368   ASRTER(INUMP(start) && INUM(start)>=0, start, ARG2, s_copybitfield);
 1369   len = INUM(end) - INUM(start);
 1370   ASRTER(INUMP(end), end, ARG3, s_copybitfield);
 1371   ASRTER(len >= 0, MAKINUM(len), OUTOFRANGE, s_copybitfield);
 1372 #ifdef BIGDIG
 1373   if (NINUMP(from) || NINUMP(to) || (INUM(end) >= LONG_BIT - 2)) {
 1374     SCM mask = difference(scm_ash(MAKINUM(1L), MAKINUM(len)), MAKINUM(1L));
 1375     mask = scm_ash(mask, start);
 1376     return scm_logior(scm_logand(mask, scm_ash(from, start)),
 1377               scm_logand(scm_lognot(mask), to));
 1378   }
 1379 #else
 1380   ASRTER(INUMP(to), to, ARG1, s_copybitfield);
 1381   ASRTER(INUMP(from), from, ARG4, s_copybitfield);
 1382   ASRTER(INUM(end) < LONG_BIT - 2, end, OUTOFRANGE, s_copybitfield);
 1383 #endif
 1384   {
 1385     long mask = ((1L<<len) - 1)<<INUM(start);
 1386     return MAKINUM((mask & (INUM(from)<<INUM(start))) | ((~mask) & INUM(to)));
 1387   }
 1388 }
 1389 
 1390 char logtab[] = {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
 1391 SCM scm_bitwise_bit_count(n)
 1392      SCM n;
 1393 {
 1394   register unsigned long c = 0;
 1395   register long nn;
 1396 #ifdef BIGDIG
 1397   if (NINUMP(n)) {
 1398     sizet i; BIGDIG *ds, d;
 1399     ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_bitwise_bit_count);
 1400     if (BIGSIGN(n)) {
 1401       SCM df = difference(MAKINUM(-1L), n);
 1402       SCM bc = scm_bitwise_bit_count(df);
 1403       bigrecy(df);
 1404       return scm_lognot(bc);
 1405     }
 1406     ds = BDIGITS(n);
 1407     for (i = NUMDIGS(n); i--; )
 1408       for (d = ds[i]; d; d >>= 4) c += logtab[15 & d];
 1409     if (BIGSIGN(n))
 1410       return MAKINUM(-1 - c);
 1411     return MAKINUM(c);
 1412   }
 1413 #else
 1414   ASRTER(INUMP(n), n, ARG1, s_bitwise_bit_count);
 1415 #endif
 1416   if ((nn = INUM(n)) < 0) nn = -1 - nn;
 1417   for (; nn; nn >>= 4) c += logtab[15 & nn];
 1418   if (n < 0)
 1419     return MAKINUM(-1 - c);
 1420   return MAKINUM(c);
 1421 }
 1422 
 1423 SCM scm_logcount(n)
 1424      SCM n;
 1425 {
 1426   register unsigned long c = 0;
 1427   register long nn;
 1428 #ifdef BIGDIG
 1429   if (NINUMP(n)) {
 1430     ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_logcount);
 1431     if (BIGSIGN(n)) {
 1432       SCM df = difference(MAKINUM(-1L), n);
 1433       SCM bc = scm_bitwise_bit_count(df);
 1434       bigrecy(df);
 1435       return bc;
 1436     }
 1437     return scm_bitwise_bit_count(n);
 1438   }
 1439 #else
 1440   ASRTER(INUMP(n), n, ARG1, s_logcount);
 1441 #endif
 1442   if ((nn = INUM(n)) < 0) nn = -1 - nn;
 1443   for (; nn; nn >>= 4) c += logtab[15 & nn];
 1444   return MAKINUM(c);
 1445 }
 1446 
 1447 char ilentab[] = {0, 1, 2, 2, 3, 3, 3, 3, 4, 4, 4, 4, 4, 4, 4, 4};
 1448 SCM scm_intlength(n)
 1449      SCM n;
 1450 {
 1451   register unsigned long c = 0;
 1452   register long nn;
 1453   unsigned int l = 4;
 1454 #ifdef BIGDIG
 1455   if (NINUMP(n)) {
 1456     BIGDIG *ds, d;
 1457     ASRTER(NIMP(n) && BIGP(n), n, ARG1, s_intlength);
 1458     if (BIGSIGN(n)) {
 1459       SCM df = difference(MAKINUM(-1L), n);
 1460       SCM si = scm_intlength(df);
 1461       bigrecy(df);
 1462       return si;
 1463     }
 1464     ds = BDIGITS(n);
 1465     d = ds[c = NUMDIGS(n)-1];
 1466     for (c *= BITSPERDIG; d; d >>= 4) {c += 4; l = ilentab[15 & d];}
 1467     return MAKINUM(c - 4 + l);
 1468   }
 1469 #else
 1470   ASRTER(INUMP(n), n, ARG1, s_intlength);
 1471 #endif
 1472   if ((nn = INUM(n)) < 0) nn = -1 - nn;
 1473   for (;nn; nn >>= 4) {c += 4; l = ilentab[15 & nn];}
 1474   return MAKINUM(c - 4 + l);
 1475 }
 1476 
 1477 SCM charp(x)
 1478      SCM x;
 1479 {
 1480     return ICHRP(x) ? BOOL_T : BOOL_F;
 1481 }
 1482 SCM char_lessp(x, y)
 1483      SCM x, y;
 1484 {
 1485     ASRTER(ICHRP(x), x, ARG1, s_ch_lessp);
 1486     ASRTER(ICHRP(y), y, ARG2, s_ch_lessp);
 1487     return (ICHR(x) < ICHR(y)) ? BOOL_T : BOOL_F;
 1488 }
 1489 SCM char_leqp(x, y)
 1490      SCM x, y;
 1491 {
 1492     ASRTER(ICHRP(x), x, ARG1, s_ch_leqp);
 1493     ASRTER(ICHRP(y), y, ARG2, s_ch_leqp);
 1494     return (ICHR(x) <= ICHR(y)) ? BOOL_T : BOOL_F;
 1495 }
 1496 SCM char_grp(x, y)
 1497      SCM x, y;
 1498 {
 1499     ASRTER(ICHRP(x), x, ARG1, s_ch_grp);
 1500     ASRTER(ICHRP(y), y, ARG2, s_ch_grp);
 1501     return (ICHR(x) > ICHR(y)) ? BOOL_T : BOOL_F;
 1502 }
 1503 SCM char_geqp(x, y)
 1504      SCM x, y;
 1505 {
 1506     ASRTER(ICHRP(x), x, ARG1, s_ch_geqp);
 1507     ASRTER(ICHRP(y), y, ARG2, s_ch_geqp);
 1508     return (ICHR(x) >= ICHR(y)) ? BOOL_T : BOOL_F;
 1509 }
 1510 SCM chci_eq(x, y)
 1511      SCM x, y;
 1512 {
 1513     ASRTER(ICHRP(x), x, ARG1, s_ci_eq);
 1514     ASRTER(ICHRP(y), y, ARG2, s_ci_eq);
 1515     return (upcase[ICHR(x)]==upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
 1516 }
 1517 SCM chci_lessp(x, y)
 1518      SCM x, y;
 1519 {
 1520     ASRTER(ICHRP(x), x, ARG1, s_ci_lessp);
 1521     ASRTER(ICHRP(y), y, ARG2, s_ci_lessp);
 1522     return (upcase[ICHR(x)] < upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
 1523 }
 1524 SCM chci_leqp(x, y)
 1525      SCM x, y;
 1526 {
 1527     ASRTER(ICHRP(x), x, ARG1, s_ci_leqp);
 1528     ASRTER(ICHRP(y), y, ARG2, s_ci_leqp);
 1529     return (upcase[ICHR(x)] <= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
 1530 }
 1531 SCM chci_grp(x, y)
 1532      SCM x, y;
 1533 {
 1534     ASRTER(ICHRP(x), x, ARG1, s_ci_grp);
 1535     ASRTER(ICHRP(y), y, ARG2, s_ci_grp);
 1536     return (upcase[ICHR(x)] > upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
 1537 }
 1538 SCM chci_geqp(x, y)
 1539      SCM x, y;
 1540 {
 1541     ASRTER(ICHRP(x), x, ARG1, s_ci_geqp);
 1542     ASRTER(ICHRP(y), y, ARG2, s_ci_geqp);
 1543     return (upcase[ICHR(x)] >= upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
 1544 }
 1545 SCM char_alphap(chr)
 1546      SCM chr;
 1547 {
 1548     ASRTER(ICHRP(chr), chr, ARG1, s_ch_alphap);
 1549     return (isascii(ICHR(chr)) && isalpha(ICHR(chr))) ? BOOL_T : BOOL_F;
 1550 }
 1551 SCM char_nump(chr)
 1552      SCM chr;
 1553 {
 1554     ASRTER(ICHRP(chr), chr, ARG1, s_ch_nump);
 1555     return (isascii(ICHR(chr)) && isdigit(ICHR(chr))) ? BOOL_T : BOOL_F;
 1556 }
 1557 SCM char_whitep(chr)
 1558      SCM chr;
 1559 {
 1560     ASRTER(ICHRP(chr), chr, ARG1, s_ch_whitep);
 1561     return (isascii(ICHR(chr)) && isspace(ICHR(chr))) ? BOOL_T : BOOL_F;
 1562 }
 1563 SCM char_upperp(chr)
 1564      SCM chr;
 1565 {
 1566     ASRTER(ICHRP(chr), chr, ARG1, s_ch_upperp);
 1567     return (isascii(ICHR(chr)) && isupper(ICHR(chr))) ? BOOL_T : BOOL_F;
 1568 }
 1569 SCM char_lowerp(chr)
 1570      SCM chr;
 1571 {
 1572     ASRTER(ICHRP(chr), chr, ARG1, s_ch_lowerp);
 1573     return (isascii(ICHR(chr)) && islower(ICHR(chr))) ? BOOL_T : BOOL_F;
 1574 }
 1575 SCM char2int(chr)
 1576      SCM chr;
 1577 {
 1578     ASRTER(ICHRP(chr), chr, ARG1, s_char2int);
 1579     return MAKINUM(ICHR(chr));
 1580 }
 1581 SCM int2char(n)
 1582      SCM n;
 1583 {
 1584   ASRTER(INUMP(n), n, ARG1, s_int2char);
 1585   ASRTER((n >= INUM0) && (n < MAKINUM(CHAR_CODE_LIMIT)),
 1586      n, OUTOFRANGE, s_int2char);
 1587   return MAKICHR(INUM(n));
 1588 }
 1589 SCM char_upcase(chr)
 1590      SCM chr;
 1591 {
 1592     ASRTER(ICHRP(chr), chr, ARG1, s_ch_upcase);
 1593     return MAKICHR(upcase[ICHR(chr)]);
 1594 }
 1595 SCM char_downcase(chr)
 1596      SCM chr;
 1597 {
 1598     ASRTER(ICHRP(chr), chr, ARG1, s_ch_downcase);
 1599     return MAKICHR(downcase[ICHR(chr)]);
 1600 }
 1601 
 1602 SCM stringp(x)
 1603      SCM x;
 1604 {
 1605     if (IMP(x)) return BOOL_F;
 1606     return STRINGP(x) ? BOOL_T : BOOL_F;
 1607 }
 1608 SCM string(chrs)
 1609      SCM chrs;
 1610 {
 1611     SCM res;
 1612     register unsigned char *data;
 1613     long i = ilength(chrs);
 1614     ASRTER(i >= 0, chrs, ARG1, s_string);
 1615     res = makstr(i);
 1616     data = UCHARS(res);
 1617     for (;NNULLP(chrs);chrs = CDR(chrs)) {
 1618         ASRTER(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
 1619         *data++ = ICHR(CAR(chrs));
 1620     }
 1621     return res;
 1622 }
 1623 SCM make_string(k, chr)
 1624      SCM k, chr;
 1625 {
 1626     SCM res;
 1627     register unsigned char *dst;
 1628     register long i;
 1629     ASRTER(INUMP(k) && (k >= 0), k, ARG1, s_make_string);
 1630     i = INUM(k);
 1631     res = makstr(i);
 1632     dst = UCHARS(res);
 1633     if (!UNBNDP(chr)) {
 1634       ASRTER(ICHRP(chr), chr, ARG2, s_make_string);
 1635       for (i--;i >= 0;i--) dst[i] = ICHR(chr);
 1636     }
 1637     return res;
 1638 }
 1639 SCM st_length(str)
 1640      SCM str;
 1641 {
 1642     ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_length);
 1643     return MAKINUM(LENGTH(str));
 1644 }
 1645 SCM st_ref(str, k)
 1646      SCM str, k;
 1647 {
 1648     ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_ref);
 1649     ASRTER(INUMP(k), k, ARG2, s_st_ref);
 1650     ASRTER(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_ref);
 1651     return MAKICHR(UCHARS(str)[INUM(k)]);
 1652 }
 1653 SCM st_set(str, k, chr)
 1654      SCM str, k, chr;
 1655 {
 1656     ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_set);
 1657     ASRTER(INUMP(k), k, ARG2, s_st_set);
 1658     ASRTER(ICHRP(chr), chr, ARG3, s_st_set);
 1659     ASRTER(INUM(k) < LENGTH(str) && INUM(k) >= 0, k, OUTOFRANGE, s_st_set);
 1660     UCHARS(str)[INUM(k)] = ICHR(chr);
 1661     return UNSPECIFIED;
 1662 }
 1663 SCM st_equal(s1, s2)
 1664      SCM s1, s2;
 1665 {
 1666     register sizet i;
 1667     register unsigned char *c1, *c2;
 1668     ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_equal);
 1669     ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_equal);
 1670     i = LENGTH(s2);
 1671     if (LENGTH(s1) != i) return BOOL_F;
 1672     c1 = UCHARS(s1);
 1673     c2 = UCHARS(s2);
 1674     while(0 != i--) if (*c1++ != *c2++) return BOOL_F;
 1675     return BOOL_T;
 1676 }
 1677 SCM stci_equal(s1, s2)
 1678      SCM s1, s2;
 1679 {
 1680     register sizet i;
 1681     register unsigned char *c1, *c2;
 1682     ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_equal);
 1683     ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_equal);
 1684     i = LENGTH(s2);
 1685     if (LENGTH(s1) != i) return BOOL_F;
 1686     c1 = UCHARS(s1);
 1687     c2 = UCHARS(s2);
 1688     while(0 != i--) if (upcase[*c1++] != upcase[*c2++]) return BOOL_F;
 1689     return BOOL_T;
 1690 }
 1691 SCM st_lessp(s1, s2)
 1692      SCM s1, s2;
 1693 {
 1694     register sizet i, len;
 1695     register unsigned char *c1, *c2;
 1696     register int c;
 1697     ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_st_lessp);
 1698     ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_st_lessp);
 1699     len = LENGTH(s1);
 1700     i = LENGTH(s2);
 1701     if (len>i) i = len;
 1702     c1 = UCHARS(s1);
 1703     c2 = UCHARS(s2);
 1704     for (i = 0;i<len;i++) {
 1705         c = (*c1++ - *c2++);
 1706         if (c>0) return BOOL_F;
 1707         if (c<0) return BOOL_T;
 1708     }
 1709     return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
 1710 }
 1711 SCM st_leqp(s1, s2)
 1712      SCM s1, s2;
 1713 {
 1714   return BOOL_NOT(st_lessp(s2, s1));
 1715 }
 1716 SCM st_grp(s1, s2)
 1717      SCM s1, s2;
 1718 {
 1719   return st_lessp(s2, s1);
 1720 }
 1721 SCM st_geqp(s1, s2)
 1722      SCM s1, s2;
 1723 {
 1724   return BOOL_NOT(st_lessp(s1, s2));
 1725 }
 1726 SCM stci_lessp(s1, s2)
 1727      SCM s1, s2;
 1728 {
 1729     register sizet i, len;
 1730     register unsigned char *c1, *c2;
 1731     register int c;
 1732     ASRTER(NIMP(s1) && STRINGP(s1), s1, ARG1, s_stci_lessp);
 1733     ASRTER(NIMP(s2) && STRINGP(s2), s2, ARG2, s_stci_lessp);
 1734     len = LENGTH(s1);
 1735     i = LENGTH(s2);
 1736     if (len>i) i=len;
 1737     c1 = UCHARS(s1);
 1738     c2 = UCHARS(s2);
 1739     for (i = 0;i<len;i++) {
 1740         c = (upcase[*c1++] - upcase[*c2++]);
 1741         if (c>0) return BOOL_F;
 1742         if (c<0) return BOOL_T;
 1743     }
 1744     return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
 1745 }
 1746 SCM stci_leqp(s1, s2)
 1747      SCM s1, s2;
 1748 {
 1749   return BOOL_NOT(stci_lessp(s2, s1));
 1750 }
 1751 SCM stci_grp(s1, s2)
 1752      SCM s1, s2;
 1753 {
 1754   return stci_lessp(s2, s1);
 1755 }
 1756 SCM stci_geqp(s1, s2)
 1757      SCM s1, s2;
 1758 {
 1759   return BOOL_NOT(stci_lessp(s1, s2));
 1760 }
 1761 SCM substring(str, start, end)
 1762      SCM str, start, end;
 1763 {
 1764     long l;
 1765     ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_substring);
 1766     ASRTER(INUMP(start), start, ARG2, s_substring);
 1767     ASRTER(INUMP(end), end, ARG3, s_substring);
 1768     ASRTER(INUM(start) <= LENGTH(str), start, OUTOFRANGE, s_substring);
 1769     ASRTER(INUM(end) <= LENGTH(str), end, OUTOFRANGE, s_substring);
 1770     l = INUM(end)-INUM(start);
 1771     ASRTER(l >= 0, MAKINUM(l), OUTOFRANGE, s_substring);
 1772     return makfromstr(&CHARS(str)[INUM(start)], (sizet)l);
 1773 }
 1774 SCM st_append(args)
 1775      SCM args;
 1776 {
 1777     SCM res;
 1778     register long i = 0;
 1779     register SCM l, s;
 1780     register unsigned char *data;
 1781     for (l = args;NIMP(l);) {
 1782         ASRTER(CONSP(l), l, ARGn, s_st_append);
 1783         s = CAR(l);
 1784         ASRTER(NIMP(s) && STRINGP(s), s, ARGn, s_st_append);
 1785         i += LENGTH(s);
 1786         l = CDR(l);
 1787     }
 1788     ASRTER(NULLP(l), args, ARGn, s_st_append);
 1789     res = makstr(i);
 1790     data = UCHARS(res);
 1791     for (l = args;NIMP(l);l = CDR(l)) {
 1792         s = CAR(l);
 1793         for (i = 0;i<LENGTH(s);i++) *data++ = UCHARS(s)[i];
 1794     }
 1795     return res;
 1796 }
 1797 
 1798 SCM vectorp(x)
 1799      SCM x;
 1800 {
 1801     if (IMP(x)) return BOOL_F;
 1802     return VECTORP(x) ? BOOL_T : BOOL_F;
 1803 }
 1804 SCM vector_length(v)
 1805      SCM v;
 1806 {
 1807     ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
 1808     return MAKINUM(LENGTH(v));
 1809 }
 1810 SCM vector(l)
 1811      SCM l;
 1812 {
 1813     SCM res;
 1814     register SCM *data;
 1815     long i = ilength(l);
 1816     ASRTER(i >= 0, l, ARG1, s_vector);
 1817     res = make_vector(MAKINUM(i), UNSPECIFIED);
 1818     data = VELTS(res);
 1819     for (;NIMP(l);l = CDR(l)) *data++ = CAR(l);
 1820     return res;
 1821 }
 1822 SCM vector_ref(v, k)
 1823      SCM v, k;
 1824 {
 1825   ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_ref);
 1826   ASRTER(INUMP(k), k, ARG2, s_ve_ref);
 1827   ASRTER((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_ref);
 1828   return VELTS(v)[((long) INUM(k))];
 1829 }
 1830 SCM vector_set(v, k, obj)
 1831      SCM v, k, obj;
 1832 {
 1833   ASRTER(NIMP(v) && VECTORP(v), v, ARG1, s_ve_set);
 1834   ASRTER(INUMP(k), k, ARG2, s_ve_set);
 1835   ASRTER((INUM(k) < LENGTH(v)) && (INUM(k) >= 0), k, OUTOFRANGE, s_ve_set);
 1836   VELTS(v)[((long) INUM(k))] = obj;
 1837   return UNSPECIFIED;
 1838 }
 1839 char    s_make_vector[] = "make-vector";
 1840 SCM make_vector(k, fill)
 1841      SCM k, fill;
 1842 {
 1843   SCM v;
 1844   register long i;
 1845   register SCM *velts;
 1846 #ifdef SHORT_SIZET
 1847   ASRTER(INUMP(k), k, ARG1, s_make_vector);
 1848 #else
 1849   ASRTER(INUMP(k) && (!(~LENGTH_MAX & INUM(k))), k, ARG1, s_make_vector);
 1850 #endif
 1851   if (UNBNDP(fill)) fill = UNSPECIFIED;
 1852   i = INUM(k);
 1853   DEFER_INTS;
 1854   v = must_malloc_cell(i ? i*sizeof(SCM) : 1L,
 1855                MAKE_LENGTH(i, tc7_vector), s_vector);
 1856   velts = VELTS(v);
 1857   while(--i >= 0) (velts)[i] = fill;
 1858   ALLOW_INTS;
 1859   return v;
 1860 }
 1861 #ifdef BIGDIG
 1862 char s_big_OVFLOW[] = "numerical overflow; NUMDIGS_MAX <";
 1863 char s_bignum[] = "bignum";
 1864 SCM mkbig(nlen, sign)
 1865      sizet nlen;
 1866      int sign;
 1867 {
 1868   SCM v;
 1869   if (NUMDIGS_MAX <= nlen) wta(MAKINUM(nlen), s_big_OVFLOW, s_bignum);
 1870   DEFER_INTS;
 1871   v = must_malloc_cell((0L+nlen)*sizeof(BIGDIG),
 1872                MAKE_NUMDIGS(nlen, sign ? tc16_bigneg : tc16_bigpos),
 1873                s_bignum);
 1874   ALLOW_INTS;
 1875   return v;
 1876 }
 1877 /* big2inum() frees bignum b when it returns an INUM */
 1878 SCM big2inum(b, l)
 1879      SCM b;
 1880      sizet l;
 1881 {
 1882   unsigned long num = 0;
 1883   BIGDIG *tmp = BDIGITS(b);
 1884   while (l--) num = BIGUP(num) + tmp[l];
 1885   if (TYP16(b)==tc16_bigpos) {
 1886     if (POSFIXABLE(num)) {
 1887       bigrecy(b);
 1888       return MAKINUM(num);
 1889     }}
 1890   else if (UNEGFIXABLE(num)) {
 1891     bigrecy(b);
 1892     return MAKINUM(-(long)num);
 1893   }
 1894   return b;
 1895 }
 1896 char s_adjbig[] = "adjbig";
 1897 SCM adjbig(b, nlen)
 1898      SCM b;
 1899      sizet nlen;
 1900 {
 1901   long nsiz = nlen;
 1902   if (((nsiz << 16) >> 16) != nlen)
 1903     wta(MAKINUM(nsiz), s_big_OVFLOW, s_adjbig);
 1904   DEFER_INTS;
 1905   must_realloc_cell(b, (long)(NUMDIGS(b)*sizeof(BIGDIG)),
 1906             (long)(nsiz*sizeof(BIGDIG)), s_adjbig);
 1907   SETNUMDIGS(b, nsiz, TYP16(b));
 1908   ALLOW_INTS;
 1909   return b;
 1910 }
 1911 SCM normbig(b)
 1912      SCM b;
 1913 {
 1914 # ifndef _UNICOS
 1915   sizet nlen = NUMDIGS(b);
 1916 # else
 1917   int nlen = NUMDIGS(b);   /* unsigned nlen breaks on Cray when nlen => 0 */
 1918 # endif
 1919   BIGDIG *zds = BDIGITS(b);
 1920   while (nlen-- && !zds[nlen]); nlen++;
 1921   if (nlen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
 1922     if (INUMP(b = big2inum(b, (sizet)nlen))) return b;
 1923   if (NUMDIGS(b)==nlen) return b;
 1924   return adjbig(b, (sizet)nlen);
 1925 }
 1926 SCM copybig(b, sign)
 1927      SCM b;
 1928      int sign;
 1929 {
 1930   sizet i = NUMDIGS(b);
 1931   SCM ans = mkbig(i, sign);
 1932   BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
 1933   while (i--) dst[i] = src[i];
 1934   return ans;
 1935 }
 1936 SCM long2big(n)
 1937      long n;
 1938 {
 1939   sizet i = 0;
 1940   BIGDIG *digits;
 1941   SCM ans = mkbig(DIGSPERLONG, n<0);
 1942   digits = BDIGITS(ans);
 1943   if (n < 0) n = -n;
 1944   while (i < DIGSPERLONG) {
 1945     digits[i++] = BIGLO(n);
 1946     n = BIGDN(n);
 1947   }
 1948   return ans;
 1949 }
 1950 SCM ulong2big(n)
 1951      unsigned long n;
 1952 {
 1953   sizet i = 0;
 1954   BIGDIG *digits;
 1955   SCM ans = mkbig(DIGSPERLONG, 0);
 1956   digits = BDIGITS(ans);
 1957   while (i < DIGSPERLONG) {
 1958     digits[i++] = BIGLO(n);
 1959     n = BIGDN(n);
 1960   }
 1961   return ans;
 1962 }
 1963 
 1964 int bigcomp(x, y)
 1965      SCM x, y;
 1966 {
 1967   int xsign = BIGSIGN(x);
 1968   int ysign = BIGSIGN(y);
 1969   long xlen;
 1970   sizet ylen;
 1971   if (ysign < xsign) return 1;
 1972   if (ysign > xsign) return -1;
 1973   if ((ylen = NUMDIGS(y)) > (xlen = NUMDIGS(x))) return (xsign) ? -1 : 1;
 1974   if (ylen < xlen) return (xsign) ? 1 : -1;
 1975   while (xlen-- && (BDIGITS(y)[xlen]==BDIGITS(x)[xlen]));
 1976   if (-1==xlen) return 0;
 1977   return (BDIGITS(y)[xlen] > BDIGITS(x)[xlen]) ?
 1978     (xsign ? -1 : 1) : (xsign ? 1 : -1);
 1979 }
 1980 
 1981 # ifndef DIGSTOOBIG
 1982 long pseudolong(x)
 1983     long x;
 1984 {
 1985   union {
 1986     long l;
 1987     BIGDIG bd[DIGSPERLONG];
 1988   } p;
 1989   sizet i = 0;
 1990   if (x < 0) x = -x;
 1991   while (i < DIGSPERLONG) {p.bd[i++] = BIGLO(x); x = BIGDN(x);}
 1992 /*  p.bd[0] = BIGLO(x); p.bd[1] = BIGDN(x); */
 1993   return p.l;
 1994 }
 1995 # else
 1996 void longdigs(x, digs)
 1997      long x;
 1998      BIGDIG digs[DIGSPERLONG];
 1999 {
 2000   sizet i = 0;
 2001   if (x < 0) x = -x;
 2002   while (i < DIGSPERLONG) {digs[i++] = BIGLO(x); x = BIGDN(x);}
 2003 }
 2004 # endif
 2005 
 2006 SCM addbig(x, nx, xsgn, bigy, sgny)
 2007      BIGDIG *x;
 2008      SCM bigy;
 2009      sizet nx;      /* Assumes nx <= NUMDIGS(bigy) */
 2010      int xsgn, sgny;    /* Assumes xsgn and sgny equal either 0 or 0x0100 */
 2011 {
 2012   SBIGLONG num = 0;
 2013   sizet i = 0, ny = NUMDIGS(bigy);
 2014   SCM z = copybig(bigy, BIGSIGN(bigy) ^ sgny);
 2015   BIGDIG *zds = BDIGITS(z);
 2016   if (xsgn ^ BIGSIGN(z)) {
 2017     do {
 2018       num += (long) zds[i] - x[i];
 2019       if (num < 0) {zds[i] = num + BIGRAD; num = -1;}
 2020       else {zds[i] = BIGLO(num); num = 0;}
 2021     } while (++i < nx);
 2022     if (num && nx==ny) {
 2023       num = 1; i = 0;
 2024       CAR(z) ^= 0x0100;
 2025       do {
 2026     num += (BIGRAD-1) - zds[i];
 2027     zds[i++] = BIGLO(num);
 2028     num = BIGDN(num);
 2029       } while (i < ny);
 2030     }
 2031     else while (i < ny) {
 2032       num += zds[i];
 2033       if (num < 0) {zds[i++] = num + BIGRAD; num = -1;}
 2034       else {zds[i++] = BIGLO(num); num = 0;}
 2035     }
 2036   } else {
 2037     do {
 2038       num += (long) zds[i] + x[i];
 2039       zds[i++] = BIGLO(num);
 2040       num = BIGDN(num);
 2041     } while (i < nx);
 2042     if (!num) return z;
 2043     while (i < ny) {
 2044       num += zds[i];
 2045       zds[i++] = BIGLO(num);
 2046       num = BIGDN(num);
 2047       if (!num) return z;
 2048     }
 2049     if (num) {z = adjbig(z, ny+1); BDIGITS(z)[ny] = num; return z;}
 2050   }
 2051   return normbig(z);
 2052 }
 2053 
 2054 SCM mulbig(x, nx, y, ny, sgn)
 2055      BIGDIG *x, *y;
 2056      sizet nx, ny;
 2057      int sgn;
 2058 {
 2059   sizet i = 0, j = nx + ny;
 2060   UBIGLONG n = 0;
 2061   SCM z = mkbig(j, sgn);
 2062   BIGDIG *zds = BDIGITS(z);
 2063   while (j--) zds[j] = 0;
 2064   do {
 2065     j = 0;
 2066     if (x[i]) {
 2067       do {
 2068     n += zds[i + j] + ((UBIGLONG) x[i] * y[j]);
 2069     zds[i + j++] = BIGLO(n);
 2070     n = BIGDN(n);
 2071       } while (j < ny);
 2072       if (n) {zds[i + j] = n; n = 0;}
 2073     }
 2074   } while (++i < nx);
 2075   return normbig(z);
 2076 }
 2077 UBIGLONG divbigdig(ds, h, div)
 2078      BIGDIG *ds;
 2079      sizet h;
 2080      BIGDIG div;
 2081 {
 2082   register UBIGLONG t2 = 0L;
 2083   while(h--) {
 2084     t2 = BIGUP(t2) + ds[h];
 2085     ds[h] = t2 / div;
 2086     t2 %= div;
 2087   }
 2088   return t2;
 2089 }
 2090 SCM divbigint(x, z, sgn, mode)
 2091      SCM x;
 2092      long z;
 2093      int sgn, mode;
 2094 {
 2095   if (z < 0) z = -z;
 2096   if (z < BIGRAD) {
 2097     register UBIGLONG t2 = 0;
 2098     register BIGDIG *ds = BDIGITS(x);
 2099     sizet nd = NUMDIGS(x);
 2100     while(nd--) t2 = (BIGUP(t2) + ds[nd]) % z;
 2101     if (mode && t2) t2 = z - t2;
 2102     return MAKINUM(sgn ? -(long)t2 : t2);
 2103   }
 2104   {
 2105 # ifndef DIGSTOOBIG
 2106     UBIGLONG t2 = pseudolong(z);
 2107     return divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&t2,
 2108              DIGSPERLONG, sgn, mode);
 2109 # else
 2110     BIGDIG t2[DIGSPERLONG];
 2111     longdigs(z, t2);
 2112     return divbigbig(BDIGITS(x), NUMDIGS(x), t2, DIGSPERLONG, sgn, mode);
 2113 # endif
 2114   }
 2115 }
 2116 
 2117 static SCM scm_copy_big_ash1 P((BIGDIG *xds, sizet xlen, BIGDIG dscl));
 2118 /* Make a copy of 2*xds and divide by dscl if dscl > 0 */
 2119 SCM scm_copy_big_ash1 (xds, xlen, dscl)
 2120      BIGDIG *xds;
 2121      sizet xlen;
 2122      BIGDIG dscl;
 2123 {
 2124   sizet rlen = xlen + 1, i;
 2125   SCM dencell = mkbig(rlen, 0);
 2126   BIGDIG *dends = BDIGITS(dencell);
 2127   dends[xlen] = xds[xlen-1]>>(BITSPERDIG - 1);
 2128   for (i = xlen - 1; i > 0; i--)
 2129     dends[i] = (((xds[i])<<1) & (BIGRAD - 1))
 2130       | ((xds[i-1])>>(BITSPERDIG - 1));
 2131   dends[0] = (((xds[0])<<1) & (BIGRAD - 1));
 2132   while(rlen && !dends[rlen-1]) rlen--;
 2133   if (dscl) {
 2134     divbigdig(dends, rlen, dscl);
 2135     while(rlen && !dends[rlen-1]) rlen--;
 2136   }
 2137   SETNUMDIGS(dencell, rlen, TYP16(dencell));
 2138   return dencell;
 2139 }
 2140 
 2141 SCM divbigbig(x, xlen, y, ylen, sgn, mode)
 2142      BIGDIG *x, *y;
 2143      sizet xlen, ylen;
 2144      int sgn, mode;
 2145      /* mode description
 2146     0   remainder
 2147     1   modulo
 2148     2   quotient
 2149     3   quotient with round-toward-even
 2150     4   quotient but returns NULL if division is not exact. */
 2151 {
 2152   int roundup = 0;      /* used for round-quotient */
 2153   sizet i = 0, j = 0;       /* loop indexes */
 2154   SBIGLONG dds = 0;     /* double-digit signed */
 2155   UBIGLONG ddu = 0;     /* double-digit unsigned */
 2156   SCM quocell, dencell;
 2157   sizet rlen;
 2158   BIGDIG *quods,        /* quotient digits */
 2159     *dends,         /* scaled denominator digits */
 2160     dscl = 0,           /* unscale quotient from scaled divisor */
 2161     qhat;
 2162   while(!y[ylen-1]) ylen--;    /* in case y came in as a psuedolong */
 2163   if (xlen < ylen)
 2164     switch (mode) {
 2165     case 0:         /* remainder -- just return x */
 2166       quocell = mkbig(xlen, sgn); quods = BDIGITS(quocell);
 2167       do {quods[i] = x[i];} while (++i < xlen);
 2168       return quocell;
 2169     case 1:         /* modulo -- return y-x */
 2170       quocell = mkbig(ylen, sgn); quods = BDIGITS(quocell);
 2171       do {
 2172     dds += (long) y[i] - x[i];
 2173     if (dds < 0) {quods[i] = dds + BIGRAD; dds = -1;}
 2174     else {quods[i] = dds; dds = 0;}
 2175       } while (++i < xlen);
 2176       while (i < ylen) {
 2177     dds += y[i];
 2178     if (dds < 0) {quods[i++] = dds + BIGRAD; dds = -1;}
 2179     else {quods[i++] = dds; dds = 0;}
 2180       }
 2181       goto doadj;
 2182     case 2: return INUM0;   /* quotient is zero */
 2183     case 3:         /* round-toward-even */
 2184       /* Use dencell and dends variables to double the numerator */
 2185       dencell = scm_copy_big_ash1(x, xlen, dscl);
 2186       dends = BDIGITS(dencell);
 2187       rlen = NUMDIGS(dencell);
 2188       if (rlen < ylen) return INUM0;;
 2189       if (rlen > ylen) goto retone;
 2190       i = rlen;
 2191       while (i-- && (y[i]==dends[i]));
 2192       if (-1==i || (y[i] > dends[i])) return INUM0;
 2193     retone:
 2194       return MAKINUM(sgn ? -1 : 1);
 2195     case 4: return 0;       /* the division is not exact */
 2196     }
 2197   /* main algorithm requires xlen >= ylen */
 2198   quocell = mkbig(xlen==ylen ? xlen+2 : xlen+1, sgn); quods = BDIGITS(quocell);
 2199   if (xlen==ylen) quods[xlen+1] = 0;
 2200   if (y[ylen-1] < (BIGRAD>>1)) { /* normalize operands */
 2201     dscl = BIGRAD/(y[ylen-1]+1);
 2202     dencell = mkbig(ylen, 0); dends = BDIGITS(dencell);
 2203     while(j < ylen) {
 2204       ddu += (UBIGLONG) y[j]*dscl;
 2205       dends[j++] = BIGLO(ddu); ddu = BIGDN(ddu);
 2206     }
 2207     j = 0; ddu = 0;     /* y = dends; */
 2208     while(j < xlen) {
 2209       ddu += (UBIGLONG) x[j]*dscl;
 2210       quods[j++] = BIGLO(ddu); ddu = BIGDN(ddu);
 2211     }
 2212     quods[j] = ddu;
 2213   } else {
 2214     dends = y;
 2215     quods[j = xlen] = 0;
 2216     while (j--) quods[j] = x[j];
 2217   }
 2218   j = xlen==ylen ? xlen+1 : xlen;   /* dividend needs more digits than divisor */
 2219   do {              /* loop over digits of quotient */
 2220     if (quods[j]==dends[ylen-1]) qhat = BIGRAD-1;
 2221     else qhat = (BIGUP(quods[j]) + quods[j-1])/dends[ylen-1];
 2222     if (!qhat) continue;
 2223     i = 0; dds = 0; ddu = 0;
 2224     do {            /* multiply and subtract */
 2225       ddu += (UBIGLONG) dends[i] * qhat;
 2226       dds += quods[j - ylen + i] - BIGLO(ddu);
 2227       if (dds < 0) {quods[j - ylen + i] = dds + BIGRAD; dds = -1;}
 2228       else {quods[j - ylen + i] = dds; dds = 0;}
 2229       ddu = BIGDN(ddu);
 2230     } while (++i < ylen);
 2231     dds += quods[j - ylen + i] - ddu; /* borrow from high digit; don't update */
 2232     while (dds) {       /* "add back" required */
 2233       i = 0; dds = 0; qhat--;
 2234       do {
 2235     dds += (long) quods[j - ylen + i] + dends[i];
 2236     quods[j - ylen + i] = BIGLO(dds);
 2237     dds = BIGDN(dds);
 2238       } while (++i < ylen);
 2239       dds--;
 2240     }
 2241     if (mode >= 2) quods[j] = qhat; /* returning quotient */
 2242   } while (--j >= ylen);
 2243   switch (mode) {
 2244   case 4:           /* check that remainder==0 */
 2245     for (j = ylen;j && !quods[j-1];--j) ; if (j) return 0;
 2246   case 3:           /* round toward even */
 2247     /* Reuse dencell and dends variables to double the remainder */
 2248     dencell = scm_copy_big_ash1(quods, ylen, dscl);
 2249     dends = BDIGITS(dencell);
 2250     rlen = NUMDIGS(dencell);
 2251     if (rlen > ylen) roundup = 1;
 2252     else if (rlen < ylen) ;
 2253     else {
 2254       i = rlen;
 2255       while (i-- && (y[i]==dends[i]));
 2256       if (-1==i) {
 2257         if (0==roundup && quods[ylen] & 1) roundup = 1;
 2258       } else if (y[i] < dends[i]) roundup = 1;
 2259     }
 2260   case 2:           /* move quotient down in quocell */
 2261     j = (xlen==ylen ? xlen+2 : xlen+1) - ylen;
 2262     for (i = 0;i < j;i++) quods[i] = quods[i+ylen];
 2263     ylen = i;
 2264     if (roundup) {
 2265       i = 0; dds = 1;
 2266       while (i < ylen) {
 2267     dds += quods[i];
 2268     quods[i++] = BIGLO(dds);
 2269     dds = BIGDN(dds);
 2270     if (!dds) break;
 2271       }
 2272     }
 2273     break;
 2274   case 1:           /* subtract for modulo */
 2275     i = 0; dds = 0; j = 0;
 2276     do {dds += dends[i] - quods[i];
 2277       j = j | quods[i];
 2278       if (dds < 0) {quods[i] = dds + BIGRAD; dds = -1;}
 2279       else {quods[i] = dds; dds = 0;}
 2280     } while (++i < ylen);
 2281     if (!j) return INUM0;
 2282   case 0:           /* just normalize remainder */
 2283     if (dscl) divbigdig(quods, ylen, dscl);
 2284   }
 2285  doadj:
 2286   for (j = ylen;j && !quods[j-1];--j) ;
 2287   if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT)
 2288     if (INUMP(quocell = big2inum(quocell, j))) return quocell;
 2289   return adjbig(quocell, j);
 2290 }
 2291 #endif
 2292 
 2293 static iproc cxrs[] = {
 2294     {"cr", 0},
 2295     {"car", 0}, {"cdr", 0},
 2296     {"caar", 0}, {"cadr", 0}, {"cdar", 0}, {"cddr", 0},
 2297     {"caaar", 0}, {"caadr", 0}, {"cadar", 0}, {"caddr", 0},
 2298     {"cdaar", 0}, {"cdadr", 0}, {"cddar", 0}, {"cdddr", 0},
 2299     {"caaaar", 0}, {"caaadr", 0}, {"caadar", 0}, {"caaddr", 0},
 2300     {"cadaar", 0}, {"cadadr", 0}, {"caddar", 0}, {"cadddr", 0},
 2301     {"cdaaar", 0}, {"cdaadr", 0}, {"cdadar", 0}, {"cdaddr", 0},
 2302     {"cddaar", 0}, {"cddadr", 0}, {"cdddar", 0}, {"cddddr", 0},
 2303     {0, 0}};
 2304 
 2305 static iproc subr1s[] = {
 2306     {"not", lnot},
 2307     {"boolean?", booleanp},
 2308     {"pair?", consp},
 2309     {"null?", nullp},
 2310     {"list?", listp},
 2311     {s_length, length},
 2312     {s_reverse, reverse},
 2313     {"symbol?", symbolp},
 2314     {s_symbol2string, symbol2string},
 2315     {s_str2symbol, string2symbol},
 2316     {s_exactp, exactp},
 2317     {s_oddp, oddp},
 2318     {s_evenp, evenp},
 2319     {s_lognot, scm_lognot},
 2320     {s_logcount, scm_logcount},
 2321     {s_bitwise_bit_count, scm_bitwise_bit_count},
 2322     {s_intlength, scm_intlength},
 2323     {"char?", charp},
 2324     {s_ch_alphap, char_alphap},
 2325     {s_ch_nump, char_nump},
 2326     {s_ch_whitep, char_whitep},
 2327     {s_ch_upperp, char_upperp},
 2328     {s_ch_lowerp, char_lowerp},
 2329     {s_char2int, char2int},
 2330     {s_int2char, int2char},
 2331     {s_ch_upcase, char_upcase},
 2332     {s_ch_downcase, char_downcase},
 2333     {"string?", stringp},
 2334     {s_st_length, st_length},
 2335     {"vector?", vectorp},
 2336     {s_ve_length, vector_length},
 2337     {"procedure?", procedurep},
 2338     {"promise?", promisep},
 2339     {0, 0}};
 2340 
 2341 static char s_acons[] = "acons";
 2342 static iproc subr2s[] = {
 2343     {&s_acons[1], cons},
 2344     {s_setcar, setcar},
 2345     {s_setcdr, setcdr},
 2346     {s_list_ref, list_ref},
 2347     {s_memq, memq},
 2348     {s_member, member},
 2349     {s_assq, assq},
 2350     {s_assoc, assoc},
 2351     {s_quotient, lquotient},
 2352     /* {"rq", rq}, */
 2353     {s_rquotient, scm_round_quotient},
 2354     {s_remainder, lremainder},
 2355     {s_modulo, modulo},
 2356     {s_logtest, scm_logtest},
 2357     {s_logbitp, scm_logbitp},
 2358     {s_ash, scm_ash},
 2359     {s_st_ref, st_ref},
 2360     {"string<=?", st_leqp},
 2361     {"string-ci<=?", stci_leqp},
 2362     {s_ve_ref, vector_ref},
 2363     {0, 0}};
 2364 
 2365 static iproc lsubrs[] = {
 2366     {s_list, list},
 2367     {s_append, append},
 2368     {s_string, string},
 2369     {s_st_append, st_append},
 2370     {s_vector, vector},
 2371     {0, 0}};
 2372 
 2373 static iproc subr2os[] = {
 2374     {s_make_string, make_string},
 2375     {s_make_vector, make_vector},
 2376     {0, 0}};
 2377 
 2378 static iproc asubrs[] = {
 2379     {s_gcd, lgcd},
 2380     {"lcm", llcm},
 2381     {s_logand, scm_logand},
 2382     {s_logior, scm_logior},
 2383     {s_logxor, scm_logxor},
 2384     {0, 0}};
 2385 
 2386 static iproc rpsubrs[] = {
 2387     {"eq?", eq},
 2388     {"equal?", equal},
 2389     {"char=?", eq},
 2390     {s_ch_lessp, char_lessp},
 2391     {s_ci_eq, chci_eq},
 2392     {s_ci_lessp, chci_lessp},
 2393     {s_ch_leqp, char_leqp},
 2394     {s_ci_leqp, chci_leqp},
 2395     {s_ch_grp, char_grp},
 2396     {s_ci_grp, chci_grp},
 2397     {s_ch_geqp, char_geqp},
 2398     {s_ci_geqp, chci_geqp},
 2399 
 2400     {s_st_equal, st_equal},
 2401     {s_stci_equal, stci_equal},
 2402     {s_st_lessp, st_lessp},
 2403     {s_stci_lessp, stci_lessp},
 2404     {"string>?", st_grp},
 2405     {"string-ci>?", stci_grp},
 2406     {"string>=?", st_geqp},
 2407     {"string-ci>=?", stci_geqp},
 2408     {0, 0}};
 2409 
 2410 static iproc subr3s[] = {
 2411     {s_bitfield, scm_bitfield},
 2412     {s_bitif, scm_bitif},
 2413     {s_copybit, scm_copybit},
 2414     {s_substring, substring},
 2415     {s_acons, acons},
 2416     {s_st_set, st_set},
 2417     {s_ve_set, vector_set},
 2418     {0, 0}};
 2419 
 2420 void init_iprocs(subra, type)
 2421      iproc *subra;
 2422      int type;
 2423 {
 2424   for (;subra->string; subra++)
 2425     make_subr(subra->string,
 2426           type,
 2427           subra->cproc);
 2428 }
 2429 
 2430 void init_subrs()
 2431 {
 2432   init_iprocs(cxrs, tc7_cxr);
 2433   init_iprocs(subr1s, tc7_subr_1);
 2434   init_iprocs(subr2s, tc7_subr_2);
 2435   init_iprocs(subr2os, tc7_subr_2o);
 2436   init_iprocs(rpsubrs, tc7_rpsubr);
 2437   init_iprocs(lsubrs, tc7_lsubr);
 2438   init_iprocs(asubrs, tc7_asubr);
 2439   init_iprocs(subr3s, tc7_subr_3);
 2440   make_subr(s_copybitfield, tc7_lsubr_2, scm_copybitfield);
 2441 }