/* Scheme implementation intended for JACAL.
   Copyright (C) 1990, 1991, 1992, 1993 Aubrey Jaffer.

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 1, 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 program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

The author can be reached at jaffer@ai.mit.edu or
Aubrey Jaffer, 84 Pleasant St., Wakefield MA 01880
*/

#include <ctype.h>
#include "scm.h"

#define	s_length (s_st_length+7)
#define s_append (s_st_append+7)

char	scm_s_make_string[] = "make-string";
char	scm_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",
	s_str2osymbol[] = "intern-string",
	s_intern_symbol[] = "intern-symbol!",
	s_unintern_symbol[] = "unintern-symbol!",
        s_symbol_binding[] = "symbol-binding",
	s_symbol_bound[] = "symbol-bound?",
	s_symbol_internedp[] = "symbol-interned?",
        s_symbol_set[] = "symbol-set!";
extern char scm_s_inexactp[];
#define s_exactp (scm_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_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";

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 scm_lnot(x)
SCM x;
{
	return FALSEP(x) ? BOOL_T : BOOL_F;
}
SCM scm_booleanp(obj)
SCM obj;
{
	if (BOOL_F==obj) return BOOL_T;
	if (BOOL_T==obj) return BOOL_T;
	return BOOL_F;
}
SCM scm_eq(x, y)
SCM x, y;
{
	if (x==y) return BOOL_T;
	else return BOOL_F;
}

