-/* 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 program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
-/* 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,
*/
\f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
#include <errno.h>
#include <string.h>
#include <unistd.h>
#endif
+#ifdef HAVE_IO_H
+#include <io.h>
+#endif
+
\f
/* The set of uniform scm_vector types is:
* Vector of: Called:
* long long llvect
*/
-scm_bits_t scm_tc16_array;
+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. */
switch (SCM_TYP7 (obj))
{
case scm_tc7_bvect:
- result = sizeof (scm_bits_t);
- break;
case scm_tc7_uvect:
case scm_tc7_ivect:
result = sizeof (long);
result = sizeof (short);
break;
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
result = sizeof (long long);
break;
static int
singp (SCM obj)
{
- if (!SCM_SLOPPY_REALP (obj))
+ if (!SCM_REALP (obj))
return 0;
else
{
}
}
-#if (SIZEOF_SIZE_T < SCM_SIZEOF_BITS_T)
-# define CHECK_BYTE_SIZE(s,k) SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= (size_t)(~(size_t)0))
-#else
-# define CHECK_BYTE_SIZE(s,k)
-#endif
+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 (scm_bits_t k, SCM prot)
+scm_make_uve (long k, SCM prot)
#define FUNC_NAME "scm_make_uve"
{
- SCM v;
- size_t i;
- scm_bits_t type;
- scm_ubits_t size_in_bytes;
-
if (SCM_EQ_P (prot, SCM_BOOL_T))
{
- SCM_NEWCELL (v);
if (k > 0)
{
- SCM_ASSERT_RANGE (1, scm_bits2num (k),
- k <= SCM_BITVECTOR_MAX_LENGTH);
- size_in_bytes = sizeof (scm_bits_t) * ((k + SCM_BITS_LENGTH - 1) /
- SCM_BITS_LENGTH);
- CHECK_BYTE_SIZE (size_in_bytes, k);
- i = (size_t) size_in_bytes;
- SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector"));
- SCM_SET_BITVECTOR_LENGTH (v, k);
+ 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);
+ return scm_cell (SCM_MAKE_BITVECTOR_TAG (k),
+ (scm_t_bits) scm_gc_malloc (i, "vector"));
}
else
- {
- SCM_SET_BITVECTOR_BASE (v, 0);
- SCM_SET_BITVECTOR_LENGTH (v, 0);
- }
- return v;
+ return scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
}
else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
- {
- size_in_bytes = sizeof (char) * k;
- type = scm_tc7_byvect;
- }
+ return make_uve (scm_tc7_byvect, k, sizeof (char));
else if (SCM_CHARP (prot))
- {
- size_in_bytes = sizeof (char) * k;
- CHECK_BYTE_SIZE (size_in_bytes, k);
- i = (size_t) size_in_bytes;
- 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))
{
- size_in_bytes = 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)))
{
s = SCM_SYMBOL_CHARS (prot)[0];
if (s == 's')
- {
- size_in_bytes = sizeof (short) * k;
- type = scm_tc7_svect;
- }
-#ifdef HAVE_LONG_LONGS
+ return make_uve (scm_tc7_svect, k, sizeof (short));
+#if SCM_SIZEOF_LONG_LONG != 0
else if (s == 'l')
- {
- size_in_bytes = 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))
- {
- size_in_bytes = sizeof (float) * k;
- type = scm_tc7_fvect;
- }
+ return make_uve (scm_tc7_fvect, k, sizeof (float));
else if (SCM_COMPLEXP (prot))
- {
- size_in_bytes = 2 * sizeof (double) * k;
- type = scm_tc7_cvect;
- }
- else
- {
- size_in_bytes = sizeof (double) * k;
- type = scm_tc7_dvect;
- }
-
- CHECK_BYTE_SIZE (size_in_bytes, k);
- i = (size_t) size_in_bytes;
-
- SCM_ASSERT_RANGE (1, scm_bits2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
-
- SCM_NEWCELL (v);
- SCM_DEFER_INTS;
- SCM_SET_UVECTOR_BASE (v, (char *) scm_must_malloc (i ? i : 1, "vector"));
- SCM_SET_UVECTOR_LENGTH (v, k, type);
- SCM_ALLOW_INTS;
- return v;
+ 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}.")
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v));
v = SCM_ARRAY_V (v);
}
if (nprot)
- return SCM_BOOL(nprot);
+ return scm_from_bool(nprot);
else
{
int protp = 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]);
-#ifdef HAVE_LONG_LONGS
+ 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
case scm_tc7_fvect:
case scm_tc7_cvect:
case scm_tc7_dvect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
case scm_tc7_svect:
{
SCM res = SCM_EOL;
size_t k;
- scm_array_dim_t *s;
+ scm_t_array_dim *s;
if (SCM_IMP (ra))
return SCM_BOOL_F;
switch (SCM_TYP7 (ra))
case scm_tc7_cvect:
case scm_tc7_dvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
{
SCM res = SCM_EOL;
size_t k;
- scm_array_dim_t *s;
+ scm_t_array_dim *s;
SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
k = SCM_ARRAY_NDIM (ra);
s = SCM_ARRAY_DIMS (ra);
static char s_bad_ind[] = "Bad scm_array index";
-scm_bits_t
+long
scm_aind (SCM ra, SCM args, const char *what)
#define FUNC_NAME what
{
SCM ind;
- register scm_bits_t j;
- register scm_bits_t pos = SCM_ARRAY_BASE (ra);
- register size_t k = SCM_ARRAY_NDIM (ra);
- scm_array_dim_t *s = SCM_ARRAY_DIMS (ra);
+ register long j;
+ register unsigned long pos = SCM_ARRAY_BASE (ra);
+ register unsigned long k = SCM_ARRAY_NDIM (ra);
+ scm_t_array_dim *s = SCM_ARRAY_DIMS (ra);
if (SCM_INUMP (args))
{
if (k != 1)
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);
scm_make_ra (int ndim)
{
SCM ra;
- SCM_NEWCELL (ra);
SCM_DEFER_INTS;
- SCM_NEWSMOB(ra, ((scm_bits_t) ndim << 17) + scm_tc16_array,
- scm_must_malloc ((sizeof (scm_array_t) +
- ndim * sizeof (scm_array_dim_t)),
- "array"));
+ SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array,
+ scm_gc_malloc ((sizeof (scm_t_array) +
+ ndim * sizeof (scm_t_array_dim)),
+ "array"));
SCM_ARRAY_V (ra) = scm_nullvect;
SCM_ALLOW_INTS;
return ra;
SCM
scm_shap2ra (SCM args, const char *what)
{
- scm_array_dim_t *s;
+ scm_t_array_dim *s;
SCM ra, spec, sp;
int ndim = scm_ilength (args);
if (ndim < 0)
SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
(SCM dims, SCM prot, SCM fill),
- "@deffnx primitive make-uniform-vector length prototype [fill]\n"
+ "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
"Create and return a uniform array or vector of type\n"
"corresponding to @var{prototype} with dimensions @var{dims} or\n"
"length @var{length}. If @var{fill} is supplied, it's used to\n"
#define FUNC_NAME s_scm_dimensions_to_uniform_array
{
size_t k;
- scm_bits_t rlen = 1;
- scm_array_dim_t *s;
+ unsigned long rlen = 1;
+ scm_t_array_dim *s;
SCM ra;
if (SCM_INUMP (dims))
while (k--)
{
s[k].inc = rlen;
- SCM_ASSERT_RANGE (1, dims, s[k].inc >= 0);
SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd);
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
}
scm_array_fill_x (ra, prot);
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
- if (s[0].ubnd < s[0].lbnd || (0 == s[0].lbnd && 1 == s[0].inc))
+ if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
return SCM_ARRAY_V (ra);
return ra;
}
size_t k = SCM_ARRAY_NDIM (ra);
if (k)
{
- scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k - 1].inc; /*??*/
+ long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
while (k--)
{
if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
SCM ra;
SCM inds, indptr;
SCM imap;
- size_t k;
- scm_bits_t i;
- scm_bits_t old_min, new_min, old_max, new_max;
- scm_array_dim_t *s;
+ size_t k, i;
+ long old_min, new_min, old_max, new_max;
+ scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (dims);
- SCM_VALIDATE_ARRAY (1,oldra);
- SCM_VALIDATE_PROC (2,mapfunc);
+ SCM_VALIDATE_ARRAY (1, oldra);
+ SCM_VALIDATE_PROC (2, mapfunc);
ra = scm_shap2ra (dims, FUNC_NAME);
if (SCM_ARRAYP (oldra))
{
return ra;
}
}
- imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
if (SCM_ARRAYP (oldra))
- i = scm_aind (oldra, imap, FUNC_NAME);
+ i = (size_t) scm_aind (oldra, imap, FUNC_NAME);
else
{
if (SCM_NINUMP (imap))
if (s[k].ubnd > s[k].lbnd)
{
SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
- imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
+ imap = scm_apply_0 (mapfunc, scm_reverse (inds));
if (SCM_ARRAYP (oldra))
s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i;
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
{
SCM v = SCM_ARRAY_V (ra);
- scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
"@end lisp")
#define FUNC_NAME s_scm_transpose_array
{
- SCM res, vargs, *ve = &vargs;
- scm_array_dim_t *s, *r;
+ SCM res, vargs;
+ SCM const *ve = &vargs;
+ scm_t_array_dim *s, *r;
int ndim, i, k;
SCM_VALIDATE_REST_ARGUMENT (args);
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
#define FUNC_NAME s_scm_enclose_array
{
SCM axv, res, ra_inr;
- scm_array_dim_t vdim, *s = &vdim;
+ scm_t_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
SCM_VALIDATE_REST_ARGUMENT (axes);
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
s->lbnd = 0;
#define FUNC_NAME s_scm_array_in_bounds_p
{
SCM ind = SCM_EOL;
- scm_bits_t pos = 0;
+ long pos = 0;
register size_t k;
- register scm_bits_t j;
- scm_array_dim_t *s;
+ register long j;
+ scm_t_array_dim *s;
SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
case scm_tc7_vector:
case scm_tc7_wvect:
{
- scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
+ 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);
}
}
}
SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
(SCM v, SCM args),
- "@deffnx primitive array-ref v . args\n"
+ "@deffnx {Scheme Procedure} array-ref v . args\n"
"Return the element at the @code{(index1, index2)} element in\n"
"@var{array}.")
#define FUNC_NAME s_scm_uniform_vector_ref
{
- scm_bits_t pos;
+ long pos;
if (SCM_IMP (v))
{
}
else
{
- scm_bits_t length;
+ unsigned long int length;
if (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
}
else
{
- SCM_VALIDATE_INUM (2,args);
+ SCM_VALIDATE_INUM (2, args);
pos = SCM_INUM (args);
}
length = SCM_INUM (scm_uniform_vector_length (v));
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
#endif
tries to recycle conses. (Make *sure* you want them recycled.) */
SCM
-scm_cvref (SCM v, scm_bits_t pos, SCM last)
+scm_cvref (SCM v, unsigned long pos, SCM last)
#define FUNC_NAME "scm_cvref"
{
switch SCM_TYP7 (v)
default:
SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
case scm_tc7_bvect:
- if (SCM_BITVEC_REF(v,pos))
+ if (SCM_BITVEC_REF(v, pos))
return SCM_BOOL_T;
else
return SCM_BOOL_F;
return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
case scm_tc7_svect:
return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
#endif
case scm_tc7_fvect:
- if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
+ if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
{
SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
return last;
}
return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_dvect:
- if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
+ if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
{
SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
return last;
}
return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_cvect:
- if (SCM_NIMP (last) && SCM_SLOPPY_COMPLEXP (last))
+ if (SCM_COMPLEXP (last))
{
SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
PROC is used (and it's called from C too). */
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
(SCM v, SCM obj, SCM args),
- "@deffnx primitive uniform-array-set1! v obj args\n"
- "Sets the element at the @code{(index1, index2)} element in @var{array} to\n"
+ "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
+ "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
"@var{new-value}. The value returned by array-set! is unspecified.")
#define FUNC_NAME s_scm_array_set_x
{
- scm_bits_t pos = 0;
+ long pos = 0;
- SCM_VALIDATE_REST_ARGUMENT (args);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_ARRAYP (v))
{
}
else
{
- scm_bits_t length;
- if (SCM_NIMP (args))
+ unsigned long int length;
+ if (SCM_CONSP (args))
{
- SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
- SCM_ARG3, FUNC_NAME);
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG3, FUNC_NAME);
SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
pos = SCM_INUM (SCM_CAR (args));
}
else
{
- SCM_VALIDATE_INUM_COPY (3,args,pos);
+ SCM_VALIDATE_INUM_COPY (3, args, pos);
}
length = SCM_INUM (scm_uniform_vector_length (v));
SCM_ASRTGO (pos >= 0 && pos < length, outrng);
case scm_tc7_smob: /* enclosed */
goto badarg1;
case scm_tc7_bvect:
- if (SCM_FALSEP (obj))
- SCM_BITVEC_CLR(v,pos);
+ if (scm_is_false (obj))
+ SCM_BITVEC_CLR(v, pos);
else if (SCM_EQ_P (obj, SCM_BOOL_T))
- SCM_BITVEC_SET(v,pos);
+ SCM_BITVEC_SET(v, pos);
else
badobj:SCM_WRONG_TYPE_ARG (2, obj);
break;
((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
break;
case scm_tc7_uvect:
- ((unsigned long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2ulong(obj, SCM_ARG2, FUNC_NAME));
+ ((unsigned long *) SCM_UVECTOR_BASE (v))[pos]
+ = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME);
break;
case scm_tc7_ivect:
- ((long *) SCM_VELTS(v))[pos] = SCM_PACK (scm_num2long (obj, SCM_ARG2, FUNC_NAME));
+ ((long *) SCM_UVECTOR_BASE (v))[pos]
+ = scm_num2long (obj, SCM_ARG2, FUNC_NAME);
break;
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (obj), badobj);
- ((short *) SCM_CELL_WORD_1 (v))[pos] = SCM_INUM (obj);
+ ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
break;
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
- ((long long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
+ ((long long *) SCM_UVECTOR_BASE (v))[pos]
+ = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
break;
#endif
-
-
case scm_tc7_fvect:
- ((float *) SCM_CELL_WORD_1 (v))[pos] = (float) scm_num2dbl (obj, FUNC_NAME);
+ ((float *) SCM_UVECTOR_BASE (v))[pos]
+ = (float) scm_num2dbl (obj, FUNC_NAME);
break;
case scm_tc7_dvect:
- ((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME);
+ ((double *) SCM_UVECTOR_BASE (v))[pos]
+ = scm_num2dbl (obj, FUNC_NAME);
break;
case scm_tc7_cvect:
SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
if (SCM_REALP (obj)) {
- ((double *) SCM_CELL_WORD_1 (v))[2 * pos] = SCM_REAL_VALUE (obj);
- ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1] = 0.0;
+ ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
+ ((double *) SCM_UVECTOR_BASE (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);
+ ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
+ ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
}
break;
case scm_tc7_vector:
case scm_tc7_wvect:
- SCM_VELTS (v)[pos] = obj;
+ SCM_VECTOR_SET (v, pos, obj);
break;
}
return SCM_UNSPECIFIED;
wouldn't have contiguous elements. */
SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
(SCM ra, SCM strict),
- "@deffnx primitive array-contents array strict\n"
"If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
"without changing their order (last subscript changing fastest), then\n"
"@code{array-contents} returns that shared array, otherwise it returns\n"
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
#endif
return ra;
case scm_tc7_smob:
{
- size_t k, ndim = SCM_ARRAY_NDIM (ra);
- scm_bits_t len = 1;
+ size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
return SCM_BOOL_F;
for (k = 0; k < ndim; k++)
if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
{
if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
- SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH ||
- len % SCM_BITS_LENGTH)
+ SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+ len % SCM_LONG_BIT)
return SCM_BOOL_F;
}
}
{
SCM v = SCM_ARRAY_V (ra);
- scm_bits_t length = SCM_INUM (scm_uniform_vector_length (v));
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
return v;
}
scm_ra2contig (SCM ra, int copy)
{
SCM ret;
- scm_bits_t inc = 1;
- size_t k;
- scm_bits_t len = 1;
+ long inc = 1;
+ size_t k, len = 1;
for (k = SCM_ARRAY_NDIM (ra); k--;)
len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
k = SCM_ARRAY_NDIM (ra);
if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
return ra;
if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
- 0 == SCM_ARRAY_BASE (ra) % SCM_BITS_LENGTH &&
- 0 == len % SCM_BITS_LENGTH))
+ 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
+ 0 == len % SCM_LONG_BIT))
return ra;
}
ret = scm_make_ra (k);
SCM_ARRAY_DIMS (ret)[k].inc = inc;
inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
}
- SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
+ SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra));
if (copy)
scm_array_copy_x (ra, ret);
return ret;
SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
(SCM ra, SCM port_or_fd, SCM start, SCM end),
- "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
- "Attempts to read all elements of @var{ura}, in lexicographic order, as\n"
+ "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
+ "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
"binary objects from @var{port-or-fdes}.\n"
- "If an end of file is encountered during\n"
- "uniform-array-read! the objects up to that point only are put into @var{ura}\n"
+ "If an end of file is encountered,\n"
+ "the objects up to that point are put into @var{ura}\n"
"(starting at the beginning) and the remainder of the array is\n"
"unchanged.\n\n"
"The optional arguments @var{start} and @var{end} allow\n"
#define FUNC_NAME s_scm_uniform_array_read_x
{
SCM cra = SCM_UNDEFINED, v = ra;
- int sz;
- scm_bits_t vlen, ans;
- scm_bits_t cstart = 0, cend = 0;
- scm_bits_t offset = 0;
+ long sz, vlen, ans;
+ long cstart = 0;
+ long cend;
+ long offset = 0;
char *base;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
SCM_ASSERT (SCM_INUMP (port_or_fd)
|| (SCM_OPINPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME);
- vlen = SCM_INUM (scm_uniform_vector_length (v));
+ vlen = (SCM_TYP7 (v) == scm_tc7_smob
+ ? 0
+ : SCM_INUM (scm_uniform_vector_length (v)));
loop:
switch SCM_TYP7 (v)
break;
case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
- vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH;
- cstart /= SCM_BITS_LENGTH;
- sz = sizeof (scm_bits_t);
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
+ sz = sizeof (long);
break;
case scm_tc7_byvect:
base = (char *) SCM_UVECTOR_BASE (v);
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short);
break;
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long long);
if (!SCM_UNBNDP (start))
{
offset =
- SCM_NUM2BITS (3, start);
+ SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
- scm_bits_t tend =
- SCM_NUM2BITS (4, end);
+ long tend =
+ SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
scm_out_of_range (FUNC_NAME, end);
if (SCM_NIMP (port_or_fd))
{
- scm_port_t *pt = SCM_PTAB_ENTRY (port_or_fd);
+ scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
int remaining = (cend - offset) * sz;
char *dest = base + (cstart + offset) * sz;
SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_BITS_LENGTH;
+ ans *= SCM_LONG_BIT;
if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
scm_array_copy_x (cra, ra);
SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
(SCM v, SCM port_or_fd, SCM start, SCM end),
- "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
+ "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
"Writes all elements of @var{ura} as binary objects to\n"
"@var{port-or-fdes}.\n\n"
"The optional arguments @var{start}\n"
"and @var{end} allow\n"
"a specified region of a vector (or linearized array) to be written.\n\n"
- "The number of objects actually written is returned. \n"
+ "The number of objects actually written is returned.\n"
"@var{port-or-fdes} may be\n"
"omitted, in which case it defaults to the value returned by\n"
"@code{(current-output-port)}.")
#define FUNC_NAME s_scm_uniform_array_write
{
- int sz;
- scm_bits_t vlen, ans;
- scm_bits_t offset = 0, cstart = 0, cend;
+ long sz, vlen, ans;
+ long offset = 0;
+ long cstart = 0;
+ long cend;
char *base;
port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
SCM_ASSERT (SCM_INUMP (port_or_fd)
|| (SCM_OPOUTPORTP (port_or_fd)),
port_or_fd, SCM_ARG2, FUNC_NAME);
- vlen = SCM_INUM (scm_uniform_vector_length (v));
-
+ vlen = (SCM_TYP7 (v) == scm_tc7_smob
+ ? 0
+ : SCM_INUM (scm_uniform_vector_length (v)));
+
loop:
switch SCM_TYP7 (v)
{
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
v = scm_ra2contig (v, 1);
cstart = SCM_ARRAY_BASE (v);
- vlen = SCM_ARRAY_DIMS (v)->inc
- * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
+ vlen = (SCM_ARRAY_DIMS (v)->inc
+ * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1));
v = SCM_ARRAY_V (v);
goto loop;
case scm_tc7_string:
break;
case scm_tc7_bvect:
base = (char *) SCM_BITVECTOR_BASE (v);
- vlen = (vlen + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH;
- cstart /= SCM_BITS_LENGTH;
- sz = sizeof (scm_bits_t);
+ vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
+ cstart /= SCM_LONG_BIT;
+ sz = sizeof (long);
break;
case scm_tc7_byvect:
base = (char *) SCM_UVECTOR_BASE (v);
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short);
break;
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long long);
if (!SCM_UNBNDP (start))
{
offset =
- SCM_NUM2BITS (3, start);
+ SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
- scm_bits_t tend =
- SCM_NUM2BITS (4, end);
+ long tend =
+ SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
scm_out_of_range (FUNC_NAME, end);
SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
- ans *= SCM_BITS_LENGTH;
+ ans *= SCM_LONG_BIT;
return SCM_MAKINUM (ans);
}
if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
return SCM_INUM0;
} else {
- scm_bits_t count = 0;
- size_t i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_BITS_LENGTH;
- scm_ubits_t w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
- if (SCM_FALSEP (b)) {
+ 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_is_false (b)) {
w = ~w;
};
- w <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_BITS_LENGTH);
+ w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
while (1) {
while (w) {
count += cnt_tab[w & 0x0f];
} else {
--i;
w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
- if (SCM_FALSEP (b)) {
+ if (scm_is_false (b)) {
w = ~w;
}
}
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
{
- size_t i;
- scm_bits_t pos;
- size_t lenw;
- int xbits;
- register scm_ubits_t w;
+ long i, lenw, xbits, pos;
+ register unsigned long w;
SCM_VALIDATE_BOOL (1, item);
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
- SCM_VALIDATE_INUM_COPY (3,k,pos);
+ SCM_VALIDATE_INUM_COPY (3, k, pos);
SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
if (pos == SCM_BITVECTOR_LENGTH (v))
return SCM_BOOL_F;
- lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; /* watch for part words */
- i = pos / SCM_BITS_LENGTH;
+ 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_BITS_LENGTH);
+ xbits = (pos % SCM_LONG_BIT);
pos -= xbits;
w = ((w >> xbits) << xbits);
- xbits = SCM_BITS_LENGTH - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH;
+ xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
while (!0)
{
if (w && (i == lenw))
}
if (++i > lenw)
break;
- pos += SCM_BITS_LENGTH;
+ 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;
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 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 size_t i;
- scm_bits_t vlen;
+ register long i, k, vlen;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
switch SCM_TYP7 (kv)
default:
badarg2:SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
- {
- unsigned long k;
vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
+ if (scm_is_false (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
- k = ((unsigned long *) SCM_VELTS (kv))[--i];
+ k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- SCM_BITVEC_CLR(v,k);
+ SCM_BITVEC_CLR(v, k);
}
else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
- k = ((unsigned long *) SCM_VELTS (kv))[--i];
+ k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- SCM_BITVEC_SET(v,k);
+ SCM_BITVEC_SET(v, k);
}
else
badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
- }
case scm_tc7_bvect:
- {
- scm_ubits_t k;
SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
- if (SCM_FALSEP (obj))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
- ((scm_ubits_t *) SCM_VELTS (v))[k] &= ~ ((scm_ubits_t *) SCM_VELTS (kv))[k];
+ 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))
- for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
- ((scm_ubits_t *) SCM_VELTS (v))[k] |= ((scm_ubits_t *) SCM_VELTS (kv))[k];
+ 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
goto badarg3;
break;
}
- }
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
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 size_t i;
- scm_bits_t vlen, count = 0;
+ register long i, vlen, count = 0;
+ register unsigned long k;
int fObj = 0;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
badarg2:
SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
- {
- unsigned long k;
vlen = SCM_BITVECTOR_LENGTH (v);
- if (SCM_FALSEP (obj))
+ if (scm_is_false (obj))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
- k = ((unsigned long *) SCM_VELTS (kv))[--i];
+ k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- if (!SCM_BITVEC_REF(v,k))
+ if (!SCM_BITVEC_REF(v, k))
count++;
}
else if (SCM_EQ_P (obj, SCM_BOOL_T))
for (i = SCM_UVECTOR_LENGTH (kv); i;)
{
- k = ((unsigned long *) SCM_VELTS (kv))[--i];
+ k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
if (k >= vlen)
scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
- if (SCM_BITVEC_REF (v,k))
+ if (SCM_BITVEC_REF (v, k))
count++;
}
else
badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
- }
case scm_tc7_bvect:
- {
- scm_ubits_t k;
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_BITS_LENGTH;
- k =
- ((scm_ubits_t *) SCM_VELTS (kv))[i]
- & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]);
- k <<= SCM_BITS_LENGTH - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_BITS_LENGTH);
+ 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]));
+ k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
while (1)
{
for (; k; k >>= 4)
return SCM_MAKINUM (count);
/* urg. repetitive (see above.) */
- k =
- ((scm_ubits_t *) SCM_VELTS (kv))[i]
- & (fObj ? ((scm_ubits_t *) SCM_VELTS (v))[i] : ~ ((scm_ubits_t *) SCM_VELTS (v))[i]);
- }
+ k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
}
}
return SCM_MAKINUM (count);
SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
(SCM v),
- "Modifies @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
{
- scm_bits_t k;
+ long int k;
SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
k = SCM_BITVECTOR_LENGTH (v);
- for (k = (k + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k--;)
- ((scm_ubits_t *) SCM_VELTS (v))[k] = ~((scm_ubits_t *) SCM_VELTS (v))[k];
+ for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
+ SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
return SCM_UNSPECIFIED;
}
SCM
-scm_istr2bve (char *str, scm_bits_t len)
+scm_istr2bve (char *str, long len)
{
SCM v = scm_make_uve (len, SCM_BOOL_T);
- scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v);
- register scm_bits_t mask;
- register size_t k;
- register int j;
- for (k = 0; k < (len + SCM_BITS_LENGTH - 1) / SCM_BITS_LENGTH; k++)
+ long *data = (long *) SCM_VELTS (v);
+ register unsigned long mask;
+ register long k;
+ register long j;
+ for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
{
data[k] = 0L;
- j = len - k * SCM_BITS_LENGTH;
- if (j > SCM_BITS_LENGTH)
- j = SCM_BITS_LENGTH;
+ j = len - k * SCM_LONG_BIT;
+ if (j > SCM_LONG_BIT)
+ j = SCM_LONG_BIT;
for (mask = 1L; j--; mask <<= 1)
switch (*str++)
{
static SCM
-ra2l (SCM ra, scm_bits_t base, size_t k)
+ra2l (SCM ra, unsigned long base, unsigned long k)
{
register SCM res = SCM_EOL;
- register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register scm_bits_t i;
+ register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
+ register size_t i;
if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
return SCM_EOL;
i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
#define FUNC_NAME s_scm_array_to_list
{
SCM res = SCM_EOL;
- register size_t k;
+ register long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
switch SCM_TYP7 (v)
{
return scm_string_to_list (v);
case scm_tc7_bvect:
{
- scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS (v);
- register scm_ubits_t mask;
- for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_BITS_LENGTH; k > 0; k--)
- for (mask = 1UL << (SCM_BITS_LENGTH - 1); mask; mask >>= 1)
- res = scm_cons (SCM_BOOL(data[k] & mask), res);
- for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_BITS_LENGTH) - 1); mask; mask >>= 1)
- res = scm_cons (SCM_BOOL(data[k] & mask), res);
+ long *data = (long *) SCM_VELTS (v);
+ 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_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_from_bool(((long *) data)[k] & mask), res);
return res;
}
case scm_tc7_byvect:
{
signed char *data = (signed char *) SCM_VELTS (v);
- scm_bits_t k = SCM_UVECTOR_LENGTH (v);
+ unsigned long k = SCM_UVECTOR_LENGTH (v);
while (k != 0)
res = scm_cons (SCM_MAKINUM (data[--k]), res);
return res;
}
case scm_tc7_uvect:
{
- scm_ubits_t *data = (scm_ubits_t *) SCM_VELTS(v);
+ long *data = (long *)SCM_VELTS(v);
for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_ubits2num(data[k]), res);
+ res = scm_cons(scm_ulong2num(data[k]), res);
return res;
}
case scm_tc7_ivect:
{
- scm_bits_t *data = (scm_bits_t *) SCM_VELTS(v);
+ long *data = (long *)SCM_VELTS(v);
for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
- res = scm_cons(scm_bits2num(data[k]), res);
+ res = scm_cons(scm_long2num(data[k]), res);
return res;
}
case scm_tc7_svect:
res = scm_cons(scm_short2num (data[k]), res);
return res;
}
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
{
long long *data = (long long *)SCM_VELTS(v);
#undef FUNC_NAME
-static int l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k);
+static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
(SCM ndim, SCM prot, SCM lst),
- "@deffnx procedure list->uniform-vector prot lst\n"
+ "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
"Return a uniform array of the type indicated by prototype\n"
"@var{prot} with elements the same as those of @var{lst}.\n"
"Elements must be of the appropriate type, no coercions are\n"
SCM shp = SCM_EOL;
SCM row = lst;
SCM ra;
- scm_bits_t k;
+ unsigned long k;
long n;
- SCM_VALIDATE_INUM_COPY (1,ndim,k);
+ SCM_VALIDATE_INUM_COPY (1, ndim, k);
while (k--)
{
n = scm_ilength (row);
}
if (!SCM_ARRAYP (ra))
{
- scm_bits_t length = SCM_INUM (scm_uniform_vector_length (ra));
+ unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
for (k = 0; k < length; k++, lst = SCM_CDR (lst))
scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
return ra;
if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
return ra;
else
- badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst));
+ badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
+ scm_list_1 (lst));
}
#undef FUNC_NAME
static int
-l2ra (SCM lst, SCM ra, scm_bits_t base, size_t k)
+l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
{
- register scm_bits_t inc = SCM_ARRAY_DIMS (ra)[k].inc;
- register scm_bits_t n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
+ register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
+ register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
int ok = 1;
if (n <= 0)
return (SCM_NULLP (lst));
{
while (n--)
{
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
+ if (!SCM_CONSP (lst))
return 0;
ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
base += inc;
lst = SCM_CDR (lst);
}
- if (SCM_NNULLP (lst))
+ if (!SCM_NULLP (lst))
return 0;
}
else
{
while (n--)
{
- if (SCM_IMP (lst) || SCM_NCONSP (lst))
+ if (!SCM_CONSP (lst))
return 0;
scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
base += inc;
lst = SCM_CDR (lst);
}
- if (SCM_NNULLP (lst))
+ if (!SCM_NULLP (lst))
return 0;
}
return ok;
static void
-rapr1 (SCM ra, scm_bits_t j, size_t k, SCM port, scm_print_state *pstate)
+rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
{
- scm_bits_t inc = 1;
- scm_bits_t n = (SCM_TYP7 (ra) == scm_tc7_smob
+ long inc = 1;
+ long n = (SCM_TYP7 (ra) == scm_tc7_smob
? 0
: SCM_INUM (scm_uniform_vector_length (ra)));
int enclosed = 0;
}
if (k + 1 < SCM_ARRAY_NDIM (ra))
{
- scm_bits_t i;
+ long i;
inc = SCM_ARRAY_DIMS (ra)[k].inc;
for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
{
scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
SCM v = exp;
- scm_bits_t base = 0;
+ unsigned long base = 0;
scm_putc ('#', port);
tail:
switch SCM_TYP7 (v)
case scm_tc7_bvect:
if (SCM_EQ_P (exp, v))
{ /* a uve, not an scm_array */
- register size_t i;
- register int j;
- scm_ubits_t w;
+ register long i, j, w;
scm_putc ('*', port);
- for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH); i++)
+ for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
{
- w = SCM_UNPACK (SCM_VELTS (exp)[i]);
- for (j = SCM_BITS_LENGTH; j; j--)
+ scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
+ for (j = SCM_LONG_BIT; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
w >>= 1;
}
}
- j = SCM_BITVECTOR_LENGTH (exp) % SCM_BITS_LENGTH;
+ j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
if (j)
{
- w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_BITS_LENGTH]);
+ w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
for (; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
case scm_tc7_svect:
scm_putc ('h', port);
break;
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
scm_putc ('l', port);
break;
return SCM_MAKINUM (-1L);
case scm_tc7_svect:
return scm_str2symbol ("s");
-#ifdef HAVE_LONG_LONGS
+#if SCM_SIZEOF_LONG_LONG != 0
case scm_tc7_llvect:
return scm_str2symbol ("l");
#endif
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);
}
static size_t
array_free (SCM ptr)
{
- scm_must_free (SCM_ARRAY_MEM (ptr));
- return sizeof (scm_array_t) +
- SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim_t);
+ scm_gc_free (SCM_ARRAY_MEM (ptr),
+ (sizeof (scm_t_array)
+ + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
+ "array");
+ return 0;
}
void
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");
-#ifndef SCM_MAGIC_SNARFER
#include "libguile/unif.x"
-#endif
}
/*
HCoop / bpt / guile.git / blobdiff