X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3ea39242b84a4b29fa85ed1d876468287fae3007..7888309be8638cb5b75db163383a3d977bd9769d:/libguile/unif.c diff --git a/libguile/unif.c b/libguile/unif.c index 7fc950f20..5268062da 100644 --- a/libguile/unif.c +++ b/libguile/unif.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public @@ -72,6 +72,7 @@ */ scm_t_bits scm_tc16_array; +static SCM exactly_one_third; /* return the size of an element in a uniform array or 0 if type not found. */ @@ -136,44 +137,47 @@ singp (SCM obj) } } +static SCM +make_uve (long type, long k, size_t size) +#define FUNC_NAME "scm_make_uve" +{ + SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); + + return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type), + (scm_t_bits) scm_gc_malloc (k * size, "vector")); +} +#undef FUNC_NAME + SCM scm_make_uve (long k, SCM prot) #define FUNC_NAME "scm_make_uve" { - SCM v; - long i, type; - if (SCM_EQ_P (prot, SCM_BOOL_T)) { if (k > 0) { + long i; SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH); i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT); - v = scm_cell (SCM_MAKE_BITVECTOR_TAG (k), - (scm_t_bits) scm_gc_malloc (i, "vector")); + return scm_cell (SCM_MAKE_BITVECTOR_TAG (k), + (scm_t_bits) scm_gc_malloc (i, "vector")); } else - v = scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); - return v; + return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0); } else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0')) - { - i = sizeof (char) * k; - type = scm_tc7_byvect; - } + return make_uve (scm_tc7_byvect, k, sizeof (char)); else if (SCM_CHARP (prot)) - { - i = sizeof (char) * k; - return scm_allocate_string (i); - } + return scm_allocate_string (sizeof (char) * k); else if (SCM_INUMP (prot)) + return make_uve (SCM_INUM (prot) > 0 ? scm_tc7_uvect : scm_tc7_ivect, + k, + sizeof (long)); + else if (SCM_FRACTIONP (prot)) { - i = sizeof (long) * k; - if (SCM_INUM (prot) > 0) - type = scm_tc7_uvect; - else - type = scm_tc7_ivect; + if (scm_num_eq_p (exactly_one_third, prot)) + goto dvect; } else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot))) { @@ -181,50 +185,27 @@ scm_make_uve (long k, SCM prot) s = SCM_SYMBOL_CHARS (prot)[0]; if (s == 's') - { - i = sizeof (short) * k; - type = scm_tc7_svect; - } + return make_uve (scm_tc7_svect, k, sizeof (short)); #if SCM_SIZEOF_LONG_LONG != 0 else if (s == 'l') - { - i = sizeof (long long) * k; - type = scm_tc7_llvect; - } + return make_uve (scm_tc7_llvect, k, sizeof (long long)); #endif else - { - return scm_c_make_vector (k, SCM_UNDEFINED); - } + return scm_c_make_vector (k, SCM_UNDEFINED); } else if (!SCM_INEXACTP (prot)) /* Huge non-unif vectors are NOT supported. */ /* no special scm_vector */ return scm_c_make_vector (k, SCM_UNDEFINED); else if (singp (prot)) - { - i = sizeof (float) * k; - type = scm_tc7_fvect; - } + return make_uve (scm_tc7_fvect, k, sizeof (float)); else if (SCM_COMPLEXP (prot)) - { - i = 2 * sizeof (double) * k; - type = scm_tc7_cvect; - } - else - { - i = sizeof (double) * k; - type = scm_tc7_dvect; - } - - SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH); - - return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type), - (scm_t_bits) scm_gc_malloc (i, "vector")); + return make_uve (scm_tc7_cvect, k, 2 * sizeof (double)); + dvect: + return make_uve (scm_tc7_dvect, k, sizeof (double)); } #undef FUNC_NAME - SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, (SCM v), "Return the number of elements in @var{uve}.") @@ -282,7 +263,7 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, v = SCM_ARRAY_V (v); } if (nprot) - return SCM_BOOL(nprot); + return scm_from_bool(nprot); else { int protp = 0; @@ -291,39 +272,51 @@ SCM_DEFINE (scm_array_p, "array?", 1, 1, 0, { case scm_tc7_bvect: protp = (SCM_EQ_P (prot, SCM_BOOL_T)); + break; case scm_tc7_string: protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0'); + break; case scm_tc7_byvect: protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0')); + break; case scm_tc7_uvect: protp = SCM_INUMP(prot) && SCM_INUM(prot)>0; + break; case scm_tc7_ivect: protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0; - + break; case scm_tc7_svect: protp = SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)) && ('s' == SCM_SYMBOL_CHARS (prot)[0]); + break; #if SCM_SIZEOF_LONG_LONG != 0 case scm_tc7_llvect: protp = SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)) - && ('s' == SCM_SYMBOL_CHARS (prot)[0]); + && ('l' == SCM_SYMBOL_CHARS (prot)[0]); + break; #endif case scm_tc7_fvect: protp = singp (prot); + break; case scm_tc7_dvect: - protp = SCM_REALP(prot); + protp = ((SCM_REALP(prot) && ! singp (prot)) + || (SCM_FRACTIONP (prot) + && scm_num_eq_p (exactly_one_third, prot))); + break; case scm_tc7_cvect: protp = SCM_COMPLEXP(prot); + break; case scm_tc7_vector: case scm_tc7_wvect: protp = SCM_NULLP(prot); + break; default: /* no default */ ; } - return SCM_BOOL(protp); + return scm_from_bool(protp); } } #undef FUNC_NAME @@ -473,7 +466,7 @@ scm_aind (SCM ra, SCM args, const char *what) scm_error_num_args_subr (what); return pos + (SCM_INUM (args) - s->lbnd) * (s->inc); } - while (k && !SCM_NULLP (args)) + while (k && SCM_CONSP (args)) { ind = SCM_CAR (args); args = SCM_CDR (args); @@ -1045,7 +1038,7 @@ tail: { unsigned long int length = SCM_INUM (scm_uniform_vector_length (v)); SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna); - return SCM_BOOL(pos >= 0 && pos < length); + return scm_from_bool(pos >= 0 && pos < length); } } } @@ -1276,7 +1269,7 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, case scm_tc7_smob: /* enclosed */ goto badarg1; case scm_tc7_bvect: - if (SCM_FALSEP (obj)) + if (scm_is_false (obj)) SCM_BITVEC_CLR(v, pos); else if (SCM_EQ_P (obj, SCM_BOOL_T)) SCM_BITVEC_SET(v, pos); @@ -1769,7 +1762,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, unsigned long int count = 0; unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT; unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); - if (SCM_FALSEP (b)) { + if (scm_is_false (b)) { w = ~w; }; w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT); @@ -1783,7 +1776,7 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, } else { --i; w = SCM_UNPACK (SCM_VELTS (bitvector)[i]); - if (SCM_FALSEP (b)) { + if (scm_is_false (b)) { w = ~w; } } @@ -1795,9 +1788,15 @@ SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0, SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, (SCM item, SCM v, SCM k), - "Return the minimum index of an occurrence of @var{bool} in\n" - "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n" - "within the specified range @code{#f} is returned.") + "Return the index of the first occurrance of @var{item} in bit\n" + "vector @var{v}, starting from @var{k}. If there is no\n" + "@var{item} entry between @var{k} and the end of\n" + "@var{bitvector}, then return @code{#f}. For example,\n" + "\n" + "@example\n" + "(bit-position #t #*000101 0) @result{} 3\n" + "(bit-position #f #*0001111 3) @result{} #f\n" + "@end example") #define FUNC_NAME s_scm_bit_position { long i, lenw, xbits, pos; @@ -1814,7 +1813,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */ i = pos / SCM_LONG_BIT; w = SCM_UNPACK (SCM_VELTS (v)[i]); - if (SCM_FALSEP (item)) + if (scm_is_false (item)) w = ~w; xbits = (pos % SCM_LONG_BIT); pos -= xbits; @@ -1848,7 +1847,7 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, break; pos += SCM_LONG_BIT; w = SCM_UNPACK (SCM_VELTS (v)[i]); - if (SCM_FALSEP (item)) + if (scm_is_false (item)) w = ~w; } return SCM_BOOL_F; @@ -1858,14 +1857,32 @@ SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0, SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, (SCM v, SCM kv, SCM obj), - "If uve is a bit-vector @var{bv} and uve must be of the same\n" - "length. If @var{bool} is @code{#t}, uve is OR'ed into\n" - "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n" - "AND'ed into @var{bv}.\n\n" - "If uve is a unsigned long integer vector all the elements of uve\n" - "must be between 0 and the @code{length} of @var{bv}. The bits\n" - "of @var{bv} corresponding to the indexes in uve are set to\n" - "@var{bool}. The return value is unspecified.") + "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n" + "selecting the entries to change. The return value is\n" + "unspecified.\n" + "\n" + "If @var{kv} is a bit vector, then those entries where it has\n" + "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n" + "@var{kv} and @var{v} must be the same length. When @var{obj}\n" + "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n" + "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n" + "\n" + "@example\n" + "(define bv #*01000010)\n" + "(bit-set*! bv #*10010001 #t)\n" + "bv\n" + "@result{} #*11010011\n" + "@end example\n" + "\n" + "If @var{kv} is a uniform vector of unsigned long integers, then\n" + "they're indexes into @var{v} which are set to @var{obj}.\n" + "\n" + "@example\n" + "(define bv #*01000010)\n" + "(bit-set*! bv #u(5 2 7) #t)\n" + "bv\n" + "@result{} #*01100111\n" + "@end example") #define FUNC_NAME s_scm_bit_set_star_x { register long i, k, vlen; @@ -1877,7 +1894,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, badarg2:SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); - if (SCM_FALSEP (obj)) + if (scm_is_false (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); @@ -1898,7 +1915,7 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, break; case scm_tc7_bvect: SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); - if (SCM_FALSEP (obj)) + if (scm_is_false (obj)) for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;) SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k]; else if (SCM_EQ_P (obj, SCM_BOOL_T)) @@ -1915,11 +1932,23 @@ SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0, SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, (SCM v, SCM kv, SCM obj), - "Return\n" - "@lisp\n" - "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n" - "@end lisp\n" - "@var{bv} is not modified.") + "Return a count of how many entries in bit vector @var{v} are\n" + "equal to @var{obj}, with @var{kv} selecting the entries to\n" + "consider.\n" + "\n" + "If @var{kv} is a bit vector, then those entries where it has\n" + "@code{#t} are the ones in @var{v} which are considered.\n" + "@var{kv} and @var{v} must be the same length.\n" + "\n" + "If @var{kv} is a uniform vector of unsigned long integers, then\n" + "it's the indexes in @var{v} to consider.\n" + "\n" + "For example,\n" + "\n" + "@example\n" + "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n" + "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n" + "@end example") #define FUNC_NAME s_scm_bit_count_star { register long i, vlen, count = 0; @@ -1935,7 +1964,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, SCM_WRONG_TYPE_ARG (2, kv); case scm_tc7_uvect: vlen = SCM_BITVECTOR_LENGTH (v); - if (SCM_FALSEP (obj)) + if (scm_is_false (obj)) for (i = SCM_UVECTOR_LENGTH (kv); i;) { k = SCM_UNPACK (SCM_VELTS (kv)[--i]); @@ -1960,7 +1989,7 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME); if (0 == SCM_BITVECTOR_LENGTH (v)) return SCM_INUM0; - SCM_ASRTGO (SCM_BOOLP (obj), badarg3); + SCM_ASRTGO (scm_is_bool (obj), badarg3); fObj = SCM_EQ_P (obj, SCM_BOOL_T); i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i])); @@ -1983,7 +2012,8 @@ SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0, SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0, (SCM v), - "Modify @var{bv} by replacing each element with its negation.") + "Modify the bit vector @var{v} by replacing each element with\n" + "its negation.") #define FUNC_NAME s_scm_bit_invert_x { long int k; @@ -2086,9 +2116,9 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0, register unsigned long mask; for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--) for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); + res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res); for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1) - res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res); + res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res); return res; } case scm_tc7_byvect: @@ -2552,7 +2582,7 @@ loop: case scm_tc7_fvect: return scm_make_real (1.0); case scm_tc7_dvect: - return scm_make_real (1.0 / 3.0); + return exactly_one_third; case scm_tc7_cvect: return scm_make_complex (0.0, 1.0); } @@ -2585,6 +2615,8 @@ scm_init_unif () scm_set_smob_free (scm_tc16_array, array_free); scm_set_smob_print (scm_tc16_array, scm_raprin1); scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p); + exactly_one_third = scm_permanent_object (scm_make_ratio (SCM_MAKINUM (1), + SCM_MAKINUM (3))); scm_add_feature ("array"); #include "libguile/unif.x" }