SCM scm_consp(x)
SCM x;
{
	if IMP(x) return BOOL_F;
	return CONSP(x) ? BOOL_T : BOOL_F;
}
SCM scm_setcar(pair, value)
SCM pair, value;
{
	ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcar);
	CAR(pair) = value;
	return UNSPECIFIED;
}
SCM scm_setcdr(pair, value)
SCM pair, value;
{
	ASSERT(NIMP(pair) && CONSP(pair), pair, ARG1, s_setcdr);
	CDR(pair) = value;
	return UNSPECIFIED;
}
SCM scm_nullp(x)
SCM x;
{
	return NULLP(x) ? BOOL_T : BOOL_F;
}
long scm_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 -1;
		x = CDR(x);
		i++;
		if IMP(x) return NULLP(x) ? i : -1;
		if NCONSP(x) return -1;
		x = CDR(x);
		i++;
		sx = CDR(sx);
	}
	while (x != sx);
	return -1;
}
SCM scm_listp(x)
SCM x;
{
	if (scm_ilength(x)<0) return BOOL_F;
	else return BOOL_T;
}
SCM scm_list(objs)
SCM objs;
{
	return objs;
}
static char s_list_length[] = "list-length";
SCM scm_list_length(x)
     SCM x;
{
  int i;
  i = scm_ilength(x);
  ASSERT(i >= 0, x, ARG1, s_length);
  return MAKINUM (i);
}
SCM scm_length(x)
SCM x;
{
  int i;
  i = scm_ilength(x);
  if (i >= 0)
    return MAKINUM (i);
  else
    {
      ASSERT(NIMP (x), x, ARG1, s_length);
      if (ROSTRINGP (x))
	return LENGTH (x);
      else if (VECTORP (x))
	return LENGTH (x);
      else
	ASSERT(0, x, ARG1, s_length);
    }
  return i;
}
SCM 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 = scm_cons(CAR(arg), EOL);
			lloc = &CDR(*lloc);
		}
		ASSERT(NULLP(arg), arg, ARGn, s_append);
	}
}
SCM 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 = scm_cons(CAR(p), res);
	}
	ASSERT(NULLP(p), lst, ARG1, s_reverse);
	return res;
}
SCM 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 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 scm_member(x, lst)
SCM x, lst;
{
	for(;NIMP(lst);lst = CDR(lst)) {
		ASSERT(CONSP(lst), lst, ARG2, s_member);
		if NFALSEP(scm_equal(CAR(lst), x)) return lst;
	}
	ASSERT(NULLP(lst), lst, ARG2, s_member);
	return BOOL_F;
}
SCM 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 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(scm_equal(CAR(tmp), x)) return tmp;
	}
	ASSERT(NULLP(alist), alist, ARG2, s_assoc);
	return BOOL_F;
}
static char s_delq[] = "delq!";
SCM scm_delq (item, lst)
     SCM item;
     SCM lst;
{
  SCM start;
  if (lst == EOL)
    return EOL;

  start = lst;
  ASSERT (CONSP (lst), lst, ARG2, s_delq);
  if (CAR (lst) == item)
    return CDR (lst);

  while (CDR(lst) != EOL)
    {
      ASSERT (CONSP (CDR(lst)), lst, ARG2, s_delq);
      if (CAR (CDR (lst)) == item)
	{
	  SETCDR (lst, CDR (CDR (lst)));
	  return start;
	}
      lst = CDR (lst);
    }
  return start;
}
SCM scm_symbolp(x)
SCM x;
{
	if IMP(x) return BOOL_F;
	return SYMBOLP(x) ? BOOL_T : BOOL_F;
}
SCM scm_symbol2string(s)
SCM s;
{
	ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol2string);
	return scm_makfromstr(CHARS(s), (sizet)LENGTH(s), 0);
}
SCM scm_string2symbol(s)
SCM s;
{
	ASSERT(NIMP(s) && ROSTRINGP(s), s, ARG1, s_str2symbol);
	s = scm_intern(CHARS(s), (sizet)LENGTH(s));
	return CAR(s);
}
SCM scm_string2osymbol(o, s)
SCM o;
SCM s;
{
	ASSERT(NIMP(s) && ROSTRINGP(s), s, ARG2, s_str2osymbol);
	ASSERT((o == BOOL_F) || (NIMP(s) && VECTORP(o)),
	       o, ARG1, s_str2osymbol);
	s = scm_intern_obarray (CHARS(s), (sizet)LENGTH(s), o);
	return CAR(s);
}
SCM scm_intern_symbol(o, s)
SCM o;
SCM s;
{
        sizet hval;
	ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_intern_symbol);
	if (o == BOOL_F)
	  o = symhash;
	ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_intern_symbol);
	hval = scm_strhash (UCHARS (s), LENGTH (s), LENGTH(o));
	/* If the symbol is already interned, simply return. */
	{
	  SCM lsym;
	  SCM sym;
	  for (lsym = VELTS (o)[hval];
	       NIMP (lsym);
	       lsym = CDR (lsym))
	    {
	      sym = CAR (lsym);
	      if (CAR (sym) == s)
		return UNSPECIFIED;
	    }
	  VELTS (o)[hval] =
	    scm_acons (s, SCM_UNDEFINED, VELTS (o)[hval]);
	}
	return UNSPECIFIED;
}
SCM scm_unintern_symbol(o, s)
SCM o;
SCM s;
{
        sizet hval;
	ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_unintern_symbol);
	if (o == BOOL_F)
	  o = symhash;
	ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_unintern_symbol);
	hval = scm_strhash (UCHARS (s), LENGTH (s), LENGTH(o));
	{
	  SCM lsym_follow;
	  SCM lsym;
	  SCM sym;
	  for (lsym = VELTS (o)[hval], lsym_follow = BOOL_F;
	       NIMP (lsym);
	       lsym_follow = lsym, lsym = CDR (lsym))
	    {
	      sym = CAR (lsym);
	      if (CAR (sym) == s)
		{
		  /* Found the symbol to unintern. */
		  if (lsym_follow == BOOL_F)
		    VELTS(o)[hval] = lsym;
		  else
		    CDR(lsym_follow) = CDR(lsym);
		  return BOOL_T;
		}
	    }
	}
	return BOOL_F;
}
SCM scm_symbol_binding (o, s)
SCM o;
SCM s;
{
  SCM vcell;
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_binding);
  if (o == BOOL_F)
    o = symhash;
  ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_binding);
  vcell = scm_sym2ovcell (s, o);
  return CDR(vcell);
}
SCM
scm_symbol_internedp (o, s)
     SCM o;
     SCM s;
{
  SCM vcell;
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_internedp);
  if (o == BOOL_F)
    o = symhash;
  ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_internedp);
  vcell = scm_sym2ovcell_soft (s, o);
  return (NIMP(vcell)
	  ? BOOL_T
	  : BOOL_F);
}
SCM 
scm_symbol_bound (o, s)
SCM o;
SCM s;
{
  SCM vcell;
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_bound);
  if (o == BOOL_F)
    o = symhash;
  ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_bound);
  vcell = scm_sym2ovcell_soft (s, o);
  return ((  NIMP(vcell)
	   && (CDR(vcell) != SCM_UNDEFINED))
	  ? BOOL_T
	  : BOOL_F);
}
SCM scm_symbol_set (o, s, v)
SCM o;
SCM s;
SCM v;
{
  SCM vcell;
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG2, s_symbol_set);
  if (o == BOOL_F)
    o = symhash;
  ASSERT(NIMP(o) && VECTORP(o), o, ARG1, s_symbol_set);
  vcell = scm_sym2ovcell (s, o);
  CDR(vcell) = v;
  return UNSPECIFIED;
}
static void
msymbolize (s)
     SCM s;
{
  SCM string;
  string = scm_makfromstr (CHARS (s), LENGTH (s), SYMBOL_SLOTS);
  DEFER_INTS;
  CHARS (s) = CHARS (string);
  SETLENGTH (s, LENGTH (s), tc7_msymbol);
  CDR (string) = EOL;
  CAR (string) = EOL;
  ALLOW_INTS;
}
static char s_symbol_fref[]="symbol-fref";
SCM
scm_symbol_fref (s)
     SCM s;
{
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_fref);
  if (TYP7(s) == tc7_ssymbol)
    msymbolize (s);
  return SYMBOL_FUNC (s);
}
static char s_symbol_pref[]="symbol-pref";
SCM
scm_symbol_pref (s)
     SCM s;
{
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_pref);
  if (TYP7(s) == tc7_ssymbol)
    msymbolize (s);
  return SYMBOL_PROPS (s);
}
static char s_symbol_fset[]="symbol-fset!";
SCM
scm_symbol_fset (s, val)
     SCM s;
     SCM val;
{
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_fset);
  if (TYP7(s) == tc7_ssymbol)
    msymbolize (s);
  SYMBOL_FUNC (s) = val;
  return UNSPECIFIED;
}
static char s_symbol_pset[]="symbol-pset!";
SCM
scm_symbol_pset (s, val)
     SCM s;
     SCM val;
{
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_pset);
  if (TYP7(s) == tc7_ssymbol)
    msymbolize (s);
  SYMBOL_PROPS (s) = val;
  return UNSPECIFIED;
}
static char s_symbol_hash[]="symbol-hash!";
SCM
scm_symbol_hash (s)
     SCM s;
{
  ASSERT(NIMP(s) && SYMBOLP(s), s, ARG1, s_symbol_hash);
  return MAKINUM ((unsigned long)s ^ SYMBOL_HASH (s));
}
SCM 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 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 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 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 scm_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 scm_long2big(x);
#else
    scm_wta(MAKINUM(-x), (char *)OVFLOW, s_abs);
#endif
  return MAKINUM(x);
}
SCM 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 scm_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 = scm_copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
      scm_divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z);
      return scm_normbig(w);
    }
#ifndef DIGSTOOBIG
    w = scm_pseudolong(z);
    return scm_divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&w, DIGSPERLONG,
		     BIGSIGN(x) ? (y>0) : (y<0), 2);
