/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  
 */

/* "scl.c" non-IEEE utility functions and non-integer arithmetic.
   Authors: Jerry D. Hedden and Aubrey Jaffer */

#include "scm.h"

#ifdef FLOATS
# include <math.h>

static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar",
	    s_magnitude[] = "magnitude", s_angle[] = "angle",
	    s_real_part[] = "real-part", s_imag_part[] = "imag-part",
	    s_in2ex[] = "inexact->exact",s_ex2in[] = "exact->inexact";

static char s_expt[] = "$expt", s_atan2[] = "$atan2";
#endif
static char s_memv[] = "memv", s_assv[] = "assv";

SCM sys_protects[NUM_PROTECTS];
sizet num_protects = NUM_PROTECTS;

char		s_inexactp[] = "inexact?";
static char     s_zerop[] = "zero?",
		s_positivep[] = "positive?", s_negativep[] = "negative?";
static char     s_eqp[] = "=", s_lessp[] = "<", s_grp[] = ">";
static char     s_leqp[] = "<=", s_greqp[] = ">=";
static char     s_max[] = "max", s_min[] = "min";
char		s_sum[] = "+", s_difference[] = "-", s_product[] = "*",
		s_divide[] = "/";
static char     s_number2string[] = "number->string",
		s_str2number[] = "string->number";

static char s_list_tail[] = "list-tail";
static char s_str2list[] = "string->list";
static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!";
static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!";

/*** NUMBERS -> STRINGS ***/
#ifdef FLOATS
int dblprec;
static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5,
			   5e-6, 5e-7, 5e-8, 5e-9, 5e-10,
			   5e-11,5e-12,5e-13,5e-14,5e-15,
			   5e-16,5e-17,5e-18,5e-19,5e-20};

static sizet idbl2str(f, a)
     double f;
     char *a;
{
  int efmt, dpt, d, i, wp = dblprec;
  sizet ch = 0;
  int exp = 0;

  if (f==0.0) goto zero;	/*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
  if (f < 0.0) {f = -f;a[ch++]='-';}
  else if (f > 0.0) ;
  else goto funny;
  if IS_INF(f) {
    if (ch==0) a[ch++]='+';
  funny: a[ch++]='#'; a[ch++]='.'; a[ch++]='#'; return ch;
  }
# ifdef DBL_MIN_10_EXP		/* Prevent unnormalized values, as from
			make-uniform-vector, from causing infinite loops. */
  while (f < 1.0) {f *= 10.0;  if (exp-- < DBL_MIN_10_EXP) goto funny;}
  while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;}
# else
  while (f < 1.0) {f *= 10.0; exp--;}
  while (f > 10.0) {f /= 10.0; exp++;}
# endif
  if (f+fx[wp] >= 10.0) {f = 1.0; exp++;}
 zero:
# ifdef ENGNOT
  dpt = (exp+9999)%3;
  exp -= dpt++;
  efmt = 1;
# else
  efmt = (exp < -3) || (exp > wp+2);
  if (!efmt)
    if (exp < 0) {
      a[ch++] = '0';
      a[ch++] = '.';
      dpt = exp;
      while (++dpt)  a[ch++] = '0';
    } else
      dpt = exp+1;
  else
    dpt = 1;
# endif

  do {
    d = f;
    f -= d;
    a[ch++] = d+'0';
    if (f < fx[wp])  break;
    if (f+fx[wp] >= 1.0) {
      a[ch-1]++;
      break;
    }
    f *= 10.0;
    if (!(--dpt))  a[ch++] = '.';
  } while (wp--);

  if (dpt > 0)
# ifndef ENGNOT
    if ((dpt > 4) && (exp > 6)) {
      d = (a[0]=='-'?2:1);
      for (i = ch++; i > d; i--)
	a[i] = a[i-1];
      a[d] = '.';
      efmt = 1;
    } else
# endif
      {
	while (--dpt)  a[ch++] = '0';
	a[ch++] = '.';
      }
  if (a[ch-1]=='.')  a[ch++]='0'; /* trailing zero */
  if (efmt && exp) {
    a[ch++] = 'e';
    if (exp < 0) {
      exp = -exp;
      a[ch++] = '-';
    }
    for (i = 10; i <= exp; i *= 10);
    for (i /= 10; i; i /= 10) {
      a[ch++] = exp/i + '0';
      exp %= i;
    }
  }
  return ch;
}

static sizet iflo2str(flt, str)
     SCM flt;
     char *str;
{
  sizet i;
# ifdef SINGLES
  if SINGP(flt) i = idbl2str(FLO(flt), str);
  else
# endif
    i = idbl2str(REAL(flt), str);
  if CPLXP(flt) {
              if(0 <= IMAG(flt)) /* jeh */
                str[i++] = '+'; /* jeh */
    i += idbl2str(IMAG(flt), &str[i]);
    str[i++] = 'i';
  }
  return i;
}
#endif				/* FLOATS */

sizet iuint2str(num, rad, p)
     unsigned long num;
     int rad;
     char *p;
{
  sizet j;
  register int i = 1, d;
  register unsigned long n = num;
  for (n /= rad;n > 0;n /= rad) i++;
  j = i;
  n = num;
  while (i--) {
    d = n % rad;
    n /= rad;
    p[i] = d + ((d < 10) ? '0' : 'a' - 10);
  }
  return j;
}
sizet iint2str(num, rad, p)
     long num;
     int rad;
     char *p;
{
  if ((num < 0) && !(rad < 0)) {
    *p++ = '-';
    return 1 + iuint2str((unsigned long) -num, rad, p);
  }
  return iuint2str((unsigned long) num, rad < 0 ? -rad : rad, p);
}
#ifdef BIGDIG
static SCM big2str(b, radix)
     SCM b;
     register unsigned int radix;
{
  SCM t = copybig(b, 0);	/* sign of temp doesn't matter */
  register BIGDIG *ds = BDIGITS(t);
  sizet i = NUMDIGS(t);
  sizet j = radix==16 ? (BITSPERDIG*i)/4+2
    : radix >= 10 ? (BITSPERDIG*i*241L)/800+2
      : (BITSPERDIG*i)+2;
  sizet k = 0;
  sizet radct = 0;
      sizet ch; /* jeh */
  BIGDIG radpow = 1, radmod = 0;
  SCM ss = makstr((long)j);
  char *s = CHARS(ss), c;
  scm_protect_temp(&t);
  while ((long) radpow * radix < BIGRAD) {
    radpow *= radix;
    radct++;
  }
  s[0] = tc16_bigneg==TYP16(b) ? '-' : '+';
  while ((i || radmod) && j) {
    if (k==0) {
      radmod = (BIGDIG)divbigdig(ds, i, radpow);
      k = radct;
      if (!ds[i-1]) i--;
    }
    c = radmod % radix; radmod /= radix; k--;
    s[--j] = c < 10 ? c + '0' : c + 'a' - 10;
  }
      ch = s[0]=='-' ? 1 : 0; /* jeh */
  if (ch < j) { /* jeh */
    for(i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */
    resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */
  }
  return ss;
}
#endif
SCM number2string(x, radix)
     SCM x, radix;
{
  if UNBNDP(radix) radix=MAKINUM(10L);
  else ASSERT(INUMP(radix), radix, ARG2, s_number2string);
#ifdef FLOATS
  if NINUMP(x) {
    char num_buf[FLOBUFLEN];
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) return big2str(x, (unsigned int)INUM(radix));
#  ifndef RECKLESS
    if (!(INEXP(x)))
    badx: wta(x, (char *)ARG1, s_number2string);
#  endif
# else
    ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
# endif
    return makfromstr(num_buf, iflo2str(x, num_buf));
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
    return big2str(x, (unsigned int)INUM(radix));
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_number2string);
# endif
#endif
  {
    char num_buf[INTBUFLEN];
    return makfromstr(num_buf, iint2str(INUM(x), (int)INUM(radix), num_buf));
  }
}
/* These print routines are stubbed here so that repl.c doesn't need
   FLOATS or BIGDIGs conditionals */
