Import Upstream version 5e1upstream/5e1

1 files changed, 63 insertions, 23 deletions

diff --git a/scl.c b/scl.c
index 13f6023..2858989 100644
--- a/scl.c
+++ b/scl.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 2005 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
@@ -140,13 +140,13 @@ static double lpow10(x, n)
   return x/p10[-n];
 }
 
-int NaN2str(f, a)
+int inf2str(f, a)
      double f;
      char *a;
 {
   sizet ch = 0;
   if (f < 0.0) a[ch++] = '-';
-  a[ch++] = IS_INF(f)?'1':'0';
+  a[ch++] = (f != f) ? '0' : '1';
   a[ch++] = '/'; a[ch++] = '0';
   return ch;
 }
@@ -164,10 +164,10 @@ static sizet idbl2str(f, a)
   sizet ch = 0;
 
   if (f==0.0) {exp = 0; goto zero;}	/*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/
-  if IS_INF(f) return NaN2str(f, a);
+  if (f==2*f) return inf2str(f, a);
   if (f < 0.0) {f = -f;a[ch++]='-';}
   else if (f > 0.0) ;
-  else return NaN2str(f, a);
+  else return inf2str(f, a);
   exp = apx_log10(f);
   f = lpow10(f, -exp);
   fprec = lpow10(fprec, -exp);
@@ -177,12 +177,12 @@ static sizet idbl2str(f, a)
   while (f < 1.0) {
     f *= 10.0;
     fprec *= 10.0;
-    if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return NaN2str(f, a);
+    if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return inf2str(f, a);
   }
   while (f > 10.0) {
     f /= 10.0;
     fprec /= 10.0;
-    if (exp++ > DBL_MAX_10_EXP) return NaN2str(f, a);
+    if (exp++ > DBL_MAX_10_EXP) return inf2str(f, a);
   }
 # else
   while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;}
@@ -264,6 +264,7 @@ static sizet iflo2str(flt, str)
   else
 # endif
     i = idbl2str(REAL(flt), str);
+  if (scm_narn==flt) return i;
   if CPLXP(flt) {
     if (!(0 > IMAG(flt))) str[i++] = '+';
     i += idbl2str(IMAG(flt), &str[i]);
@@ -685,9 +686,9 @@ SCM istr2flo(str, len, radix)
       switch (c = str[i]) {
       case DIGITS:
 	expon = expon*10 + c-'0';
-/* 	if (expon > MAXEXP) */
-/* 	  if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */
-/* 	    return BOOL_F; /\* exponent too large *\/ */
+/*	if (expon > MAXEXP) */
+/*	  if (1==expsgn || expon > (MAXEXP + dblprec + 1)) */
+/*	    return BOOL_F; /\* exponent too large *\/ */
 	break;
       default:
 	goto out4;
@@ -804,6 +805,12 @@ SCM makdbl (x, y)
 {
   SCM z;
   if ((y==0.0) && (x==0.0)) return flo0;
+# ifndef _MSC_VER
+#  ifndef SINGLESONLY
+  if ((y != y) || (x != x) || (y==(2 * y) && y != 0.0)) return scm_narn;
+  if ((x==(2 * x)) && (x != 0.0) && (y != 0.0)) return scm_narn;
+#  endif
+# endif
   DEFER_INTS;
   if (y==0.0) {
 # ifdef SINGLES
@@ -962,13 +969,12 @@ SCM bigequal(x, y)
 }
 #endif
 #ifdef FLOATS
-# define REALLY_UNEQUAL(x,y) ((x) != (y) && !((x)!=(x) && (y)!=(y)))
 SCM floequal(x, y)
      SCM x, y;
 {
-  if (REALLY_UNEQUAL(REALPART(x), REALPART(y))) return BOOL_F;
+  if ((REALPART(x) != REALPART(y))) return BOOL_F;
   if (CPLXP(x))
-    return (CPLXP(y) && !REALLY_UNEQUAL(IMAG(x), IMAG(y))) ? BOOL_T : BOOL_F;
+    return (CPLXP(y) && (IMAG(x)==IMAG(y))) ? BOOL_T : BOOL_F;
   return CPLXP(y) ? BOOL_F : BOOL_T;
 }
 #endif
@@ -1008,20 +1014,27 @@ SCM equal(x, y)
 	}
 }
 