#else
    { BIGDIG zdigs[DIGSPERLONG];
      longdigs(z, zdigs);
      return scm_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: scm_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: scm_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 scm_long2big(z);
#else
  scm_wta(x, (char *)OVFLOW, s_quotient);
#endif
  return MAKINUM(z);
}
SCM 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 scm_divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
		       BIGSIGN(x), 0);
    }
    if (!(z = INUM(y))) goto ov;
    return scm_divbigint(x, z, BIGSIGN(x), 0);
  }
  if NINUMP(y) {
# ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: scm_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: scm_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 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 scm_divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
		       BIGSIGN(y), (BIGSIGN(x) ^ BIGSIGN(y)) ? 1 : 0);
    }
    if (!(z = INUM(y))) goto ov;
    return scm_divbigint(x, z, y < 0, (BIGSIGN(x) ? (y > 0) : (y < 0)) ? 1 : 0);
  }
  if NINUMP(y) {
# ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: scm_wta(y, (char *)ARG2, s_modulo);
# endif
    return (BIGSIGN(y) ? (x>0) : (x<0)) ? scm_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: scm_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 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 = scm_copybig(x, 0);
  newy:
    if NINUMP(y) {
      ASSERT(NIMP(y) && BIGP(y), y, ARG2, s_gcd);
      if BIGSIGN(y) y = scm_copybig(y, 0);
      switch (scm_bigcomp(x, y)) {
      case -1:
      swaprec: t = scm_lremainder(x, y); x = y; y = t; goto tailrec;
      case  0: return x;
      case  1: y = scm_lremainder(y, x); goto newy;
      }
      /* instead of the switch, we could just return scm_lgcd(y, scm_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 scm_long2big(u);
#else
    scm_wta(x, (char *)OVFLOW, s_gcd);
#endif
  return MAKINUM(u);
}
SCM scm_llcm(n1, n2)
SCM n1, n2;
{
  SCM d;
  if UNBNDP(n2) {
    n2 = MAKINUM(1L);
    if UNBNDP(n1) return n2;
  }
  d = scm_lgcd(n1, n2);
  if (INUM0==d) return d;
  return scm_absval(scm_product(n1, scm_lquotient(n2, d)));
}
#ifndef BIGDIG
# ifndef FLOATS
#  define long2num MAKINUM
# endif
#endif

#ifndef long2num
SCM scm_logand(n1, n2)
     SCM n1, n2;
{
  return scm_long2num(scm_num2long(n1, (char *)ARG1, s_logand)
		      & scm_num2long(n2, (char *)ARG2, s_logand));
}

SCM scm_logior(n1, n2)
     SCM n1, n2;
{
  return scm_long2num(scm_num2long(n1, (char *)ARG1, s_logior)
		      | scm_num2long(n2, (char *)ARG2, s_logior));
}

SCM scm_logxor(n1, n2)
     SCM n1, n2;
{
  return scm_long2num(scm_num2long(n1, (char *)ARG1, s_logxor)
		      ^ scm_num2long(n2, (char *)ARG2, s_logxor));
}

SCM scm_logtest(n1, n2)
SCM n1, n2;
{
  return ((scm_num2long (n1, (char *)ARG1, s_logtest)
	   & scm_num2long (n2, (char *)ARG2, s_logtest))
	  ? BOOL_T : BOOL_F);
}

SCM scm_logbitp(n1, n2)
SCM n1, n2;
{
  return (((1 << scm_num2long (n1, (char *)ARG1, s_logtest))
	   & scm_num2long (n2, (char *)ARG2, s_logtest))
	  ? BOOL_T : BOOL_F);
}

#else

SCM scm_logand(n1, n2)
SCM n1, n2;
{
  ASSERT(INUMP(n1), n1, ARG1, s_logand);
  ASSERT(INUMP(n2), n2, ARG2, s_logand);
  return MAKINUM(INUM(n1) & INUM(n2));
}

SCM scm_logior(n1, n2)
SCM n1, n2;
{
  ASSERT(INUMP(n1), n1, ARG1, s_logior);
  ASSERT(INUMP(n2), n2, ARG2, s_logior);
  return MAKINUM(INUM(n1) | INUM(n2));
}

SCM scm_logxor(n1, n2)
SCM n1, n2;
{
  ASSERT(INUMP(n1), n1, ARG1, s_logxor);
  ASSERT(INUMP(n2), n2, ARG2, s_logxor);
  return MAKINUM(INUM(n1) ^ INUM(n2));
}

SCM scm_logtest(n1, n2)
SCM n1, n2;
{
  ASSERT(INUMP(n1), n1, ARG1, s_logtest);
  ASSERT(INUMP(n2), n2, ARG2, s_logtest);
  return (INUM(n1) & INUM(n2)) ? BOOL_T : BOOL_F;
}

SCM scm_logbitp(n1, n2)
SCM n1, n2;
{
  ASSERT(INUMP(n1) && INUM(n1) >= 0, n1, ARG1, s_logbitp);
  ASSERT(INUMP(n2), n2, ARG2, s_logbitp);
  return ((1 << INUM(n1)) & INUM(n2)) ? BOOL_T : BOOL_F;
}
#endif

SCM scm_lognot(n)
     SCM n;
{
  ASSERT(INUMP(n), n, ARG1, s_lognot);
  return scm_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==scm_evenp(z2)?z1:acc;
#endif
  ASSERT(INUMP(z2), z2, ARG2, s_intexpt);
  z2 = INUM(z2);
  if (z2 < 0) {
    z2 = -z2;
    z1 = scm_divide(z1, SCM_UNDEFINED);
  }
  while(1) {
    if (0==z2) return acc;
    if (1==z2) return scm_product(acc, z1);
    if (z2 & 1) acc = scm_product(acc, z1);
    z1 = scm_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(scm_negativep(n))
      return scm_sum(MAKINUM(-1L), scm_lquotient(scm_sum(MAKINUM(1L), n), res));
    else return scm_lquotient(n, res);
  }
  else return scm_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)) scm_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(scm_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 scm_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(scm_difference(MAKINUM(-1L), n));
    ds = BDIGITS(n);
    for(i = NUMDIGS(n); i--; )
      for(d = ds[i]; d; d >>= 4) c += scm_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 += scm_logtab[15 & nn];
  return MAKINUM(c);
}

char scm_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(scm_difference(MAKINUM(-1L), n));
    ds = BDIGITS(n);
    d = ds[c = NUMDIGS(n)-1];
    for(c *= BITSPERDIG; d; d >>= 4) {c += 4; l = scm_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 = scm_ilentab[15 & nn];}
  return MAKINUM(c - 4 + l);
}

SCM scm_charp(x)
SCM x;
{
	return ICHRP(x) ? BOOL_T : BOOL_F;
}
SCM 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 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 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 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 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 (scm_upcase[ICHR(x)]==scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM 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 (scm_upcase[ICHR(x)] < scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM 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 (scm_upcase[ICHR(x)] <= scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM 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 (scm_upcase[ICHR(x)] > scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM 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 (scm_upcase[ICHR(x)] >= scm_upcase[ICHR(y)]) ? BOOL_T : BOOL_F;
}
SCM 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 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 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 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 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 scm_char2int(chr)
SCM chr;
{
	ASSERT(ICHRP(chr), chr, ARG1, s_char2int);
	return MAKINUM(ICHR(chr));
}
SCM 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 scm_char_upcase(chr)
SCM chr;
{
	ASSERT(ICHRP(chr), chr, ARG1, s_ch_upcase);
	return MAKICHR(scm_upcase[ICHR(chr)]);
}
SCM scm_char_downcase(chr)
SCM chr;
{
	ASSERT(ICHRP(chr), chr, ARG1, s_ch_downcase);
	return MAKICHR(scm_downcase[ICHR(chr)]);
}

SCM scm_stringp(x)
SCM x;
{
	if IMP(x) return BOOL_F;
	return STRINGP(x) ? BOOL_T : BOOL_F;
}
SCM scm_string(chrs)
SCM chrs;
{
	SCM res;
	register char *data;
	long i = scm_ilength(chrs);
	ASSERT(i >= 0, chrs, ARG1, s_string);
	res = scm_makstr(i, 0);
	data = CHARS(res);
	for(;NNULLP(chrs);chrs = CDR(chrs)) {
		ASSERT(ICHRP(CAR(chrs)), chrs, ARG1, s_string);
		*data++ = ICHR(CAR(chrs));
	}
	return res;
}
SCM scm_make_string(k, chr)
SCM k, chr;
{
	SCM res;
	register char *dst;
	register long i;
	ASSERT(INUMP(k) && (k >= 0), k, ARG1, scm_s_make_string);
	i = INUM(k);
	res = scm_makstr(i, 0);
	dst = CHARS(res);
	if ICHRP(chr) for(i--;i >= 0;i--) dst[i] = ICHR(chr);
	return res;
}
SCM scm_st_length(str)
SCM str;
{
	ASSERT(NIMP(str) && ROSTRINGP(str), str, ARG1, s_st_length);
	return MAKINUM(LENGTH(str));
}
SCM scm_st_ref(str, k)
SCM str, k;
{
	ASSERT(NIMP(str) && ROSTRINGP(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 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 scm_st_equal(s1, s2)
SCM s1, s2;
{
	register sizet i;
	register char *c1, *c2;
	ASSERT(NIMP(s1) && ROSTRINGP(s1), s1, ARG1, s_st_equal);
	ASSERT(NIMP(s2) && ROSTRINGP(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 scm_stci_equal(s1, s2)
SCM s1, s2;
{
	register sizet i;
	register unsigned char *c1, *c2;
	ASSERT(NIMP(s1) && ROSTRINGP(s1), s1, ARG1, s_stci_equal);
	ASSERT(NIMP(s2) && ROSTRINGP(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(scm_upcase[*c1++] != scm_upcase[*c2++]) return BOOL_F;
	return BOOL_T;
}
SCM scm_st_lessp(s1, s2)
SCM s1, s2;
{
	register sizet i, len;
	register unsigned char *c1, *c2;
	register int c;
	ASSERT(NIMP(s1) && ROSTRINGP(s1), s1, ARG1, s_st_lessp);
	ASSERT(NIMP(s2) && ROSTRINGP(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 scm_st_leqp(s1, s2)
SCM s1, s2;
{
  return BOOL_NOT(scm_st_lessp(s2, s1));
}
SCM scm_st_grp(s1, s2)
SCM s1, s2;
{
  return scm_st_lessp(s2, s1);
}
SCM scm_st_geqp(s1, s2)
SCM s1, s2;
{
  return BOOL_NOT(scm_st_lessp(s1, s2));
}
SCM scm_stci_lessp(s1, s2)
SCM s1, s2;
{
	register sizet i, len;
	register unsigned char *c1, *c2;
	register int c;
	ASSERT(NIMP(s1) && ROSTRINGP(s1), s1, ARG1, s_stci_lessp);
	ASSERT(NIMP(s2) && ROSTRINGP(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 = (scm_upcase[*c1++] - scm_upcase[*c2++]);
		if (c>0) return BOOL_F;
		if (c<0) return BOOL_T;
	}
	return (LENGTH(s2) != len) ? BOOL_T : BOOL_F;
}
SCM scm_stci_leqp(s1, s2)
SCM s1, s2;
{
  return BOOL_NOT(scm_stci_lessp(s2, s1));
}
SCM scm_stci_grp(s1, s2)
SCM s1, s2;
{
  return scm_stci_lessp(s2, s1);
}
SCM scm_stci_geqp(s1, s2)
SCM s1, s2;
{
  return BOOL_NOT(scm_stci_lessp(s1, s2));
}
SCM scm_substring(str, start, end)
SCM str, start, end;
{
	long l;
	ASSERT(NIMP(str) && ROSTRINGP(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 scm_makfromstr(&CHARS(str)[INUM(start)], (sizet)l, 0);
}
SCM 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) && ROSTRINGP(s),
		       s, ARGn, s_st_append);
		i += LENGTH(s);
		l = CDR(l);
	}
	ASSERT(NULLP(l), args, ARGn, s_st_append);
	res = scm_makstr(i, 0);
	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 scm_vectorp(x)
SCM x;
{
	if IMP(x) return BOOL_F;
	return VECTORP(x) ? BOOL_T : BOOL_F;
}
SCM scm_vector_length(v)
SCM v;
{
	ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_length);
	return MAKINUM(LENGTH(v));
}
SCM scm_vector(l)
SCM l;
{
	SCM res;
	register SCM *data;
	long i = scm_ilength(l);
	ASSERT(i >= 0, l, ARG1, s_vector);
	res = scm_make_vector(MAKINUM(i), UNSPECIFIED);
	data = VELTS(res);
	for(;NIMP(l);l = CDR(l)) *data++ = CAR(l);
	return res;
}
SCM 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 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	scm_s_make_vector[] = "make-vector";
SCM scm_make_vector(k, fill)
SCM k, fill;
{
	SCM v;
	register long i;
	register SCM *velts;
	ASSERT(INUMP(k) && (0 <= INUM (k)), k, ARG1, scm_s_make_vector);
	if UNBNDP(fill) fill = UNSPECIFIED;
	i = INUM(k);
	NEWCELL(v);
	DEFER_INTS;
	SETCHARS(v, scm_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;
}

/* {Locked Vectors}
 */

static SCM f_lvector_ref;
SCM
scm_get_lvector_hook (vec, index)
     SCM vec;
     int index;
{
  SCM hooks;
  hooks = VELTS (vec)[0];
  if (   IMP (hooks)
      || !LVECTORP (hooks)
      || (index >= LENGTH (vec))
      || (LVECTOR_KEY (vec, index) != f_lvector_ref))
    return BOOL_F;
  else
    return VELTS (hooks)[index];
}

static char s_lvector_isa[] = "lvector-isa?";
static SCM f_lvector_isa;
SCM
scm_lvector_isa (vec, keyvec)
     SCM vec;
     SCM keyvec;
{
  ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_isa);
  if (keyvec == VELTS (vec)[0])
    return BOOL_T;
  {
    SCM hook;

    hook = scm_get_lvector_hook (vec, LV_ISA_FN);
    if (hook == BOOL_F)
      return BOOL_F;
    return scm_apply (hook, scm_cons (vec, scm_cons (keyvec, EOL)), EOL);
  }
}

char scm_s_lvector_set[] = "lvector-set!";
SCM scm_f_lvector_set;
SCM
scm_lvector_set (vec, key, index, val)
     SCM vec;
     SCM key;
     SCM index;
     SCM val;
{
  SCM answer;
  int i;
  ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, scm_s_lvector_set );
  ASSERT ( INUMP (index), index, ARG2, scm_s_lvector_set );
  ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, scm_s_lvector_set );
  i = INUM (index);

  if (key == VELTS (VELTS (vec)[0])[i])
    {
      VELTS (vec)[i] = val;
      return UNSPECIFIED;
    }
  else
  {
    SCM hook;
    hook = scm_get_lvector_hook (vec, LV_SET_FN);
    ASSERT (hook != BOOL_F,
	    key,
	    "wrong key for locked vector element:", scm_s_lvector_set);
    
    return scm_apply (hook,
		      scm_cons (vec,
				scm_cons (key,
					  scm_cons (index,
						    scm_cons (val, EOL)))),
		      EOL);
  }
}

