diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-03-14 06:42:56 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-03-14 06:42:56 +0000 |
commit | bc86da5de2a7c9ceee81c334c32d24298ab31d9b (patch) | |
tree | ad490af037a8a106735437e1bacb87cccf956846 /libguile/unif.c | |
parent | 1b88bf8a84374c123dca397c34f49db277af63b0 (diff) | |
download | guile-bc86da5de2a7c9ceee81c334c32d24298ab31d9b.tar.gz |
* __scm.h eq.c, eval.c, gc.c, hc.h, gh_data, hash.c, numbers.c,
numbers.h, objects.c, ramap.c, random.c, unif.c, unif.h: Extensive
rewrite of handling of real and complex numbers.
(SCM_FLOATS, SCM_SINGLES): These #ifdef conditionals have been
removed along with the support for floats. (Float vectors are
still supported.)
* unif.c (scm_makflo): Removed.
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 205 |
1 files changed, 58 insertions, 147 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index a6995dd41..e15e242c2 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998, 2000 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 @@ -114,12 +114,9 @@ scm_uniform_element_size (SCM obj) break; #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: result = sizeof (float); break; -#endif case scm_tc7_dvect: result = sizeof (double); @@ -128,7 +125,6 @@ scm_uniform_element_size (SCM obj) case scm_tc7_cvect: result = 2 * sizeof (double); break; -#endif default: result = 0; @@ -136,27 +132,21 @@ scm_uniform_element_size (SCM obj) return result; } - -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - - -SCM -scm_makflo (float x) +/* Silly function used not to modify the semantics of the silly + * prototype system in order to be backward compatible. + */ +static int +singp (SCM obj) { - SCM z; - if (x == 0.0) - return scm_flo0; - SCM_NEWCELL (z); - SCM_DEFER_INTS; - SCM_SETCAR (z, scm_tc_flo); - SCM_FLO (z) = x; - SCM_ALLOW_INTS; - return z; + if (!SCM_SLOPPY_REALP (obj)) + return 0; + else + { + double x = SCM_REAL_VALUE (obj); + float fx = x; + return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x); + } } -#endif -#endif - SCM scm_make_uve (long k, SCM prot) @@ -209,21 +199,15 @@ scm_make_uve (long k, SCM prot) } } else -#ifdef SCM_FLOATS if (SCM_IMP (prot) || !SCM_INEXP (prot)) -#endif /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED); -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES - else if (SCM_SINGP (prot)) - + else if (singp (prot)) { i = sizeof (float) * k; type = scm_tc7_fvect; } -#endif else if (SCM_CPLXP (prot)) { i = 2 * sizeof (double) * k; @@ -234,7 +218,6 @@ scm_make_uve (long k, SCM prot) i = sizeof (double) * k; type = scm_tc7_dvect; } -#endif SCM_NEWCELL (v); SCM_DEFER_INTS; @@ -327,16 +310,12 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, && (1 == SCM_LENGTH (prot)) && ('s' == SCM_CHARS (prot)[0]); #endif -# ifdef SCM_FLOATS -# ifdef SCM_SINGLES case scm_tc7_fvect: - protp = SCM_SINGP(prot); -# endif + protp = singp (prot); case scm_tc7_dvect: protp = SCM_REALP(prot); case scm_tc7_cvect: protp = SCM_CPLXP(prot); -# endif case scm_tc7_vector: case scm_tc7_wvect: protp = SCM_NULLP(prot); @@ -1123,16 +1102,10 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else case scm_tc7_uvect: return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]); case scm_tc7_ivect: return scm_long2num((long) SCM_VELTS(v)[pos]); -# endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); @@ -1141,17 +1114,13 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif + return scm_make_real (((float *) SCM_CDR (v))[pos]); case scm_tc7_dvect: - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); + return scm_make_real (((double *) SCM_CDR (v))[pos]); case scm_tc7_cvect: - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif + return scm_make_complex (((double *) SCM_CDR (v))[2 * pos], + ((double *) SCM_CDR (v))[2 * pos + 1]); case scm_tc7_vector: case scm_tc7_wvect: return SCM_VELTS (v)[pos]; @@ -1178,53 +1147,39 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) return SCM_MAKE_CHAR (SCM_UCHARS (v)[pos]); case scm_tc7_byvect: return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]); -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - return SCM_MAKINUM (SCM_VELTS (v)[pos]); -# else case scm_tc7_uvect: return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]); case scm_tc7_ivect: return scm_long2num((long) SCM_VELTS(v)[pos]); -# endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); #ifdef HAVE_LONG_LONGS case scm_tc7_llvect: return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]); #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_UNPACK_CAR (last))) + if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last)) { - SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; + SCM_REAL_VALUE (last) = ((float *) SCM_CDR (v))[pos]; return last; } - return scm_makflo (((float *) SCM_CDR (v))[pos]); -#endif + return scm_make_real (((float *) SCM_CDR (v))[pos]); case scm_tc7_dvect: -#ifdef SCM_SINGLES - if (SCM_NIMP (last) && scm_tc_dblr == SCM_UNPACK_CAR (last)) -#else - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) -#endif + if (SCM_NIMP (last) && last != scm_flo0 && SCM_SLOPPY_REALP (last)) { - SCM_REAL (last) = ((double *) SCM_CDR (v))[pos]; + SCM_REAL_VALUE (last) = ((double *) SCM_CDR (v))[pos]; return last; } - return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); + return scm_make_real (((double *) SCM_CDR (v))[pos]); case scm_tc7_cvect: - if (SCM_NIMP (last) && scm_tc_dblc == SCM_UNPACK_CAR (last)) + if (SCM_NIMP (last) && SCM_SLOPPY_COMPLEXP (last)) { - SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; - SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; + SCM_COMPLEX_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; + SCM_COMPLEX_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; return last; } - return scm_makdbl (((double *) SCM_CDR (v))[2 * pos], - ((double *) SCM_CDR (v))[2 * pos + 1]); -#endif + return scm_make_complex (((double *) SCM_CDR (v))[2 * pos], + ((double *) SCM_CDR (v))[2 * pos + 1]); case scm_tc7_vector: case scm_tc7_wvect: return SCM_VELTS (v)[pos]; @@ -1307,21 +1262,12 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, SCM_ASRTGO (SCM_INUMP (obj), badobj); ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj); break; -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj); - /* fall through */ - case scm_tc7_ivect: - SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); - break; -# else case scm_tc7_uvect: SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); break; case scm_tc7_ivect: SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME)); break; -# endif case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj); @@ -1333,21 +1279,17 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: - ((float *) SCM_CDR (v))[pos] = (float)scm_num2dbl(obj, FUNC_NAME); break; + ((float *) SCM_CDR (v))[pos] = (float) scm_num2dbl (obj, FUNC_NAME); break; -#endif case scm_tc7_dvect: - ((double *) SCM_CDR (v))[pos] = scm_num2dbl(obj, FUNC_NAME); break; + ((double *) SCM_CDR (v))[pos] = scm_num2dbl (obj, FUNC_NAME); break; case scm_tc7_cvect: SCM_ASRTGO (SCM_INEXP (obj), badobj); ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj); ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0; break; -#endif case scm_tc7_vector: case scm_tc7_wvect: SCM_VELTS (v)[pos] = obj; @@ -1530,19 +1472,15 @@ loop: sz = sizeof (long_long); break; #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: sz = sizeof (float); break; -#endif case scm_tc7_dvect: sz = sizeof (double); break; case scm_tc7_cvect: sz = 2 * sizeof (double); break; -#endif } cend = vlen; @@ -1684,19 +1622,15 @@ loop: sz = sizeof (long_long); break; #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: sz = sizeof (float); break; -#endif case scm_tc7_dvect: sz = sizeof (double); break; case scm_tc7_cvect: sz = 2 * sizeof (double); break; -#endif } cend = vlen; @@ -2098,16 +2032,6 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); return res; } -# ifdef SCM_INUMS_ONLY - case scm_tc7_uvect: - case scm_tc7_ivect: - { - long *data = (long *) SCM_VELTS (v); - for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (SCM_MAKINUM (data[k]), res); - return res; - } -# else case scm_tc7_uvect: { long *data = (long *)SCM_VELTS(v); for (k = SCM_LENGTH(v) - 1; k >= 0; k--) @@ -2120,7 +2044,6 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons(scm_long2num(data[k]), res); return res; } -# endif case scm_tc7_svect: { short *data; data = (short *)SCM_VELTS(v); @@ -2139,16 +2062,13 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: { float *data = (float *) SCM_VELTS (v); for (k = SCM_LENGTH (v) - 1; k >= 0; k--) - res = scm_cons (scm_makflo (data[k]), res); + res = scm_cons (scm_make_real (data[k]), res); return res; } -#endif /*SCM_SINGLES*/ case scm_tc7_dvect: { double *data = (double *) SCM_VELTS (v); @@ -2163,7 +2083,6 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res); return res; } -#endif /*SCM_FLOATS*/ } } #undef FUNC_NAME @@ -2378,54 +2297,54 @@ tail: } break; -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: if (n-- > 0) { - SCM z = scm_makflo (1.0); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); + SCM z = scm_make_real (1.0); + SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j]; + scm_print_real (z, port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); + SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j]; + scm_print_real (z, port, pstate); } } break; -#endif /*SCM_SINGLES*/ case scm_tc7_dvect: if (n-- > 0) { - SCM z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); + SCM z = scm_make_real (1.0 / 3.0); + SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j]; + scm_print_real (z, port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j]; - scm_floprint (z, port, pstate); + SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j]; + scm_print_real (z, port, pstate); } } break; case scm_tc7_cvect: if (n-- > 0) { - SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0); - SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]); - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); + SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0); + SCM_REAL_VALUE (z) = + SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; + SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; + scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz), + port, pstate); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; - SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; - scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate); + SCM_REAL_VALUE (z) + = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j]; + SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1]; + scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz), + port, pstate); } } break; -#endif /*SCM_FLOATS*/ } } @@ -2508,19 +2427,15 @@ tail: scm_putc ('l', port); break; #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: scm_putc ('s', port); break; -#endif /*SCM_SINGLES*/ case scm_tc7_dvect: scm_putc ('i', port); break; case scm_tc7_cvect: scm_putc ('c', port); break; -#endif /*SCM_FLOATS*/ } scm_putc ('(', port); rapr1 (exp, base, 0, port, pstate); @@ -2568,16 +2483,12 @@ loop: case scm_tc7_llvect: return SCM_CDR (scm_intern ("l", 1)); #endif -#ifdef SCM_FLOATS -#ifdef SCM_SINGLES case scm_tc7_fvect: - return scm_makflo (1.0); -#endif + return scm_make_real (1.0); case scm_tc7_dvect: - return scm_makdbl (1.0 / 3.0, 0.0); + return scm_make_real (1.0 / 3.0); case scm_tc7_cvect: - return scm_makdbl (0.0, 1.0); -#endif + return scm_make_complex (0.0, 1.0); } } #undef FUNC_NAME |