summaryrefslogtreecommitdiffstats
path: root/scl.c
diff options
context:
space:
mode:
Diffstat (limited to 'scl.c')
-rw-r--r--scl.c86
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-21 20:11:53 +0000