char scm_s_lvector_poke[] = "lvector-poke!";
SCM scm_f_lvector_poke;
SCM
scm_lvector_poke (vec, index, val)
     SCM vec;
     SCM index;
     SCM val;
{
  SCM answer;
  int i;
  ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, scm_s_lvector_poke );
  ASSERT ( INUMP (index), index, ARG2, scm_s_lvector_poke );
  ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, scm_s_lvector_poke );
  i = INUM (index);
  VELTS (vec)[i] = val;
  return UNSPECIFIED;
}


static char s_lvector_ref[] = "lvector-ref";
SCM
scm_lvector_ref (vec, key, index)
     SCM vec;
     SCM key;
     SCM index;
{
  SCM keyvec;
  SCM answer;
  int i;
  ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_ref );
  keyvec = VELTS (vec)[0];
  ASSERT ( INUMP (index), index, ARG2, s_lvector_ref );
  i = INUM (index);
  ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_ref );
  answer = VELTS (vec)[i];
  if (key == VELTS (keyvec)[i])
    return answer;

  {
    SCM hook;
    hook = scm_get_lvector_hook (vec, LV_REF_FN);
    ASSERT (hook != BOOL_F,
	    key,
	    "wrong key for locked vector element:", scm_s_lvector_set);
    
    return scm_apply (hook,
		      scm_cons (vec, scm_cons (key, scm_cons (index, EOL))),
		      EOL);
  }
}


