From 302e3218b7d487539ec305bf23881a6ee7d5be99 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:29 -0800 Subject: Import Upstream version 5e1 --- scl.c | 86 +++++++++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 63 insertions(+), 23 deletions(-) (limited to 'scl.c') 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 -- cgit v1.2.3