int floprint(sexp, port, writing)
     SCM sexp;
     SCM port;
     int writing;
{
#ifdef FLOATS
  if (!errjmp_bad) {
    char num_buf[FLOBUFLEN];
    lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port);
    return !0;
  } else
#endif
  ipruk("float", sexp, port);
  return !0;
}
int bigprint(exp, port, writing)
     SCM exp;
     SCM port;
     int writing;
{
#ifdef BIGDIG
  if (!errjmp_bad) {
    exp = big2str(exp, (unsigned int)10);
    lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
    return !0;
  } else
#endif
  ipruk("bignum", exp, port);
  return !0;
}
/*** END nums->strs ***/

/*** STRINGS -> NUMBERS ***/
#ifdef BIGDIG
SCM istr2int(str, len, radix)
     char *str;
     long len;
     register long radix;
{
  sizet j;
  register sizet k, blen = 1;
  sizet i = 0;
  int c;
  SCM res;
  register BIGDIG *ds;
  register unsigned long t2;

  if (0 >= len) return BOOL_F;	/* zero length */
  if (10==radix) j = 1+(84*len)/(BITSPERDIG*25);
  else j = (8 < radix) ? 1+(4*len)/BITSPERDIG : 1+(3*len)/BITSPERDIG;
  switch (str[0]) {		/* leading sign */
  case '-':
  case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
  }
  res = mkbig(j, '-'==str[0]);
  ds = BDIGITS(res);
  for (k = j;k--;) ds[k] = 0;
  do {
    switch (c = str[i++]) {
    case DIGITS:
      c = c - '0';
      goto accumulate;
    case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
      c = c-'A'+10;
      goto accumulate;
    case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
      c = c-'a'+10;
    accumulate:
      if (c >= radix) return BOOL_F; /* bad digit for radix */
      k = 0;
      t2 = c;
    moretodo:
      while(k < blen) {
/*	printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/
	t2 += ds[k]*radix;
	ds[k++] = BIGLO(t2);
	t2 = BIGDN(t2);
      }
      ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
      if (t2) {blen++; goto moretodo;}
      break;
    default:
      return BOOL_F;		/* not a digit */
    }
  } while (i < len);
  if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM))
    if INUMP(res = big2inum(res, blen)) return res;
  if (j==blen) return res;
  return adjbig(res, blen);
}
#else
SCM istr2int(str, len, radix)
     register char *str;
     long len;
     register long radix;
{
  register long n = 0, ln;
  register int c;
  register int i = 0;
  int lead_neg = 0;
  if (0 >= len) return BOOL_F;	/* zero length */
  switch (*str) {		/* leading sign */
  case '-': lead_neg = 1;
  case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */
  }

  do {
    switch (c = str[i++]) {
    case DIGITS:
      c = c - '0';
      goto accumulate;
    case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
      c = c-'A'+10;
      goto accumulate;
    case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
      c = c-'a'+10;
    accumulate:
      if (c >= radix) return BOOL_F; /* bad digit for radix */
      ln = n;
      n = n * radix - c;
      /* Negation is a workaround for HP700 cc bug */
      if (n > ln || (-n > -MOST_NEGATIVE_FIXNUM)) goto ovfl;
      break;
    default:
      return BOOL_F;		/* not a digit */
    }
  } while (i < len);
  if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl;
  return MAKINUM(n);
 ovfl:				/* overflow scheme integer */
  return BOOL_F;
}
#endif

#ifdef FLOATS
SCM istr2flo(str, len, radix)
     register char *str;
     register long len;
     register long radix;
{
  register int c, i = 0;
  double lead_sgn;
  double res = 0.0, tmp = 0.0;
  int flg = 0;
  int point = 0;
  SCM second;

  if (i >= len) return BOOL_F;	/* zero length */

  switch (*str) {		/* leading sign */
  case '-': lead_sgn = -1.0; i++; break;
  case '+': lead_sgn = 1.0; i++; break;
    default : lead_sgn = 0.0;
  }
  if (i==len) return BOOL_F;	/* bad if lone `+' or `-' */

  if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i'   */
    if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
    if (++i < len) return BOOL_F; /* `i' not last character */
    return makdbl(0.0, lead_sgn);
  }
  do {				/* check initial digits */
    switch (c = str[i]) {
    case DIGITS:
      c = c - '0';
      goto accum1;
    case 'D': case 'E': case 'F':
      if (radix==10) goto out1; /* must be exponent */
    case 'A': case 'B': case 'C':
      c = c-'A'+10;
      goto accum1;
    case 'd': case 'e': case 'f':
      if (radix==10) goto out1;
    case 'a': case 'b': case 'c':
      c = c-'a'+10;
    accum1:
      if (c >= radix) return BOOL_F; /* bad digit for radix */
      res = res * radix + c;
      flg = 1;			/* res is valid */
      break;
    default:
      goto out1;
    }
  } while (++i < len);
 out1:

  /* if true, then we did see a digit above, and res is valid */
  if (i==len) goto done;

  /* By here, must have seen a digit,
     or must have next char be a `.' with radix==10 */
  if (!flg)
    if (!(str[i]=='.' && radix==10))
      return BOOL_F;

  while (str[i]=='#') {		/* optional sharps */
    res *= radix;
    if (++i==len) goto done;
  }

  if (str[i]=='/') {
    while (++i < len) {
      switch (c = str[i]) {
      case DIGITS:
	c = c - '0';
	goto accum2;
      case 'A': case 'B': case 'C': case 'D': case 'E': case 'F':
	c = c-'A'+10;
	goto accum2;
      case 'a': case 'b': case 'c': case 'd': case 'e': case 'f':
	c = c-'a'+10;
      accum2:
	if (c >= radix) return BOOL_F;
	tmp = tmp * radix + c;
	break;
      default:
	goto out2;
      }
    }
  out2:
    if (tmp==0.0) return BOOL_F; /* `slash zero' not allowed */
    if (i < len)
      while (str[i]=='#') {	/* optional sharps */
	tmp *= radix;
	if (++i==len) break;
      }
    res /= tmp;
    goto done;
  }

  if (str[i]=='.') {		/* decimal point notation */
    if (radix != 10) return BOOL_F; /* must be radix 10 */
    while (++i < len) {
      switch (c = str[i]) {
      case DIGITS:
	point--;
	res = res*10.0 + c-'0';
	flg = 1;
	break;
      default:
	goto out3;
      }
    }
  out3:
    if (!flg) return BOOL_F;	/* no digits before or after decimal point */
    if (i==len) goto adjust;
    while (str[i]=='#') {	/* ignore remaining sharps */
      if (++i==len) goto adjust;
    }
  }

  switch (str[i]) {		/* exponent */
  case 'd': case 'D':
  case 'e': case 'E':
  case 'f': case 'F':
  case 'l': case 'L':
  case 's': case 'S': {
    int expsgn = 1, expon = 0;
    if (radix != 10) return BOOL_F; /* only in radix 10 */
    if (++i==len) return BOOL_F; /* bad exponent */
    switch (str[i]) {
    case '-':  expsgn=(-1);
    case '+':  if (++i==len) return BOOL_F; /* bad exponent */
    }
    if (str[i] < '0' || str[i] > '9') return BOOL_F; /* bad exponent */
    do {
      switch (c = str[i]) {
      case DIGITS:
	expon = expon*10 + c-'0';
	if (expon > MAXEXP)  return BOOL_F; /* exponent too large */
	break;
      default:
	goto out4;
      }
    } while (++i < len);
  out4:
    point += expsgn*expon;
  }
  }

 adjust:
  if (point >= 0)
    while (point--)  res *= 10.0;
  else
# ifdef _UNICOS
    while (point++)  res *= 0.1;
# else
    while (point++)  res /= 10.0;
