Import Upstream version 4e6upstream/4e6

1 files changed, 2393 insertions, 0 deletions

diff --git a/scl.c b/scl.c
new file mode 100644
index 0000000..393d0f0
--- /dev/null
+++ b/scl.c
@@ -0,0 +1,2393 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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";
+static char s_expt[] = "$expt", s_atan2[] = "$atan2";
+static char s_memv[] = "memv", s_assv[] = "assv";
+#endif
+
+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 iint2str(num, rad, p)
+     long num;
+     int rad;
+     char *p;
+{
+  sizet j;
+  register int i = 1, d;
+  register long n = num;
+  if (n < 0) {n = -n; i++;}
+  for (n /= rad;n > 0;n /= rad) i++;
+  j = i;
+  n = num;
+  if (n < 0) {n = -n; *p++ = '-'; i--;}
+  while (i--) {
+    d = n % rad;
+    n /= rad;
+    p[i] = d + ((d < 10) ? '0' : 'a' - 10);
+  }
+  return j;
+}
+#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;
+  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
+  char num_buf[FLOBUFLEN];
+  lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port);
+#else
+  ipruk("float", sexp, port);
+#endif
+  return !0;
+}
+int bigprint(exp, port, writing)
+     SCM exp;
+     SCM port;
+     int writing;
+{
+#ifdef BIGDIG
+  exp = big2str(exp, (unsigned int)10);
+  lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port);
+#else
+  ipruk("bignum", exp, port);
+#endif
+  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 (!(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 (!(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;
+  NEWCELL(z);
+  DEFER_INTS;
+  if (y==0.0) {
+# ifdef SINGLES
+    float fx;
+#  ifndef SINGLESONLY
+    if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x))
+#  endif
+      {
+	CAR(z) = tc_flo;
+	FLO(z) = x;
+	ALLOW_INTS;
+	return z;
+      }
+# endif				/* def SINGLES */
+    CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real");
+    CAR(z) = tc_dblr;
+  }
+  else {
+    CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex");
+    CAR(z) = tc_dblc;
+    IMAG(z) = y;
+  }
+  REAL(z) = x;
+  ALLOW_INTS;
+  return z;
+}
+
+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
+    if (REALPART(x) != REALPART(y)) return BOOL_F;
+    if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F;
+    return BOOL_T;
+  }
+  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				/* FLOATS */
+
+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;
+	      }
+	}
+	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 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);
+}
+
+double floident(z)
+     double z;
+{
+  return z;
+}
+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},
+#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_memv, memv},
+	{s_assv, assv},
+	{s_atan2, latan2},
+	{s_expt, expt},
+#else
+	{"memv", memq},
+	{"assv", assq},
+#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 FLOATS
+	{"eqv?", eqv},
+#else
+	{"eqv?", eq},
+#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", round},
+	{"$sqrt", sqrt},
+	{"$abs", fabs},
+	{"$exp", exp},
+	{"$log", log},
+	{"$sin", sin},
+	{"$cos", cos},
+	{"$tan", tan},
+	{"$asin", asin},
+	{"$acos", acos},
+	{"$atan", atan},
+	{"$sinh", sinh},
+	{"$cosh", cosh},
+	{"$tanh", tanh},
+	{"$asinh", lasinh},
+	{"$acosh", lacosh},
+	{"$atanh", latanh},
+	{"exact->inexact", floident},
+	{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);
+  NEWCELL(flo0);
+# ifdef SINGLES
+  CAR(flo0) = tc_flo;
+  FLO(flo0) = 0.0;
+# else
+  CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real");
+  REAL(flo0) = 0.0;
+  CAR(flo0) = tc_dblr;
+# 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
+}