From c7d035ae1a729232579a0fe41ed5affa131d3623 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:27 -0800 Subject: Import Upstream version 5d9 --- scl.c | 223 ++++++++++++++++++++++++++++++++++-------------------------------- 1 file changed, 114 insertions(+), 109 deletions(-) (limited to 'scl.c') 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 } -- cgit v1.2.3