# endif

 done:
  /* at this point, we have a legitimate floating point result */
  if (lead_sgn==-1.0)  res = -res;
  if (i==len) return makdbl(res, 0.0);

  if (str[i]=='i' || str[i]=='I') { /* pure imaginary number  */
    if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */
    if (++i < len) return BOOL_F; /* `i' not last character */
    return makdbl(0.0, res);
  }

  switch (str[i++]) {
  case '-':  lead_sgn = -1.0; break;
  case '+':  lead_sgn = 1.0;  break;
  case '@': {			/* polar input for complex number */
    /* get a `real' for angle */
    second = istr2flo(&str[i], (long)(len-i), radix);
    if IMP(second) return BOOL_F;
    if (!(INEXP(second))) return BOOL_F; /* not `real' */
    if (CPLXP(second))    return BOOL_F; /* not `real' */
    tmp = REALPART(second);
    return makdbl(res*cos(tmp), res*sin(tmp));
  }
  default: return BOOL_F;
  }

  /* at this point, last char must be `i' */
  if (str[len-1] != 'i' && str[len-1] != 'I') return BOOL_F;
  /* handles `x+i' and `x-i' */
  if (i==(len-1))  return makdbl(res, lead_sgn);
  /* get a `ureal' for complex part */
  second = istr2flo(&str[i], (long)((len-i)-1), radix);
  if IMP(second) return BOOL_F;
  if (!(INEXP(second))) return BOOL_F; /* not `ureal' */
  if (CPLXP(second))    return BOOL_F; /* not `ureal' */
  tmp = REALPART(second);
  if (tmp < 0.0)	return BOOL_F; /* not `ureal' */
  return makdbl(res, (lead_sgn*tmp));
}
#endif				/* FLOATS */


SCM istring2number(str, len, radix)
     char *str;
     long len;
     long radix;
{
  int i = 0;
  char ex = 0;
  char ex_p = 0, rx_p = 0;	/* Only allow 1 exactness and 1 radix prefix */
  SCM res;
  if (len==1)
    if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */
      return BOOL_F;

  while ((len-i) >= 2  &&  str[i]=='#' && ++i)
    switch (str[i++]) {
    case 'b': case 'B':  if (rx_p++) return BOOL_F; radix = 2;  break;
    case 'o': case 'O':  if (rx_p++) return BOOL_F; radix = 8;  break;
    case 'd': case 'D':  if (rx_p++) return BOOL_F; radix = 10; break;
    case 'x': case 'X':  if (rx_p++) return BOOL_F; radix = 16; break;
    case 'i': case 'I':  if (ex_p++) return BOOL_F; ex = 2;     break;
    case 'e': case 'E':  if (ex_p++) return BOOL_F; ex = 1;     break;
    default:  return BOOL_F;
    }

  switch (ex) {
  case 1:
    return istr2int(&str[i], len-i, radix);
  case 0:
    res = istr2int(&str[i], len-i, radix);
    if NFALSEP(res) return res;
#ifdef FLOATS
  case 2: return istr2flo(&str[i], len-i, radix);
#endif
  }
  return BOOL_F;
}


SCM string2number(str, radix)
     SCM str, radix;
{
  if UNBNDP(radix) radix=MAKINUM(10L);
  else ASSERT(INUMP(radix), radix, ARG2, s_str2number);
  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
  return istring2number(CHARS(str), LENGTH(str), INUM(radix));
}
/*** END strs->nums ***/

#ifdef FLOATS
SCM makdbl (x, y)
     double x, y;
{
  SCM z;
  if ((y==0.0) && (x==0.0)) return flo0;
  if (y==0.0) {
# ifdef SINGLES
    float fx;
#  ifndef SINGLESONLY
    if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x))
#  endif
      {
	NEWCELL(z);
	DEFER_INTS;
	CAR(z) = tc_flo;
	FLO(z) = x;
	ALLOW_INTS;
	return z;
      }
# endif				/* def SINGLES */
    DEFER_INTS;
# ifdef NUM_HP
    CDR(z) = (SCM)num_hp_alloc(sizeof(double));
# else
    z = must_malloc_cell(1L*sizeof(double), "real");
# endif
    CAR(z) = tc_dblr;
  }
  else {
    DEFER_INTS;
# ifdef NUM_HP
    CDR(z) = (SCM)num_hp_alloc(2L*sizeof(double));
# else
    z = must_malloc_cell(2L*sizeof(double), "complex");
# endif
    CAR(z) = tc_dblc;
    IMAG(z) = y;
  }
  REAL(z) = x;
  ALLOW_INTS;
  return z;
}
#endif				/* FLOATS */

#ifndef INUMS_ONLY
SCM eqv(x, y)
     SCM x, y;
{
  if (x==y) return BOOL_T;
  if IMP(x) return BOOL_F;
  if IMP(y) return BOOL_F;
  /* this ensures that types and length are the same. */
  if (CAR(x) != CAR(y)) return BOOL_F;
  if NUMP(x) {
# ifdef BIGDIG
    if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
# endif
# ifdef FLOATS
    if (REALPART(x) != REALPART(y)) return BOOL_F;
    if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F;
    return BOOL_T;
# endif
  }
  return BOOL_F;
}
SCM memv(x, lst)			/* m.borza  12.2.91 */
SCM x, lst;
{
  for(;NIMP(lst);lst = CDR(lst)) {
    ASRTGO(CONSP(lst), badlst);
    if NFALSEP(eqv(CAR(lst), x)) return lst;
  }
# ifndef RECKLESS
  if (!(NULLP(lst)))
    badlst: wta(lst, (char *)ARG2, s_memv);
# endif
  return BOOL_F;
}
SCM assv(x, alist)		/* m.borza  12.2.91 */
SCM x, alist;
{
  SCM tmp;
  for(;NIMP(alist);alist = CDR(alist)) {
    ASRTGO(CONSP(alist), badlst);
    tmp = CAR(alist);
    ASRTGO(NIMP(tmp) && CONSP(tmp), badlst);
    if NFALSEP(eqv(CAR(tmp), x)) return tmp;
  }
# ifndef RECKLESS
  if (!(NULLP(alist)))
    badlst: wta(alist, (char *)ARG2, s_assv);
# endif
  return BOOL_F;
}
#endif

SCM list_tail(lst, k)
     SCM lst, k;
{
  register long i;
  ASSERT(INUMP(k), k, ARG2, s_list_tail);
  i = INUM(k);
  while (i-- > 0) {
    ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
    lst = CDR(lst);
  }
  return lst;
}

SCM string2list(str)
     SCM str;
{
  long i;
  SCM res = EOL;
  unsigned char *src;
  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
  src = UCHARS(str);
  for(i = LENGTH(str)-1;i >= 0;i--) res = cons((SCM)MAKICHR(src[i]), res);
  return res;
}
SCM string_copy(str)
     SCM str;
{
  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
  return makfromstr(CHARS(str), (sizet)LENGTH(str));
}
SCM string_fill(str, chr)
     SCM str, chr;
{
  register char *dst, c;
  register long k;
  ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
  ASSERT(ICHRP(chr), chr, ARG2, s_st_fill);
  c = ICHR(chr);
  dst = CHARS(str);
  for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c;
  return UNSPECIFIED;
}
SCM vector2list(v)
     SCM v;
{
  SCM res = EOL;
  long i;
  SCM *data;
  ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
  data = VELTS(v);
  for(i = LENGTH(v)-1;i >= 0;i--) res = cons(data[i], res);
  return res;
}
SCM vector_fill(v, fill)
     SCM v, fill;
{
  register long i;
  register SCM *data;
  ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
  data = VELTS(v);
  for(i = LENGTH(v)-1;i >= 0;i--) data[i] = fill;
  return UNSPECIFIED;
}
static SCM vector_equal(x, y)
     SCM x, y;
{
  long i;
  for(i = LENGTH(x)-1;i >= 0;i--)
    if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F;
  return BOOL_T;
}
SCM bigequal(x, y)
     SCM x, y;
{
#ifdef BIGDIG
  if (0==bigcomp(x, y)) return BOOL_T;
#endif
  return BOOL_F;
}
SCM floequal(x, y)
     SCM x, y;
{
#ifdef FLOATS
  if (REALPART(x) != REALPART(y)) return BOOL_F;
  if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T;
#endif
  return BOOL_F;
}
SCM equal(x, y)
     SCM x, y;
{
  CHECK_STACK;
 tailrecurse: POLL;
	if (x==y) return BOOL_T;
	if IMP(x) return BOOL_F;
	if IMP(y) return BOOL_F;
	if (CONSP(x) && CONSP(y)) {
		if FALSEP(equal(CAR(x), CAR(y))) return BOOL_F;
		x = CDR(x);
		y = CDR(y);
		goto tailrecurse;
	}
	/* this ensures that types and length are the same. */
	if (CAR(x) != CAR(y)) return BOOL_F;
	switch (TYP7(x)) {
        default: return BOOL_F;
	case tc7_string: return st_equal(x, y);
	case tc7_vector: return vector_equal(x, y);
	case tc7_smob: {
	        int i = SMOBNUM(x);
	        if (!(i < numsmob)) return BOOL_F;
	        if (smobs[i].equalp) return (smobs[i].equalp)(x, y);
		else return BOOL_F;
	      }
	case tc7_bvect: case tc7_uvect: case tc7_ivect:
	case tc7_fvect:	case tc7_cvect: case tc7_dvect: {
	        SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp;
	        if (pred) return (*pred)(x, y);
		else return BOOL_F;
	      }
	}
}