static char s_lvector_peek[] = "lvector-peek";
static SCM f_lvector_peek;
SCM
scm_lvector_peek (vec, index)
     SCM vec;
     SCM index;
{
  SCM keyvec;
  SCM answer;
  int i;
  ASSERT ( NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_peek );
  keyvec = VELTS (vec)[0];
  ASSERT ( INUMP (index), index, ARG2, s_lvector_peek );
  i = INUM (index);
  ASSERT ( INUM (index) < LENGTH (vec), index, OUTOFRANGE, s_lvector_peek );
  return VELTS (vec)[i];
}


#define LVEC_CCL_KEY(C) (VELTS (C) [1])
#define LVEC_CCL_INDEX(C) (VELTS (C) [2])

static char s_lvector_accessor1[] = " lvector-accessor-procedure";

static SCM
lvector_accessor1 (ccl, lvec)
     SCM ccl;
     SCM lvec;
{
  ASSERT (NIMP (lvec) && LVECTORP (lvec), lvec, ARG1, s_lvector_accessor1);
  if (LVEC_CCL_KEY (ccl) == VELTS (lvec)[0])
    return VELTS (lvec) [INUM (LVEC_CCL_INDEX (ccl))];
  else
    return scm_lvector_ref (lvec,
			    LVEC_CCL_KEY (ccl),
			    INUM (LVEC_CCL_INDEX (ccl)));
}

