diff options
Diffstat (limited to 'scl.c')
| -rw-r--r-- | scl.c | 93 |
1 files changed, 65 insertions, 28 deletions
@@ -50,10 +50,11 @@ 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"; + s_in2ex[] = "inexact->exact",s_ex2in[] = "exact->inexact"; + static char s_expt[] = "$expt", s_atan2[] = "$atan2"; -static char s_memv[] = "memv", s_assv[] = "assv"; #endif +static char s_memv[] = "memv", s_assv[] = "assv"; SCM sys_protects[NUM_PROTECTS]; sizet num_protects = NUM_PROTECTS; @@ -84,7 +85,7 @@ static double fx[] = {0.0, 5e-1, 5e-2, 5e-3, 5e-4, 5e-5, static sizet idbl2str(f, a) double f; -char *a; + char *a; { int efmt, dpt, d, i, wp = dblprec; sizet ch = 0; @@ -189,19 +190,17 @@ static sizet iflo2str(flt, str) } #endif /* FLOATS */ -sizet iint2str(num, rad, p) - long num; +sizet iuint2str(num, rad, p) + unsigned long num; int rad; char *p; { sizet j; register int i = 1, d; - register long n = num; - if (n < 0) {n = -n; i++;} + register unsigned long n = num; 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; @@ -209,6 +208,17 @@ sizet iint2str(num, rad, p) } return j; } +sizet iint2str(num, rad, p) + long num; + int rad; + char *p; +{ + if ((num < 0) && !(rad < 0)) { + *p++ = '-'; + return 1 + iuint2str((unsigned long) -num, rad, p); + } + return iuint2str((unsigned long) num, rad < 0 ? -rad : rad, p); +} #ifdef BIGDIG static SCM big2str(b, radix) SCM b; @@ -226,6 +236,7 @@ static SCM big2str(b, radix) BIGDIG radpow = 1, radmod = 0; SCM ss = makstr((long)j); char *s = CHARS(ss), c; + scm_protect_temp(&t); while ((long) radpow * radix < BIGRAD) { radpow *= radix; radct++; @@ -671,8 +682,6 @@ SCM makdbl (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; @@ -680,17 +689,29 @@ SCM makdbl (x, y) if ((-FLTMAX < x) && (x < FLTMAX) && ((fx=x)==x)) # endif { + NEWCELL(z); + DEFER_INTS; CAR(z) = tc_flo; FLO(z) = x; ALLOW_INTS; return z; } # endif /* def SINGLES */ - CDR(z) = (SCM)must_malloc(1L*sizeof(double), "real"); + DEFER_INTS; +# ifdef NUM_HP + CDR(z) = (SCM)num_hp_alloc(sizeof(double)); +# else + z = must_malloc_cell(1L*sizeof(double), "real"); +# endif CAR(z) = tc_dblr; } else { - CDR(z) = (SCM)must_malloc(2L*sizeof(double), "complex"); + DEFER_INTS; +# ifdef NUM_HP + CDR(z) = (SCM)num_hp_alloc(2L*sizeof(double)); +# else + z = must_malloc_cell(2L*sizeof(double), "complex"); +# endif CAR(z) = tc_dblc; IMAG(z) = y; } @@ -698,7 +719,9 @@ SCM makdbl (x, y) ALLOW_INTS; return z; } +#endif /* FLOATS */ +#ifndef INUMS_ONLY SCM eqv(x, y) SCM x, y; { @@ -711,9 +734,11 @@ SCM eqv(x, y) # ifdef BIGDIG if BIGP(x) return (0==bigcomp(x, y)) ? BOOL_T : BOOL_F; # endif +# ifdef FLOATS if (REALPART(x) != REALPART(y)) return BOOL_F; if (CPLXP(x) && (IMAG(x) != IMAG(y))) return BOOL_F; return BOOL_T; +# endif } return BOOL_F; } @@ -746,7 +771,7 @@ SCM x, alist; # endif return BOOL_F; } -#endif /* FLOATS */ +#endif SCM list_tail(lst, k) SCM lst, k; @@ -1905,7 +1930,8 @@ double ltrunc(x) if (x < 0.0) return -floor(-x); return floor(x); } -double round(x) + +double scm_round(x) double x; { double plus_half = x + 0.5; @@ -2063,10 +2089,17 @@ do_angle: return makdbl(atan2(y, x), 0.0); } -double floident(z) - double z; + +SCM ex2in(z) + SCM z; { - return z; + if INUMP(z) return makdbl((double)INUM(z), 0.0); + ASRTGO(NIMP(z), badz); + if INEXP(z) return z; +# ifdef BIGDIG + if BIGP(z) return makdbl(big2dbl(z), 0.0); +# endif + badz: wta(z, (char *)ARG1, s_ex2in); } SCM in2ex(z) SCM z; @@ -2257,6 +2290,7 @@ static iproc subr1s[] = { {s_magnitude, magnitude}, {s_angle, angle}, {s_in2ex, in2ex}, + {s_ex2in, ex2in}, #else {"real?", numberp}, {"rational?", numberp}, @@ -2289,13 +2323,15 @@ static iproc subr2s[] = { #ifdef FLOATS {s_makrect, makrect}, {s_makpolar, makpolar}, - {s_memv, memv}, - {s_assv, assv}, {s_atan2, latan2}, {s_expt, expt}, +#endif +#ifdef INUMS_ONLY + {s_memv, memq}, + {s_assv, assq}, #else - {"memv", memq}, - {"assv", assq}, + {s_memv, memv}, + {s_assv, assv}, #endif {s_list_tail, list_tail}, {s_ve_fill, vector_fill}, @@ -2311,10 +2347,10 @@ static iproc subr2os[] = { {0, 0}}; static iproc rpsubrs[] = { -#ifdef FLOATS - {"eqv?", eqv}, -#else +#ifdef INUMS_ONLY {"eqv?", eq}, +#else + {"eqv?", eqv}, #endif {s_eqp, eqp}, {s_lessp, lessp}, @@ -2328,7 +2364,7 @@ static dblproc cxrs[] = { {"floor", floor}, {"ceiling", ceil}, {"truncate", ltrunc}, - {"round", round}, + {"round", scm_round}, {"$sqrt", sqrt}, {"$abs", fabs}, {"$exp", exp}, @@ -2346,7 +2382,6 @@ static dblproc cxrs[] = { {"$asinh", lasinh}, {"$acosh", lacosh}, {"$atanh", latanh}, - {"exact->inexact", floident}, {0, 0}}; #endif @@ -2372,14 +2407,16 @@ void init_scl() #endif #ifdef FLOATS init_iprocs((iproc *)cxrs, tc7_cxr); - NEWCELL(flo0); # ifdef SINGLES + NEWCELL(flo0); CAR(flo0) = tc_flo; FLO(flo0) = 0.0; # else - CDR(flo0) = (SCM)must_malloc(1L*sizeof(double), "real"); + DEFER_INTS; + flo0 = must_malloc_cell(1L*sizeof(double), "real"); REAL(flo0) = 0.0; CAR(flo0) = tc_dblr; + ALLOW_INTS; # endif # ifdef DBL_DIG dblprec = (DBL_DIG > 20) ? 20 : DBL_DIG; |