SCM numberp(x)
     SCM x;
{
  if INUMP(x) return BOOL_T;
#ifdef FLOATS
  if (NIMP(x) && NUMP(x)) return BOOL_T;
#else
# ifdef BIGDIG
  if (NIMP(x) && NUMP(x)) return BOOL_T;
# endif
#endif
  return BOOL_F;
}
#ifdef FLOATS
SCM realp(x)
     SCM x;
{
  if INUMP(x) return BOOL_T;
  if IMP(x) return BOOL_F;
  if REALP(x) return BOOL_T;
# ifdef BIGDIG
  if BIGP(x) return BOOL_T;
# endif
  return BOOL_F;
}
SCM intp(x)
     SCM x;
{
  double r;
  if INUMP(x) return BOOL_T;
  if IMP(x) return BOOL_F;
# ifdef BIGDIG
  if BIGP(x) return BOOL_T;
# endif
  if (!INEXP(x)) return BOOL_F;
  if CPLXP(x) return BOOL_F;
  r = REALPART(x);
  if (r==floor(r)) return BOOL_T;
  return BOOL_F;
}
#endif				/* FLOATS */

SCM inexactp(x)
     SCM x;
{
#ifdef FLOATS
  if (NIMP(x) && INEXP(x)) return BOOL_T;
#endif
  return BOOL_F;
}
SCM eqp(x, y)
     SCM x, y;
{
#ifdef FLOATS
  SCM t;
  if NINUMP(x) {
# ifdef BIGDIG
#  ifndef RECKLESS
    if (!(NIMP(x)))
    badx: wta(x, (char *)ARG1, s_eqp);
#  endif
    if BIGP(x) {
      if INUMP(y) return BOOL_F;
      ASRTGO(NIMP(y), bady);
      if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
      ASRTGO(INEXP(y), bady);
    bigreal:
      return (REALP(y) && (big2dbl(x)==REALPART(y))) ? BOOL_T : BOOL_F;
    }
    ASRTGO(INEXP(x), badx);
# else
    ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
# endif
    if INUMP(y) {t = x; x = y; y = t; goto realint;}
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
    ASRTGO(INEXP(y), bady);
# else
    ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
    if (REALPART(x) != REALPART(y)) return BOOL_F;
    if CPLXP(x)
      return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F;
    return CPLXP(y) ? BOOL_F : BOOL_T;
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return BOOL_F;
#  ifndef RECKLESS
    if (!(INEXP(y)))
    bady: wta(y, (char *)ARG2, s_eqp);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && INEXP(y)))
    bady: wta(y, (char *)ARG2, s_eqp);
#  endif
# endif
  realint:
    return (REALP(y) && (((double)INUM(x))==REALPART(y))) ? BOOL_T : BOOL_F;
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
    if INUMP(y) return BOOL_F;
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F;
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_eqp);
#  endif
    return BOOL_F;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_eqp);
  ASSERT(INUMP(y), y, ARG2, s_eqp);
# endif
#endif
  return ((long)x==(long)y) ? BOOL_T : BOOL_F;
}
SCM lessp(x, y)
     SCM x, y;
{
#ifdef FLOATS
  if NINUMP(x) {
# ifdef BIGDIG
#  ifndef RECKLESS
    if (!(NIMP(x)))
    badx: wta(x, (char *)ARG1, s_lessp);
#  endif
    if BIGP(x) {
      if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F;
      ASRTGO(NIMP(y), bady);
      if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
      ASRTGO(REALP(y), bady);
      return (big2dbl(x) < REALPART(y)) ? BOOL_T : BOOL_F;
    }
    ASRTGO(REALP(x), badx);
# else
    ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp);
# endif
    if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F;
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return (REALPART(x) < big2dbl(y)) ? BOOL_T : BOOL_F;
    ASRTGO(REALP(y), bady);
# else
    ASRTGO(NIMP(y) && REALP(y), bady);
# endif
    return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F;
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T;
#  ifndef RECKLESS
    if (!(REALP(y)))
    bady: wta(y, (char *)ARG2, s_lessp);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && REALP(y)))
    bady: wta(y, (char *)ARG2, s_lessp);
#  endif
# endif
    return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F;
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
    if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F;
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F;
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_lessp);
#  endif
    return BIGSIGN(y) ? BOOL_F : BOOL_T;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_lessp);
  ASSERT(INUMP(y), y, ARG2, s_lessp);
# endif
#endif
  return ((long)x < (long)y) ? BOOL_T : BOOL_F;
}
SCM greaterp(x, y)
     SCM x, y;
{
  return lessp(y, x);
}
SCM leqp(x, y)
     SCM x, y;
{
  return BOOL_NOT(lessp(y, x));
}
SCM greqp(x, y)
     SCM x, y;
{
  return BOOL_NOT(lessp(x, y));
}
SCM zerop(z)
     SCM z;
{
#ifdef FLOATS
  if NINUMP(z) {
# ifdef BIGDIG
    ASRTGO(NIMP(z), badz);
    if BIGP(z) return BOOL_F;
#  ifndef RECKLESS
    if (!(INEXP(z)))
      badz: wta(z, (char *)ARG1, s_zerop);
#  endif
# else
    ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
# endif
    return (z==flo0) ? BOOL_T : BOOL_F;
  }
#else
# ifdef BIGDIG
  if NINUMP(z) {
    ASSERT(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
    return BOOL_F;
  }
# else
  ASSERT(INUMP(z), z, ARG1, s_zerop);
# endif
#endif
  return (z==INUM0) ? BOOL_T: BOOL_F;
}
SCM positivep(x)
     SCM x;
{
#ifdef FLOATS
  if NINUMP(x) {
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
#  ifndef RECKLESS
    if (!(REALP(x)))
      badx: wta(x, (char *)ARG1, s_positivep);
#  endif
# else
    ASSERT(NIMP(x) && REALP(x), x, ARG1, s_positivep);
# endif
    return (REALPART(x) > 0.0) ? BOOL_T : BOOL_F;
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_positivep);
    return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_positivep);
# endif
#endif
  return (x > INUM0) ? BOOL_T : BOOL_F;
}
SCM negativep(x)
     SCM x;
{
#ifdef FLOATS
  if NINUMP(x) {
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T;
#  ifndef RECKLESS
    if (!(REALP(x)))
      badx: wta(x, (char *)ARG1, s_negativep);
#  endif
# else
    ASSERT(NIMP(x) && REALP(x), x, ARG1, s_negativep);
# endif
    return (REALPART(x) < 0.0) ? BOOL_T : BOOL_F;
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_negativep);
    return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_negativep);
# endif
#endif
  return (x < INUM0) ? BOOL_T : BOOL_F;
}

SCM lmax(x, y)
     SCM x, y;
{
#ifdef FLOATS
  double z;
#endif
  if UNBNDP(y) {
#ifndef RECKLESS
    if (!(NUMBERP(x)))
    badx: wta(x, (char *)ARG1, s_max);
#endif
    return x;
  }
#ifdef FLOATS
  if NINUMP(x) {
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) {
      if INUMP(y) return BIGSIGN(x) ? y : x;
      ASRTGO(NIMP(y), bady);
      if BIGP(y) return (1==bigcomp(x, y)) ? y : x;
      ASRTGO(REALP(y), bady);
      z = big2dbl(x);
      return (z < REALPART(y)) ? y : makdbl(z, 0.0);
    }
    ASRTGO(REALP(x), badx);
# else
    ASSERT(NIMP(x) && REALP(x), x, ARG1, s_max);
# endif
    if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return (REALPART(x) < (z = big2dbl(y))) ? makdbl(z, 0.0) : x;
    ASRTGO(REALP(y), bady);
# else
    ASRTGO(NIMP(y) && REALP(y), bady);
# endif
    return (REALPART(x) < REALPART(y)) ? y : x;
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return BIGSIGN(y) ? x : y;
#  ifndef RECKLESS
    if (!(REALP(y)))
    bady: wta(y, (char *)ARG2, s_max);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && REALP(y)))
    bady: wta(y, (char *)ARG2, s_max);
#  endif
# endif
    return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_max);
    if INUMP(y) return BIGSIGN(x) ? y : x;
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return (1==bigcomp(x, y)) ? y : x;
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_max);
#  endif
    return BIGSIGN(y) ? x : y;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_max);
  ASSERT(INUMP(y), y, ARG2, s_max);
# endif
#endif
  return ((long)x < (long)y) ? y : x;
}

SCM lmin(x, y)
     SCM x, y;
{
#ifdef FLOATS
  double z;
#endif
  if UNBNDP(y) {
#ifndef RECKLESS
    if (!(NUMBERP(x)))
    badx: wta(x, (char *)ARG1, s_min);
#endif
    return x;
  }
#ifdef FLOATS
  if NINUMP(x) {
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) {
      if INUMP(y) return BIGSIGN(x) ? x : y;
      ASRTGO(NIMP(y), bady);
      if BIGP(y) return (-1==bigcomp(x, y)) ? y : x;
      ASRTGO(REALP(y), bady);
      z = big2dbl(x);
      return (z > REALPART(y)) ? y : makdbl(z, 0.0);
    }
    ASRTGO(REALP(x), badx);
# else
    ASSERT(NIMP(x) && REALP(x), x, ARG1, s_min);
# endif
    if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x;
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return (REALPART(x) > (z = big2dbl(y))) ? makdbl(z, 0.0) : x;
    ASRTGO(REALP(y), bady);
# else
    ASRTGO(NIMP(y) && REALP(y), bady);
# endif
    return (REALPART(x) > REALPART(y)) ? y : x;
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return BIGSIGN(y) ? y : x;
#  ifndef RECKLESS
    if (!(REALP(y)))
    bady: wta(y, (char *)ARG2, s_min);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && REALP(y)))
    bady: wta(y, (char *)ARG2, s_min);
#  endif
# endif
    return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_min);
    if INUMP(y) return BIGSIGN(x) ? x : y;
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return (-1==bigcomp(x, y)) ? y : x;
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_min);
#  endif
    return BIGSIGN(y) ? y : x;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_min);
  ASSERT(INUMP(y), y, ARG2, s_min);
# endif
#endif
  return ((long)x > (long)y) ? y : x;
}

SCM sum(x, y)
     SCM x, y;
{
  if UNBNDP(y) {
    if UNBNDP(x) return INUM0;
#ifndef RECKLESS
    if (!(NUMBERP(x)))
    badx: wta(x, (char *)ARG1, s_sum);
#endif
    return x;
  }
#ifdef FLOATS
  if NINUMP(x) {
    SCM t;
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) {
      if INUMP(y) {t = x; x = y; y = t; goto intbig;}
      ASRTGO(NIMP(y), bady);
      if BIGP(y) {
	if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
	return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
      }
      ASRTGO(INEXP(y), bady);
    bigreal: return makdbl(big2dbl(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
    }
    ASRTGO(INEXP(x), badx);
# else
    ASRTGO(NIMP(x) && INEXP(x), badx);
# endif
    if INUMP(y) {t = x; x = y; y = t; goto intreal;}
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
#  ifndef RECKLESS
    else if (!(INEXP(y)))
    bady: wta(y, (char *)ARG2, s_sum);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && INEXP(y)))
    bady: wta(y, (char *)ARG2, s_sum);
#  endif
# endif
    { double i = 0.0;
      if CPLXP(x) i = IMAG(x);
      if CPLXP(y) i += IMAG(y);
      return makdbl(REALPART(x)+REALPART(y), i); }
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y)
    intbig: {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(x));
      return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
#  endif
    }
    ASRTGO(INEXP(y), bady);
# else
    ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
  intreal: return makdbl(INUM(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    SCM t;
    ASRTGO(NIMP(x) && BIGP(x), badx);
    if INUMP(y) {t = x; x = y; y = t; goto intbig;}
    ASRTGO(NIMP(y) && BIGP(y), bady);
    if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;}
    return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0);
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_sum);
#  endif
    intbig: {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(x));
      return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0);
#  endif
    }
  }
# else
  ASRTGO(INUMP(x), badx);
  ASSERT(INUMP(y), y, ARG2, s_sum);
# endif
#endif
  x = INUM(x)+INUM(y);
  if FIXABLE(x) return MAKINUM(x);
#ifdef BIGDIG
  return long2big(x);
#else
# ifdef FLOATS
  return makdbl((double)x, 0.0);
# else
  wta(y, (char *)OVFLOW, s_sum);
# endif
#endif
}

SCM difference(x, y)
     SCM x, y;
{
#ifdef FLOATS
  if NINUMP(x) {
# ifndef RECKLESS
    if (!(NIMP(x)))
    badx: wta(x, (char *)ARG1, s_difference);
# endif
    if UNBNDP(y) {
# ifdef BIGDIG
      if BIGP(x) {
	x = copybig(x, !BIGSIGN(x));
	return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
	  big2inum(x, NUMDIGS(x)) : x;
      }
# endif
      ASRTGO(INEXP(x), badx);
      return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0);
    }
    if INUMP(y) return sum(x, MAKINUM(-INUM(y)));
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(x) {
      if BIGP(y) return (NUMDIGS(x) < NUMDIGS(y)) ?
		   addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
		   addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
      ASRTGO(INEXP(y), bady);
      return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
    }
    ASRTGO(INEXP(x), badx);
    if BIGP(y) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0);
    ASRTGO(INEXP(y), bady);
# else
    ASRTGO(INEXP(x), badx);
    ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
    if CPLXP(x)
      if CPLXP(y)
	return makdbl(REAL(x)-REAL(y), IMAG(x)-IMAG(y));
      else
	return makdbl(REAL(x)-REALPART(y), IMAG(x));
    return makdbl(REALPART(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
  }
  if UNBNDP(y) {x = -INUM(x); goto checkx;}
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(x));
      return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
#  endif
    }
#  ifndef RECKLESS
    if (!(INEXP(y)))
    bady: wta(y, (char *)ARG2, s_difference);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && INEXP(y)))
    bady: wta(y, (char *)ARG2, s_difference);
#  endif
# endif
    return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference);
    if UNBNDP(y) {
      x = copybig(x, !BIGSIGN(x));
      return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
		big2inum(x, NUMDIGS(x)) : x;
    }
    if INUMP(y) {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(y));
      return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return addbig(zdigs, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0);
#  endif
    }
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return (NUMDIGS(x) < NUMDIGS(y)) ?
		   addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) :
		   addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0);
  }
  if UNBNDP(y) {x = -INUM(x); goto checkx;}
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_difference);
#  endif
    {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(x));
      return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100);
#  endif
    }
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_difference);
  if UNBNDP(y) {x = -INUM(x); goto checkx;}
  ASSERT(INUMP(y), y, ARG2, s_difference);
# endif
#endif
  x = INUM(x)-INUM(y);
 checkx:
  if FIXABLE(x) return MAKINUM(x);
#ifdef BIGDIG
  return long2big(x);
#else
# ifdef FLOATS
  return makdbl((double)x, 0.0);
# else
  wta(y, (char *)OVFLOW, s_difference);
# endif
#endif
}