static char s_lvector_modifier1[] = " lvector-modifier-procedure";

static SCM
lvector_modifier1 (ccl, lvec, val)
     SCM ccl;
     SCM lvec;
     SCM val;
{
  ASSERT (NIMP (lvec) && LVECTORP (lvec), lvec, ARG1, s_lvector_modifier1);
  if (LVEC_CCL_KEY (ccl) == VELTS (lvec)[0])
    {
      VELTS (lvec) [INUM (LVEC_CCL_INDEX (ccl))] = val;
      return UNSPECIFIED;
    }
  else
    return scm_lvector_set (lvec,
			    LVEC_CCL_KEY (ccl), INUM (LVEC_CCL_INDEX (ccl)),
			    val);
}


static char s_lvector_accessor[] = "lvector-accessor";
static char s_lvector_modifier[] = "lvector-modifier";
static SCM f_lvector_accessor1;
static SCM f_lvector_modifier1;

SCM
scm_lvector_accessor (type, index)
     SCM type;
     SCM index;
{
  SCM answer;
  ASSERT (NIMP (type) && VECTORP (type), type, ARG1, s_lvector_accessor);
  ASSERT (INUMP (index), index, ARG2, s_lvector_accessor);
  ASSERT (INUM (index) < LENGTH (type), index, OUTOFRANGE, s_lvector_accessor);
  answer = scm_makcclo (f_lvector_accessor1, 3L);
  LVEC_CCL_KEY (answer) = ((type != BOOL_F) ? type : answer);
  LVEC_CCL_INDEX (answer) = index;
  return answer;
}


SCM
scm_lvector_modifier (type, index)
     SCM type;
     SCM index;
{
  SCM answer;
  ASSERT (NIMP (type) && VECTORP (type), type, ARG1, s_lvector_modifier);
  ASSERT (INUMP (index), index, ARG2, s_lvector_modifier);
  ASSERT (INUM (index) < LENGTH (type), index, OUTOFRANGE, s_lvector_modifier);
  answer = scm_makcclo (f_lvector_modifier1, 3L);
  LVEC_CCL_KEY (answer) = ((type != BOOL_F) ? type : answer);
  LVEC_CCL_INDEX (answer) = index;
  return answer;
}


static char s_lock_vector[] = "lock-vector!";

SCM
scm_lock_vector (vec)
     SCM vec;
{
  SCM keyvec;
  ASSERT (NIMP (vec) && VECTORP (vec), vec, ARG1, s_lock_vector);
  ASSERT (LENGTH (vec), vec, "missing key vector as element 0", s_lock_vector);
  keyvec = VELTS (vec)[0];
  ASSERT (NIMP (keyvec) && VECTORP (keyvec), vec,
	  "bad key vecotr (element 0)", s_lock_vector);
  ASSERT (LENGTH (keyvec) >= LENGTH (vec), vec,
	  "key vector too short", s_lock_vector);
  SETLENGTH ( vec, LENGTH (vec), tc7_lvector );
  return vec;
}


static char s_unlock_vector[] = "unlock-vector!";

SCM
scm_unlock_vector (vec)
     SCM vec;
{
  ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_unlock_vector);
  SETLENGTH ( vec, LENGTH (vec), tc7_vector );
  return vec;
}


static char s_lvector_keys[] = "lvector-keys";

SCM
scm_lvector_keys (vec)
     SCM vec;
{
  ASSERT (NIMP (vec) && LVECTORP (vec), vec, ARG1, s_lvector_keys);
  return VELTS (vec)[0];
}

static char s_lvectorp[] = "lvector?";

SCM
scm_lvectorp (vec)
     SCM vec;
{
  return  ((NIMP (vec) && LVECTORP (vec))
	   ? BOOL_T
	   : BOOL_F);
}



#ifdef BIGDIG
char scm_s_bignum[] = "bignum";
SCM scm_mkbig(nlen, sign)
sizet nlen;
int sign;
{
	SCM v = nlen;
	if (((v << 16) >> 16) != nlen)
	  scm_wta(MAKINUM(nlen), (char *)NALLOC, scm_s_bignum);
	NEWCELL(v);
	DEFER_INTS;
	SETCHARS(v, scm_must_malloc((long)(nlen*sizeof(BIGDIG)), scm_s_bignum));
	SETNUMDIGS(v, nlen, sign?tc16_bigneg:tc16_bigpos);
	ALLOW_INTS;
	return v;
}
SCM 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 scm_s_adjbig[] = "scm_adjbig";
SCM scm_adjbig(b, nlen)
     SCM b;
     sizet nlen;
{
  long nsiz = nlen;
  if (((nsiz << 16) >> 16) != nlen) scm_wta(MAKINUM(nsiz), (char *)NALLOC, scm_s_adjbig);
  DEFER_INTS;
  SETCHARS(b, (BIGDIG *)scm_must_realloc((char *)CHARS(b),
				    (long)(NUMDIGS(b)*sizeof(BIGDIG)),
				    (long)(nsiz*sizeof(BIGDIG)), scm_s_adjbig));
  SETNUMDIGS(b, nsiz, TYP16(b));
  ALLOW_INTS;
  return b;
}
SCM 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 = scm_big2inum(b, (sizet)nlen)) return b;
  if (NUMDIGS(b)==nlen) return b;
  return scm_adjbig(b, (sizet)nlen);
}
SCM scm_copybig(b, sign)
     SCM b;
     int sign;
{
  sizet i = NUMDIGS(b);
  SCM ans = scm_mkbig(i, sign);
  BIGDIG *src = BDIGITS(b), *dst = BDIGITS(ans);
  while (i--) dst[i] = src[i];
  return ans;
}
SCM scm_long2big(n)
     long n;
{
  sizet i = 0;
  BIGDIG *digits;
  SCM ans = scm_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 scm_2ulong2big(np)
     unsigned long * np;
{
  unsigned long n;
  sizet i;
  sizet offset;
  BIGDIG *digits;
  SCM ans;

  ans = scm_mkbig(2 * DIGSPERLONG, 0);
  digits = BDIGITS(ans);

  n = np[0];
  for (i = 0; i < DIGSPERLONG; ++i)
    {
      digits[i] = BIGLO(n);
      n = BIGDN((unsigned long)n);
    }
  n = np[1];
  for (i = 0; i < DIGSPERLONG; ++i)
    {
      digits[i + DIGSPERLONG] = BIGLO(n);
      n = BIGDN((unsigned long)n);
    }
  return ans;
}
SCM scm_ulong2big(n)
     unsigned long n;
{
  sizet i = 0;
  BIGDIG *digits;
  SCM ans = scm_mkbig(DIGSPERLONG, 0);
  digits = BDIGITS(ans);
  while (i < DIGSPERLONG) {
    digits[i++] = BIGLO(n);
    n = BIGDN(n);
  }
  return ans;
}

int scm_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 scm_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 scm_addbig(x, nx, xsgn, bigy, sgny)
     BIGDIG *x;
     SCM bigy;
     sizet nx;		/* Assumes nx <= NUMDIGS(bigy) */
     int xsgn, sgny;	/* Assumes xsgn and sgny scm_equal either 0 or 0x0100 */
{
  long num = 0;
  sizet i = 0, ny = NUMDIGS(bigy);
  SCM z = scm_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 = scm_adjbig(z, ny+1); BDIGITS(z)[ny] = num; return z;}
  }
  return scm_normbig(z);
}

