aboutsummaryrefslogtreecommitdiffstats
path: root/scl.c
diff options
context:
space:
mode:
Diffstat (limited to 'scl.c')
-rw-r--r--scl.c93
1 files changed, 65 insertions, 28 deletions
diff --git a/scl.c b/scl.c
index 8e89bd8..1b4507d 100644
--- a/scl.c
+++ b/scl.c
@@ -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;