SCM product(x, y)
     SCM x, y;
{
  if UNBNDP(y) {
    if UNBNDP(x) return MAKINUM(1L);
#ifndef RECKLESS
    if (!(NUMBERP(x)))
    badx: wta(x, (char *)ARG1, s_product);
#endif
    return x;
  }
#ifdef FLOATS
  if NINUMP(x) {
    SCM t;
# ifdef BIGDIG
    ASRTGO(NIMP(x), badx);
    if BIGP(x) {
      if INUMP(y) {t = x; x = y; y = t; goto intbig;}
      ASRTGO(NIMP(y), bady);
      if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
			       BIGSIGN(x) ^ BIGSIGN(y));
      ASRTGO(INEXP(y), bady);
    bigreal: {
      double bg = big2dbl(x);
      return makdbl(bg*REALPART(y), CPLXP(y)?bg*IMAG(y):0.0); }
    }
    ASRTGO(INEXP(x), badx);
# else
    ASRTGO(NIMP(x) && INEXP(x), badx);
# endif
    if INUMP(y) {t = x; x = y; y = t; goto intreal;}
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {t = x; x = y; y = t; goto bigreal;}
#  ifndef RECKLESS
    else if (!(INEXP(y)))
    bady: wta(y, (char *)ARG2, s_product);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && INEXP(y)))
    bady: wta(y, (char *)ARG2, s_product);
#  endif
# endif
    if CPLXP(x)
      if CPLXP(y)
	return makdbl(REAL(x)*REAL(y)-IMAG(x)*IMAG(y),
		      REAL(x)*IMAG(y)+IMAG(x)*REAL(y));
      else
	return makdbl(REAL(x)*REALPART(y), IMAG(x)*REALPART(y));
    return makdbl(REALPART(x)*REALPART(y),
		  CPLXP(y)?REALPART(x)*IMAG(y):0.0);
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {
    intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
      {
#  ifndef DIGSTOOBIG
	long z = pseudolong(INUM(x));
	return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
		      BIGSIGN(y) ? (x>0) : (x<0));
#  else
	BIGDIG zdigs[DIGSPERLONG];
	longdigs(INUM(x), zdigs);
	return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
		      BIGSIGN(y) ? (x>0) : (x<0));
#  endif
      }
    }
    ASRTGO(INEXP(y), bady);
# else
    ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
  intreal: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    ASRTGO(NIMP(x) && BIGP(x), badx);
    if INUMP(y) {SCM t = x; x = y; y = t; goto intbig;}
    ASRTGO(NIMP(y) && BIGP(y), bady);
    return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
		  BIGSIGN(x) ^ BIGSIGN(y));
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_product);
#  endif
  intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y;
    {
#  ifndef DIGSTOOBIG
      long z = pseudolong(INUM(x));
      return mulbig(&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
		    BIGSIGN(y) ? (x>0) : (x<0));
#  else
      BIGDIG zdigs[DIGSPERLONG];
      longdigs(INUM(x), zdigs);
      return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y),
		    BIGSIGN(y) ? (x>0) : (x<0));
#  endif
    }
  }
# else
  ASRTGO(INUMP(x), badx);
  ASSERT(INUMP(y), y, ARG2, s_product);
# endif
#endif
  {
    long i, j, k;
    i = INUM(x);
    if (0==i) return x;
    j = INUM(y);
    k = i * j;
    y = MAKINUM(k);
    if (k != INUM(y) || k/i != j)
#ifdef BIGDIG
      { int sgn = (i < 0) ^ (j < 0);
# ifndef DIGSTOOBIG
	i = pseudolong(i);
	j = pseudolong(j);
	return mulbig((BIGDIG *)&i, DIGSPERLONG,
		      (BIGDIG *)&j, DIGSPERLONG, sgn);
# else /* DIGSTOOBIG */
	BIGDIG idigs[DIGSPERLONG];
	BIGDIG jdigs[DIGSPERLONG];
	longdigs(i, idigs);
	longdigs(j, jdigs);
	return mulbig(idigs, DIGSPERLONG, jdigs, DIGSPERLONG, sgn);
# endif
      }
#else
# ifdef FLOATS
    return makdbl(((double)i)*((double)j), 0.0);
# else
    wta(y, (char *)OVFLOW, s_product);
# endif
#endif
    return y;
  }
}

SCM divide(x, y)
     SCM x, y;
{
#ifdef FLOATS
  double d, r, i, a;
  if NINUMP(x) {
# ifndef RECKLESS
    if (!(NIMP(x)))
    badx: wta(x, (char *)ARG1, s_divide);
# endif
    if UNBNDP(y) {
# ifdef BIGDIG
      if BIGP(x) return makdbl(1.0/big2dbl(x), 0.0);
# endif
      ASRTGO(INEXP(x), badx);
      if REALP(x) return makdbl(1.0/REALPART(x), 0.0);
      r = REAL(x);  i = IMAG(x);  d = r*r+i*i;
      return makdbl(r/d, -i/d);
    }
# ifdef BIGDIG
    if BIGP(x) {
      SCM z;
      if INUMP(y) {
        z = INUM(y);
        ASSERT(z, y, OVFLOW, s_divide);
	if (1==z) return x;
        if (z < 0) z = -z;
        if (z < BIGRAD) {
          SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
          return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ?
	    makdbl(big2dbl(x)/INUM(y), 0.0) : normbig(w);
	}
#  ifndef DIGSTOOBIG
        z = pseudolong(z);
        z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG,
                      BIGSIGN(x) ? (y>0) : (y<0), 3);
#  else
	{ BIGDIG zdigs[DIGSPERLONG];
	  longdigs(z, zdigs);
	  z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
			BIGSIGN(x) ? (y>0) : (y<0), 3);}
#  endif
        return z ? z : makdbl(big2dbl(x)/INUM(y), 0.0);
      }
      ASRTGO(NIMP(y), bady);
      if BIGP(y) {
	z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
		      BIGSIGN(x) ^ BIGSIGN(y), 3);
	return z ? z : makdbl(big2dbl(x)/big2dbl(y), 0.0);
      }
      ASRTGO(INEXP(y), bady);
      if REALP(y) return makdbl(big2dbl(x)/REALPART(y), 0.0);
      a = big2dbl(x);
      goto complex_div;
    }
# endif
    ASRTGO(INEXP(x), badx);
    if INUMP(y) {d = INUM(y); goto basic_div;}
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) {d = big2dbl(y); goto basic_div;}
    ASRTGO(INEXP(y), bady);
# else
    ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
    if REALP(y) {
      d = REALPART(y);
    basic_div: return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0);
    }
    a = REALPART(x);
    if REALP(x) goto complex_div;
    r = REAL(y);  i = IMAG(y);  d = r*r+i*i;
    return makdbl((a*r+IMAG(x)*i)/d, (IMAG(x)*r-a*i)/d);
  }
  if UNBNDP(y) {
    if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
    return makdbl(1.0/((double)INUM(x)), 0.0);
  }
  if NINUMP(y) {
# ifdef BIGDIG
    ASRTGO(NIMP(y), bady);
    if BIGP(y) return makdbl(INUM(x)/big2dbl(y), 0.0);
#  ifndef RECKLESS
    if (!(INEXP(y)))
    bady: wta(y, (char *)ARG2, s_divide);
#  endif
# else
#  ifndef RECKLESS
    if (!(NIMP(y) && INEXP(y)))
    bady: wta(y, (char *)ARG2, s_divide);
#  endif
# endif
    if REALP(y) return makdbl(INUM(x)/REALPART(y), 0.0);
    a = INUM(x);
  complex_div:
    r = REAL(y);  i = IMAG(y);  d = r*r+i*i;
    return makdbl((a*r)/d, (-a*i)/d);
  }
#else
# ifdef BIGDIG
  if NINUMP(x) {
    SCM z;
    ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide);
    if UNBNDP(y) goto ov;
    if INUMP(y) {
      z = INUM(y);
      if (!z) goto ov;
      if (1==z) return x;
      if (z < 0) z = -z;
      if (z < BIGRAD) {
        SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0));
        if (divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z)) goto ov;
        return w;
      }
