mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 23:00:22 +02:00
Code Activity

More distinguished handling of real and complex values.

Browse source
This commit is contained in:
Dirk Herrmann 2000-05-10 12:34:43 +00:00
parent 7235ee58f5
commit eb42e2f03a
8 changed files with 52 additions and 27 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/ChangeLog
View file

@ -1,3 +1,17 @@
2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* eq.c (scm_eqv_p): Separate handling of real and complex
values. Remove #ifdef SCM_BIGDIG #endif test.
* eval.c (SCM_CEVAL, SCM_APPLY), gh_data.c (gh_scm2floats,
gh_scm2doubles), hash.c (scm_hasher), ramap.c (scm_array_fill_int,
ramap_rp, scm_array_map_x), random.c (vector_scale,
vector_sum_squares), unif.c (scm_make_uve, scm_array_p,
scm_array_set_x): Use SCM_REAL_VALUE instead of SCM_REALPART if
the object is known to be real. Use SCM_COMPLEXP instead of
deprecated SCM_CPLXP. Use SCM_INEXACTP instead of deprecated
SCM_INEXP.
2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de> 2000-05-10 Dirk Herrmann <D.Herrmann@tu-bs.de>
* numbers.c: No need to include unif.h. * numbers.c: No need to include unif.h.

13
libguile/eq.c
View file

@ -104,13 +104,14 @@ SCM_DEFINE1 (scm_eqv_p, "eqv?", scm_tc7_rpsubr,
} }
if (SCM_NUMP (x)) if (SCM_NUMP (x))
{ {
# ifdef SCM_BIGDIG if (SCM_BIGP (x)) {
if (SCM_BIGP (x))
return SCM_BOOL (0 == scm_bigcomp (x, y)); return SCM_BOOL (0 == scm_bigcomp (x, y));
# endif } else if (SCM_SLOPPY_REALP (x)) {
if (SCM_REALPART (x) != SCM_REALPART(y)) return SCM_BOOL_F; return SCM_BOOL (SCM_REAL_VALUE (x) == SCM_REAL_VALUE (y));
if (SCM_CPLXP(x) && (SCM_IMAG(x) != SCM_IMAG(y))) return SCM_BOOL_F; } else { /* complex */
return SCM_BOOL_T; return SCM_BOOL (SCM_COMPLEX_REAL (x) == SCM_COMPLEX_REAL (y)
&& SCM_COMPLEX_IMAG (x) == SCM_COMPLEX_IMAG (y));
}
} }
return SCM_BOOL_F; return SCM_BOOL_F;
} }

4
libguile/eval.c
View file

@ -2739,7 +2739,7 @@ evapply:
SCM_ASRTGO (SCM_NIMP (t.arg1), floerr); SCM_ASRTGO (SCM_NIMP (t.arg1), floerr);
if (SCM_REALP (t.arg1)) if (SCM_REALP (t.arg1))
{ {
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REALPART (t.arg1)))); RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (t.arg1))));
} }
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
if (SCM_BIGP (t.arg1)) if (SCM_BIGP (t.arg1))
@ -3335,7 +3335,7 @@ tail:
SCM_ASRTGO (SCM_NIMP (arg1), floerr); SCM_ASRTGO (SCM_NIMP (arg1), floerr);
if (SCM_REALP (arg1)) if (SCM_REALP (arg1))
{ {
RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REALPART (arg1)))); RETURN (scm_make_real (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1))));
} }
#ifdef SCM_BIGDIG #ifdef SCM_BIGDIG
if (SCM_BIGP (arg1)) if (SCM_BIGP (arg1))

4
libguile/gh_data.c
View file

@ -422,7 +422,7 @@ gh_scm2floats (SCM obj, float *m)
else if (SCM_BIGP (val)) else if (SCM_BIGP (val))
m[i] = scm_num2long (val, 0, 0); m[i] = scm_num2long (val, 0, 0);
else else
m[i] = SCM_REALPART (val); m[i] = SCM_REAL_VALUE (val);
} }
break; break;
#ifdef HAVE_ARRAYS #ifdef HAVE_ARRAYS
@ -478,7 +478,7 @@ gh_scm2doubles (SCM obj, double *m)
else if (SCM_BIGP (val)) else if (SCM_BIGP (val))
m[i] = scm_num2long (val, 0, 0); m[i] = scm_num2long (val, 0, 0);
else else
m[i] = SCM_REALPART (val); m[i] = SCM_REAL_VALUE (val);
} }
break; break;
#ifdef HAVE_ARRAYS #ifdef HAVE_ARRAYS

2
libguile/hash.c
View file

