summaryrefslogtreecommitdiffstats
path: root/scl.c
diff options
context:
space:
mode:
Diffstat (limited to 'scl.c')
-rw-r--r--scl.c223
1 files changed, 114 insertions, 109 deletions
diff --git a/scl.c b/scl.c
index 57d020e..13f6023 100644
--- a/scl.c
+++ b/scl.c
@@ -74,8 +74,9 @@ 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_lessp[] = "<", s_grp[] = ">";
static char s_leqp[] = "<=", s_greqp[] = ">=";
+#define s_eqp (&s_leqp[1])
static char s_max[] = "max", s_min[] = "min";
char s_sum[] = "+", s_difference[] = "-", s_product[] = "*",
s_divide[] = "/";
@@ -91,9 +92,6 @@ static char s_intexpt[] = "integer-expt";
/*** NUMBERS -> STRINGS ***/
#ifdef FLOATS
-# ifndef DBL_MANT_DIG
-# define DBL_MANT_DIG dbl_mant_dig
-# endif
static int dbl_mant_dig = 0;
static double max_dbl_int; /* Integers less than or equal to max_dbl_int
are representable exactly as doubles. */
@@ -105,10 +103,10 @@ double dbl_prec(x)
double frac = frexp(x, &expt);
# ifdef DBL_MIN_EXP
if (0.0==x || expt < DBL_MIN_EXP) /* gradual underflow */
- return ldexp(1.0, -DBL_MANT_DIG) * ldexp(1.0, DBL_MIN_EXP);
+ return ldexp(1.0, - dbl_mant_dig) * ldexp(1.0, DBL_MIN_EXP);
# endif
- if (1.0==frac) return ldexp(1.0, expt - DBL_MANT_DIG + 1);
- return ldexp(1.0, expt - DBL_MANT_DIG);
+ if (1.0==frac) return ldexp(1.0, expt - dbl_mant_dig + 1);
+ return ldexp(1.0, expt - dbl_mant_dig);
}
static double llog2 = 0.3010299956639812; /* log10(2) */
@@ -142,6 +140,17 @@ static double lpow10(x, n)
return x/p10[-n];
}
+int NaN2str(f, a)
+ double f;
+ char *a;
+{
+ sizet ch = 0;
+ if (f < 0.0) a[ch++] = '-';
+ a[ch++] = IS_INF(f)?'1':'0';
+ a[ch++] = '/'; a[ch++] = '0';
+ return ch;
+}
+
/* DBL2STR_FUZZ is a somewhat arbitrary guard against
round off error in scaling f and fprec. */
# define DBL2STR_FUZZ 0.9
@@ -155,13 +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 < 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;
- }
+ else return NaN2str(f, a);
exp = apx_log10(f);
f = lpow10(f, -exp);
fprec = lpow10(fprec, -exp);
@@ -171,12 +177,13 @@ static sizet idbl2str(f, a)
while (f < 1.0) {
f *= 10.0;
fprec *= 10.0;
- if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) goto funny;
+ if (exp-- < DBL_MIN_10_EXP - DBL_DIG - 1) return NaN2str(f, a);
}
while (f > 10.0) {
f /= 10.0;
fprec /= 10.0;
- if (exp++ > DBL_MAX_10_EXP) goto funny;}
+ if (exp++ > DBL_MAX_10_EXP) return NaN2str(f, a);
+ }
# else
while (f < 1.0) {f *= 10.0; fprec *= 10.0; exp--;}
while (f > 10.0) {f /= 10.0; fprec /= 10.0; exp++;}
@@ -258,8 +265,7 @@ static sizet iflo2str(flt, str)
# endif
i = idbl2str(REAL(flt), str);
if CPLXP(flt) {
- if(0 <= IMAG(flt)) /* jeh */
- str[i++] = '+'; /* jeh */
+ if (!(0 > IMAG(flt))) str[i++] = '+';
i += idbl2str(IMAG(flt), &str[i]);
str[i++] = 'i';
}
@@ -340,7 +346,7 @@ SCM number2string(x, radix)
SCM x, radix;
{
if UNBNDP(radix) radix=MAKINUM(10L);
- else ASSERT(INUMP(radix), radix, ARG2, s_number2string);
+ else ASRTER(INUMP(radix), radix, ARG2, s_number2string);
#ifdef FLOATS
if NINUMP(x) {
char num_buf[FLOBUFLEN];
@@ -352,18 +358,18 @@ SCM number2string(x, radix)
badx: wta(x, (char *)ARG1, s_number2string);
# endif
# else
- ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_number2string);
+ ASRTER(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);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_number2string);
return big2str(x, (unsigned int)INUM(radix));
}
# else
- ASSERT(INUMP(x), x, ARG1, s_number2string);
+ ASRTER(INUMP(x), x, ARG1, s_number2string);
# endif
#endif
{
@@ -451,7 +457,7 @@ SCM istr2int(str, len, radix)
ds[k++] = BIGLO(t2);
t2 = BIGDN(t2);
}
- ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
+ ASRTER(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum");
if (t2) {blen++; goto moretodo;}
break;
default:
@@ -630,7 +636,7 @@ SCM istr2flo(str, len, radix)
}
}
out2:
- if (tmp==0.0) return BOOL_F; /* `slash zero' not allowed */
+/* if (tmp==0.0) return BOOL_F; /\* `slash zero' not allowed *\/ */
if (i < len)
while (str[i]=='#') { /* optional sharps */
tmp *= radix;
@@ -679,9 +685,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;
@@ -786,8 +792,8 @@ 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);
+ else ASRTER(INUMP(radix), radix, ARG2, s_str2number);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_str2number);
return istring2number(CHARS(str), LENGTH(str), INUM(radix));
}
/*** END strs->nums ***/
@@ -840,9 +846,7 @@ SCM eqv(x, y)
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;
+ return floequal(x, y);
# endif
}
return BOOL_F;
@@ -882,10 +886,10 @@ SCM list_tail(lst, k)
SCM lst, k;
{
register long i;
- ASSERT(INUMP(k), k, ARG2, s_list_tail);
+ ASRTER(INUMP(k), k, ARG2, s_list_tail);
i = INUM(k);
while (i-- > 0) {
- ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
+ ASRTER(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail);
lst = CDR(lst);
}
return lst;
@@ -897,7 +901,7 @@ SCM string2list(str)
long i;
SCM res = EOL;
unsigned char *src;
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_str2list);
+ ASRTER(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;
@@ -905,7 +909,7 @@ SCM string2list(str)
SCM string_copy(str)
SCM str;
{
- ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy);
return makfromstr(CHARS(str), (sizet)LENGTH(str));
}
SCM string_fill(str, chr)
@@ -913,8 +917,8 @@ SCM string_fill(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);
+ ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_st_fill);
+ ASRTER(ICHRP(chr), chr, ARG2, s_st_fill);
c = ICHR(chr);
dst = CHARS(str);
for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c;
@@ -926,7 +930,7 @@ SCM vector2list(v)
SCM res = EOL;
long i;
SCM *data;
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_vect2list);
+ ASRTER(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;
@@ -936,7 +940,7 @@ SCM vector_fill(v, fill)
{
register long i;
register SCM *data;
- ASSERT(NIMP(v) && VECTORP(v), v, ARG1, s_ve_fill);
+ ASRTER(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;
@@ -958,12 +962,14 @@ 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 (REALPART(x) != REALPART(y)) return BOOL_F;
- if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T;
- return BOOL_F;
+ if (REALLY_UNEQUAL(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) ? BOOL_F : BOOL_T;
}
#endif
SCM equal(x, y)
@@ -1030,7 +1036,7 @@ int scm_bigdblcomp(b, d)
blen = INUM(scm_intlength(b));
if (blen > dlen) return dneg ? 1 : -1;
if (blen < dlen) return dneg ? -1 : 1;
- if ((blen <= DBL_MANT_DIG) || (blen - scm_twos_power(b)) <= DBL_MANT_DIG) {
+ if ((blen <= dbl_mant_dig) || (blen - scm_twos_power(b)) <= dbl_mant_dig) {
double bd = big2dbl(b);
if (bd > d) return -1;
if (bd < d) return 1;
@@ -1075,6 +1081,7 @@ SCM inexactp(x)
#endif
return BOOL_F;
}
+
SCM eqp(x, y)
SCM x, y;
{
@@ -1097,7 +1104,7 @@ SCM eqp(x, y)
}
ASRTGO(INEXP(x), badx);
# else
- ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
+ ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_eqp);
# endif
if INUMP(y) {t = x; x = y; y = t; goto realint;}
# ifdef BIGDIG
@@ -1107,10 +1114,8 @@ SCM eqp(x, y)
# 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 (x==y) return BOOL_T;
+ return floequal(x, y);
}
if NINUMP(y) {
# ifdef BIGDIG
@@ -1132,7 +1137,7 @@ SCM eqp(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_eqp);
+ ASRTER(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;
@@ -1145,8 +1150,8 @@ SCM eqp(x, y)
return BOOL_F;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_eqp);
- ASSERT(INUMP(y), y, ARG2, s_eqp);
+ ASRTER(INUMP(x), x, ARG1, s_eqp);
+ ASRTER(INUMP(y), y, ARG2, s_eqp);
# endif
#endif
return ((long)x==(long)y) ? BOOL_T : BOOL_F;
@@ -1170,7 +1175,7 @@ SCM lessp(x, y)
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp);
+ ASRTER(NIMP(x) && REALP(x), x, ARG1, s_lessp);
# endif
if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F;
# ifdef BIGDIG
@@ -1201,7 +1206,7 @@ SCM lessp(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_lessp);
+ ASRTER(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;
@@ -1214,8 +1219,8 @@ SCM lessp(x, y)
return BIGSIGN(y) ? BOOL_F : BOOL_T;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_lessp);
- ASSERT(INUMP(y), y, ARG2, s_lessp);
+ ASRTER(INUMP(x), x, ARG1, s_lessp);
+ ASRTER(INUMP(y), y, ARG2, s_lessp);
# endif
#endif
return ((long)x < (long)y) ? BOOL_T : BOOL_F;
@@ -1248,18 +1253,18 @@ SCM zerop(z)
badz: wta(z, (char *)ARG1, s_zerop);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_zerop);
+ ASRTER(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);
+ ASRTER(NIMP(z) && BIGP(z), z, ARG1, s_zerop);
return BOOL_F;
}
# else
- ASSERT(INUMP(z), z, ARG1, s_zerop);
+ ASRTER(INUMP(z), z, ARG1, s_zerop);
# endif
#endif
return (z==INUM0) ? BOOL_T: BOOL_F;
@@ -1277,18 +1282,18 @@ SCM positivep(x)
badx: wta(x, (char *)ARG1, s_positivep);
# endif
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_positivep);
+ ASRTER(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);
+ ASRTER(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);
+ ASRTER(INUMP(x), x, ARG1, s_positivep);
# endif
#endif
return (x > INUM0) ? BOOL_T : BOOL_F;
@@ -1306,18 +1311,18 @@ SCM negativep(x)
badx: wta(x, (char *)ARG1, s_negativep);
# endif
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_negativep);
+ ASRTER(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);
+ ASRTER(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);
+ ASRTER(INUMP(x), x, ARG1, s_negativep);
# endif
#endif
return (x < INUM0) ? BOOL_T : BOOL_F;
@@ -1350,12 +1355,12 @@ SCM lmax(x, y)
big_dbl:
if (-1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
- ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
+ ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_max);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_max);
+ ASRTER(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
@@ -1388,7 +1393,7 @@ SCM lmax(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_max);
+ ASRTER(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;
@@ -1401,8 +1406,8 @@ SCM lmax(x, y)
return BIGSIGN(y) ? x : y;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_max);
- ASSERT(INUMP(y), y, ARG2, s_max);
+ ASRTER(INUMP(x), x, ARG1, s_max);
+ ASRTER(INUMP(y), y, ARG2, s_max);
# endif
#endif
return ((long)x < (long)y) ? y : x;
@@ -1434,12 +1439,12 @@ SCM lmin(x, y)
big_dbl:
if (1 != scm_bigdblcomp(x, REALPART(y))) return y;
z = big2dbl(x);
- ASSERT(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
+ ASRTER(0==scm_bigdblcomp(x, z), x, s_exactprob, s_min);
return makdbl(z, 0.0);
}
ASRTGO(REALP(x), badx);
# else
- ASSERT(NIMP(x) && REALP(x), x, ARG1, s_min);
+ ASRTER(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
@@ -1472,7 +1477,7 @@ SCM lmin(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_min);
+ ASRTER(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;
@@ -1485,8 +1490,8 @@ SCM lmin(x, y)
return BIGSIGN(y) ? y : x;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_min);
- ASSERT(INUMP(y), y, ARG2, s_min);
+ ASRTER(INUMP(x), x, ARG1, s_min);
+ ASRTER(INUMP(y), y, ARG2, s_min);
# endif
#endif
return ((long)x > (long)y) ? y : x;
@@ -1589,7 +1594,7 @@ SCM sum(x, y)
}
# else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_sum);
+ ASRTER(INUMP(y), y, ARG2, s_sum);
# endif
#endif
x = INUM(x)+INUM(y);
@@ -1642,11 +1647,12 @@ SCM difference(x, y)
ASRTGO(INEXP(x), badx);
ASRTGO(NIMP(y) && INEXP(y), bady);
# endif
- if CPLXP(x)
+ 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;}
@@ -1678,7 +1684,7 @@ SCM difference(x, y)
#else
# ifdef BIGDIG
if NINUMP(x) {
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_difference);
if UNBNDP(y) {
x = copybig(x, !BIGSIGN(x));
return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ?
@@ -1717,9 +1723,9 @@ SCM difference(x, y)
}
}
# else
- ASSERT(INUMP(x), x, ARG1, s_difference);
+ ASRTER(INUMP(x), x, ARG1, s_difference);
if UNBNDP(y) {x = -INUM(x); goto checkx;}
- ASSERT(INUMP(y), y, ARG2, s_difference);
+ ASRTER(INUMP(y), y, ARG2, s_difference);
# endif
#endif
x = INUM(x)-INUM(y);
@@ -1779,12 +1785,13 @@ SCM product(x, y)
bady: wta(y, (char *)ARG2, s_product);
# endif
# endif
- if CPLXP(x)
+ 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);
}
@@ -1842,7 +1849,7 @@ SCM product(x, y)
}
# else
ASRTGO(INUMP(x), badx);
- ASSERT(INUMP(y), y, ARG2, s_product);
+ ASRTER(INUMP(y), y, ARG2, s_product);
# endif
#endif
{
@@ -1902,7 +1909,7 @@ SCM divide(x, y)
SCM z;
if INUMP(y) {
z = INUM(y);
- ASSERT(z, y, OVFLOW, s_divide);
+ ASRTER(z, y, OVFLOW, s_divide);
if (1==z) return x;
if (z < 0) z = -z;
if (z < BIGRAD) {
@@ -1978,7 +1985,7 @@ SCM divide(x, y)
# ifdef BIGDIG
if NINUMP(x) {
SCM z;
- ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide);
+ ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_divide);
if UNBNDP(y) goto ov;
if INUMP(y) {
z = INUM(y);
@@ -2020,12 +2027,12 @@ SCM divide(x, y)
goto ov;
}
# else
- ASSERT(INUMP(x), x, ARG1, s_divide);
+ ASRTER(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);
+ ASRTER(INUMP(y), y, ARG2, s_divide);
# endif
#endif
{
@@ -2056,7 +2063,7 @@ SCM scm_intexpt(z1, z2)
if (INUM0==z1 || acc==z1) return z1;
else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc;
#endif
- ASSERT(INUMP(z2), z2, ARG2, s_intexpt);
+ ASRTER(INUMP(z2), z2, ARG2, s_intexpt);
z2 = INUM(z2);
if (z2 < 0) {
z2 = -z2;
@@ -2101,7 +2108,7 @@ SCM scm_intexpt(z1, z2)
#endif
goto ret;
}
- ASSERT(NIMP(z1), z1, ARG1, s_intexpt);
+ ASRTER(NIMP(z1), z1, ARG1, s_intexpt);
#ifdef FLOATS
if REALP(z1) {
dz1 = REALPART(z1);
@@ -2183,7 +2190,7 @@ void two_doubles(z1, z2, sstring, xy)
# endif
xy->x = REALPART(z1);}
# else
- {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
+ {ASRTER(NIMP(z1) && REALP(z1), z1, ARG1, sstring);
xy->x = REALPART(z1);}
# endif
}
@@ -2199,7 +2206,7 @@ void two_doubles(z1, z2, sstring, xy)
# endif
xy->y = REALPART(z2);}
# else
- {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
+ {ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring);
xy->y = REALPART(z2);}
# endif
}
@@ -2246,7 +2253,7 @@ SCM real_part(z)
badz: wta(z, (char *)ARG1, s_real_part);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_real_part);
# endif
if CPLXP(z) return makdbl(REAL(z), 0.0);
}
@@ -2264,7 +2271,7 @@ SCM imag_part(z)
badz: wta(z, (char *)ARG1, s_imag_part);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_imag_part);
# endif
if CPLXP(z) return makdbl(IMAG(z), 0.0);
return flo0;
@@ -2281,7 +2288,7 @@ SCM magnitude(z)
badz: wta(z, (char *)ARG1, s_magnitude);
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_magnitude);
# endif
if CPLXP(z)
{
@@ -2304,7 +2311,7 @@ SCM angle(z)
badz: wta(z, (char *)ARG1, s_angle);}
# endif
# else
- ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle);
+ ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_angle);
# endif
if REALP(z) {x = REALPART(z); goto do_angle;}
x = REAL(z); y = IMAG(z);
@@ -2336,7 +2343,7 @@ SCM in2ex(z)
badz: wta(z, (char *)ARG1, s_in2ex);
# endif
# else
- ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
+ ASRTER(NIMP(z) && REALP(z), z, ARG1, s_in2ex);
# endif
# ifdef BIGDIG
{
@@ -2349,7 +2356,7 @@ SCM in2ex(z)
SCM ans = MAKINUM((long)u);
if (INUM(ans)==(long)u) return ans;
}
- ASRTGO(!IS_INF(u), badz); /* problem? */
+ ASRTGO(!(IS_INF(u) || (u)!=(u)), badz); /* problem? */
return dbl2big(u);
}
# else
@@ -2361,7 +2368,7 @@ static char s_trunc[] = "truncate";
SCM numident(x)
SCM x;
{
- ASSERT(INUMP(x), x, ARG1, s_trunc);
+ ASRTER(INUMP(x), x, ARG1, s_trunc);
return x;
}
#endif /* FLOATS */
@@ -2385,7 +2392,7 @@ SCM dbl2big(d)
u -= c;
digits[i] = c;
}
- ASSERT(0==u, INUM0, OVFLOW, "dbl2big");
+ ASRTER(0==u, INUM0, OVFLOW, "dbl2big");
return ans;
}
double big2dbl(b)
@@ -2480,7 +2487,7 @@ static char s_dfloat_parts[] = "double-float-parts";
SCM scm_dfloat_parts(f)
SCM f;
{
- int expt, ndig = DBL_MANT_DIG;
+ int expt, ndig = dbl_mant_dig;
double mant = frexp(num2dbl(f, (char *)ARG1, s_dfloat_parts), &expt);
# ifdef DBL_MIN_EXP
if (expt < DBL_MIN_EXP)
@@ -2496,8 +2503,8 @@ SCM scm_make_dfloat(mant, expt)
{
double dmant = num2dbl(mant, (char *)ARG1, s_make_dfloat);
int e = INUM(expt);
- ASSERT(INUMP(expt), expt, ARG2, s_make_dfloat);
- ASSERT((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
+ ASRTER(INUMP(expt), expt, ARG2, s_make_dfloat);
+ ASRTER((dmant < 0 ? -dmant : dmant)<=max_dbl_int, mant,
OUTOFRANGE, s_make_dfloat);
return makdbl(ldexp(dmant, e), 0.0);
}
@@ -2515,7 +2522,7 @@ SCM scm_next_dfloat(f1, f2)
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
- eps = ldexp(1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+ eps = ldexp(1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
d = ldexp(d + eps, e);
}
@@ -2524,7 +2531,7 @@ SCM scm_next_dfloat(f1, f2)
if (e < DBL_MIN_EXP)
eps = ldexp(eps, DBL_MIN_EXP - e);
else if (0.0==d)
- eps = ldexp(-1.0, DBL_MIN_EXP - DBL_MANT_DIG);
+ eps = ldexp(-1.0, DBL_MIN_EXP - dbl_mant_dig);
# endif
if (0.5==d) eps *= 0.5;
d = ldexp(d - eps, e);
@@ -2616,7 +2623,7 @@ SCM hash(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash);
+ ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hash);
return MAKINUM(hasher(obj, INUM(n), 10));
}
@@ -2624,7 +2631,7 @@ SCM hashv(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashv);
+ ASRTER(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));
@@ -2634,7 +2641,7 @@ SCM hashq(obj, n)
SCM obj;
SCM n;
{
- ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
+ ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashq);
return MAKINUM((((unsigned) obj) >> 1) % INUM(n));
}
@@ -2755,13 +2762,11 @@ static dblproc cxrs[] = {
#endif
#ifdef FLOATS
-/* # ifndef DBL_DIG -- also needed for ifndef DBL_MANT_DIG */
static void add1(f, fsum)
double f, *fsum;
{
*fsum = f + 1.0;
}
-/* #endif */
#endif
void init_scl()
@@ -2803,7 +2808,7 @@ void init_scl()
# ifdef DBL_MANT_DIG
dbl_mant_dig = DBL_MANT_DIG;
# else
- if (!DBL_MANT_DIG) { /* means we #defined it. */
+ { /* means we #defined it. */
double fsum = 0.0, eps = 1.0;
int i = 0;
while (fsum != 1.0) {
@@ -2816,7 +2821,7 @@ void init_scl()
# endif /* DBL_MANT_DIG */
max_dbl_int = pow(2.0, dbl_mant_dig - 1.0);
max_dbl_int = max_dbl_int + (max_dbl_int - 1.0);
- dbl_eps = ldexp(1.0, -dbl_mant_dig);
- sysintern("double-float-mantissa-length", MAKINUM(DBL_MANT_DIG));
+ dbl_eps = ldexp(1.0, - dbl_mant_dig);
+ sysintern("double-float-mantissa-length", MAKINUM(dbl_mant_dig));
#endif
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 09:54:45 +0000