SCM 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 = scm_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 scm_normbig(z);
}
unsigned int scm_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 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 = z - t2;
    return MAKINUM(sgn ? -t2 : t2);
  }
  {
#ifndef DIGSTOOBIG
    unsigned long t2 = scm_pseudolong(z);
    return scm_divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&t2,
		     DIGSPERLONG, sgn, mode); 
#else
    BIGDIG t2[DIGSPERLONG];
    longdigs(z, t2);
    return scm_divbigbig(BDIGITS(x), NUMDIGS(x), t2, DIGSPERLONG, sgn, mode);
#endif
  }
}
SCM scm_divbigbig(x, nx, y, ny, sgn, modes)
     BIGDIG *x, *y;
     sizet nx, ny;
     int sgn, modes;
     /* modes description
	0	remainder
	1	scm_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 = scm_mkbig(nx, sgn); zds = BDIGITS(z);
      do {zds[i] = x[i];} while (++i < nx);
      return z;
    case 1:			/* scm_modulo -- return y-x */
      z = scm_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 = scm_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 = scm_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 scm_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) scm_divbigdig(zds, ny, d);
  }
 doadj:
  for(j = ny;j && !zds[j-1];--j) ;
  if (j * BITSPERDIG <= sizeof(SCM)*CHAR_BIT)
    if INUMP(z = scm_big2inum(z, j)) return z;
  return scm_adjbig(z, j);
}
#endif

SCM scm_object_address(obj)
SCM obj;
{
    if (IMP(obj))
	return BOOL_F;
    else
	return MAKINUM(obj & ~0x3);
}


/* {Aribters}
 *
 * These procedures implement synchronization primitives.  Processors
 * with an atomic test-and-set instruction can use it here (and not
 * DEFER_INTS). 
 *
 * (Why isn't this in subrs.c?) 
 */

static long scm_tc16_arbiter;

static int 
prinarb (exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
  scm_lputs ("#<arbiter ", port);
  if (CAR (exp) & (1L << 16))
    scm_lputs ("locked ", port);
  scm_iprin1 (CDR (exp), port, writing);
  scm_lputc ('>', port);
  return !0;
}

static scm_smobfuns arbsmob =
{
  scm_markcdr, scm_free0, prinarb
};

static char s_makarb[] = "make-arbiter";
SCM 
scm_makarb (name)
     SCM name;
{
  register SCM z;
  NEWCELL (z);
  CDR (z) = name;
  CAR (z) = scm_tc16_arbiter;
  return z;
}

static char scm_s_tryarb[] = "try-arbiter";
SCM 
scm_tryarb (arb)
     SCM arb;
{
  ASSERT ((TYP16 (arb) == scm_tc16_arbiter), arb, ARG1, scm_s_tryarb);
  DEFER_INTS;
  if (CAR (arb) & (1L << 16))
    arb = BOOL_F;
  else
    {
      CAR (arb) = scm_tc16_arbiter | (1L << 16);
      arb = BOOL_T;
    }
  ALLOW_INTS;
  return arb;
}

static char scm_s_relarb[] = "release-arbiter";
SCM 
scm_relarb (arb)
     SCM arb;
{
  ASSERT ((TYP16 (arb) == scm_tc16_arbiter), arb, ARG1, scm_s_relarb);
  if (!(CAR (arb) & (1L << 16)))
    return BOOL_F;
  CAR (arb) = scm_tc16_arbiter;
  return BOOL_T;
}




static scm_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 scm_iproc subr1s[] = {
	{"not", scm_lnot},
	{"boolean?", scm_booleanp},
	{"pair?", scm_consp},
	{"null?", scm_nullp},
	{"list?", scm_listp},
	{s_list_length, scm_list_length},
	{s_length, scm_length},
	{s_reverse, scm_reverse},
	{"symbol?", scm_symbolp},
	{s_symbol2string, scm_symbol2string},
	{s_str2symbol, scm_string2symbol},
	{s_exactp, scm_exactp},
	{s_oddp, scm_oddp},
	{s_evenp, scm_evenp},
	{s_abs, scm_absval},
	{s_lognot, scm_lognot},
	{s_logcount, scm_logcount},
	{s_intlength, scm_intlength},
	{"char?", scm_charp},
	{s_ch_alphap, scm_char_alphap},
	{s_ch_nump, scm_char_nump},
	{s_ch_whitep, scm_char_whitep},
	{s_ch_upperp, scm_char_upperp},
	{s_ch_lowerp, scm_char_lowerp},
	{s_char2int, scm_char2int},
	{s_int2char, scm_int2char},
	{s_ch_upcase, scm_char_upcase},
	{s_ch_downcase, scm_char_downcase},
	{"string?", scm_stringp},
	{s_st_length, scm_st_length},
	{"vector?", scm_vectorp},
	{s_ve_length, scm_vector_length},
	{"procedure?", scm_procedurep},
	{"object-address", scm_object_address},
	{s_lvectorp, scm_lvectorp},
	{s_lvector_keys, scm_lvector_keys},
	{s_lock_vector, scm_lock_vector},
	{s_unlock_vector, scm_unlock_vector},
	{s_symbol_fref, scm_symbol_fref},
	{s_symbol_pref, scm_symbol_pref},
	{s_symbol_hash, scm_symbol_hash},
	{ s_makarb, scm_makarb },
	{ scm_s_tryarb, scm_tryarb },
	{ scm_s_relarb, scm_relarb },
	{0, 0}};