@ -106,7 +106,7 @@ scm_hasher(SCM obj, unsigned long n, scm_sizet d)
return 263 % n; return 263 % n;
case scm_tc16_real: case scm_tc16_real:
{ {
double r = SCM_REALPART(obj); double r = SCM_REAL_VALUE(obj);
if (floor(r)==r) { if (floor(r)==r) {
obj = scm_inexact_to_exact (obj); obj = scm_inexact_to_exact (obj);
if SCM_IMP(obj) return SCM_INUM(obj) % n; if SCM_IMP(obj) return SCM_INUM(obj) % n;

21
libguile/ramap.c
View file

@ -585,7 +585,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
{ /* scope */ { /* scope */
float f, *ve = (float *) SCM_VELTS (ra); float f, *ve = (float *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_REALP (fill), badarg2); SCM_ASRTGO (SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill); f = SCM_REAL_VALUE (fill);
for (i = base; n--; i += inc) for (i = base; n--; i += inc)
ve[i] = f; ve[i] = f;
break; break;
@ -594,7 +594,7 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
{ /* scope */ { /* scope */
double f, *ve = (double *) SCM_VELTS (ra); double f, *ve = (double *) SCM_VELTS (ra);
SCM_ASRTGO (SCM_REALP (fill), badarg2); SCM_ASRTGO (SCM_REALP (fill), badarg2);
f = SCM_REALPART (fill); f = SCM_REAL_VALUE (fill);
for (i = base; n--; i += inc) for (i = base; n--; i += inc)
ve[i] = f; ve[i] = f;
break; break;
@ -603,9 +603,14 @@ scm_array_fill_int (SCM ra, SCM fill, SCM ignore)
{ /* scope */ { /* scope */
double fr, fi; double fr, fi;
double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra); double (*ve)[2] = (double (*)[2]) SCM_VELTS (ra);
SCM_ASRTGO (SCM_INEXP (fill), badarg2); SCM_ASRTGO (SCM_INEXACTP (fill), badarg2);
fr = SCM_REALPART (fill); if (SCM_REALP (fill)) {
fi = (SCM_CPLXP (fill) ? SCM_IMAG (fill) : 0.0); fr = SCM_REAL_VALUE (fill);
fi = 0.0;
} else {
fr = SCM_COMPLEX_REAL (fill);
fi = SCM_COMPLEX_IMAG (fill);
}
for (i = base; n--; i += inc) for (i = base; n--; i += inc)
{ {
ve[i][0] = fr; ve[i][0] = fr;
@ -1365,8 +1370,8 @@ ramap_rp (SCM ra0,SCM proc,SCM ras)
for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2) for (; n-- > 0; i0 += inc0, i1 += inc1, i2 += inc2)
if (SCM_BITVEC_REF (ra0, i0)) if (SCM_BITVEC_REF (ra0, i0))
{ {
SCM_REAL (a1) = ((double *) SCM_VELTS (ra1))[i1]; SCM_REAL_VALUE (a1) = ((double *) SCM_VELTS (ra1))[i1];
SCM_REAL (a2) = ((double *) SCM_VELTS (ra2))[i2]; SCM_REAL_VALUE (a2) = ((double *) SCM_VELTS (ra2))[i2];
if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2))) if (SCM_FALSEP (SCM_SUBRF (proc) (a1, a2)))
SCM_BITVEC_CLR (ra0, i0); SCM_BITVEC_CLR (ra0, i0);
} }
@ -1550,7 +1555,7 @@ SCM_DEFINE (scm_array_map_x, "array-map!", 2, 0, 1,
if (SCM_INUMP(fill)) if (SCM_INUMP(fill))
{ {
prot = scm_array_prototype (ra0); prot = scm_array_prototype (ra0);
if (SCM_INEXP (prot)) if (SCM_INEXACTP (prot))
fill = scm_make_real ((double) SCM_INUM (fill)); fill = scm_make_real ((double) SCM_INUM (fill));
} }

4
libguile/random.c
View file

@ -447,7 +447,7 @@ vector_scale (SCM v, double c)
int n = SCM_LENGTH (v); int n = SCM_LENGTH (v);
if (SCM_VECTORP (v)) if (SCM_VECTORP (v))
while (--n >= 0) while (--n >= 0)
SCM_REAL (SCM_VELTS (v)[n]) *= c; SCM_REAL_VALUE (SCM_VELTS (v)[n]) *= c;
else else
while (--n >= 0) while (--n >= 0)
((double *) SCM_VELTS (v))[n] *= c; ((double *) SCM_VELTS (v))[n] *= c;
@ -461,7 +461,7 @@ vector_sum_squares (SCM v)
if (SCM_VECTORP (v)) if (SCM_VECTORP (v))
while (--n >= 0) while (--n >= 0)
{ {
x = SCM_REAL (SCM_VELTS (v)[n]); x = SCM_REAL_VALUE (SCM_VELTS (v)[n]);
sum += x * x; sum += x * x;
} }
else else

17
libguile/unif.c
View file

@ -202,7 +202,7 @@ scm_make_uve (long k, SCM prot)
} }
} }
else else
if (SCM_IMP (prot) || !SCM_INEXP (prot)) if (SCM_IMP (prot) || !SCM_INEXACTP (prot))
/* Huge non-unif vectors are NOT supported. */ /* Huge non-unif vectors are NOT supported. */
/* no special scm_vector */ /* no special scm_vector */
return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED);
@ -211,7 +211,7 @@ scm_make_uve (long k, SCM prot)
i = sizeof (float) * k; i = sizeof (float) * k;
type = scm_tc7_fvect; type = scm_tc7_fvect;
} }
else if (SCM_CPLXP (prot)) else if (SCM_COMPLEXP (prot))
{ {
i = 2 * sizeof (double) * k; i = 2 * sizeof (double) * k;
type = scm_tc7_cvect; type = scm_tc7_cvect;
@ -318,7 +318,7 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
case scm_tc7_dvect: case scm_tc7_dvect:
protp = SCM_REALP(prot); protp = SCM_REALP(prot);
case scm_tc7_cvect: case scm_tc7_cvect:
protp = SCM_CPLXP(prot); protp = SCM_COMPLEXP(prot);
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect:
protp = SCM_NULLP(prot); protp = SCM_NULLP(prot);
@ -1332,9 +1332,14 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME); ((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME);
break; break;
case scm_tc7_cvect: case scm_tc7_cvect:
SCM_ASRTGO (SCM_INEXP (obj), badobj); SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_REALPART (obj); if (SCM_REALP (obj)) {
((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; ((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_REAL_VALUE (obj);
((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = 0.0;
} else {
((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
}
break; break;
case scm_tc7_vector: case scm_tc7_vector:
case scm_tc7_wvect: case scm_tc7_wvect: