diff options
Diffstat (limited to 'libguile/unif.c')
-rw-r--r-- | libguile/unif.c | 190 |
1 files changed, 110 insertions, 80 deletions
diff --git a/libguile/unif.c b/libguile/unif.c index 32ff7416a..8af679e95 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -42,6 +42,13 @@ /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999, gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */ +/* + This file has code for arrays in lots of variants (double, integer, + unsigned etc. ). It suffers from hugely repetitive code because + there is similar (but different) code for every variant included. (urg.) + + --hwn +*/ #include <stdio.h> @@ -280,10 +287,9 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, enclosed = 0; if (SCM_IMP (v)) return SCM_BOOL_F; -loop: - switch (SCM_TYP7 (v)) + + while (SCM_TYP7 (v) == scm_tc7_smob) { - case scm_tc7_smob: if (!SCM_ARRAYP (v)) return SCM_BOOL_F; if (nprot) @@ -291,45 +297,55 @@ loop: if (enclosed++) return SCM_BOOL_F; v = SCM_ARRAY_V (v); - goto loop; - case scm_tc7_bvect: - return nprot || SCM_BOOL(SCM_BOOL_T==prot); - case scm_tc7_string: - return nprot || SCM_BOOL(SCM_CHARP(prot) && (prot != SCM_MAKE_CHAR('\0'))); - case scm_tc7_byvect: - return nprot || SCM_BOOL(prot == SCM_MAKE_CHAR('\0')); - case scm_tc7_uvect: - return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)>0); - case scm_tc7_ivect: - return nprot || SCM_BOOL(SCM_INUMP(prot) && SCM_INUM(prot)<=0); - case scm_tc7_svect: - return ( nprot - || (SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); + } + if (nprot) + return SCM_BOOL(nprot); + else + { + int protp = 0; + + switch (SCM_TYP7 (v)) + { + case scm_tc7_bvect: + protp = (SCM_BOOL_T==prot); + case scm_tc7_string: + protp = SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0')); + case scm_tc7_byvect: + protp = prot == SCM_MAKICHR('\0'); + case scm_tc7_uvect: + protp = SCM_INUMP(prot) && SCM_INUM(prot)>0; + case scm_tc7_ivect: + protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0; + + case scm_tc7_svect: + protp = SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]); #ifdef HAVE_LONG_LONGS - case scm_tc7_llvect: - return ( nprot - || (SCM_SYMBOLP (prot) - && (1 == SCM_LENGTH (prot)) - && ('s' == SCM_CHARS (prot)[0]))); + case scm_tc7_llvect: + protp = SCM_SYMBOLP (prot) + && (1 == SCM_LENGTH (prot)) + && ('s' == SCM_CHARS (prot)[0]); #endif # ifdef SCM_FLOATS # ifdef SCM_SINGLES - case scm_tc7_fvect: - return nprot || SCM_BOOL(SCM_SINGP(prot)); + case scm_tc7_fvect: + protp = SCM_SINGP(prot); # endif - case scm_tc7_dvect: - return nprot || SCM_BOOL(SCM_REALP(prot)); - case scm_tc7_cvect: - return nprot || SCM_BOOL(SCM_CPLXP(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: - return nprot || SCM_BOOL(SCM_NULLP(prot)); - default:; + case scm_tc7_vector: + case scm_tc7_wvect: + protp = SCM_NULLP(prot); + default: + /* no default */ + ; + } + return SCM_BOOL(protp); } - return SCM_BOOL_F; } #undef FUNC_NAME @@ -1079,8 +1095,11 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, badarg: SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (SCM_FUNC_NAME); + + outrng: + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: + scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: { /* enclosed */ int k = SCM_ARRAY_NDIM (v); @@ -1096,7 +1115,7 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return res; } case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + if (SCM_BITVEC_REF (v, pos)) return SCM_BOOL_T; else return SCM_BOOL_F; @@ -1110,9 +1129,9 @@ SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); + return scm_ulong2num((unsigned long ) SCM_VELTS(v)[pos]); case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); + return scm_long2num((long) SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: @@ -1151,7 +1170,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) default: scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref"); case scm_tc7_bvect: - if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT))) + if (SCM_BITVEC_REF(v,pos)) return SCM_BOOL_T; else return SCM_BOOL_F; @@ -1165,9 +1184,9 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) return SCM_MAKINUM (SCM_VELTS (v)[pos]); # else case scm_tc7_uvect: - return scm_ulong2num(SCM_VELTS(v)[pos]); + return scm_ulong2num((unsigned long) SCM_VELTS(v)[pos]); case scm_tc7_ivect: - return scm_long2num(SCM_VELTS(v)[pos]); + return scm_long2num((long) SCM_VELTS(v)[pos]); # endif case scm_tc7_svect: return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]); @@ -1178,7 +1197,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) #ifdef SCM_FLOATS #ifdef SCM_SINGLES case scm_tc7_fvect: - if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last))) + if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CARW (last))) { SCM_FLO (last) = ((float *) SCM_CDR (v))[pos]; return last; @@ -1187,7 +1206,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) #endif case scm_tc7_dvect: #ifdef SCM_SINGLES - if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last)) + if (SCM_NIMP (last) && scm_tc_dblr == SCM_CARW (last)) #else if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last))) #endif @@ -1197,7 +1216,7 @@ scm_cvref (SCM v, scm_sizet pos, SCM last) } return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0); case scm_tc7_cvect: - if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last)) + if (SCM_NIMP (last) && scm_tc_dblc == SCM_CARW (last)) { SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos]; SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1]; @@ -1264,15 +1283,17 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, default: badarg1: SCM_WTA (1,v); abort (); - outrng:scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); - wna: scm_wrong_num_args (SCM_FUNC_NAME); + outrng: + scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos)); + wna: + scm_wrong_num_args (SCM_FUNC_NAME); case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: if (SCM_BOOL_F == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT)); + SCM_BITVEC_CLR(v,pos); else if (SCM_BOOL_T == obj) - SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT)); + SCM_BITVEC_SET(v,pos); else badobj:SCM_WTA (2,obj); break; @@ -1291,12 +1312,15 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, 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; + SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); + break; # else case scm_tc7_uvect: - SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME); break; + SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME)); + break; case scm_tc7_ivect: - SCM_VELTS(v)[pos] = scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME); break; + SCM_VELTS(v)[pos] = SCM_ASSCM (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME)); + break; # endif case scm_tc7_svect: SCM_ASRTGO (SCM_INUMP (obj), badobj); @@ -1727,7 +1751,8 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, #define FUNC_NAME s_scm_bit_count { long i; - register unsigned long cnt = 0, w; + register unsigned long cnt = 0; + register unsigned long w; SCM_VALIDATE_INUM (2,seq); switch SCM_TYP7 (seq) { @@ -1737,7 +1762,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, if (0 == SCM_LENGTH (seq)) return SCM_INUM0; i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT; - w = SCM_VELTS (seq)[i]; + w = SCM_ASWORD (SCM_VELTS (seq)[i]); if (SCM_FALSEP (item)) w = ~w; w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT); @@ -1747,7 +1772,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, cnt += cnt_tab[w & 0x0f]; if (0 == i--) return SCM_MAKINUM (cnt); - w = SCM_VELTS (seq)[i]; + w = SCM_ASWORD (SCM_VELTS (seq)[i]); if (SCM_FALSEP (item)) w = ~w; } @@ -1780,7 +1805,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, return SCM_MAKINUM (-1L); lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ i = pos / SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; + w = SCM_ASWORD (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; xbits = (pos % SCM_LONG_BIT); @@ -1814,7 +1839,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, if (++i > lenw) break; pos += SCM_LONG_BIT; - w = SCM_VELTS (v)[i]; + w = SCM_ASWORD (SCM_VELTS (v)[i]); if (SCM_FALSEP (item)) w = ~w; } @@ -1846,22 +1871,22 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1: SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT)); + SCM_BITVEC_CLR(v,k); } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT)); + SCM_BITVEC_SET(v,k); } else badarg3:SCM_WTA (3,obj); @@ -1871,10 +1896,10 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1); if (SCM_BOOL_F == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]); + SCM_ASWORD (SCM_VELTS (v)[k]) &= ~ SCM_ASWORD(SCM_VELTS (kv)[k]); else if (SCM_BOOL_T == obj) for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k]; + SCM_ASWORD (SCM_VELTS (v)[k]) |= SCM_ASWORD (SCM_VELTS (kv)[k]); else goto badarg3; break; @@ -1895,34 +1920,37 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, { register long i, vlen, count = 0; register unsigned long k; + SCM_ASRTGO (SCM_NIMP (v), badarg1); SCM_ASRTGO (SCM_NIMP (kv), badarg2); switch SCM_TYP7 (kv) { default: - badarg2:SCM_WTA (2,kv); + badarg2: + SCM_WTA (2,kv); case scm_tc7_uvect: switch SCM_TYP7 (v) { default: - badarg1:SCM_WTA (1,v); + badarg1: + SCM_WTA (1,v); case scm_tc7_bvect: vlen = SCM_LENGTH (v); if (SCM_BOOL_F == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))) + if (!SCM_BITVEC_REF(v,k)) count++; } else if (SCM_BOOL_T == obj) for (i = SCM_LENGTH (kv); i;) { - k = SCM_VELTS (kv)[--i]; + k = SCM_ASWORD (SCM_VELTS (kv)[--i]); SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, FUNC_NAME); - if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))) + if (SCM_BITVEC_REF (v,k)) count++; } else @@ -1934,17 +1962,19 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, if (0 == SCM_LENGTH (v)) return SCM_INUM0; SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3); - obj = (SCM_BOOL_T == obj); + obj = (SCM_BOOL_T == obj); /* ugh. */ i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD (SCM_VELTS (v)[i]) : ~ SCM_ASWORD (SCM_VELTS (v)[i])); k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT); - while (!0) + while (1) { for (; k; k >>= 4) count += cnt_tab[k & 0x0f]; if (0 == i--) return SCM_MAKINUM (count); - k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]); + + /* urg. repetitive (see above.) */ + k = SCM_ASWORD (SCM_VELTS (kv)[i]) & (obj ? SCM_ASWORD(SCM_VELTS (v)[i]) : ~SCM_ASWORD (SCM_VELTS (v)[i])); } } return SCM_MAKINUM (count); @@ -1965,7 +1995,7 @@ SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, { case scm_tc7_bvect: for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) - SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k]; + SCM_ASWORD (SCM_VELTS (v)[k]) = ~SCM_ASWORD(SCM_VELTS (v)[k]); break; default: badarg1:SCM_WTA (1,v); @@ -2329,11 +2359,11 @@ tail: } case scm_tc7_ivect: if (n-- > 0) - scm_intprint (SCM_VELTS (ra)[j], 10, port); + scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); for (j += inc; n-- > 0; j += inc) { scm_putc (' ', port); - scm_intprint (SCM_VELTS (ra)[j], 10, port); + scm_intprint ((int)SCM_VELTS (ra)[j], 10, port); } break; @@ -2435,7 +2465,7 @@ tail: scm_putc ('*', port); for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++) { - w = SCM_VELTS (exp)[i]; + SCMWORD w = SCM_ASWORD (SCM_VELTS (exp)[i]); for (j = SCM_LONG_BIT; j; j--) { scm_putc (w & 1 ? '1' : '0', port); @@ -2445,7 +2475,7 @@ tail: j = SCM_LENGTH (exp) % SCM_LONG_BIT; if (j) { - w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]; + w = SCM_ASWORD (SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT]); for (; j; j--) { scm_putc (w & 1 ? '1' : '0', port); |