-SCM numberp(x)
-     SCM x;
+SCM numberp(obj)
+     SCM obj;
 {
-  if INUMP(x) return BOOL_T;
+  if INUMP(obj) return BOOL_T;
 #ifdef FLOATS
-  if (NIMP(x) && NUMP(x)) return BOOL_T;
+  if (NIMP(obj) && NUMP(obj)) return BOOL_T;
 #else
 # ifdef BIGDIG
-  if (NIMP(x) && NUMP(x)) return BOOL_T;
+  if (NIMP(obj) && NUMP(obj)) return BOOL_T;
 # endif
 #endif
   return BOOL_F;
 }
 #ifdef FLOATS
+SCM scm_complex_p(obj)
+     SCM obj;
+{
+  if (obj==scm_narn) return BOOL_F;
+  return numberp(obj);
+}
+
 # ifdef BIGDIG
 int scm_bigdblcomp(b, d)
      SCM b;
@@ -1056,6 +1069,21 @@ SCM realp(x)
 # endif
   return BOOL_F;
 }
+SCM scm_rationalp(x)
+     SCM x;
+{
+  if INUMP(x) return BOOL_T;
+  if IMP(x) return BOOL_F;
+  if REALP(x) {
+    float y = REALPART(x);
+    if (y==2*y && y != 0.0) return BOOL_F;
+    return BOOL_T;
+  }
+# ifdef BIGDIG
+  if BIGP(x) return BOOL_T;
+# endif
+  return BOOL_F;
+}
 SCM intp(x)
      SCM x;
 {
@@ -1068,8 +1096,9 @@ SCM intp(x)
   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;
+  if (r != floor(r)) return BOOL_F;
+  if (r==2*r && r != 0.0) return BOOL_F;
+  return BOOL_T;
 }
 #endif				/* FLOATS */
 
@@ -2079,6 +2108,9 @@ SCM scm_intexpt(z1, z2)
 	acc = long2num(iacc);
 	break;
       }
+      if (0==iz1)
+	if (0==recip) return z1;
+	else goto overflow;
       if (1==z2) {
 	tmp = iacc*iz1;
 	if (tmp/iacc != iz1) {
@@ -2356,7 +2388,7 @@ SCM in2ex(z)
       SCM ans = MAKINUM((long)u);
       if (INUM(ans)==(long)u) return ans;
     }
-    ASRTGO(!(IS_INF(u) || (u)!=(u)), badz); /* problem? */
+    ASRTGO(!((u==2*u) || (u)!=(u)), badz); /* problem? */
     return dbl2big(u);
   }
 # else
@@ -2647,11 +2679,11 @@ SCM hashq(obj, n)
 
 static iproc subr1s[] = {
 	{"number?", numberp},
-	{"complex?", numberp},
 	{s_inexactp, inexactp},
 #ifdef FLOATS
+	{"complex?", scm_complex_p},
 	{"real?", realp},
-	{"rational?", realp},
+	{"rational?", scm_rationalp},
 	{"integer?", intp},
 	{s_real_part, real_part},
 	{s_imag_part, imag_part},
@@ -2663,6 +2695,7 @@ static iproc subr1s[] = {
 	{s_dfloat_parts, scm_dfloat_parts},
 # endif
 #else
+	{"complex?", numberp},
 	{"real?", numberp},
 	{"rational?", numberp},
 	{"integer?", exactp},
@@ -2791,6 +2824,13 @@ void init_scl()
   REAL(flo0) = 0.0;
   ALLOW_INTS;
 # endif
+# ifndef _MSC_VER
+  DEFER_INTS;
+  scm_narn = must_malloc_cell(2L*sizeof(double), (SCM)tc_dblc, "complex");
+  REAL(scm_narn) = 0.0/0.0;
+  IMAG(scm_narn) = 0.0/0.0;
+  ALLOW_INTS;
+# endif
 # ifdef DBL_DIG
   dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG;
 # else