static char s_acons[] = "acons";
static scm_iproc subr2s[] = {
	{&s_acons[1], scm_cons},
	{s_setcar, scm_setcar},
	{s_setcdr, scm_setcdr},
	{s_list_ref, scm_list_ref},
	{s_memq, scm_memq},
	{s_member, scm_member},
	{s_assq, scm_assq},
	{s_assoc, scm_assoc},
	{s_quotient, scm_lquotient},
	{s_remainder, scm_lremainder},
	{s_modulo, scm_modulo},
	{s_logtest, scm_logtest},
	{s_logbitp, scm_logbitp},
	{s_ash, scm_ash},
	{s_intexpt, scm_intexpt},
	{s_st_ref, scm_st_ref},
	{"string<=?", scm_st_leqp},
	{"string-ci<=?", scm_stci_leqp},
	{s_str2osymbol, scm_string2osymbol},
	{s_intern_symbol, scm_intern_symbol},
	{s_unintern_symbol, scm_unintern_symbol},
	{s_symbol_binding, scm_symbol_binding},
	{s_symbol_bound, scm_symbol_bound},
	{s_symbol_internedp, scm_symbol_internedp},
	{s_ve_ref, scm_vector_ref},
	{s_lvector_accessor, scm_lvector_accessor},
	{s_lvector_modifier, scm_lvector_modifier},
	{s_symbol_fset, scm_symbol_fset},
	{s_symbol_pset, scm_symbol_pset},
	{s_delq, scm_delq},
	{0, 0}};

static scm_iproc lsubrs[] = {
	{scm_s_list, scm_list},
	{s_append, scm_append},
	{s_string, scm_string},
	{s_st_append, scm_st_append},
	{s_vector, scm_vector},
	{0, 0}};

static scm_iproc subr2os[] = {
	{scm_s_make_string, scm_make_string},
	{scm_s_make_vector, scm_make_vector},
	{0, 0}};

static scm_iproc asubrs[] = {
	{s_gcd, scm_lgcd},
	{"lcm", scm_llcm},
	{s_logand, scm_logand},
	{s_logior, scm_logior},
	{s_logxor, scm_logxor},
	{0, 0}};

static scm_iproc rpsubrs[] = {
	{"eq?", scm_eq},
	{"equal?", scm_equal},
	{"char=?", scm_eq},
	{s_ch_lessp, scm_char_lessp},
	{s_ci_eq, scm_chci_eq},
	{s_ci_lessp, scm_chci_lessp},
	{s_ch_leqp, scm_char_leqp},
	{s_ci_leqp, scm_chci_leqp},
	{s_ch_grp, scm_char_grp},
	{s_ci_grp, scm_chci_grp},
	{s_ch_geqp, scm_char_geqp},
	{s_ci_geqp, scm_chci_geqp},

	{s_st_equal, scm_st_equal},
	{s_stci_equal, scm_stci_equal},
	{s_st_lessp, scm_st_lessp},
	{s_stci_lessp, scm_stci_lessp},
	{"string>?", scm_st_grp},
	{"string-ci>?", scm_stci_grp},
	{"string>=?", scm_st_geqp},
	{"string-ci>=?", scm_stci_geqp},
	{0, 0}};

static scm_iproc subr3s[] = {
	{s_bitextract, scm_bitextract},
	{s_substring, scm_substring},
	{s_acons, scm_acons},
	{s_st_set, scm_st_set},
	{s_ve_set, scm_vector_set},
	{s_symbol_set, scm_symbol_set},
	{0, 0}};

void scm_init_iprocs(subra, type)
     scm_iproc *subra;
     int type;
{
  for(;subra->scm_string; subra++)
    scm_make_subr(subra->scm_string,
	      type,
	      subra->cproc);
}

void scm_init_subrs()
{
  scm_init_iprocs(cxrs, tc7_cxr);
  scm_init_iprocs(subr1s, tc7_subr_1);
  scm_init_iprocs(subr2s, tc7_subr_2);
  scm_init_iprocs(subr2os, tc7_subr_2o);
  scm_init_iprocs(rpsubrs, tc7_rpsubr);
  scm_init_iprocs(lsubrs, tc7_lsubr);
  scm_init_iprocs(asubrs, tc7_asubr);
  scm_init_iprocs(subr3s, tc7_subr_3);
  /* lvector-set! is declared in gsubr.c because it depends on gsubrs
   * which by this point of the code have not been initalized.
   */
  f_lvector_accessor1 = scm_make_subr (s_lvector_accessor1, tc7_subr_2,
				       lvector_accessor1);
  f_lvector_modifier1 = scm_make_subr (s_lvector_modifier1, tc7_subr_3,
				       lvector_modifier1);
  f_lvector_ref = scm_make_subr (s_lvector_ref, tc7_subr_3, scm_lvector_ref);
  f_lvector_isa = scm_make_subr (s_lvector_isa, tc7_subr_2, scm_lvector_isa);
  scm_tc16_arbiter = scm_newsmob (&arbsmob);
}
