From 5ca6e8e6a4e5c022a6fb5d28f30219c22c99eda8 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:23 -0800 Subject: Import Upstream version 4e6 --- scl.c | 2393 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 2393 insertions(+) create mode 100644 scl.c (limited to 'scl.c') diff --git a/scl.c b/scl.c new file mode 100644 index 0000000..393d0f0 --- /dev/null +++ b/scl.c @@ -0,0 +1,2393 @@ +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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 + * the Free Software Foundation; either version 2, or (at your option) + * any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU General Public License for more details. + * + * You should have received a copy of the GNU General Public License + * along with this software; see the file COPYING. If not, write to + * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. + * + * As a special exception, the Free Software Foundation gives permission + * for additional uses of the text contained in its release of GUILE. + * + * The exception is that, if you link the GUILE library with other files + * to produce an executable, this does not by itself cause the + * resulting executable to be covered by the GNU General Public License. + * Your use of that executable is in no way restricted on account of + * linking the GUILE library code into it. + * + * This exception does not however invalidate any other reasons why + * the executable file might be covered by the GNU General Public License. + * + * This exception applies only to the code released by the + * Free Software Foundation under the name GUILE. If you copy + * code from other Free Software Foundation releases into a copy of + * GUILE, as the General Public License permits, the exception does + * not apply to the code that you add in this way. To avoid misleading + * anyone as to the status of such modified files, you must delete + * this exception notice from them. + * + * If you write modifications of your own for GUILE, it is your choice + * whether to permit this exception to apply to your modifications. + * If you do not wish that, delete this exception notice. + */ + +/* "scl.c" non-IEEE utility functions and non-integer arithmetic. + Authors: Jerry D. Hedden and Aubrey Jaffer */ + +#include "scm.h" + +#ifdef FLOATS +# include + +static char s_makrect[] = "make-rectangular", s_makpolar[] = "make-polar", + s_magnitude[] = "magnitude", s_angle[] = "angle", + s_real_part[] = "real-part", s_imag_part[] = "imag-part", + s_in2ex[] = "inexact->exact"; +static char s_expt[] = "$expt", s_atan2[] = "$atan2"; +static char s_memv[] = "memv", s_assv[] = "assv"; +#endif + +SCM sys_protects[NUM_PROTECTS]; +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_leqp[] = "<=", s_greqp[] = ">="; +static char s_max[] = "max", s_min[] = "min"; +char s_sum[] = "+", s_difference[] = "-", s_product[] = "*", + s_divide[] = "/"; +static char s_number2string[] = "number->string", + s_str2number[] = "string->number"; + +static char s_list_tail[] = "list-tail"; +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!"; + +/*** NUMBERS -> STRINGS ***/ +#ifdef FLOATS +int dblprec; +static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, + 5e-6, 5e-7, 5e-8, 5e-9, 5e-10, + 5e-11,5e-12,5e-13,5e-14,5e-15, + 5e-16,5e-17,5e-18,5e-19,5e-20}; + +static sizet idbl2str(f, a) + double f; +char *a; +{ + int efmt, dpt, d, i, wp = dblprec; + sizet ch = 0; + int exp = 0; + + if (f==0.0) goto zero; /*{a[0]='0'; a[1]='.'; a[2]='0'; return 3;}*/ + 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; + } +# ifdef DBL_MIN_10_EXP /* Prevent unnormalized values, as from + make-uniform-vector, from causing infinite loops. */ + while (f < 1.0) {f *= 10.0; if (exp-- < DBL_MIN_10_EXP) goto funny;} + while (f > 10.0) {f *= 0.10; if (exp++ > DBL_MAX_10_EXP) goto funny;} +# else + while (f < 1.0) {f *= 10.0; exp--;} + while (f > 10.0) {f /= 10.0; exp++;} +# endif + if (f+fx[wp] >= 10.0) {f = 1.0; exp++;} + zero: +# ifdef ENGNOT + dpt = (exp+9999)%3; + exp -= dpt++; + efmt = 1; +# else + efmt = (exp < -3) || (exp > wp+2); + if (!efmt) + if (exp < 0) { + a[ch++] = '0'; + a[ch++] = '.'; + dpt = exp; + while (++dpt) a[ch++] = '0'; + } else + dpt = exp+1; + else + dpt = 1; +# endif + + do { + d = f; + f -= d; + a[ch++] = d+'0'; + if (f < fx[wp]) break; + if (f+fx[wp] >= 1.0) { + a[ch-1]++; + break; + } + f *= 10.0; + if (!(--dpt)) a[ch++] = '.'; + } while (wp--); + + if (dpt > 0) +# ifndef ENGNOT + if ((dpt > 4) && (exp > 6)) { + d = (a[0]=='-'?2:1); + for (i = ch++; i > d; i--) + a[i] = a[i-1]; + a[d] = '.'; + efmt = 1; + } else +# endif + { + while (--dpt) a[ch++] = '0'; + a[ch++] = '.'; + } + if (a[ch-1]=='.') a[ch++]='0'; /* trailing zero */ + if (efmt && exp) { + a[ch++] = 'e'; + if (exp < 0) { + exp = -exp; + a[ch++] = '-'; + } + for (i = 10; i <= exp; i *= 10); + for (i /= 10; i; i /= 10) { + a[ch++] = exp/i + '0'; + exp %= i; + } + } + return ch; +} + +static sizet iflo2str(flt, str) + SCM flt; + char *str; +{ + sizet i; +# ifdef SINGLES + if SINGP(flt) i = idbl2str(FLO(flt), str); + else +# endif + i = idbl2str(REAL(flt), str); + if CPLXP(flt) { + if(0 <= IMAG(flt)) /* jeh */ + str[i++] = '+'; /* jeh */ + i += idbl2str(IMAG(flt), &str[i]); + str[i++] = 'i'; + } + return i; +} +#endif /* FLOATS */ + +sizet iint2str(num, rad, p) + long num; + int rad; + char *p; +{ + sizet j; + register int i = 1, d; + register long n = num; + if (n < 0) {n = -n; i++;} + for (n /= rad;n > 0;n /= rad) i++; + j = i; + n = num; + if (n < 0) {n = -n; *p++ = '-'; i--;} + while (i--) { + d = n % rad; + n /= rad; + p[i] = d + ((d < 10) ? '0' : 'a' - 10); + } + return j; +} +#ifdef BIGDIG +static SCM big2str(b, radix) + SCM b; + register unsigned int radix; +{ + SCM t = copybig(b, 0); /* sign of temp doesn't matter */ + register BIGDIG *ds = BDIGITS(t); + sizet i = NUMDIGS(t); + sizet j = radix==16 ? (BITSPERDIG*i)/4+2 + : radix >= 10 ? (BITSPERDIG*i*241L)/800+2 + : (BITSPERDIG*i)+2; + sizet k = 0; + sizet radct = 0; + sizet ch; /* jeh */ + BIGDIG radpow = 1, radmod = 0; + SCM ss = makstr((long)j); + char *s = CHARS(ss), c; + while ((long) radpow * radix < BIGRAD) { + radpow *= radix; + radct++; + } + s[0] = tc16_bigneg==TYP16(b) ? '-' : '+'; + while ((i || radmod) && j) { + if (k==0) { + radmod = (BIGDIG)divbigdig(ds, i, radpow); + k = radct; + if (!ds[i-1]) i--; + } + c = radmod % radix; radmod /= radix; k--; + s[--j] = c < 10 ? c + '0' : c + 'a' - 10; + } + 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 */ + } + return ss; +} +#endif +SCM number2string(x, radix) + SCM x, radix; +{ + if UNBNDP(radix) radix=MAKINUM(10L); + else ASSERT(INUMP(radix), radix, ARG2, s_number2string); +#ifdef FLOATS + if NINUMP(x) { + char num_buf[FLOBUFLEN]; +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return big2str(x, (unsigned int)INUM(radix)); +# ifndef RECKLESS + if (!(INEXP(x))) + badx: wta(x, (char *)ARG1, s_number2string); +# endif +# else + ASSERT(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); + return big2str(x, (unsigned int)INUM(radix)); + } +# else + ASSERT(INUMP(x), x, ARG1, s_number2string); +# endif +#endif + { + char num_buf[INTBUFLEN]; + return makfromstr(num_buf, iint2str(INUM(x), (int)INUM(radix), num_buf)); + } +} +/* These print routines are stubbed here so that repl.c doesn't need + FLOATS or BIGDIGs conditionals */ +int floprint(sexp, port, writing) + SCM sexp; + SCM port; + int writing; +{ +#ifdef FLOATS + char num_buf[FLOBUFLEN]; + lfwrite(num_buf, (sizet)sizeof(char), iflo2str(sexp, num_buf), port); +#else + ipruk("float", sexp, port); +#endif + return !0; +} +int bigprint(exp, port, writing) + SCM exp; + SCM port; + int writing; +{ +#ifdef BIGDIG + exp = big2str(exp, (unsigned int)10); + lfwrite(CHARS(exp), (sizet)sizeof(char), (sizet)LENGTH(exp), port); +#else + ipruk("bignum", exp, port); +#endif + return !0; +} +/*** END nums->strs ***/ + +/*** STRINGS -> NUMBERS ***/ +#ifdef BIGDIG +SCM istr2int(str, len, radix) + char *str; + long len; + register long radix; +{ + sizet j; + register sizet k, blen = 1; + sizet i = 0; + int c; + SCM res; + register BIGDIG *ds; + register unsigned long t2; + + if (0 >= len) return BOOL_F; /* zero length */ + if (10==radix) j = 1+(84*len)/(BITSPERDIG*25); + else j = (8 < radix) ? 1+(4*len)/BITSPERDIG : 1+(3*len)/BITSPERDIG; + switch (str[0]) { /* leading sign */ + case '-': + case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */ + } + res = mkbig(j, '-'==str[0]); + ds = BDIGITS(res); + for (k = j;k--;) ds[k] = 0; + do { + switch (c = str[i++]) { + case DIGITS: + c = c - '0'; + goto accumulate; + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + c = c-'A'+10; + goto accumulate; + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + c = c-'a'+10; + accumulate: + if (c >= radix) return BOOL_F; /* bad digit for radix */ + k = 0; + t2 = c; + moretodo: + while(k < blen) { +/* 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); + } + ASSERT(blen <= j, (SCM)MAKINUM(blen), OVFLOW, "bignum"); + if (t2) {blen++; goto moretodo;} + break; + default: + return BOOL_F; /* not a digit */ + } + } while (i < len); + if (blen * BITSPERDIG/CHAR_BIT <= sizeof(SCM)) + if INUMP(res = big2inum(res, blen)) return res; + if (j==blen) return res; + return adjbig(res, blen); +} +#else +SCM istr2int(str, len, radix) + register char *str; + long len; + register long radix; +{ + register long n = 0, ln; + register int c; + register int i = 0; + int lead_neg = 0; + if (0 >= len) return BOOL_F; /* zero length */ + switch (*str) { /* leading sign */ + case '-': lead_neg = 1; + case '+': if (++i==len) return BOOL_F; /* bad if lone `+' or `-' */ + } + + do { + switch (c = str[i++]) { + case DIGITS: + c = c - '0'; + goto accumulate; + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + c = c-'A'+10; + goto accumulate; + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + c = c-'a'+10; + accumulate: + if (c >= radix) return BOOL_F; /* bad digit for radix */ + ln = n; + n = n * radix - c; + /* Negation is a workaround for HP700 cc bug */ + if (n > ln || (-n > -MOST_NEGATIVE_FIXNUM)) goto ovfl; + break; + default: + return BOOL_F; /* not a digit */ + } + } while (i < len); + if (!lead_neg) if ((n = -n) > MOST_POSITIVE_FIXNUM) goto ovfl; + return MAKINUM(n); + ovfl: /* overflow scheme integer */ + return BOOL_F; +} +#endif + +#ifdef FLOATS +SCM istr2flo(str, len, radix) + register char *str; + register long len; + register long radix; +{ + register int c, i = 0; + double lead_sgn; + double res = 0.0, tmp = 0.0; + int flg = 0; + int point = 0; + SCM second; + + if (i >= len) return BOOL_F; /* zero length */ + + 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 `-' */ + + 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); + } + do { /* check initial digits */ + switch (c = str[i]) { + case DIGITS: + c = c - '0'; + goto accum1; + case 'D': case 'E': case 'F': + if (radix==10) goto out1; /* must be exponent */ + case 'A': case 'B': case 'C': + c = c-'A'+10; + goto accum1; + case 'd': case 'e': case 'f': + if (radix==10) goto out1; + case 'a': case 'b': case 'c': + c = c-'a'+10; + accum1: + if (c >= radix) return BOOL_F; /* bad digit for radix */ + res = res * radix + c; + flg = 1; /* res is valid */ + break; + default: + goto out1; + } + } while (++i < len); + out1: + + /* if true, then we did see a digit above, and res is valid */ + if (i==len) goto done; + + /* By here, must have seen a digit, + or must have next char be a `.' with radix==10 */ + if (!flg) + if (!(str[i]=='.' && radix==10)) + return BOOL_F; + + while (str[i]=='#') { /* optional sharps */ + res *= radix; + if (++i==len) goto done; + } + + if (str[i]=='/') { + while (++i < len) { + switch (c = str[i]) { + case DIGITS: + c = c - '0'; + goto accum2; + case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': + c = c-'A'+10; + goto accum2; + case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': + c = c-'a'+10; + accum2: + if (c >= radix) return BOOL_F; + tmp = tmp * radix + c; + break; + default: + goto out2; + } + } + out2: + if (tmp==0.0) return BOOL_F; /* `slash zero' not allowed */ + if (i < len) + while (str[i]=='#') { /* optional sharps */ + tmp *= radix; + if (++i==len) break; + } + res /= tmp; + goto done; + } + + if (str[i]=='.') { /* decimal point notation */ + if (radix != 10) return BOOL_F; /* must be radix 10 */ + while (++i < len) { + switch (c = str[i]) { + case DIGITS: + point--; + res = res*10.0 + c-'0'; + flg = 1; + break; + default: + goto out3; + } + } + out3: + if (!flg) return BOOL_F; /* no digits before or after decimal point */ + if (i==len) goto adjust; + while (str[i]=='#') { /* ignore remaining sharps */ + if (++i==len) goto adjust; + } + } + + switch (str[i]) { /* exponent */ + case 'd': case 'D': + case 'e': case 'E': + case 'f': case 'F': + case 'l': case 'L': + case 's': case 'S': { + int expsgn = 1, expon = 0; + if (radix != 10) return BOOL_F; /* only in radix 10 */ + if (++i==len) return BOOL_F; /* bad exponent */ + switch (str[i]) { + case '-': expsgn=(-1); + case '+': if (++i==len) return BOOL_F; /* bad exponent */ + } + if (str[i] < '0' || str[i] > '9') return BOOL_F; /* bad exponent */ + do { + switch (c = str[i]) { + case DIGITS: + expon = expon*10 + c-'0'; + if (expon > MAXEXP) return BOOL_F; /* exponent too large */ + break; + default: + goto out4; + } + } while (++i < len); + out4: + point += expsgn*expon; + } + } + + adjust: + if (point >= 0) + while (point--) res *= 10.0; + else +# ifdef _UNICOS + while (point++) res *= 0.1; +# else + while (point++) res /= 10.0; +# endif + + done: + /* at this point, we have a legitimate floating point result */ + if (lead_sgn==-1.0) res = -res; + if (i==len) return makdbl(res, 0.0); + + if (str[i]=='i' || str[i]=='I') { /* pure imaginary number */ + 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, res); + } + + switch (str[i++]) { + case '-': lead_sgn = -1.0; break; + case '+': lead_sgn = 1.0; break; + case '@': { /* polar input for complex number */ + /* get a `real' for angle */ + second = istr2flo(&str[i], (long)(len-i), radix); + if (!(INEXP(second))) return BOOL_F; /* not `real' */ + if (CPLXP(second)) return BOOL_F; /* not `real' */ + tmp = REALPART(second); + return makdbl(res*cos(tmp), res*sin(tmp)); + } + default: return BOOL_F; + } + + /* at this point, last char must be `i' */ + if (str[len-1] != 'i' && str[len-1] != 'I') return BOOL_F; + /* handles `x+i' and `x-i' */ + 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 (!(INEXP(second))) return BOOL_F; /* not `ureal' */ + if (CPLXP(second)) return BOOL_F; /* not `ureal' */ + tmp = REALPART(second); + if (tmp < 0.0) return BOOL_F; /* not `ureal' */ + return makdbl(res, (lead_sgn*tmp)); +} +#endif /* FLOATS */ + + +SCM istring2number(str, len, radix) + char *str; + long len; + long radix; +{ + int i = 0; + char ex = 0; + char ex_p = 0, rx_p = 0; /* Only allow 1 exactness and 1 radix prefix */ + SCM res; + if (len==1) + if (*str=='+' || *str=='-') /* Catches lone `+' and `-' for speed */ + return BOOL_F; + + while ((len-i) >= 2 && str[i]=='#' && ++i) + switch (str[i++]) { + case 'b': case 'B': if (rx_p++) return BOOL_F; radix = 2; break; + case 'o': case 'O': if (rx_p++) return BOOL_F; radix = 8; break; + case 'd': case 'D': if (rx_p++) return BOOL_F; radix = 10; break; + case 'x': case 'X': if (rx_p++) return BOOL_F; radix = 16; break; + case 'i': case 'I': if (ex_p++) return BOOL_F; ex = 2; break; + case 'e': case 'E': if (ex_p++) return BOOL_F; ex = 1; break; + default: return BOOL_F; + } + + switch (ex) { + case 1: + return istr2int(&str[i], len-i, radix); + case 0: + res = istr2int(&str[i], len-i, radix); + if NFALSEP(res) return res; +#ifdef FLOATS + case 2: return istr2flo(&str[i], len-i, radix); +#endif + } + return BOOL_F; +} + + +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); + return istring2number(CHARS(str), LENGTH(str), INUM(radix)); +} +/*** END strs->nums ***/ + +#ifdef FLOATS +SCM makdbl (x, y) + double x, y; +{ + SCM z; + if ((y==0.0) && (x==0.0)) return flo0; + NEWCELL(z); + DEFER_INTS; + if (y==0.0) { +# ifdef SINGLES + float fx; +# ifndef SINGLESONLY + if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x)) +# endif + { + CAR(z) = tc_flo; + FLO(z) = x; + ALLOW_INTS; + return z; + } +# endif /* def SINGLES */ + CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real"); + CAR(z) = tc_dblr; + } + else { + CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex"); + CAR(z) = tc_dblc; + IMAG(z) = y; + } + REAL(z) = x; + ALLOW_INTS; + return z; +} + +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; + /* this ensures that types and length are the same. */ + if (CAR(x) != CAR(y)) return BOOL_F; + if NUMP(x) { +# ifdef BIGDIG + if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; +# endif + if (REALPART(x) != REALPART(y)) return BOOL_F; + if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F; + return BOOL_T; + } + return BOOL_F; +} +SCM memv(x, lst) /* m.borza 12.2.91 */ +SCM x, lst; +{ + for(;NIMP(lst);lst = CDR(lst)) { + ASRTGO(CONSP(lst), badlst); + if NFALSEP(eqv(CAR(lst), x)) return lst; + } +# ifndef RECKLESS + if (!(NULLP(lst))) + badlst: wta(lst, (char *)ARG2, s_memv); +# endif + return BOOL_F; +} +SCM assv(x, alist) /* m.borza 12.2.91 */ +SCM x, alist; +{ + SCM tmp; + for(;NIMP(alist);alist = CDR(alist)) { + ASRTGO(CONSP(alist), badlst); + tmp = CAR(alist); + ASRTGO(NIMP(tmp) && CONSP(tmp), badlst); + if NFALSEP(eqv(CAR(tmp), x)) return tmp; + } +# ifndef RECKLESS + if (!(NULLP(alist))) + badlst: wta(alist, (char *)ARG2, s_assv); +# endif + return BOOL_F; +} +#endif /* FLOATS */ + +SCM list_tail(lst, k) + SCM lst, k; +{ + register long i; + ASSERT(INUMP(k), k, ARG2, s_list_tail); + i = INUM(k); + while (i-- > 0) { + ASSERT(NIMP(lst) && CONSP(lst), lst, ARG1, s_list_tail); + lst = CDR(lst); + } + return lst; +} + +SCM string2list(str) + SCM str; +{ + long i; + SCM res = EOL; + unsigned char *src; + ASSERT(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; +} +SCM string_copy(str) + SCM str; +{ + ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_st_copy); + return makfromstr(CHARS(str), (sizet)LENGTH(str)); +} +SCM string_fill(str, chr) + SCM 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); + c = ICHR(chr); + dst = CHARS(str); + for(k = LENGTH(str)-1;k >= 0;k--) dst[k] = c; + return UNSPECIFIED; +} +SCM vector2list(v) + SCM v; +{ + SCM res = EOL; + long i; + SCM *data; + ASSERT(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; +} +SCM vector_fill(v, fill) + SCM v, fill; +{ + register long i; + register SCM *data; + ASSERT(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; +} +static SCM vector_equal(x, y) + SCM x, y; +{ + long i; + for(i = LENGTH(x)-1;i >= 0;i--) + if FALSEP(equal(VELTS(x)[i], VELTS(y)[i])) return BOOL_F; + return BOOL_T; +} +SCM bigequal(x, y) + SCM x, y; +{ +#ifdef BIGDIG + if (0==bigcomp(x, y)) return BOOL_T; +#endif + return BOOL_F; +} +SCM floequal(x, y) + SCM x, y; +{ +#ifdef FLOATS + if (REALPART(x) != REALPART(y)) return BOOL_F; + if (!(CPLXP(x) && (IMAG(x) != IMAG(y)))) return BOOL_T; +#endif + return BOOL_F; +} +SCM equal(x, y) + SCM 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_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; + } + } + return BOOL_F; +} + +SCM numberp(x) + SCM x; +{ + if INUMP(x) return BOOL_T; +#ifdef FLOATS + if (NIMP(x) && NUMP(x)) return BOOL_T; +#else +# ifdef BIGDIG + if (NIMP(x) && NUMP(x)) return BOOL_T; +# endif +#endif + return BOOL_F; +} +#ifdef FLOATS +SCM realp(x) + SCM x; +{ + 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; +# endif + return BOOL_F; +} +SCM intp(x) + SCM x; +{ + double r; + if INUMP(x) return BOOL_T; + if IMP(x) return BOOL_F; +# ifdef BIGDIG + if BIGP(x) return BOOL_T; +# endif + 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; +} +#endif /* FLOATS */ + +SCM inexactp(x) + SCM x; +{ +#ifdef FLOATS + if (NIMP(x) && INEXP(x)) return BOOL_T; +#endif + return BOOL_F; +} +SCM eqp(x, y) + SCM x, y; +{ +#ifdef FLOATS + SCM t; + if NINUMP(x) { +# ifdef BIGDIG +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_eqp); +# endif + 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; + ASRTGO(INEXP(y), bady); + bigreal: + return (REALP(y) && (big2dbl(x)==REALPART(y))) ? BOOL_T : BOOL_F; + } + ASRTGO(INEXP(x), badx); +# else + ASSERT(NIMP(x) && INEXP(x), x, ARG1, s_eqp); +# endif + 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;} + ASRTGO(INEXP(y), bady); +# 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 NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BOOL_F; +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif +# endif + realint: + return (REALP(y) && (((double)INUM(x))==REALPART(y))) ? BOOL_T : BOOL_F; + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASSERT(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; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_eqp); +# endif + return BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_eqp); + ASSERT(INUMP(y), y, ARG2, s_eqp); +# endif +#endif + return ((long)x==(long)y) ? BOOL_T : BOOL_F; +} +SCM lessp(x, y) + SCM x, y; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_lessp); +# endif + 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; + ASRTGO(REALP(y), bady); + return (big2dbl(x) < REALPART(y)) ? BOOL_T : BOOL_F; + } + ASRTGO(REALP(x), badx); +# else + ASSERT(NIMP(x) && REALP(x), x, ARG1, s_lessp); +# endif + if INUMP(y) return (REALPART(x) < ((double)INUM(y))) ? BOOL_T : BOOL_F; +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) < big2dbl(y)) ? 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) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? BOOL_F : BOOL_T; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_lessp); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + 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) { + ASSERT(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; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_lessp); +# endif + return BIGSIGN(y) ? BOOL_F : BOOL_T; + } +# else + ASSERT(INUMP(x), x, ARG1, s_lessp); + ASSERT(INUMP(y), y, ARG2, s_lessp); +# endif +#endif + return ((long)x < (long)y) ? BOOL_T : BOOL_F; +} +SCM greaterp(x, y) + SCM x, y; +{ + return lessp(y, x); +} +SCM leqp(x, y) + SCM x, y; +{ + return BOOL_NOT(lessp(y, x)); +} +SCM greqp(x, y) + SCM x, y; +{ + return BOOL_NOT(lessp(x, y)); +} +SCM zerop(z) + SCM z; +{ +#ifdef FLOATS + if NINUMP(z) { +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return BOOL_F; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_zerop); +# endif +# else + ASSERT(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); + return BOOL_F; + } +# else + ASSERT(INUMP(z), z, ARG1, s_zerop); +# endif +#endif + return (z==INUM0) ? BOOL_T: BOOL_F; +} +SCM positivep(x) + SCM x; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; +# ifndef RECKLESS + if (!(REALP(x))) + badx: wta(x, (char *)ARG1, s_positivep); +# endif +# else + ASSERT(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); + return TYP16(x)==tc16_bigpos ? BOOL_T : BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_positivep); +# endif +#endif + return (x > INUM0) ? BOOL_T : BOOL_F; +} +SCM negativep(x) + SCM x; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + if BIGP(x) return TYP16(x)==tc16_bigpos ? BOOL_F : BOOL_T; +# ifndef RECKLESS + if (!(REALP(x))) + badx: wta(x, (char *)ARG1, s_negativep); +# endif +# else + ASSERT(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); + return (TYP16(x)==tc16_bigneg) ? BOOL_T : BOOL_F; + } +# else + ASSERT(INUMP(x), x, ARG1, s_negativep); +# endif +#endif + return (x < INUM0) ? BOOL_T : BOOL_F; +} + +SCM lmax(x, y) + SCM x, y; +{ +#ifdef FLOATS + double z; +#endif + if UNBNDP(y) { +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_max); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + 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; + ASRTGO(REALP(y), bady); + z = big2dbl(x); + return (z < REALPART(y)) ? y : makdbl(z, 0.0); + } + ASRTGO(REALP(x), badx); +# else + ASSERT(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 + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) < (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + ASRTGO(REALP(y), bady); +# else + ASRTGO(NIMP(y) && REALP(y), bady); +# endif + return (REALPART(x) < REALPART(y)) ? y : x; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? x : y; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_max); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + 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) { + ASSERT(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; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_max); +# endif + return BIGSIGN(y) ? x : y; + } +# else + ASSERT(INUMP(x), x, ARG1, s_max); + ASSERT(INUMP(y), y, ARG2, s_max); +# endif +#endif + return ((long)x < (long)y) ? y : x; +} + +SCM lmin(x, y) + SCM x, y; +{ +#ifdef FLOATS + double z; +#endif + if UNBNDP(y) { +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_min); +#endif + return x; + } +#ifdef FLOATS + if NINUMP(x) { +# ifdef BIGDIG + ASRTGO(NIMP(x), badx); + 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; + ASRTGO(REALP(y), bady); + z = big2dbl(x); + return (z > REALPART(y)) ? y : makdbl(z, 0.0); + } + ASRTGO(REALP(x), badx); +# else + ASSERT(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 + ASRTGO(NIMP(y), bady); + if BIGP(y) return (REALPART(x) > (z = big2dbl(y))) ? makdbl(z, 0.0) : x; + ASRTGO(REALP(y), bady); +# else + ASRTGO(NIMP(y) && REALP(y), bady); +# endif + return (REALPART(x) > REALPART(y)) ? y : x; + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return BIGSIGN(y) ? y : x; +# ifndef RECKLESS + if (!(REALP(y))) + bady: wta(y, (char *)ARG2, s_min); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && REALP(y))) + 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) { + ASSERT(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; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_min); +# endif + return BIGSIGN(y) ? y : x; + } +# else + ASSERT(INUMP(x), x, ARG1, s_min); + ASSERT(INUMP(y), y, ARG2, s_min); +# endif +#endif + return ((long)x > (long)y) ? y : x; +} + +SCM sum(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return INUM0; +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_sum); +#endif + return x; + } +#ifdef FLOATS + 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;} + ASRTGO(NIMP(y), bady); + if BIGP(y) { + if (NUMDIGS(x) > NUMDIGS(y)) {t = x; x = y; y = t;} + return addbig(BDIGITS(x), NUMDIGS(x), BIGSIGN(x), y, 0); + } + ASRTGO(INEXP(y), bady); + bigreal: return makdbl(big2dbl(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0); + } + ASRTGO(INEXP(x), badx); +# else + ASRTGO(NIMP(x) && INEXP(x), badx); +# endif + 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;} +# ifndef RECKLESS + else if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_sum); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + 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); } + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# endif + } + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + intreal: return makdbl(INUM(x)+REALPART(y), CPLXP(y)?IMAG(y):0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + SCM t; + ASRTGO(NIMP(x) && BIGP(x), badx); + 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) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_sum); +# endif + intbig: { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0); +# endif + } + } +# else + ASRTGO(INUMP(x), badx); + ASSERT(INUMP(y), y, ARG2, s_sum); +# endif +#endif + x = INUM(x)+INUM(y); + if FIXABLE(x) return MAKINUM(x); +#ifdef BIGDIG + return long2big(x); +#else +# ifdef FLOATS + return makdbl((double)x, 0.0); +# else + wta(y, (char *)OVFLOW, s_sum); +# endif +#endif +} + +SCM difference(x, y) + SCM x, y; +{ +#ifdef FLOATS + if NINUMP(x) { +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_difference); +# endif + if UNBNDP(y) { +# ifdef BIGDIG + if BIGP(x) { + x = copybig(x, !BIGSIGN(x)); + return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? + big2inum(x, NUMDIGS(x)) : x; + } +# endif + ASRTGO(INEXP(x), badx); + return makdbl(-REALPART(x), CPLXP(x)?-IMAG(x):0.0); + } + 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); + 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); + ASRTGO(INEXP(y), bady); +# else + ASRTGO(INEXP(x), badx); + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + 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) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig((BIGDIG *)&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# endif + } +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_difference); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + 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) { + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_difference); + if UNBNDP(y) { + x = copybig(x, !BIGSIGN(x)); + return NUMDIGS(x) * BITSPERDIG/CHAR_BIT <= sizeof(SCM) ? + big2inum(x, NUMDIGS(x)) : x; + } + if INUMP(y) { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(y)); + return addbig(&z, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (y < 0) ? 0 : 0x0100, x, 0); +# endif + } + 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); + } + 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); +# endif + { +# ifndef DIGSTOOBIG + long z = pseudolong(INUM(x)); + return addbig(&z, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# else + BIGDIG zdigs[DIGSPERLONG]; + longdigs(INUM(x), zdigs); + return addbig(zdigs, DIGSPERLONG, (x < 0) ? 0x0100 : 0, y, 0x0100); +# endif + } + } +# else + ASSERT(INUMP(x), x, ARG1, s_difference); + if UNBNDP(y) {x = -INUM(x); goto checkx;} + ASSERT(INUMP(y), y, ARG2, s_difference); +# endif +#endif + x = INUM(x)-INUM(y); + checkx: + if FIXABLE(x) return MAKINUM(x); +#ifdef BIGDIG + return long2big(x); +#else +# ifdef FLOATS + return makdbl((double)x, 0.0); +# else + wta(y, (char *)OVFLOW, s_difference); +# endif +#endif +} + +SCM product(x, y) + SCM x, y; +{ + if UNBNDP(y) { + if UNBNDP(x) return MAKINUM(1L); +#ifndef RECKLESS + if (!(NUMBERP(x))) + badx: wta(x, (char *)ARG1, s_product); +#endif + return x; + } +#ifdef FLOATS + 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;} + ASRTGO(NIMP(y), bady); + if BIGP(y) return mulbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y)); + ASRTGO(INEXP(y), bady); + bigreal: { + double bg = big2dbl(x); + return makdbl(bg*REALPART(y), CPLXP(y)?bg*IMAG(y):0.0); } + } + ASRTGO(INEXP(x), badx); +# else + ASRTGO(NIMP(x) && INEXP(x), badx); +# endif + 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;} +# ifndef RECKLESS + else if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_product); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_product); +# endif +# endif + 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); + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + 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)); +# else + 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 + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + intreal: return makdbl(INUM(x)*REALPART(y), CPLXP(y)?INUM(x)*IMAG(y):0.0); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + ASRTGO(NIMP(x) && BIGP(x), badx); + 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) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + 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)); +# else + 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); + ASSERT(INUMP(y), y, ARG2, s_product); +# endif +#endif + { + long i, j, k; + i = INUM(x); + if (0==i) return x; + j = INUM(y); + k = i * j; + y = MAKINUM(k); + if (k != INUM(y) || k/i != j) +#ifdef BIGDIG + { int sgn = (i < 0) ^ (j < 0); +# ifndef DIGSTOOBIG + i = pseudolong(i); + j = pseudolong(j); + return mulbig((BIGDIG *)&i, DIGSPERLONG, + (BIGDIG *)&j, DIGSPERLONG, sgn); +# else /* DIGSTOOBIG */ + BIGDIG idigs[DIGSPERLONG]; + BIGDIG jdigs[DIGSPERLONG]; + longdigs(i, idigs); + longdigs(j, jdigs); + return mulbig(idigs, DIGSPERLONG, jdigs, DIGSPERLONG, sgn); +# endif + } +#else +# ifdef FLOATS + return makdbl(((double)i)*((double)j), 0.0); +# else + wta(y, (char *)OVFLOW, s_product); +# endif +#endif + return y; + } +} + +SCM divide(x, y) + SCM x, y; +{ +#ifdef FLOATS + double d, r, i, a; + if NINUMP(x) { +# ifndef RECKLESS + if (!(NIMP(x))) + badx: wta(x, (char *)ARG1, s_divide); +# endif + if UNBNDP(y) { +# ifdef BIGDIG + 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); + r = REAL(x); i = IMAG(x); d = r*r+i*i; + return makdbl(r/d, -i/d); + } +# ifdef BIGDIG + if BIGP(x) { + SCM z; + if INUMP(y) { + z = INUM(y); + ASSERT(z, y, OVFLOW, s_divide); + if (1==z) return x; + if (z < 0) z = -z; + if (z < BIGRAD) { + SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); + return divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z) ? + makdbl(big2dbl(x)/INUM(y), 0.0) : normbig(w); + } +# ifndef DIGSTOOBIG + z = pseudolong(z); + z = divbigbig(BDIGITS(x), NUMDIGS(x), (BIGDIG *)&z, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3); +# else + { BIGDIG zdigs[DIGSPERLONG]; + longdigs(z, zdigs); + z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3);} +# endif + return z ? z : makdbl(big2dbl(x)/INUM(y), 0.0); + } + ASRTGO(NIMP(y), bady); + if BIGP(y) { + z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y), 3); + return z ? z : makdbl(big2dbl(x)/big2dbl(y), 0.0); + } + ASRTGO(INEXP(y), bady); + if REALP(y) return makdbl(big2dbl(x)/REALPART(y), 0.0); + a = big2dbl(x); + goto complex_div; + } +# endif + ASRTGO(INEXP(x), badx); + if INUMP(y) {d = INUM(y); goto basic_div;} +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) {d = big2dbl(y); goto basic_div;} + ASRTGO(INEXP(y), bady); +# else + ASRTGO(NIMP(y) && INEXP(y), bady); +# endif + 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; + 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 ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; + return makdbl(1.0/((double)INUM(x)), 0.0); + } + if NINUMP(y) { +# ifdef BIGDIG + ASRTGO(NIMP(y), bady); + if BIGP(y) return makdbl(INUM(x)/big2dbl(y), 0.0); +# ifndef RECKLESS + if (!(INEXP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif +# else +# ifndef RECKLESS + if (!(NIMP(y) && INEXP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif +# endif + 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; + return makdbl((a*r)/d, (-a*i)/d); + } +#else +# ifdef BIGDIG + if NINUMP(x) { + SCM z; + ASSERT(NIMP(x) && BIGP(x), x, ARG1, s_divide); + if UNBNDP(y) goto ov; + if INUMP(y) { + z = INUM(y); + if (!z) goto ov; + if (1==z) return x; + if (z < 0) z = -z; + if (z < BIGRAD) { + SCM w = copybig(x, BIGSIGN(x) ? (y>0) : (y<0)); + if (divbigdig(BDIGITS(w), NUMDIGS(w), (BIGDIG)z)) goto ov; + return w; + } +# ifndef DIGSTOOBIG + z = pseudolong(z); + z = divbigbig(BDIGITS(x), NUMDIGS(x), &z, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3); +# else + { BIGDIG zdigs[DIGSPERLONG]; + longdigs(z, zdigs); + z = divbigbig(BDIGITS(x), NUMDIGS(x), zdigs, DIGSPERLONG, + BIGSIGN(x) ? (y>0) : (y<0), 3);} +# endif + } else { + ASRTGO(NIMP(y) && BIGP(y), bady); + z = divbigbig(BDIGITS(x), NUMDIGS(x), BDIGITS(y), NUMDIGS(y), + BIGSIGN(x) ^ BIGSIGN(y), 3); + } + if (!z) goto ov; + return z; + } + if UNBNDP(y) { + if ((MAKINUM(1L)==x) || (MAKINUM(-1L)==x)) return x; + goto ov; + } + if NINUMP(y) { +# ifndef RECKLESS + if (!(NIMP(y) && BIGP(y))) + bady: wta(y, (char *)ARG2, s_divide); +# endif + goto ov; + } +# else + ASSERT(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); +# endif +#endif + { + long z = INUM(y); + if ((0==z) || INUM(x)%z) goto ov; + z = INUM(x)/z; + if FIXABLE(z) return MAKINUM(z); +#ifdef BIGDIG + return long2big(z); +#endif +#ifdef FLOATS + ov: return makdbl(((double)INUM(x))/((double)INUM(y)), 0.0); +#else + ov: wta(x, (char *)OVFLOW, s_divide); +#endif + } +} + +#ifdef FLOATS +double lasinh(x) + double x; +{ + return log(x+sqrt(x*x+1)); +} + +double lacosh(x) + double x; +{ + return log(x+sqrt(x*x-1)); +} + +double latanh(x) + double x; +{ + return 0.5*log((1+x)/(1-x)); +} + +double ltrunc(x) + double x; +{ + if (x < 0.0) return -floor(-x); + return floor(x); +} +double round(x) + double x; +{ + double plus_half = x + 0.5; + double result = floor(plus_half); + /* Adjust so that the round is towards even. */ + return (plus_half==result && plus_half / 2 != floor(plus_half / 2)) + ? result - 1 : result; +} + +struct dpair {double x, y;}; + +void two_doubles(z1, z2, sstring, xy) + SCM z1, z2; + char *sstring; + struct dpair *xy; +{ + if INUMP(z1) xy->x = INUM(z1); + else { +# ifdef BIGDIG + ASRTGO(NIMP(z1), badz1); + if BIGP(z1) xy->x = big2dbl(z1); + else { +# ifndef RECKLESS + if (!(REALP(z1))) + badz1: wta(z1, (char *)ARG1, sstring); +# endif + xy->x = REALPART(z1);} +# else + {ASSERT(NIMP(z1) && REALP(z1), z1, ARG1, sstring); + xy->x = REALPART(z1);} +# endif + } + if INUMP(z2) xy->y = INUM(z2); + else { +# ifdef BIGDIG + ASRTGO(NIMP(z2), badz2); + if BIGP(z2) xy->y = big2dbl(z2); + else { +# ifndef RECKLESS + if (!(REALP(z2))) + badz2: wta(z2, (char *)ARG2, sstring); +# endif + xy->y = REALPART(z2);} +# else + {ASSERT(NIMP(z2) && REALP(z2), z2, ARG2, sstring); + xy->y = REALPART(z2);} +# endif + } +} + +SCM expt(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_expt, &xy); + return makdbl(pow(xy.x, xy.y), 0.0); +} +SCM latan2(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_atan2, &xy); + return makdbl(atan2(xy.x, xy.y), 0.0); +} +SCM makrect(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_makrect, &xy); + return makdbl(xy.x, xy.y); +} +SCM makpolar(z1, z2) + SCM z1, z2; +{ + struct dpair xy; + two_doubles(z1, z2, s_makpolar, &xy); + return makdbl(xy.x*cos(xy.y), xy.x*sin(xy.y)); +} + +SCM real_part(z) + SCM z; +{ + if NINUMP(z) { +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return z; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_real_part); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_real_part); +# endif + if CPLXP(z) return makdbl(REAL(z), 0.0); + } + return z; +} +SCM imag_part(z) + SCM z; +{ + if INUMP(z) return INUM0; +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return INUM0; +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_imag_part); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_imag_part); +# endif + if CPLXP(z) return makdbl(IMAG(z), 0.0); + return flo0; +} +SCM magnitude(z) + SCM z; +{ + if INUMP(z) return absval(z); +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return absval(z); +# ifndef RECKLESS + if (!(INEXP(z))) + badz: wta(z, (char *)ARG1, s_magnitude); +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_magnitude); +# endif + if CPLXP(z) + { + double i = IMAG(z), r = REAL(z); + return makdbl(sqrt(i*i+r*r), 0.0); + } + return makdbl(fabs(REALPART(z)), 0.0); +} + +SCM angle(z) + SCM z; +{ + double x, y = 0.0; + 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;} +# ifndef RECKLESS + if (!(INEXP(z))) { + badz: wta(z, (char *)ARG1, s_angle);} +# endif +# else + ASSERT(NIMP(z) && INEXP(z), z, ARG1, s_angle); +# endif + if REALP(z) {x = REALPART(z); goto do_angle;} + x = REAL(z); y = IMAG(z); +do_angle: + return makdbl(atan2(y, x), 0.0); +} + +double floident(z) + double z; +{ + return z; +} +SCM in2ex(z) + SCM z; +{ + if INUMP(z) return z; +# ifdef BIGDIG + ASRTGO(NIMP(z), badz); + if BIGP(z) return z; +# ifndef RECKLESS + if (!(REALP(z))) + badz: wta(z, (char *)ARG1, s_in2ex); +# endif +# else + ASSERT(NIMP(z) && REALP(z), z, ARG1, s_in2ex); +# endif +# ifdef BIGDIG + { + double u = floor(REALPART(z)+0.5); + if ((u <= MOST_POSITIVE_FIXNUM) && (-u <= -MOST_NEGATIVE_FIXNUM)) { + /* Negation is a workaround for HP700 cc bug */ + SCM ans = MAKINUM((long)u); + if (INUM(ans)==(long)u) return ans; + } + ASRTGO(!IS_INF(u), badz); /* problem? */ + return dbl2big(u); + } +# else + return MAKINUM((long)floor(REALPART(z)+0.5)); +# endif +} +#else /* ~FLOATS */ +static char s_trunc[] = "truncate"; +SCM numident(x) + SCM x; +{ + ASSERT(INUMP(x), x, ARG1, s_trunc); + return x; +} +#endif /* FLOATS */ + +#ifdef BIGDIG +# ifdef FLOATS +SCM dbl2big(d) + double d; /* must be integer */ +{ + sizet i = 0; + long c; + BIGDIG *digits; + SCM ans; + double u = (d < 0)?-d:d; + while (0 != floor(u)) {u /= BIGRAD;i++;} + ans = mkbig(i, d < 0); + digits = BDIGITS(ans); + while (i--) { + u *= BIGRAD; + c = floor(u); + u -= c; + digits[i] = c; + } + ASSERT(0==u, INUM0, OVFLOW, "dbl2big"); + return ans; +} +double big2dbl(b) + SCM b; +{ + double ans = 0.0; + sizet i = NUMDIGS(b); + BIGDIG *digits = BDIGITS(b); + while (i--) ans = digits[i] + BIGRAD*ans; + if (tc16_bigneg==TYP16(b)) return -ans; + return ans; +} +# endif +#endif + +unsigned long hasher(obj, n, d) + SCM obj; + unsigned long n; + sizet d; +{ + switch (7 & (int) obj) { + case 2: case 6: /* INUMP(obj) */ + return INUM(obj) % n; + case 4: + if ICHRP(obj) + return (unsigned)(downcase[ICHR(obj)]) % n; + switch ((int) obj) { +#ifndef SICP + case (int) EOL: d = 256; break; +#endif + case (int) BOOL_T: d = 257; break; + case (int) BOOL_F: d = 258; break; + case (int) EOF_VAL: d = 259; break; + default: d = 263; /* perhaps should be error */ + } + return d % n; + default: return 263 % n; /* perhaps should be error */ + case 0: + switch TYP7(obj) { + default: return 263 % n; + case tc7_smob: + switch TYP16(obj) { + case tcs_bignums: + bighash: return INUM(modulo(obj, MAKINUM(n))); + default: return 263 % n; +#ifdef FLOATS + case tc16_flo: + if REALP(obj) { + double r = REALPART(obj); + if (floor(r)==r) { + obj = in2ex(obj); + if IMP(obj) return INUM(obj) % n; + goto bighash; + } + } + obj = number2string(obj, MAKINUM(10)); +#endif + } + case tcs_symbols: case tc7_string: + return strhash(UCHARS(obj), (sizet) LENGTH(obj), n); + case tc7_vector: { + sizet len = LENGTH(obj); + SCM *data = VELTS(obj); + if (len>5) { + sizet i = d/2; + unsigned long h = 1; + while (i--) h = ((h<<8) + (hasher(data[h % len], n, 2))) % n; + return h; + } + else { + sizet i = len; + unsigned long h = (n)-1; + while (i--) h = ((h<<8) + (hasher(data[i], n, d/len))) % n; + return h; + } + } + case tcs_cons_imcar: case tcs_cons_nimcar: + if (d) return (hasher(CAR(obj), n, d/2)+hasher(CDR(obj), n, d/2)) % n; + else return 1; + case tc7_port: + return ((RDNG & CAR(obj)) ? 260 : 261) % n; + case tcs_closures: case tc7_contin: case tcs_subrs: + return 262 % n; + } + } +} + +static char s_hashv[] = "hashv", s_hashq[] = "hashq"; +extern char s_obunhash[]; +#define s_hash (&s_obunhash[9]) + +SCM hash(obj, n) + SCM obj; + SCM n; +{ + ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hash); + return MAKINUM(hasher(obj, INUM(n), 10)); +} + +SCM hashv(obj, n) + SCM obj; + SCM n; +{ + ASSERT(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)); +} + +SCM hashq(obj, n) + SCM obj; + SCM n; +{ + ASSERT(INUMP(n) && 0 <= n, n, ARG2, s_hashq); + return MAKINUM((((unsigned) obj) >> 1) % INUM(n)); +} + +static iproc subr1s[] = { + {"number?", numberp}, + {"complex?", numberp}, + {s_inexactp, inexactp}, +#ifdef FLOATS + {"real?", realp}, + {"rational?", realp}, + {"integer?", intp}, + {s_real_part, real_part}, + {s_imag_part, imag_part}, + {s_magnitude, magnitude}, + {s_angle, angle}, + {s_in2ex, in2ex}, +#else + {"real?", numberp}, + {"rational?", numberp}, + {"integer?", exactp}, + {"floor", numident}, + {"ceiling", numident}, + {s_trunc, numident}, + {"round", numident}, +#endif + {s_zerop, zerop}, + {s_positivep, positivep}, + {s_negativep, negativep}, + {s_str2list, string2list}, + {"list->string", string}, + {s_st_copy, string_copy}, + {"list->vector", vector}, + {s_vect2list, vector2list}, + {0, 0}}; + +static iproc asubrs[] = { + {s_difference, difference}, + {s_divide, divide}, + {s_max, lmax}, + {s_min, lmin}, + {s_sum, sum}, + {s_product, product}, + {0, 0}}; + +static iproc subr2s[] = { +#ifdef FLOATS + {s_makrect, makrect}, + {s_makpolar, makpolar}, + {s_memv, memv}, + {s_assv, assv}, + {s_atan2, latan2}, + {s_expt, expt}, +#else + {"memv", memq}, + {"assv", assq}, +#endif + {s_list_tail, list_tail}, + {s_ve_fill, vector_fill}, + {s_st_fill, string_fill}, + {s_hash, hash}, + {s_hashv, hashv}, + {s_hashq, hashq}, + {0, 0}}; + +static iproc subr2os[] = { + {s_str2number, string2number}, + {s_number2string, number2string}, + {0, 0}}; + +static iproc rpsubrs[] = { +#ifdef FLOATS + {"eqv?", eqv}, +#else + {"eqv?", eq}, +#endif + {s_eqp, eqp}, + {s_lessp, lessp}, + {s_grp, greaterp}, + {s_leqp, leqp}, + {s_greqp, greqp}, + {0, 0}}; + +#ifdef FLOATS +static dblproc cxrs[] = { + {"floor", floor}, + {"ceiling", ceil}, + {"truncate", ltrunc}, + {"round", round}, + {"$sqrt", sqrt}, + {"$abs", fabs}, + {"$exp", exp}, + {"$log", log}, + {"$sin", sin}, + {"$cos", cos}, + {"$tan", tan}, + {"$asin", asin}, + {"$acos", acos}, + {"$atan", atan}, + {"$sinh", sinh}, + {"$cosh", cosh}, + {"$tanh", tanh}, + {"$asinh", lasinh}, + {"$acosh", lacosh}, + {"$atanh", latanh}, + {"exact->inexact", floident}, + {0, 0}}; +#endif + +#ifdef FLOATS +# ifndef DBL_DIG +static void add1(f, fsum) + double f, *fsum; +{ + *fsum = f + 1.0; +} +# endif +#endif + +void init_scl() +{ + init_iprocs(subr1s, tc7_subr_1); + init_iprocs(subr2os, tc7_subr_2o); + init_iprocs(subr2s, tc7_subr_2); + init_iprocs(asubrs, tc7_asubr); + init_iprocs(rpsubrs, tc7_rpsubr); +#ifdef SICP + add_feature("sicp"); +#endif +#ifdef FLOATS + init_iprocs((iproc *)cxrs, tc7_cxr); + NEWCELL(flo0); +# ifdef SINGLES + CAR(flo0) = tc_flo; + FLO(flo0) = 0.0; +# else + CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real"); + REAL(flo0) = 0.0; + CAR(flo0) = tc_dblr; +# endif +# ifdef DBL_DIG + dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; +# else + { /* determine floating point precision */ + double f = 0.1; + double fsum = 1.0+f; + while (fsum != 1.0) { + f /= 10.0; + if (++dblprec > 20) break; + add1(f, &fsum); + } + dblprec = dblprec-1; + } +# endif /* DBL_DIG */ +#endif +} -- cgit v1.2.3