From ae2b295c7deaf2d7c18ad1ed9b6050970e56bae7 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:31 -0800 Subject: Import Upstream version 5e2 --- scl.c | 749 ++++++++++++++++++++++++++++++++++++------------------------------ 1 file changed, 412 insertions(+), 337 deletions(-) (limited to 'scl.c') diff --git a/scl.c b/scl.c index 2858989..9fe779f 100644 --- a/scl.c +++ b/scl.c @@ -56,7 +56,7 @@ static int apx_log10 P((double x)); static double lpow10 P((double x, int n)); static sizet idbl2str P((double f, char *a)); static sizet iflo2str P((SCM flt, char *str)); -static void add1 P((double f, double *fsum)); +static void safe_add_1 P((double f, double *fsum)); static long scm_twos_power P((SCM n)); static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", @@ -72,7 +72,7 @@ SCM sys_protects[NUM_PROTECTS]; sizet num_protects = NUM_PROTECTS; char s_inexactp[] = "inexact?"; -static char s_zerop[] = "zero?", +static char s_zerop[] = "zero?", s_abs[] = "abs", s_positivep[] = "positive?", s_negativep[] = "negative?"; static char s_lessp[] = "<", s_grp[] = ">"; static char s_leqp[] = "<=", s_greqp[] = ">="; @@ -88,7 +88,7 @@ static char s_str2list[] = "string->list"; static char s_st_copy[] = "string-copy", s_st_fill[] = "string-fill!"; static char s_vect2list[] = "vector->list", s_ve_fill[] = "vector-fill!"; static char s_intexpt[] = "integer-expt"; - +static char str_inf0[] = "inf.0"; /*** NUMBERS -> STRINGS ***/ #ifdef FLOATS @@ -114,11 +114,11 @@ static int apx_log10(x) double x; { int expt; - double frac = frexp(x, &expt); + frexp(x, &expt); expt -= 1; if (expt >= 0) return (int)(expt * llog2); - return -((int)( -expt * llog2)); + return -((int)(-expt * llog2)); } static double p10[] = {1.0, 1e1, 1e2, 1e3, 1e4, 1e5, 1e6, 1e7}; @@ -146,8 +146,21 @@ int inf2str(f, a) { sizet ch = 0; if (f < 0.0) a[ch++] = '-'; - a[ch++] = (f != f) ? '0' : '1'; - a[ch++] = '/'; a[ch++] = '0'; + else if (f > 0.0) a[ch++] = '+'; + else { + a[ch++] = '0'; a[ch++] = '/'; a[ch++] = '0'; + return ch; + } + while (str_inf0[ch - 1]) { + a[ch] = str_inf0[ch - 1]; + ch++; + } +/* # ifdef COMPACT_INFINITY_NOTATION */ +/* else a[ch++] = '0'; */ +/* # else */ +/* a[ch++] = (f != f) ? '0' : '1'; */ +/* # endif */ +/* a[ch++] = '/'; a[ch++] = '0'; */ return ch; } @@ -260,12 +273,12 @@ static sizet iflo2str(flt, str) { sizet i; # ifdef SINGLES - if SINGP(flt) i = idbl2str(FLO(flt), str); + if (SINGP(flt)) i = idbl2str(FLO(flt), str); else # endif i = idbl2str(REAL(flt), str); if (scm_narn==flt) return i; - if CPLXP(flt) { + if (CPLXP(flt)) { if (!(0 > IMAG(flt))) str[i++] = '+'; i += idbl2str(IMAG(flt), &str[i]); str[i++] = 'i'; @@ -313,10 +326,10 @@ static SCM big2str(b, radix) sizet i = NUMDIGS(t); sizet j = radix==16 ? (BITSPERDIG*i)/4+2 : radix >= 10 ? (BITSPERDIG*i*241L)/800+2 - : (BITSPERDIG*i)+2; + : (BITSPERDIG*i)+2; sizet k = 0; sizet radct = 0; - sizet ch; /* jeh */ + sizet ch; /* jeh */ BIGDIG radpow = 1, radmod = 0; SCM ss = makstr((long)j); char *s = CHARS(ss), c; @@ -335,7 +348,7 @@ static SCM big2str(b, radix) c = radmod % radix; radmod /= radix; k--; s[--j] = c < 10 ? c + '0' : c + 'a' - 10; } - ch = s[0]=='-' ? 1 : 0; /* jeh */ + ch = s[0]=='-' ? 1 : 0; /* jeh */ if (ch < j) { /* jeh */ for(i = j;j < LENGTH(ss);j++) s[ch+j-i] = s[j]; /* jeh */ resizuve(ss, (SCM)MAKINUM(ch+LENGTH(ss)-i)); /* jeh */ @@ -346,17 +359,17 @@ static SCM big2str(b, radix) SCM number2string(x, radix) SCM x, radix; { - if UNBNDP(radix) radix=MAKINUM(10L); + if (UNBNDP(radix)) radix=MAKINUM(10L); else ASRTER(INUMP(radix), radix, ARG2, s_number2string); #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { char num_buf[FLOBUFLEN]; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return big2str(x, (unsigned int)INUM(radix)); + if (BIGP(x)) return big2str(x, (unsigned int)INUM(radix)); # ifndef RECKLESS if (!(INEXP(x))) - badx: wta(x, (char *)ARG1, s_number2string); + badx: wta(x, (char *)ARG1, s_number2string); # endif # else ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_number2string); @@ -365,7 +378,7 @@ SCM number2string(x, radix) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_number2string); return big2str(x, (unsigned int)INUM(radix)); } @@ -453,7 +466,7 @@ SCM istr2int(str, len, radix) t2 = c; moretodo: while(k < blen) { -/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ +/* printf("k = %d, blen = %d, t2 = %ld, ds[k] = %d\n", k, blen, t2, ds[k]);*/ t2 += ds[k]*radix; ds[k++] = BIGLO(t2); t2 = BIGDN(t2); @@ -466,7 +479,7 @@ SCM istr2int(str, len, radix) } } while (i < len); if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM)) - if INUMP(res = big2inum(res, blen)) return res; + if (INUMP(res = big2inum(res, blen))) return res; if (j==blen) return res; return adjbig(res, blen); } @@ -532,7 +545,7 @@ static long scm_twos_power(n) long d, c = 0; int d4; # ifdef BIGDIG - if NINUMP(n) { + if (NINUMP(n)) { BIGDIG *ds; int i = 0; ds = BDIGITS(n); @@ -558,7 +571,7 @@ SCM istr2flo(str, len, radix) register long radix; { register int c, i = 0; - double lead_sgn; + double lead_sgn = 0.0; double res = 0.0, tmp = 0.0; int flg = 0; int point = 0; @@ -569,15 +582,27 @@ SCM istr2flo(str, len, radix) switch (*str) { /* leading sign */ case '-': lead_sgn = -1.0; i++; break; case '+': lead_sgn = 1.0; i++; break; - default : lead_sgn = 0.0; } if (i==len) return BOOL_F; /* bad if lone `+' or `-' */ +# ifdef FLOATS + if (6==len && ('+'==str[0] || '-'==str[0])) + if (0==strcmp(str_inf0, &str[1])) + return makdbl(1./0. * ('+'==str[0] ? 1 : -1), 0.0); +# endif + if (str[i]=='i' || str[i]=='I') { /* handle `+i' and `-i' */ if (lead_sgn==0.0) return BOOL_F; /* must have leading sign */ if (++i < len) return BOOL_F; /* `i' not last character */ return makdbl(0.0, lead_sgn); } + /* # ifdef COMPACT_INFINITY_NOTATION */ + if (0.0 != lead_sgn && str[i]=='/') { + res = 1; + flg = 1; + goto out1; + } + /* # endif */ do { /* check initial digits */ switch (c = str[i]) { case DIGITS: @@ -637,7 +662,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; @@ -686,9 +711,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; @@ -706,7 +731,7 @@ SCM istr2flo(str, len, radix) # ifdef _UNICOS while (point++) res *= 0.1; # else - while (point++) res /= 10.0; + while (point++) res /= 10.0; # endif done: @@ -726,7 +751,7 @@ SCM istr2flo(str, len, radix) case '@': { /* polar input for complex number */ /* get a `real' for angle */ second = istr2flo(&str[i], (long)(len-i), radix); - if IMP(second) return BOOL_F; + if (IMP(second)) return BOOL_F; if (!(INEXP(second))) return BOOL_F; /* not `real' */ if (CPLXP(second)) return BOOL_F; /* not `real' */ tmp = REALPART(second); @@ -741,7 +766,7 @@ SCM istr2flo(str, len, radix) if (i==(len-1)) return makdbl(res, lead_sgn); /* get a `ureal' for complex part */ second = istr2flo(&str[i], (long)((len-i)-1), radix); - if IMP(second) return BOOL_F; + if (IMP(second)) return BOOL_F; if (!(INEXP(second))) return BOOL_F; /* not `ureal' */ if (CPLXP(second)) return BOOL_F; /* not `ureal' */ tmp = REALPART(second); @@ -780,7 +805,7 @@ SCM istring2number(str, len, radix) return istr2int(&str[i], len-i, radix); case 0: res = istr2int(&str[i], len-i, radix); - if NFALSEP(res) return res; + if (NFALSEP(res)) return res; #ifdef FLOATS case 2: return istr2flo(&str[i], len-i, radix); #endif @@ -792,7 +817,7 @@ SCM istring2number(str, len, radix) SCM string2number(str, radix) SCM str, radix; { - if UNBNDP(radix) radix=MAKINUM(10L); + if (UNBNDP(radix)) radix=MAKINUM(10L); 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)); @@ -807,8 +832,8 @@ SCM makdbl (x, y) 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; + if ((y != y) || (x != x) || (y==(2 * y) && (y != 0.0))) return scm_narn; + if ((x==(2 * x)) && (x != 0.0)) y = 0.0; # endif # endif DEFER_INTS; @@ -844,13 +869,13 @@ SCM eqv(x, y) SCM x, y; { if (x==y) return BOOL_T; - if IMP(x) return BOOL_F; - if IMP(y) return BOOL_F; + if (IMP(x)) return BOOL_F; + if (IMP(y)) return BOOL_F; /* this ensures that types and length are the same. */ if (CAR(x) != CAR(y)) return BOOL_F; - if NUMP(x) { + if (NUMP(x)) { # ifdef BIGDIG - if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(x)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; # endif # ifdef FLOATS return floequal(x, y); @@ -863,7 +888,7 @@ SCM x, lst; { for(;NIMP(lst);lst = CDR(lst)) { ASRTGO(CONSP(lst), badlst); - if NFALSEP(eqv(CAR(lst), x)) return lst; + if (NFALSEP(eqv(CAR(lst), x))) return lst; } # ifndef RECKLESS if (!(NULLP(lst))) @@ -879,7 +904,7 @@ SCM x, alist; ASRTGO(CONSP(alist), badlst); tmp = CAR(alist); ASRTGO(NIMP(tmp) && CONSP(tmp), badlst); - if NFALSEP(eqv(CAR(tmp), x)) return tmp; + if (NFALSEP(eqv(CAR(tmp), x))) return tmp; } # ifndef RECKLESS if (!(NULLP(alist))) @@ -957,7 +982,7 @@ static SCM vector_equal(x, y) { long i; for(i = LENGTH(x)-1;i >= 0;i--) - if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F; + if (FALSEP(equal(VELTS(x)[i], VELTS(y)[i]))) return BOOL_F; return BOOL_T; } #ifdef BIGDIG @@ -983,41 +1008,41 @@ SCM equal(x, y) { CHECK_STACK; tailrecurse: POLL; - if (x==y) return BOOL_T; - if IMP(x) return BOOL_F; - if IMP(y) return BOOL_F; - if (CONSP(x) && CONSP(y)) { - if FALSEP(equal(CAR(x), CAR(y))) return BOOL_F; - x = CDR(x); - y = CDR(y); - goto tailrecurse; - } - /* this ensures that types and length are the same. */ - if (CAR(x) != CAR(y)) return BOOL_F; - switch (TYP7(x)) { - default: return BOOL_F; - case tc7_string: return st_equal(x, y); - case tc7_vector: return vector_equal(x, y); - case tc7_smob: { - int i = SMOBNUM(x); - if (!(i < numsmob)) return BOOL_F; - if (smobs[i].equalp) return (smobs[i].equalp)(x, y); - else return BOOL_F; - } - case tc7_bvect: - case tc7_uvect: case tc7_ivect: case tc7_svect: - case tc7_fvect: case tc7_cvect: case tc7_dvect: { - SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; - if (pred) return (*pred)(x, y); - else return BOOL_F; - } - } + if (x==y) return BOOL_T; + if (IMP(x)) return BOOL_F; + if (IMP(y)) return BOOL_F; + if (CONSP(x) && CONSP(y)) { + if (FALSEP(equal(CAR(x), CAR(y)))) return BOOL_F; + x = CDR(x); + y = CDR(y); + goto tailrecurse; + } + /* this ensures that types and length are the same. */ + if (CAR(x) != CAR(y)) return BOOL_F; + switch (TYP7(x)) { + default: return BOOL_F; + case tc7_string: return st_equal(x, y); + case tc7_vector: return vector_equal(x, y); + case tc7_smob: { + int i = SMOBNUM(x); + if (!(i < numsmob)) return BOOL_F; + if (smobs[i].equalp) return (smobs[i].equalp)(x, y); + else return BOOL_F; + } + case tc7_bvect: + case tc7_uvect: case tc7_ivect: case tc7_svect: + case tc7_fvect: case tc7_cvect: case tc7_dvect: { + SCM (*pred)() = smobs[0x0ff & (tc16_array>>8)].equalp; + if (pred) return (*pred)(x, y); + else return BOOL_F; + } + } } SCM numberp(obj) SCM obj; { - if INUMP(obj) return BOOL_T; + if (INUMP(obj)) return BOOL_T; #ifdef FLOATS if (NIMP(obj) && NUMP(obj)) return BOOL_T; #else @@ -1061,26 +1086,26 @@ int scm_bigdblcomp(b, d) SCM realp(x) SCM x; { - if INUMP(x) return BOOL_T; - if IMP(x) return BOOL_F; - if REALP(x) return BOOL_T; + if (INUMP(x)) return BOOL_T; + if (IMP(x)) return BOOL_F; + if (REALP(x)) return BOOL_T; # ifdef BIGDIG - if BIGP(x) return BOOL_T; + if (BIGP(x)) return BOOL_T; # 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) { + 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; + if (BIGP(x)) return BOOL_T; # endif return BOOL_F; } @@ -1088,13 +1113,13 @@ SCM intp(x) SCM x; { double r; - if INUMP(x) return BOOL_T; - if IMP(x) return BOOL_F; + if (INUMP(x)) return BOOL_T; + if (IMP(x)) return BOOL_F; # ifdef BIGDIG - if BIGP(x) return BOOL_T; + if (BIGP(x)) return BOOL_T; # endif if (!INEXP(x)) return BOOL_F; - if CPLXP(x) return BOOL_F; + if (CPLXP(x)) return BOOL_F; r = REALPART(x); if (r != floor(r)) return BOOL_F; if (r==2*r && r != 0.0) return BOOL_F; @@ -1116,16 +1141,16 @@ SCM eqp(x, y) { #ifdef FLOATS SCM t; - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_eqp); + badx: wta(x, (char *)ARG1, s_eqp); # endif - if BIGP(x) { - if INUMP(y) return BOOL_F; + if (BIGP(x)) { + if (INUMP(y)) return BOOL_F; ASRTGO(NIMP(y), bady); - if BIGP(y) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(INEXP(y), bady); bigreal: return (REALP(y) && (0==scm_bigdblcomp(x, REALPART(y)))) ? @@ -1135,10 +1160,10 @@ SCM eqp(x, y) # else ASRTER(NIMP(x) && INEXP(x), x, ARG1, s_eqp); # endif - if INUMP(y) {t = x; x = y; y = t; goto realint;} + if (INUMP(y)) {t = x; x = y; y = t; goto realint;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} ASRTGO(INEXP(y), bady); # else ASRTGO(NIMP(y) && INEXP(y), bady); @@ -1146,18 +1171,18 @@ SCM eqp(x, y) if (x==y) return BOOL_T; return floequal(x, y); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BOOL_F; + if (BIGP(y)) return BOOL_F; # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif # endif realint: @@ -1165,16 +1190,16 @@ SCM eqp(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_eqp); - if INUMP(y) return BOOL_F; + if (INUMP(y)) return BOOL_F; ASRTGO(NIMP(y) && BIGP(y), bady); return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_eqp); + bady: wta(y, (char *)ARG2, s_eqp); # endif return BOOL_F; } @@ -1189,16 +1214,16 @@ SCM lessp(x, y) SCM x, y; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_lessp); + badx: wta(x, (char *)ARG1, s_lessp); # endif - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? BOOL_T : BOOL_F; ASRTGO(NIMP(y), bady); - if BIGP(y) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (1==bigcomp(x, y)) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); return (1==scm_bigdblcomp(x, REALPART(y))) ? BOOL_T : BOOL_F; } @@ -1206,44 +1231,44 @@ SCM lessp(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_lessp); # endif - if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; + if (INUMP(y)) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F; + if (BIGP(y)) return (-1==scm_bigdblcomp(y, REALPART(x))) ? BOOL_T : BOOL_F; ASRTGO(REALP(y), bady); # else ASRTGO(NIMP(y) && REALP(y), bady); # endif return (REALPART(x) < REALPART(y)) ? BOOL_T : BOOL_F; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T; + if (BIGP(y)) return BIGSIGN(y) ? BOOL_F : BOOL_T; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif # endif return (((double)INUM(x)) < REALPART(y)) ? BOOL_T : BOOL_F; } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_lessp); - if INUMP(y) return BIGSIGN(x) ? BOOL_T : BOOL_F; + 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; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_lessp); + bady: wta(y, (char *)ARG2, s_lessp); # endif return BIGSIGN(y) ? BOOL_F : BOOL_T; } @@ -1273,10 +1298,10 @@ SCM zerop(z) SCM z; { #ifdef FLOATS - if NINUMP(z) { + if (NINUMP(z)) { # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return BOOL_F; + if (BIGP(z)) return BOOL_F; # ifndef RECKLESS if (!(INEXP(z))) badz: wta(z, (char *)ARG1, s_zerop); @@ -1288,7 +1313,7 @@ SCM zerop(z) } #else # ifdef BIGDIG - if NINUMP(z) { + if (NINUMP(z)) { ASRTER(NIMP(z) && BIGP(z), z, ARG1, s_zerop); return BOOL_F; } @@ -1302,10 +1327,10 @@ SCM positivep(x) SCM x; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; + if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; # ifndef RECKLESS if (!(REALP(x))) badx: wta(x, (char *)ARG1, s_positivep); @@ -1317,7 +1342,7 @@ SCM positivep(x) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_positivep); return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; } @@ -1331,10 +1356,10 @@ SCM negativep(x) SCM x; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; + if (BIGP(x)) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; # ifndef RECKLESS if (!(REALP(x))) badx: wta(x, (char *)ARG1, s_negativep); @@ -1346,7 +1371,7 @@ SCM negativep(x) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_negativep); return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F; } @@ -1365,21 +1390,21 @@ SCM lmax(x, y) SCM t; double z; #endif - if UNBNDP(y) { + if (UNBNDP(y)) { #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_max); + badx: wta(x, (char *)ARG1, s_max); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? y : x; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? y : x; ASRTGO(NIMP(y), bady); - if BIGP(y) return (1==bigcomp(x, y)) ? y : x; + if (BIGP(y)) return (1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); big_dbl: if (-1 != scm_bigdblcomp(x, REALPART(y))) return y; @@ -1391,10 +1416,10 @@ SCM lmax(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_max); # endif - if INUMP(y) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; + if (INUMP(y)) return (REALPART(x) < (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { t = y; y = x; x = t; goto big_dbl; } ASRTGO(REALP(y), bady); @@ -1403,34 +1428,34 @@ SCM lmax(x, y) # endif return (REALPART(x) < REALPART(y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? x : y; + if (BIGP(y)) return BIGSIGN(y) ? x : y; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif # endif return ((z = INUM(x)) < REALPART(y)) ? y : makdbl(z, 0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_max); - if INUMP(y) return BIGSIGN(x) ? y : x; + if (INUMP(y)) return BIGSIGN(x) ? y : x; ASRTGO(NIMP(y) && BIGP(y), bady); return (1==bigcomp(x, y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_max); + bady: wta(y, (char *)ARG2, s_max); # endif return BIGSIGN(y) ? x : y; } @@ -1449,21 +1474,21 @@ SCM lmin(x, y) SCM t; double z; #endif - if UNBNDP(y) { + if (UNBNDP(y)) { #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_min); + badx: wta(x, (char *)ARG1, s_min); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) return BIGSIGN(x) ? x : y; + if (BIGP(x)) { + if (INUMP(y)) return BIGSIGN(x) ? x : y; ASRTGO(NIMP(y), bady); - if BIGP(y) return (-1==bigcomp(x, y)) ? y : x; + if (BIGP(y)) return (-1==bigcomp(x, y)) ? y : x; ASRTGO(REALP(y), bady); big_dbl: if (1 != scm_bigdblcomp(x, REALPART(y))) return y; @@ -1475,10 +1500,10 @@ SCM lmin(x, y) # else ASRTER(NIMP(x) && REALP(x), x, ARG1, s_min); # endif - if INUMP(y) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; + if (INUMP(y)) return (REALPART(x) > (z = INUM(y))) ? makdbl(z, 0.0) : x; # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { t = y; y = x; x = t; goto big_dbl; } ASRTGO(REALP(y), bady); @@ -1487,34 +1512,34 @@ SCM lmin(x, y) # endif return (REALPART(x) > REALPART(y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return BIGSIGN(y) ? y : x; + if (BIGP(y)) return BIGSIGN(y) ? y : x; # ifndef RECKLESS if (!(REALP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif # else # ifndef RECKLESS if (!(NIMP(y) && REALP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif # endif return ((z = INUM(x)) > REALPART(y)) ? y : makdbl(z, 0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_min); - if INUMP(y) return BIGSIGN(x) ? x : y; + if (INUMP(y)) return BIGSIGN(x) ? x : y; ASRTGO(NIMP(y) && BIGP(y), bady); return (-1==bigcomp(x, y)) ? y : x; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_min); + bady: wta(y, (char *)ARG2, s_min); # endif return BIGSIGN(y) ? y : x; } @@ -1529,23 +1554,23 @@ SCM lmin(x, y) SCM sum(x, y) SCM x, y; { - if UNBNDP(y) { - if UNBNDP(x) return INUM0; + if (UNBNDP(y)) { + if (UNBNDP(x)) return INUM0; #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_sum); + badx: wta(x, (char *)ARG1, s_sum); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { SCM t; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (BIGP(x)) { + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); } @@ -1556,30 +1581,32 @@ SCM sum(x, y) # else ASRTGO(NIMP(x) && INEXP(x), badx); # endif - if INUMP(y) {t = x; x = y; y = t; goto intreal;} + if (INUMP(y)) {t = x; x = y; y = t; goto intreal;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} # ifndef RECKLESS else if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif # endif - { double i = 0.0; - if CPLXP(x) i = IMAG(x); - if CPLXP(y) i += IMAG(y); - return makdbl(REALPART(x)+REALPART(y), i); } + { + double i = 0.0; + if (CPLXP(x)) i = IMAG(x); + if (CPLXP(y)) i += IMAG(y); + return makdbl(REALPART(x)+REALPART(y), i); + } } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) - intbig: { + if (BIGP(y)) + intbig: { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); @@ -1597,23 +1624,23 @@ SCM sum(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { SCM t; ASRTGO(NIMP(x) && BIGP(x), badx); - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y) && BIGP(y), bady); if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_sum); + bady: wta(y, (char *)ARG2, s_sum); # endif - intbig: { + intbig: { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); - return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1627,7 +1654,7 @@ SCM sum(x, y) # endif #endif x = INUM(x)+INUM(y); - if FIXABLE(x) return MAKINUM(x); + if (FIXABLE(x)) return MAKINUM(x); #ifdef BIGDIG return long2big(x); #else @@ -1643,14 +1670,14 @@ SCM difference(x, y) SCM x, y; { #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_difference); + badx: wta(x, (char *)ARG1, s_difference); # endif - if UNBNDP(y) { + if (UNBNDP(y)) { # ifdef BIGDIG - if BIGP(x) { + if (BIGP(x)) { x = copybig(x, !BIGSIGN(x)); return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? big2inum(x, NUMDIGS(x)) : x; @@ -1659,36 +1686,36 @@ SCM difference(x, y) ASRTGO(INEXP(x), badx); return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0); } - if INUMP(y) return sum(x, MAKINUM(-INUM(y))); + if (INUMP(y)) return sum(x, MAKINUM(-INUM(y))); # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(x) { - if BIGP(y) return (NUMDIGS(x) < NUMDIGS(y)) ? - addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : - addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + if (BIGP(x)) { + if (BIGP(y)) return (NUMDIGS(x) < NUMDIGS(y)) ? + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); ASRTGO(INEXP(y), bady); return makdbl(big2dbl(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } ASRTGO(INEXP(x), badx); - if BIGP(y) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0); + if (BIGP(y)) return makdbl(REALPART(x)-big2dbl(y), CPLXP(x)?IMAG(x):0.0); ASRTGO(INEXP(y), bady); # else ASRTGO(INEXP(x), badx); ASRTGO(NIMP(y) && INEXP(y), bady); # endif - if CPLXP(x) { - if CPLXP(y) + 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;} - if NINUMP(y) { + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); @@ -1700,29 +1727,29 @@ SCM difference(x, y) } # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif # endif return makdbl(INUM(x)-REALPART(y), CPLXP(y)?-IMAG(y):0.0); } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_difference); - if UNBNDP(y) { + if (UNBNDP(y)) { x = copybig(x, !BIGSIGN(x)); return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? - big2inum(x, NUMDIGS(x)) : x; + big2inum(x, NUMDIGS(x)) : x; } - if INUMP(y) { + if (INUMP(y)) { # ifndef DIGSTOOBIG long z = pseudolong(INUM(y)); - return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); + return addbig((BIGDIG *)&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1731,19 +1758,19 @@ SCM difference(x, y) } ASRTGO(NIMP(y) && BIGP(y), bady); return (NUMDIGS(x) < NUMDIGS(y)) ? - addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : - addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); + addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0x0100) : + addbig(BDIGITS(y), NUMDIGS(y), BIGSIGN(y) ^ 0x0100, x, 0); } - if UNBNDP(y) {x = -INUM(x); goto checkx;} - if NINUMP(y) { + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_difference); + bady: wta(y, (char *)ARG2, s_difference); # endif { # ifndef DIGSTOOBIG long z = pseudolong(INUM(x)); - return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); # else BIGDIG zdigs[DIGSPERLONG]; longdigs(INUM(x), zdigs); @@ -1753,13 +1780,13 @@ SCM difference(x, y) } # else ASRTER(INUMP(x), x, ARG1, s_difference); - if UNBNDP(y) {x = -INUM(x); goto checkx;} + if (UNBNDP(y)) {x = -INUM(x); goto checkx;} ASRTER(INUMP(y), y, ARG2, s_difference); # endif #endif x = INUM(x)-INUM(y); checkx: - if FIXABLE(x) return MAKINUM(x); + if (FIXABLE(x)) return MAKINUM(x); #ifdef BIGDIG return long2big(x); #else @@ -1774,24 +1801,24 @@ SCM difference(x, y) SCM product(x, y) SCM x, y; { - if UNBNDP(y) { - if UNBNDP(x) return MAKINUM(1L); + if (UNBNDP(y)) { + if (UNBNDP(x)) return MAKINUM(1L); #ifndef RECKLESS if (!(NUMBERP(x))) - badx: wta(x, (char *)ARG1, s_product); + badx: wta(x, (char *)ARG1, s_product); #endif return x; } #ifdef FLOATS - if NINUMP(x) { + if (NINUMP(x)) { SCM t; # ifdef BIGDIG ASRTGO(NIMP(x), badx); - if BIGP(x) { - if INUMP(y) {t = x; x = y; y = t; goto intbig;} + if (BIGP(x)) { + if (INUMP(y)) {t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y), bady); - if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), - BIGSIGN(x) ^ BIGSIGN(y)); + if (BIGP(y)) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y)); ASRTGO(INEXP(y), bady); bigreal: return bigdblop('*', x, REALPART(y), CPLXP(y) ? IMAG(y) : 0.0); @@ -1800,22 +1827,22 @@ SCM product(x, y) # else ASRTGO(NIMP(x) && INEXP(x), badx); # endif - if INUMP(y) {t = x; x = y; y = t; goto intreal;} + if (INUMP(y)) {t = x; x = y; y = t; goto intreal;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) {t = x; x = y; y = t; goto bigreal;} + if (BIGP(y)) {t = x; x = y; y = t; goto bigreal;} # ifndef RECKLESS else if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif # endif - if CPLXP(x) { - if CPLXP(y) + 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 @@ -1824,23 +1851,23 @@ SCM product(x, y) return makdbl(REALPART(x)*REALPART(y), CPLXP(y)?REALPART(x)*IMAG(y):0.0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; - { + { # ifndef DIGSTOOBIG - long z = pseudolong(INUM(x)); - return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + long z = pseudolong(INUM(x)); + return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # else - BIGDIG zdigs[DIGSPERLONG]; - longdigs(INUM(x), zdigs); - return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # endif - } + } } ASRTGO(INEXP(y), bady); # else @@ -1850,31 +1877,31 @@ SCM product(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { ASRTGO(NIMP(x) && BIGP(x), badx); - if INUMP(y) {SCM t = x; x = y; y = t; goto intbig;} + if (INUMP(y)) {SCM t = x; x = y; y = t; goto intbig;} ASRTGO(NIMP(y) && BIGP(y), bady); return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y)); } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_product); + bady: wta(y, (char *)ARG2, s_product); # endif intbig: if (INUM0==x) return x; if (MAKINUM(1L)==x) return y; - { + { # ifndef DIGSTOOBIG - long z = pseudolong(INUM(x)); - return mulbig(&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + long z = pseudolong(INUM(x)); + return mulbig((BIGDIG *)&z, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # else - BIGDIG zdigs[DIGSPERLONG]; - longdigs(INUM(x), zdigs); - return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), - BIGSIGN(y) ? (x>0) : (x<0)); + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return mulbig(zdigs, DIGSPERLONG, BDIGITS(y), NUMDIGS(y), + BIGSIGN(y) ? (x>0) : (x<0)); # endif - } + } } # else ASRTGO(INUMP(x), badx); @@ -1890,7 +1917,8 @@ SCM product(x, y) y = MAKINUM(k); if (k != INUM(y) || k/i != j) #ifdef BIGDIG - { int sgn = (i < 0) ^ (j < 0); + { + int sgn = (i < 0) ^ (j < 0); # ifndef DIGSTOOBIG i = pseudolong(i); j = pseudolong(j); @@ -1919,24 +1947,24 @@ SCM divide(x, y) { #ifdef FLOATS double d, r, i, a; - if NINUMP(x) { + if (NINUMP(x)) { # ifndef RECKLESS if (!(NIMP(x))) - badx: wta(x, (char *)ARG1, s_divide); + badx: wta(x, (char *)ARG1, s_divide); # endif - if UNBNDP(y) { + if (UNBNDP(y)) { # ifdef BIGDIG - if BIGP(x) return makdbl(1.0/big2dbl(x), 0.0); + if (BIGP(x)) return makdbl(1.0/big2dbl(x), 0.0); # endif ASRTGO(INEXP(x), badx); - if REALP(x) return makdbl(1.0/REALPART(x), 0.0); + if (REALP(x)) return makdbl(1.0/REALPART(x), 0.0); r = REAL(x); i = IMAG(x); d = r*r+i*i; return makdbl(r/d, -i/d); } # ifdef BIGDIG - if BIGP(x) { + if (BIGP(x)) { SCM z; - if INUMP(y) { + if (INUMP(y)) { z = INUM(y); ASRTER(z, y, OVFLOW, s_divide); if (1==z) return x; @@ -1951,15 +1979,17 @@ SCM divide(x, y) z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, BIGSIGN(x) ? (y>0) : (y<0), 3); # else - { BIGDIG zdigs[DIGSPERLONG]; + { + BIGDIG zdigs[DIGSPERLONG]; longdigs(z, zdigs); z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, - BIGSIGN(x) ? (y>0) : (y<0), 3);} + BIGSIGN(x) ? (y>0) : (y<0), 3); + } # endif return z ? z : bigdblop('/', x, INUM(y), 0.0); } ASRTGO(NIMP(y), bady); - if BIGP(y) { + if (BIGP(y)) { z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), BIGSIGN(x) ^ BIGSIGN(y), 3); return z ? z : inex_divbigbig(x, y); @@ -1969,42 +1999,42 @@ SCM divide(x, y) } # endif ASRTGO(INEXP(x), badx); - if INUMP(y) {d = INUM(y); goto basic_div;} + if (INUMP(y)) {d = INUM(y); goto basic_div;} # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0); + if (BIGP(y)) return bigdblop('\\', y, REALPART(x), CPLXP(x) ? IMAG(x) : 0.0); ASRTGO(INEXP(y), bady); # else ASRTGO(NIMP(y) && INEXP(y), bady); # endif - if REALP(y) { + if (REALP(y)) { d = REALPART(y); basic_div: return makdbl(REALPART(x)/d, CPLXP(x)?IMAG(x)/d:0.0); } a = REALPART(x); - if REALP(x) goto complex_div; + if (REALP(x)) goto complex_div; r = REAL(y); i = IMAG(y); d = r*r+i*i; return makdbl((a*r+IMAG(x)*i)/d, (IMAG(x)*r-a*i)/d); } - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; return makdbl(1.0/((double)INUM(x)), 0.0); } - if NINUMP(y) { + if (NINUMP(y)) { # ifdef BIGDIG ASRTGO(NIMP(y), bady); - if BIGP(y) return bigdblop('\\', y, INUM(x), 0.0); + if (BIGP(y)) return bigdblop('\\', y, INUM(x), 0.0); # ifndef RECKLESS if (!(INEXP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif # else # ifndef RECKLESS if (!(NIMP(y) && INEXP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif # endif - if REALP(y) return makdbl(INUM(x)/REALPART(y), 0.0); + if (REALP(y)) return makdbl(INUM(x)/REALPART(y), 0.0); a = INUM(x); complex_div: r = REAL(y); i = IMAG(y); d = r*r+i*i; @@ -2012,11 +2042,11 @@ SCM divide(x, y) } #else # ifdef BIGDIG - if NINUMP(x) { + if (NINUMP(x)) { SCM z; ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_divide); - if UNBNDP(y) goto ov; - if INUMP(y) { + if (UNBNDP(y)) goto ov; + if (INUMP(y)) { z = INUM(y); if (!z) goto ov; if (1==z) return x; @@ -2028,13 +2058,15 @@ SCM divide(x, y) } # ifndef DIGSTOOBIG z = pseudolong(z); - z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG, + z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, BIGSIGN(x) ? (y>0) : (y<0), 3); # else - { BIGDIG zdigs[DIGSPERLONG]; + { + BIGDIG zdigs[DIGSPERLONG]; longdigs(z, zdigs); z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, - BIGSIGN(x) ? (y>0) : (y<0), 3);} + BIGSIGN(x) ? (y>0) : (y<0), 3); + } # endif } else { ASRTGO(NIMP(y) && BIGP(y), bady); @@ -2044,20 +2076,20 @@ SCM divide(x, y) if (!z) goto ov; return z; } - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; goto ov; } - if NINUMP(y) { + if (NINUMP(y)) { # ifndef RECKLESS if (!(NIMP(y) && BIGP(y))) - bady: wta(y, (char *)ARG2, s_divide); + bady: wta(y, (char *)ARG2, s_divide); # endif goto ov; } # else ASRTER(INUMP(x), x, ARG1, s_divide); - if UNBNDP(y) { + if (UNBNDP(y)) { if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; goto ov; } @@ -2068,7 +2100,7 @@ SCM divide(x, y) long z = INUM(y); if ((0==z) || INUM(x)%z) goto ov; z = INUM(x)/z; - if FIXABLE(z) return MAKINUM(z); + if (FIXABLE(z)) return MAKINUM(z); #ifdef BIGDIG return long2big(z); #endif @@ -2088,17 +2120,16 @@ SCM scm_intexpt(z1, z2) #ifdef FLOATS double dacc, dz1; #endif -#ifdef BIGDIG - if (INUM0==z1 || acc==z1) return z1; - else if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; -#endif + if (INUM0==z2) return sum(acc, product(z1, INUM0)); ASRTER(INUMP(z2), z2, ARG2, s_intexpt); + if (acc==z1) return z1; + if (MAKINUM(-1L)==z1) return BOOL_F==evenp(z2)?z1:acc; z2 = INUM(z2); if (z2 < 0) { z2 = -z2; recip = 1; /* z1 = divide(z1, UNDEFINED); */ } - if INUMP(z1) { + if (INUMP(z1)) { long tmp, iacc = 1, iz1 = INUM(z1); #ifdef FLOATS if (recip) { dz1 = iz1; goto flocase; } @@ -2142,7 +2173,7 @@ SCM scm_intexpt(z1, z2) } ASRTER(NIMP(z1), z1, ARG1, s_intexpt); #ifdef FLOATS - if REALP(z1) { + if (REALP(z1)) { dz1 = REALPART(z1); flocase: dacc = 1.0; @@ -2168,25 +2199,27 @@ SCM scm_intexpt(z1, z2) } #ifdef FLOATS -double lasinh(x) +# ifndef HAVE_ATANH +double asinh(x) double x; { return log(x+sqrt(x*x+1)); } -double lacosh(x) +double acosh(x) double x; { return log(x+sqrt(x*x-1)); } -double latanh(x) +double atanh(x) double x; { return 0.5*log((1+x)/(1-x)); } +# endif -double ltrunc(x) +double scm_truncate(x) double x; { if (x < 0.0) return -floor(-x); @@ -2210,36 +2243,38 @@ void two_doubles(z1, z2, sstring, xy) char *sstring; struct dpair *xy; { - if INUMP(z1) xy->x = INUM(z1); + if (INUMP(z1)) xy->x = INUM(z1); else { # ifdef BIGDIG ASRTGO(NIMP(z1), badz1); - if BIGP(z1) xy->x = big2dbl(z1); + if (BIGP(z1)) xy->x = big2dbl(z1); else { # ifndef RECKLESS if (!(REALP(z1))) - badz1: wta(z1, (char *)ARG1, sstring); + badz1: wta(z1, (char *)ARG1, sstring); # endif xy->x = REALPART(z1);} # else {ASRTER(NIMP(z1) && REALP(z1), z1, ARG1, sstring); - xy->x = REALPART(z1);} + xy->x = REALPART(z1);} # endif } - if INUMP(z2) xy->y = INUM(z2); + if (INUMP(z2)) xy->y = INUM(z2); else { # ifdef BIGDIG ASRTGO(NIMP(z2), badz2); - if BIGP(z2) xy->y = big2dbl(z2); + if (BIGP(z2)) xy->y = big2dbl(z2); else { # ifndef RECKLESS if (!(REALP(z2))) - badz2: wta(z2, (char *)ARG2, sstring); + badz2: wta(z2, (char *)ARG2, sstring); # endif xy->y = REALPART(z2);} # else - {ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring); - xy->y = REALPART(z2);} + { + ASRTER(NIMP(z2) && REALP(z2), z2, ARG2, sstring); + xy->y = REALPART(z2); + } # endif } } @@ -2276,53 +2311,63 @@ SCM makpolar(z1, z2) SCM real_part(z) SCM z; { - if NINUMP(z) { + if (NINUMP(z)) { # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return z; + if (BIGP(z)) return z; # ifndef RECKLESS if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_real_part); + badz: wta(z, (char *)ARG1, s_real_part); # endif # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_real_part); # endif - if CPLXP(z) return makdbl(REAL(z), 0.0); + if (CPLXP(z)) return makdbl(REAL(z), 0.0); } return z; } SCM imag_part(z) SCM z; { - if INUMP(z) return INUM0; + if (INUMP(z)) return INUM0; # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return INUM0; + if (BIGP(z)) return INUM0; # ifndef RECKLESS if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_imag_part); + badz: wta(z, (char *)ARG1, s_imag_part); # endif # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_imag_part); # endif - if CPLXP(z) return makdbl(IMAG(z), 0.0); + if (CPLXP(z)) return makdbl(IMAG(z), 0.0); return flo0; } -SCM magnitude(z) + +SCM scm_abs(z) SCM z; { - if INUMP(z) return absval(z); + if (INUMP(z)) return scm_iabs(z); + ASRTGO(NIMP(z), badz); # ifdef BIGDIG + if (BIGP(z)) return scm_iabs(z); +# endif + if (!REALP(z)) + badz: wta(z, (char *)ARG1, s_abs); + return makdbl(fabs(REALPART(z)), 0.0); +} + +SCM scm_magnitude(z) + SCM z; +{ + if (INUMP(z)) return scm_iabs(z); ASRTGO(NIMP(z), badz); - if BIGP(z) return absval(z); -# ifndef RECKLESS - if (!(INEXP(z))) - badz: wta(z, (char *)ARG1, s_magnitude); -# endif -# else - ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_magnitude); +# ifdef BIGDIG + if (BIGP(z)) return scm_iabs(z); # endif - if CPLXP(z) + if (!INEXP(z)) + badz: wta(z, (char *)ARG1, s_magnitude); + if (CPLXP(z)) { double i = IMAG(z), r = REAL(z); return makdbl(sqrt(i*i+r*r), 0.0); @@ -2334,10 +2379,10 @@ SCM angle(z) SCM z; { double x, y = 0.0; - if INUMP(z) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;} + if (INUMP(z)) {x = (z>=INUM0) ? 1.0 : -1.0; goto do_angle;} # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} + if (BIGP(z)) {x = (TYP16(z)==tc16_bigpos) ? 1.0 : -1.0; goto do_angle;} # ifndef RECKLESS if (!(INEXP(z))) { badz: wta(z, (char *)ARG1, s_angle);} @@ -2345,7 +2390,7 @@ SCM angle(z) # else ASRTER(NIMP(z) && INEXP(z), z, ARG1, s_angle); # endif - if REALP(z) {x = REALPART(z); goto do_angle;} + if (REALP(z)) {x = REALPART(z); goto do_angle;} x = REAL(z); y = IMAG(z); do_angle: return makdbl(atan2(y, x), 0.0); @@ -2355,21 +2400,21 @@ do_angle: SCM ex2in(z) SCM z; { - if INUMP(z) return makdbl((double)INUM(z), 0.0); + if (INUMP(z)) return makdbl((double)INUM(z), 0.0); ASRTGO(NIMP(z), badz); - if INEXP(z) return z; + if (INEXP(z)) return z; # ifdef BIGDIG - if BIGP(z) return makdbl(big2dbl(z), 0.0); + if (BIGP(z)) return makdbl(big2dbl(z), 0.0); # endif badz: wta(z, (char *)ARG1, s_ex2in); } SCM in2ex(z) SCM z; { - if INUMP(z) return z; + if (INUMP(z)) return z; # ifdef BIGDIG ASRTGO(NIMP(z), badz); - if BIGP(z) return z; + if (BIGP(z)) return z; # ifndef RECKLESS if (!(REALP(z))) badz: wta(z, (char *)ARG1, s_in2ex); @@ -2400,11 +2445,38 @@ static char s_trunc[] = "truncate"; SCM numident(x) SCM x; { +# ifdef BIGDIG + ASRTER(INUMP(x) || (NIMP(x) && BIGP(x)), x, ARG1, s_trunc); +# else ASRTER(INUMP(x), x, ARG1, s_trunc); +# endif return x; } #endif /* FLOATS */ +SCM scm_iabs(x) + SCM x; +{ +#ifdef BIGDIG + if (NINUMP(x)) { + ASRTER(NIMP(x) && BIGP(x), x, ARG1, s_abs); + if (TYP16(x)==tc16_bigpos) return x; + return copybig(x, 0); + } +#else + ASRTER(INUMP(x), x, ARG1, s_abs); +#endif + if (INUM(x) >= 0) return x; + x = -INUM(x); + if (!POSFIXABLE(x)) +#ifdef BIGDIG + return long2big(x); +#else + wta(MAKINUM(-x), (char *)OVFLOW, s_abs); +#endif + return MAKINUM(x); +} + #ifdef BIGDIG # ifdef FLOATS SCM dbl2big(d) @@ -2584,7 +2656,7 @@ unsigned long hasher(obj, n, d) case 2: case 6: /* INUMP(obj) */ return INUM(obj) % n; case 4: - if ICHRP(obj) + if (ICHRP(obj)) return (unsigned)(downcase[ICHR(obj)]) % n; switch ((int) obj) { #ifndef SICP @@ -2607,11 +2679,11 @@ unsigned long hasher(obj, n, d) default: return 263 % n; #ifdef FLOATS case tc16_flo: - if REALP(obj) { + if (REALP(obj)) { double r = REALPART(obj); if (floor(r)==r) { obj = in2ex(obj); - if IMP(obj) return INUM(obj) % n; + if (IMP(obj)) return INUM(obj) % n; goto bighash; } } @@ -2664,7 +2736,7 @@ SCM hashv(obj, n) SCM n; { ASRTER(INUMP(n) && 0 <= n, n, ARG2, s_hashv); - if ICHRP(obj) return MAKINUM((unsigned)(downcase[ICHR(obj)]) % INUM(n)); + 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)); } @@ -2687,10 +2759,11 @@ static iproc subr1s[] = { {"integer?", intp}, {s_real_part, real_part}, {s_imag_part, imag_part}, - {s_magnitude, magnitude}, + {s_magnitude, scm_magnitude}, {s_angle, angle}, {s_in2ex, in2ex}, {s_ex2in, ex2in}, + {s_abs, scm_abs}, # ifdef BIGDIG {s_dfloat_parts, scm_dfloat_parts}, # endif @@ -2703,6 +2776,7 @@ static iproc subr1s[] = { {"ceiling", numident}, {s_trunc, numident}, {"round", numident}, + {s_abs, scm_iabs}, #endif {s_zerop, zerop}, {s_positivep, positivep}, @@ -2772,7 +2846,7 @@ static iproc rpsubrs[] = { static dblproc cxrs[] = { {"floor", floor}, {"ceiling", ceil}, - {"truncate", ltrunc}, + {"truncate", scm_truncate}, {"round", scm_round}, {"$sqrt", sqrt}, {"$abs", fabs}, @@ -2788,14 +2862,14 @@ static dblproc cxrs[] = { {"$sinh", sinh}, {"$cosh", cosh}, {"$tanh", tanh}, - {"$asinh", lasinh}, - {"$acosh", lacosh}, - {"$atanh", latanh}, + {"$asinh", asinh}, + {"$acosh", acosh}, + {"$atanh", atanh}, {0, 0}}; #endif #ifdef FLOATS -static void add1(f, fsum) +static void safe_add_1(f, fsum) double f, *fsum; { *fsum = f + 1.0; @@ -2836,11 +2910,11 @@ void init_scl() # else { /* determine floating point precision */ double f = 0.1; - double fsum = 1.0+f; + volatile double fsum = 1.0+f; while (fsum != 1.0) { f /= 10.0; if (++dblprec > 20) break; - add1(f, &fsum); + safe_add_1(f, &fsum); } dblprec = dblprec-1; } @@ -2849,11 +2923,12 @@ void init_scl() dbl_mant_dig = DBL_MANT_DIG; # else { /* means we #defined it. */ - double fsum = 0.0, eps = 1.0; + volatile double fsum = 0.0; + double eps = 1.0; int i = 0; while (fsum != 1.0) { eps = 0.5 * eps; - add1(eps, &fsum); + safe_add_1(eps, &fsum); i++; } dbl_mant_dig = i; -- cgit v1.2.3