#  ifndef DIGSTOOBIG
      z = pseudolong(z);
      z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG,
		    BIGSIGN(x) ? (y>0) : (y<0), 3);
#  else
      { BIGDIG zdigs[DIGSPERLONG];
	longdigs(z, zdigs);
	z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG,
		      BIGSIGN(x) ? (y>0) : (y<0), 3);}
#  endif
    } else {
      ASRTGO(NIMP(y) && BIGP(y), bady);
      z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y),
		    BIGSIGN(x) ^ BIGSIGN(y), 3);
    }
    if (!z) goto ov;
    return z;
  }
  if UNBNDP(y) {
    if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
    goto ov;
  }
  if NINUMP(y) {
#  ifndef RECKLESS
    if (!(NIMP(y) && BIGP(y)))
    bady: wta(y, (char *)ARG2, s_divide);
#  endif
    goto ov;
  }
# else
  ASSERT(INUMP(x), x, ARG1, s_divide);
  if UNBNDP(y) {
    if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x;
    goto ov;
  }
  ASSERT(INUMP(y), y, ARG2, s_divide);
# endif
#endif
  {
    long z = INUM(y);
    if ((0==z) || INUM(x)%z) goto ov;
    z = INUM(x)/z;
    if FIXABLE(z) return MAKINUM(z);
#ifdef BIGDIG
    return long2big(z);
#endif
#ifdef FLOATS
  ov: return makdbl(((double)INUM(x))/((double)INUM(y)), 0.0);
#else
  ov: wta(x, (char *)OVFLOW, s_divide);
#endif
  }
}

#ifdef FLOATS
double lasinh(x)
     double x;
{
  return log(x+sqrt(x*x+1));
}

double lacosh(x)
     double x;
{
  return log(x+sqrt(x*x-1));
}

double latanh(x)
     double x;
{
  return 0.5*log((1+x)/(1-x));
}

double ltrunc(x)
     double x;
{
  if (x < 0.0) return -floor(-x);
  return floor(x);
}

double scm_round(x)
     double x;
{
  double plus_half = x + 0.5;
  double result = floor(plus_half);
  /* Adjust so that the round is towards even.  */
  return (plus_half==result && plus_half / 2 != floor(plus_half / 2))
    ? result - 1 : result;
}

struct dpair {double x, y;};

void two_doubles(z1, z2, sstring, xy)
     SCM z1, z2;
     char *sstring;
     struct dpair *xy;
{
  if INUMP(z1) xy->x = INUM(z1);
  else {
# ifdef BIGDIG
    ASRTGO(NIMP(z1), badz1);
    if BIGP(z1) xy->x = big2dbl(z1);
    else {
#  ifndef RECKLESS
      if (!(REALP(z1)))
      badz1: wta(z1, (char *)ARG1, sstring);
#  endif
      xy->x = REALPART(z1);}
# else
    {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
     xy->x = REALPART(z1);}
# endif
  }
  if INUMP(z2) xy->y = INUM(z2);
  else {
# ifdef BIGDIG
    ASRTGO(NIMP(z2), badz2);
    if BIGP(z2) xy->y = big2dbl(z2);
    else {
#  ifndef RECKLESS
      if (!(REALP(z2)))
      badz2: wta(z2, (char *)ARG2, sstring);
#  endif
      xy->y = REALPART(z2);}
# else
    {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
     xy->y = REALPART(z2);}
# endif
  }
}

SCM expt(z1, z2)
     SCM z1, z2;
{
  struct dpair xy;
  two_doubles(z1, z2, s_expt, &xy);
  return makdbl(pow(xy.x, xy.y), 0.0);
}
SCM latan2(z1, z2)
     SCM z1, z2;
{
  struct dpair xy;
  two_doubles(z1, z2, s_atan2, &xy);
  return makdbl(atan2(xy.x, xy.y), 0.0);
}
SCM makrect(z1, z2)
     SCM z1, z2;
{
  struct dpair xy;
  two_doubles(z1, z2, s_makrect, &xy);
  return makdbl(xy.x, xy.y);
}
SCM makpolar(z1, z2)
     SCM z1, z2;
{
  struct dpair xy;
  two_doubles(z1, z2, s_makpolar, &xy);
  return makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y));
}

SCM real_part(z)
     SCM z;
{
  if NINUMP(z) {
# ifdef BIGDIG
    ASRTGO(NIMP(z), badz);
    if BIGP(z) return z;
#  ifndef RECKLESS
    if (!(INEXP(z)))
    badz: wta(z, (char *)ARG1, s_real_part);
#  endif
# else
    ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
# endif
    if CPLXP(z) return makdbl(REAL(z), 0.0);
  }
  return z;
}
SCM imag_part(z)
     SCM z;
{
  if INUMP(z) return INUM0;
# ifdef BIGDIG
  ASRTGO(NIMP(z), badz);
  if BIGP(z) return INUM0;
#  ifndef RECKLESS
  if (!(INEXP(z)))
  badz: wta(z, (char *)ARG1, s_imag_part);
#  endif
# else
  ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
# endif
  if CPLXP(z) return makdbl(IMAG(z), 0.0);
  return flo0;
}
SCM magnitude(z)
     SCM z;
{
  if INUMP(z) return absval(z);
# ifdef BIGDIG
  ASRTGO(NIMP(z), badz);
  if BIGP(z) return absval(z);
#  ifndef RECKLESS
  if (!(INEXP(z)))
  badz: wta(z, (char *)ARG1, s_magnitude);
#  endif
# else
  ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
# endif
  if CPLXP(z)
    {
      double i = IMAG(z), r = REAL(z);
      return makdbl(sqrt(i*i+r*r), 0.0);
    }
  return makdbl(fabs(REALPART(z)), 0.0);
}

SCM angle(z)
     SCM z;
{
  double x, y = 0.0;
  if INUMP(z) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;}
# ifdef BIGDIG
  ASRTGO(NIMP(z), badz);
  if BIGP(z) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;}
#  ifndef RECKLESS
  if (!(INEXP(z))) {
    badz: wta(z, (char *)ARG1, s_angle);}
#  endif
# else
  ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle);
# endif
  if REALP(z) {x = REALPART(z); goto do_angle;}
  x = REAL(z); y = IMAG(z);
do_angle:
  return makdbl(atan2(y, x), 0.0);
}


SCM ex2in(z)
     SCM z;
{
  if INUMP(z) return makdbl((double)INUM(z), 0.0);
  ASRTGO(NIMP(z), badz);
  if INEXP(z) return z;
# ifdef BIGDIG
  if BIGP(z) return makdbl(big2dbl(z), 0.0);
# endif
 badz: wta(z, (char *)ARG1, s_ex2in);
}
SCM in2ex(z)
     SCM z;
{
  if INUMP(z) return z;
# ifdef BIGDIG
  ASRTGO(NIMP(z), badz);
  if BIGP(z) return z;
#  ifndef RECKLESS
  if (!(REALP(z)))
    badz: wta(z, (char *)ARG1, s_in2ex);
#  endif
# else
  ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
# endif
# ifdef BIGDIG
  {
    double u = floor(REALPART(z)+0.5);
    if ((u <= MOST_POSITIVE_FIXNUM) && (-u <= -MOST_NEGATIVE_FIXNUM)) {
      /* Negation is a workaround for HP700 cc bug */
      SCM ans = MAKINUM((long)u);
      if (INUM(ans)==(long)u) return ans;
    }
    ASRTGO(!IS_INF(u), badz);	/* problem? */
    return dbl2big(u);
  }
# else
  return MAKINUM((long)floor(REALPART(z)+0.5));
# endif
}
#else				/* ~FLOATS */
static char s_trunc[] = "truncate";
SCM numident(x)
     SCM x;
{
  ASSERT(INUMP(x), x, ARG1, s_trunc);
  return x;
}
#endif				/* FLOATS */

