-/* 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.
+ * 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.
*
- * 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 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
+ */
/*
*/
\f
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
+
#include <stdio.h>
#include <errno.h>
#include <string.h>
*/
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. */
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
{
}
}
+static const char s_scm_make_uve[];
+
+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_alloc_cell (SCM_MAKE_BITVECTOR_TAG (k),
- (scm_t_bits) scm_must_malloc (i, "vector"));
+ return scm_cell (SCM_MAKE_BITVECTOR_TAG (k),
+ (scm_t_bits) scm_gc_malloc (i, "vector"));
}
else
- v = scm_alloc_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)))
{
s = SCM_SYMBOL_CHARS (prot)[0];
if (s == 's')
- {
- i = 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')
- {
- 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_alloc_cell (SCM_MAKE_UVECTOR_TAG (k, type),
- (scm_t_bits) scm_must_malloc (i ? i : 1, "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}.")
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));
{
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 */
;
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:
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_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 ra;
SCM_DEFER_INTS;
SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array,
- scm_must_malloc ((sizeof (scm_t_array) +
- ndim * sizeof (scm_t_array_dim)),
- "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_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))
{
"@end lisp")
#define FUNC_NAME s_scm_transpose_array
{
- SCM res, vargs, *ve = &vargs;
+ SCM res, vargs;
+ SCM const *ve = &vargs;
scm_t_array_dim *s, *r;
int ndim, i, k;
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)))
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;
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:
}
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
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];
}
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);
goto badarg1;
case scm_tc7_bvect:
if (SCM_FALSEP (obj))
- SCM_BITVEC_CLR(v,pos);
+ 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;
SCM_ASRTGO (SCM_INUMP (obj), badobj);
((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_UVECTOR_BASE (v))[pos]
= scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
break;
case scm_tc7_vector:
case scm_tc7_wvect:
- SCM_VELTS (v)[pos] = obj;
+ SCM_VECTOR_SET (v, pos, obj);
break;
}
return SCM_UNSPECIFIED;
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;
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);
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);
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;
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))
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;
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 = 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);
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;
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))
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
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;
static SCM
-ra2l (SCM ra,unsigned long base,unsigned long k)
+ra2l (SCM ra, unsigned long base, unsigned long k)
{
register SCM res = SCM_EOL;
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
}
-SCM_DEFINE (scm_t_arrayo_list, "array->list", 1, 0, 0,
+SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
(SCM v),
"Return a list consisting of all the elements, in order, of\n"
"@var{array}.")
-#define FUNC_NAME s_scm_t_arrayo_list
+#define FUNC_NAME s_scm_array_to_list
{
SCM res = SCM_EOL;
register long k;
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);
SCM ra;
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);
{
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,unsigned long j,unsigned long k,SCM port,scm_print_state *pstate)
+rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
{
long inc = 1;
long n = (SCM_TYP7 (ra) == scm_tc7_smob
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_t_array) +
- SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim);
+ 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
}
/*