#ifdef BIGDIG
# ifdef FLOATS
SCM dbl2big(d)
     double d;			/* must be integer */
{
  sizet i = 0;
  long c;
  BIGDIG *digits;
  SCM ans;
  double u = (d < 0)?-d:d;
  while (0 != floor(u)) {u /= BIGRAD;i++;}
  ans = mkbig(i, d < 0);
  digits = BDIGITS(ans);
  while (i--) {
    u *= BIGRAD;
    c = floor(u);
    u -= c;
    digits[i] = c;
  }
  ASSERT(0==u, INUM0, OVFLOW, "dbl2big");
  return ans;
}
double big2dbl(b)
     SCM b;
{
  double ans = 0.0;
  sizet i = NUMDIGS(b);
  BIGDIG *digits = BDIGITS(b);
  while (i--) ans = digits[i] + BIGRAD*ans;
  if (tc16_bigneg==TYP16(b)) return -ans;
  return ans;
}
# endif
#endif

unsigned long hasher(obj, n, d)
     SCM obj;
     unsigned long n;
     sizet d;
{
  switch (7 & (int) obj) {
  case 2: case 6:		/* INUMP(obj) */
    return INUM(obj) % n;
  case 4:
    if ICHRP(obj)
      return (unsigned)(downcase[ICHR(obj)]) % n;
    switch ((int) obj) {
#ifndef SICP
    case (int) EOL: d = 256; break;
#endif
    case (int) BOOL_T: d = 257; break;
    case (int) BOOL_F: d = 258; break;
    case (int) EOF_VAL: d = 259; break;
    default: d = 263;		/* perhaps should be error */
    }
    return d % n;
  default: return 263 % n;	/* perhaps should be error */
  case 0:
    switch TYP7(obj) {
    default: return 263 % n;
    case tc7_smob:
      switch TYP16(obj) {
      case tcs_bignums:
      bighash: return INUM(modulo(obj, MAKINUM(n)));
      default: return 263 % n;
#ifdef FLOATS
      case tc16_flo:
	if REALP(obj) {
	  double r = REALPART(obj);
	  if (floor(r)==r) {
	    obj = in2ex(obj);
	    if IMP(obj) return INUM(obj) % n;
	    goto bighash;
	  }
	}
	obj = number2string(obj, MAKINUM(10));
#endif
      }
    case tcs_symbols: case tc7_string:
      return strhash(UCHARS(obj), (sizet) LENGTH(obj), n);
    case tc7_vector: {
      sizet len = LENGTH(obj);
      SCM *data = VELTS(obj);
      if (len>5) {
	sizet i = d/2;
	unsigned long h = 1;
	while (i--) h = ((h<<8) + (hasher(data[h % len], n, 2))) % n;
	return h;
      }
      else {
	sizet i = len;
	unsigned long h = (n)-1;
	while (i--) h = ((h<<8) + (hasher(data[i], n, d/len))) % n;
	return h;
      }
    }
    case tcs_cons_imcar: case tcs_cons_nimcar:
      if (d) return (hasher(CAR(obj), n, d/2)+hasher(CDR(obj), n, d/2)) % n;
      else return 1;
    case tc7_port:
      return ((RDNG & CAR(obj)) ? 260 : 261) % n;
    case tcs_closures: case tc7_contin: case tcs_subrs:
      return 262 % n;
    }
  }
}

static char s_hashv[] = "hashv", s_hashq[] = "hashq";
extern char s_obunhash[];
#define s_hash (&s_obunhash[9])

SCM hash(obj, n)
     SCM obj;
     SCM n;
{
  ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash);
  return MAKINUM(hasher(obj, INUM(n), 10));
}

SCM hashv(obj, n)
     SCM obj;
     SCM n;
{
  ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
  if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n));
  if (NIMP(obj) && NUMP(obj)) return MAKINUM(hasher(obj, INUM(n), 10));
  else return MAKINUM(obj % INUM(n));
}

SCM hashq(obj, n)
     SCM obj;
     SCM n;
{
  ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
  return MAKINUM((((unsigned) obj) >> 1) % INUM(n));
}

static iproc subr1s[] = {
	{"number?", numberp},
	{"complex?", numberp},
	{s_inexactp, inexactp},
#ifdef FLOATS
	{"real?", realp},
	{"rational?", realp},
	{"integer?", intp},
	{s_real_part, real_part},
	{s_imag_part, imag_part},
	{s_magnitude, magnitude},
	{s_angle, angle},
	{s_in2ex, in2ex},
	{s_ex2in, ex2in},
#else
	{"real?", numberp},
	{"rational?", numberp},
	{"integer?", exactp},
	{"floor", numident},
	{"ceiling", numident},
	{s_trunc, numident},
	{"round", numident},
#endif
	{s_zerop, zerop},
	{s_positivep, positivep},
	{s_negativep, negativep},
	{s_str2list, string2list},
	{"list->string", string},
	{s_st_copy, string_copy},
	{"list->vector", vector},
	{s_vect2list, vector2list},
	{0, 0}};

static iproc asubrs[] = {
	{s_difference, difference},
	{s_divide, divide},
	{s_max, lmax},
	{s_min, lmin},
	{s_sum, sum},
	{s_product, product},
	{0, 0}};

static iproc subr2s[] = {
#ifdef FLOATS
	{s_makrect, makrect},
	{s_makpolar, makpolar},
	{s_atan2, latan2},
	{s_expt, expt},
#endif
#ifdef INUMS_ONLY
	{s_memv, memq},
	{s_assv, assq},
#else
	{s_memv, memv},
	{s_assv, assv},
#endif
	{s_list_tail, list_tail},
	{s_ve_fill, vector_fill},
	{s_st_fill, string_fill},
	{s_hash, hash},
	{s_hashv, hashv},
	{s_hashq, hashq},
	{0, 0}};

static iproc subr2os[] = {
	{s_str2number, string2number},
	{s_number2string, number2string},
	{0, 0}};

static iproc rpsubrs[] = {
#ifdef INUMS_ONLY
	{"eqv?", eq},
#else
	{"eqv?", eqv},
#endif
	{s_eqp, eqp},
	{s_lessp, lessp},
	{s_grp, greaterp},
	{s_leqp, leqp},
	{s_greqp, greqp},
	{0, 0}};

#ifdef FLOATS
static dblproc cxrs[] = {
	{"floor", floor},
	{"ceiling", ceil},
	{"truncate", ltrunc},
	{"round", scm_round},
	{"$sqrt", sqrt},
	{"$abs", fabs},
	{"$exp", exp},
	{"$log", log},
	{"$log10", log10},
	{"$sin", sin},
	{"$cos", cos},
	{"$tan", tan},
	{"$asin", asin},
	{"$acos", acos},
	{"$atan", atan},
	{"$sinh", sinh},
	{"$cosh", cosh},
	{"$tanh", tanh},
	{"$asinh", lasinh},
	{"$acosh", lacosh},
	{"$atanh", latanh},
	{0, 0}};
#endif

#ifdef FLOATS
# ifndef DBL_DIG
static void add1(f, fsum)
     double f, *fsum;
{
  *fsum = f + 1.0;
}
# endif
#endif

void init_scl()
{
  init_iprocs(subr1s, tc7_subr_1);
  init_iprocs(subr2os, tc7_subr_2o);
  init_iprocs(subr2s, tc7_subr_2);
  init_iprocs(asubrs, tc7_asubr);
  init_iprocs(rpsubrs, tc7_rpsubr);
#ifdef SICP
  add_feature("sicp");
#endif
#ifdef FLOATS
  init_iprocs((iproc *)cxrs, tc7_cxr);
# ifdef SINGLES
  NEWCELL(flo0);
  CAR(flo0) = tc_flo;
  FLO(flo0) = 0.0;
# else
  DEFER_INTS;
  flo0 = must_malloc_cell(1L*sizeof(double), "real");
  REAL(flo0) = 0.0;
  CAR(flo0) = tc_dblr;
  ALLOW_INTS;
# endif
# ifdef DBL_DIG
  dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
# else
  {				/* determine floating point precision */
    double f = 0.1;
    double fsum = 1.0+f;
    while (fsum != 1.0) {
      f /= 10.0;
      if (++dblprec > 20) break;
      add1(f, &fsum);
    }
    dblprec = dblprec-1;
  }
# endif /* DBL_DIG */
#endif
}
