-/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998, 2000, 2001 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
* 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. */
+
+/* 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
+*/
\f
#include <stdio.h>
-#include "_scm.h"
-#include "chars.h"
-#include "eval.h"
-#include "genio.h"
-#include "smob.h"
-#include "strop.h"
-#include "feature.h"
-
-#include "unif.h"
-#include "ramap.h"
+#include <errno.h>
+#include <string.h>
+
+#include "libguile/_scm.h"
+#include "libguile/chars.h"
+#include "libguile/eval.h"
+#include "libguile/fports.h"
+#include "libguile/smob.h"
+#include "libguile/strop.h"
+#include "libguile/feature.h"
+#include "libguile/root.h"
+#include "libguile/strings.h"
+#include "libguile/vectors.h"
+
+#include "libguile/validate.h"
+#include "libguile/unif.h"
+#include "libguile/ramap.h"
#ifdef HAVE_UNISTD_H
#include <unistd.h>
* unsigned char string
* char byvect
* boolean bvect
- * signed int ivect
- * unsigned int uvect
+ * signed long ivect
+ * unsigned long uvect
* float fvect
* double dvect
* complex double cvect
* short svect
- * long_long llvect
- */
-
-long scm_tc16_array;
-
-/*
- * This complicates things too much if allowed on any array.
- * C code can safely call it on arrays known to be used in a single
- * threaded manner.
- *
- * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
+ * long long llvect
*/
-static char s_vector_set_length_x[] = "vector-set-length!";
+scm_bits_t scm_tc16_array;
-SCM
-scm_vector_set_length_x (vect, len)
- SCM vect;
- SCM len;
+/* return the size of an element in a uniform array or 0 if type not
+ found. */
+scm_sizet
+scm_uniform_element_size (SCM obj)
{
- long l;
- scm_sizet siz;
- scm_sizet sz;
+ scm_sizet result;
- l = SCM_INUM (len);
- SCM_ASRTGO (SCM_NIMP (vect), badarg1);
- switch (SCM_TYP7 (vect))
+ switch (SCM_TYP7 (obj))
{
- default:
- badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
- case scm_tc7_string:
- SCM_ASRTGO (vect != scm_nullstr, badarg1);
- sz = sizeof (char);
- l++;
- break;
- case scm_tc7_vector:
- case scm_tc7_wvect:
- SCM_ASRTGO (vect != scm_nullvect, badarg1);
- sz = sizeof (SCM);
- break;
-#ifdef ARRAYS
case scm_tc7_bvect:
- l = (l + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
case scm_tc7_uvect:
case scm_tc7_ivect:
- sz = sizeof (long);
+ result = sizeof (long);
break;
+
case scm_tc7_byvect:
- sz = sizeof (char);
+ result = sizeof (char);
break;
case scm_tc7_svect:
- sz = sizeof (short);
+ result = sizeof (short);
break;
-#ifdef LONGLONGS
+
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- sz = sizeof (long_long);
+ result = sizeof (long_long);
break;
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
- sz = sizeof (float);
+ result = sizeof (float);
break;
-#endif
+
case scm_tc7_dvect:
- sz = sizeof (double);
+ result = sizeof (double);
break;
+
case scm_tc7_cvect:
- sz = 2 * sizeof (double);
+ result = 2 * sizeof (double);
break;
-#endif
-#endif
+
+ default:
+ result = 0;
}
- SCM_ASSERT (SCM_INUMP (len), len, SCM_ARG2, s_vector_set_length_x);
- if (!l)
- l = 1L;
- siz = l * sz;
- if (siz != l * sz)
- scm_wta (SCM_MAKINUM (l * sz), (char *) SCM_NALLOC, s_vector_set_length_x);
- SCM_REDEFER_INTS;
- SCM_SETCHARS (vect,
- ((char *)
- scm_must_realloc (SCM_CHARS (vect),
- (long) SCM_LENGTH (vect) * sz,
- (long) siz,
- s_vector_set_length_x)));
- if (SCM_VECTORP (vect))
- {
- sz = SCM_LENGTH (vect);
- while (l > sz)
- SCM_VELTS (vect)[--l] = SCM_UNSPECIFIED;
- }
- else if (SCM_STRINGP (vect))
- SCM_CHARS (vect)[l - 1] = 0;
- SCM_SETLENGTH (vect, SCM_INUM (len), SCM_TYP7 (vect));
- SCM_REALLOW_INTS;
- return vect;
+ return result;
}
-
-#ifdef ARRAYS
-
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
-
-
-SCM
-scm_makflo (float x)
+/* Silly function used not to modify the semantics of the silly
+ * prototype system in order to be backward compatible.
+ */
+static int
+singp (SCM obj)
{
- SCM z;
- if (x == 0.0)
- return scm_flo0;
- SCM_NEWCELL (z);
- SCM_DEFER_INTS;
- SCM_SETCAR (z, scm_tc_flo);
- SCM_FLO (z) = x;
- SCM_ALLOW_INTS;
- return z;
+ if (!SCM_SLOPPY_REALP (obj))
+ return 0;
+ else
+ {
+ double x = SCM_REAL_VALUE (obj);
+ float fx = x;
+ return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
+ }
}
-#endif
-#endif
-
SCM
-scm_make_uve (k, prot)
- long k;
- SCM prot;
+scm_make_uve (long k, SCM prot)
+#define FUNC_NAME "scm_make_uve"
{
SCM v;
long i, type;
- if (SCM_BOOL_T == prot)
+
+ if (SCM_EQ_P (prot, SCM_BOOL_T))
{
- i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
- type = scm_tc7_bvect;
+ SCM_NEWCELL (v);
+ if (k > 0)
+ {
+ SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH);
+ i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
+ SCM_SET_BITVECTOR_BASE (v, (char *) scm_must_malloc (i, "vector"));
+ SCM_SET_BITVECTOR_LENGTH (v, k);
+ }
+ else
+ {
+ SCM_SET_BITVECTOR_BASE (v, 0);
+ SCM_SET_BITVECTOR_LENGTH (v, 0);
+ }
+ return v;
}
- else if (SCM_ICHRP (prot) && (prot == SCM_MAKICHR ('\0')))
+ else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
{
i = sizeof (char) * k;
type = scm_tc7_byvect;
- }
- else if (SCM_ICHRP (prot))
+ }
+ else if (SCM_CHARP (prot))
{
i = sizeof (char) * k;
- type = scm_tc7_string;
+ return scm_makstr (i, 0);
}
else if (SCM_INUMP (prot))
{
else
type = scm_tc7_ivect;
}
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot) && (1 == SCM_LENGTH (prot)))
+ else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)))
{
char s;
- s = SCM_CHARS (prot)[0];
+ s = SCM_SYMBOL_CHARS (prot)[0];
if (s == 's')
{
i = sizeof (short) * k;
type = scm_tc7_svect;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
else if (s == 'l')
{
i = sizeof (long_long) * k;
#endif
else
{
- return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED);
+ return scm_c_make_vector (k, SCM_UNDEFINED);
}
}
- else
-#ifdef SCM_FLOATS
- if (SCM_IMP (prot) || !SCM_INEXP (prot))
-#endif
+ else if (!SCM_INEXACTP (prot))
/* Huge non-unif vectors are NOT supported. */
- return scm_make_vector (SCM_MAKINUM (k), SCM_UNDEFINED, SCM_UNDEFINED); /* no special scm_vector */
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
- else if (SCM_SINGP (prot))
-
+ /* no special scm_vector */
+ return scm_c_make_vector (k, SCM_UNDEFINED);
+ else if (singp (prot))
{
i = sizeof (float) * k;
type = scm_tc7_fvect;
}
-#endif
- else if (SCM_CPLXP (prot))
+ else if (SCM_COMPLEXP (prot))
{
i = 2 * sizeof (double) * k;
type = scm_tc7_cvect;
i = sizeof (double) * k;
type = scm_tc7_dvect;
}
-#endif
+
+ SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
SCM_NEWCELL (v);
SCM_DEFER_INTS;
- {
- char *m;
- m = scm_must_malloc ((i ? i : 1L), "vector");
- SCM_SETCHARS (v, (char *) m);
- }
- SCM_SETLENGTH (v, (k < SCM_LENGTH_MAX ? k : SCM_LENGTH_MAX), type);
+ 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;
}
+#undef FUNC_NAME
-SCM_PROC(s_uniform_vector_length, "uniform-vector-length", 1, 0, 0, scm_uniform_vector_length);
-SCM
-scm_uniform_vector_length (v)
- SCM v;
+SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
+ (SCM v),
+ "Returns the number of elements in @var{uve}.")
+#define FUNC_NAME s_scm_uniform_vector_length
{
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_length);
- case scm_tc7_bvect:
+ badarg1:SCM_WRONG_TYPE_ARG (1, v);
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ return SCM_MAKINUM (SCM_VECTOR_LENGTH (v));
case scm_tc7_string:
+ return SCM_MAKINUM (SCM_STRING_LENGTH (v));
+ case scm_tc7_bvect:
+ return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v));
case scm_tc7_byvect:
case scm_tc7_uvect:
case scm_tc7_ivect:
case scm_tc7_fvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
- case scm_tc7_vector:
- case scm_tc7_wvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
- return SCM_MAKINUM (SCM_LENGTH (v));
+ return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v));
}
}
-
-SCM_PROC(s_array_p, "array?", 1, 1, 0, scm_array_p);
-
-SCM
-scm_array_p (v, prot)
- SCM v;
- SCM prot;
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
+ (SCM v, SCM prot),
+ "Returns @code{#t} if the @var{obj} is an array, and @code{#f} if not.\n\n"
+ "The @var{prototype} argument is used with uniform arrays and is described\n"
+ "elsewhere.")
+#define FUNC_NAME s_scm_array_p
{
int nprot;
int enclosed;
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)
if (enclosed++)
return SCM_BOOL_F;
v = SCM_ARRAY_V (v);
- goto loop;
- case scm_tc7_bvect:
- return nprot || SCM_BOOL_T==prot ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_string:
- return nprot || (SCM_ICHRP(prot) && (prot != SCM_MAKICHR('\0'))) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_byvect:
- return nprot || (prot == SCM_MAKICHR('\0')) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_uvect:
- return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)>0) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_ivect:
- return nprot || (SCM_INUMP(prot) && SCM_INUM(prot)<=0) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_svect:
- return ( nprot
- || (SCM_NIMP (prot)
- && SCM_SYMBOLP (prot)
- && (1 == SCM_LENGTH (prot))
- && ('s' == SCM_CHARS (prot)[0])));
-#ifdef LONGLONGS
- case scm_tc7_llvect:
- return ( nprot
- || (SCM_NIMP (prot)
- && 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_EQ_P (prot, SCM_BOOL_T));
+ case scm_tc7_string:
+ protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0');
+ case scm_tc7_byvect:
+ protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\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_SYMBOL_LENGTH (prot))
+ && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
+#ifdef HAVE_LONG_LONGS
+ case scm_tc7_llvect:
+ protp = SCM_SYMBOLP (prot)
+ && (1 == SCM_SYMBOL_LENGTH (prot))
+ && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
#endif
-# ifdef SCM_FLOATS
-# ifdef SCM_SINGLES
- case scm_tc7_fvect:
- return nprot || (SCM_NIMP(prot) && SCM_SINGP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
-# endif
- case scm_tc7_dvect:
- return nprot || (SCM_NIMP(prot) && SCM_REALP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
- case scm_tc7_cvect:
- return nprot || (SCM_NIMP(prot) && SCM_CPLXP(prot)) ? SCM_BOOL_T : SCM_BOOL_F;
-# endif
- case scm_tc7_vector:
- case scm_tc7_wvect:
- return nprot || SCM_NULLP(prot) ? SCM_BOOL_T : SCM_BOOL_F;
- default:;
+ case scm_tc7_fvect:
+ protp = singp (prot);
+ case scm_tc7_dvect:
+ protp = SCM_REALP(prot);
+ case scm_tc7_cvect:
+ protp = SCM_COMPLEXP(prot);
+ 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
-SCM_PROC(s_array_rank, "array-rank", 1, 0, 0, scm_array_rank);
-
-SCM
-scm_array_rank (ra)
- SCM ra;
+SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
+ (SCM ra),
+ "Returns the number of dimensions of @var{obj}. If @var{obj} is not an\n"
+ "array, @code{0} is returned.")
+#define FUNC_NAME s_scm_array_rank
{
if (SCM_IMP (ra))
- return SCM_INUM0;
+ return SCM_INUM0;
switch (SCM_TYP7 (ra))
{
default:
case scm_tc7_fvect:
case scm_tc7_cvect:
case scm_tc7_dvect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_svect:
return SCM_INUM0;
}
}
+#undef FUNC_NAME
-SCM_PROC(s_array_dimensions, "array-dimensions", 1, 0, 0, scm_array_dimensions);
-
-SCM
-scm_array_dimensions (ra)
- SCM ra;
+SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
+ (SCM ra),
+ "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
+ "elements with a @code{0} minimum with one greater than the maximum. So:\n"
+ "@example\n"
+ "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
+ "@end example")
+#define FUNC_NAME s_scm_array_dimensions
{
SCM res = SCM_EOL;
scm_sizet k;
scm_array_dim *s;
if (SCM_IMP (ra))
- return SCM_BOOL_F;
+ return SCM_BOOL_F;
switch (SCM_TYP7 (ra))
{
default:
case scm_tc7_cvect:
case scm_tc7_dvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
- return scm_cons (SCM_MAKINUM (SCM_LENGTH (ra)), SCM_EOL);
+ return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
case scm_tc7_smob:
if (!SCM_ARRAYP (ra))
return SCM_BOOL_F;
k = SCM_ARRAY_NDIM (ra);
s = SCM_ARRAY_DIMS (ra);
while (k--)
- res = scm_cons (s[k].lbnd ? scm_cons2 (SCM_MAKINUM (s[k].lbnd), SCM_MAKINUM (s[k].ubnd), SCM_EOL) :
- SCM_MAKINUM (1 + (s[k].ubnd))
- , res);
+ res = scm_cons (s[k].lbnd
+ ? scm_cons2 (SCM_MAKINUM (s[k].lbnd),
+ SCM_MAKINUM (s[k].ubnd),
+ SCM_EOL)
+ : SCM_MAKINUM (1 + s[k].ubnd),
+ res);
return res;
}
}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector of a shared array.")
+#define FUNC_NAME s_scm_shared_array_root
+{
+ SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
+ return SCM_ARRAY_V (ra);
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
+ (SCM ra),
+ "Return the root vector index of the first element in the array.")
+#define FUNC_NAME s_scm_shared_array_offset
+{
+ SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
+ return SCM_MAKINUM (SCM_ARRAY_BASE (ra));
+}
+#undef FUNC_NAME
+
+
+SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
+ (SCM ra),
+ "For each dimension, return the distance between elements in the root vector.")
+#define FUNC_NAME s_scm_shared_array_increments
+{
+ SCM res = SCM_EOL;
+ scm_sizet k;
+ scm_array_dim *s;
+ SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
+ k = SCM_ARRAY_NDIM (ra);
+ s = SCM_ARRAY_DIMS (ra);
+ while (k--)
+ res = scm_cons (SCM_MAKINUM (s[k].inc), res);
+ return res;
+}
+#undef FUNC_NAME
static char s_bad_ind[] = "Bad scm_array index";
long
-scm_aind (ra, args, what)
- SCM ra;
- SCM args;
- char *what;
+scm_aind (SCM ra, SCM args, const char *what)
{
SCM ind;
register long j;
args = SCM_CDR (args);
SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, what);
j = SCM_INUM (ind);
- SCM_ASSERT (j >= (s->lbnd) && j <= (s->ubnd), ind, SCM_OUTOFRANGE, what);
+ if (j < s->lbnd || j > s->ubnd)
+ scm_out_of_range (what, ind);
pos += (j - s->lbnd) * (s->inc);
k--;
s++;
SCM
-scm_make_ra (ndim)
- int ndim;
+scm_make_ra (int ndim)
{
SCM ra;
SCM_NEWCELL (ra);
SCM_DEFER_INTS;
- SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
+ SCM_NEWSMOB(ra, ((long) ndim << 17) + scm_tc16_array,
+ scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
"array"));
- SCM_SETCAR (ra, ((long) ndim << 17) + scm_tc16_array);
SCM_ARRAY_V (ra) = scm_nullvect;
SCM_ALLOW_INTS;
return ra;
SCM
-scm_shap2ra (args, what)
- SCM args;
- char *what;
+scm_shap2ra (SCM args, const char *what)
{
scm_array_dim *s;
SCM ra, spec, sp;
ra = scm_make_ra (ndim);
SCM_ARRAY_BASE (ra) = 0;
s = SCM_ARRAY_DIMS (ra);
- for (; SCM_NIMP (args); s++, args = SCM_CDR (args))
+ for (; !SCM_NULLP (args); s++, args = SCM_CDR (args))
{
spec = SCM_CAR (args);
- if (SCM_IMP (spec))
-
+ if (SCM_INUMP (spec))
{
- SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec,
- s_bad_spec, what);
+ SCM_ASSERT (SCM_INUM (spec) >= 0, spec, s_bad_spec, what);
s->lbnd = 0;
s->ubnd = SCM_INUM (spec) - 1;
s->inc = 1;
s_bad_spec, what);
s->lbnd = SCM_INUM (SCM_CAR (spec));
sp = SCM_CDR (spec);
- SCM_ASSERT (SCM_NIMP (sp) && SCM_CONSP (sp)
+ SCM_ASSERT (SCM_CONSP (sp)
&& SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)),
spec, s_bad_spec, what);
s->ubnd = SCM_INUM (SCM_CAR (sp));
return ra;
}
-SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
-
-SCM
-scm_dimensions_to_uniform_array (dims, prot, fill)
- SCM dims;
- SCM prot;
- SCM fill;
+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"
+ "Creates and returns a uniform array or vector of type corresponding to\n"
+ "@var{prototype} with dimensions @var{dims} or length @var{length}. If\n"
+ "@var{fill} is supplied, it's used to fill the array, otherwise \n"
+ "@var{prototype} is used.")
+#define FUNC_NAME s_scm_dimensions_to_uniform_array
{
- scm_sizet k, vlen = 1;
- long rlen = 1;
+ scm_sizet k;
+ unsigned long int rlen = 1;
scm_array_dim *s;
SCM ra;
if (SCM_INUMP (dims))
- if (SCM_INUM (dims) < SCM_LENGTH_MAX)
- {
- SCM answer;
- answer = scm_make_uve (SCM_INUM (dims), prot);
- if (SCM_NNULLP (fill))
- {
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array),
- SCM_WNA, NULL);
- scm_array_fill_x (answer, SCM_CAR (fill));
- }
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
- scm_array_fill_x (answer, SCM_MAKINUM (0));
- else
- scm_array_fill_x (answer, prot);
- return answer;
- }
- else
- dims = scm_cons (dims, SCM_EOL);
- SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)),
- dims, SCM_ARG1, s_dimensions_to_uniform_array);
- ra = scm_shap2ra (dims, s_dimensions_to_uniform_array);
+ {
+ SCM answer = scm_make_uve (SCM_INUM (dims), prot);
+ if (!SCM_UNBNDP (fill))
+ scm_array_fill_x (answer, fill);
+ else if (SCM_SYMBOLP (prot))
+ scm_array_fill_x (answer, SCM_MAKINUM (0));
+ else
+ scm_array_fill_x (answer, prot);
+ return answer;
+ }
+ SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims),
+ dims, SCM_ARG1, FUNC_NAME);
+ ra = scm_shap2ra (dims, FUNC_NAME);
SCM_SETOR_CAR (ra, SCM_ARRAY_CONTIGUOUS);
s = SCM_ARRAY_DIMS (ra);
k = SCM_ARRAY_NDIM (ra);
while (k--)
{
- s[k].inc = (rlen > 0 ? rlen : 0);
+ s[k].inc = rlen;
+ SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd);
rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
- vlen *= (s[k].ubnd - s[k].lbnd + 1);
}
- if (rlen < SCM_LENGTH_MAX)
- SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
- else
- {
- scm_sizet bit;
- switch (SCM_TYP7 (scm_make_uve (0L, prot)))
- {
- default:
- bit = SCM_LONG_BIT;
- break;
- case scm_tc7_bvect:
- bit = 1;
- break;
- case scm_tc7_string:
- bit = SCM_CHAR_BIT;
- break;
- case scm_tc7_fvect:
- bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char);
- break;
- case scm_tc7_dvect:
- bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char);
- break;
- case scm_tc7_cvect:
- bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char);
- break;
- }
- SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit;
- rlen += SCM_ARRAY_BASE (ra);
- SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
- *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
- }
- if (SCM_NNULLP (fill))
- {
- SCM_ASSERT (1 == scm_ilength (fill),
- scm_makfrom0str (s_dimensions_to_uniform_array), SCM_WNA,
- NULL);
- scm_array_fill_x (ra, SCM_CAR (fill));
- }
- else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
+
+ SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
+
+ if (!SCM_UNBNDP (fill))
+ scm_array_fill_x (ra, fill);
+ else if (SCM_SYMBOLP (prot))
scm_array_fill_x (ra, SCM_MAKINUM (0));
else
scm_array_fill_x (ra, prot);
+
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
return SCM_ARRAY_V (ra);
return ra;
}
+#undef FUNC_NAME
void
-scm_ra_set_contp (ra)
- SCM ra;
+scm_ra_set_contp (SCM ra)
{
scm_sizet k = SCM_ARRAY_NDIM (ra);
if (k)
}
-SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array);
-
-SCM
-scm_make_shared_array (oldra, mapfunc, dims)
- SCM oldra;
- SCM mapfunc;
- SCM dims;
+SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
+ (SCM oldra, SCM mapfunc, SCM dims),
+ "@code{make-shared-array} can be used to create shared subarrays of other\n"
+ "arrays. The @var{mapper} is a function that translates coordinates in\n"
+ "the new array into coordinates in the old array. A @var{mapper} must be\n"
+ "linear, and its range must stay within the bounds of the old array, but\n"
+ "it can be otherwise arbitrary. A simple example:\n"
+ "@example\n"
+ "(define fred (make-array #f 8 8))\n"
+ "(define freds-diagonal\n"
+ " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
+ "(array-set! freds-diagonal 'foo 3)\n"
+ "(array-ref fred 3 3) @result{} foo\n"
+ "(define freds-center\n"
+ " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
+ "(array-ref freds-center 0 0) @result{} foo\n"
+ "@end example")
+#define FUNC_NAME s_scm_make_shared_array
{
SCM ra;
SCM inds, indptr;
scm_sizet i, k;
long old_min, new_min, old_max, new_max;
scm_array_dim *s;
- SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array);
- SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array);
- ra = scm_shap2ra (dims, s_make_shared_array);
+ SCM_VALIDATE_ARRAY (1,oldra);
+ SCM_VALIDATE_PROC (2,mapfunc);
+ ra = scm_shap2ra (dims, FUNC_NAME);
if (SCM_ARRAYP (oldra))
{
SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
{
SCM_ARRAY_V (ra) = oldra;
old_min = 0;
- old_max = (long) SCM_LENGTH (oldra) - 1;
+ old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1;
}
inds = SCM_EOL;
s = SCM_ARRAY_DIMS (ra);
}
imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
- i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array);
+ i = (scm_sizet) scm_aind (oldra, imap, FUNC_NAME);
else
{
if (SCM_NINUMP (imap))
{
SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
- imap, s_bad_ind, s_make_shared_array);
+ imap, s_bad_ind, FUNC_NAME);
imap = SCM_CAR (imap);
}
i = SCM_INUM (imap);
imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
if (SCM_ARRAYP (oldra))
- s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i;
+ s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i;
else
{
if (SCM_NINUMP (imap))
{
SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
- imap, s_bad_ind, s_make_shared_array);
+ imap, s_bad_ind, FUNC_NAME);
imap = SCM_CAR (imap);
}
s[k].inc = (long) SCM_INUM (imap) - i;
indptr = SCM_CDR (indptr);
}
SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
- "mapping out of range", s_make_shared_array);
+ "mapping out of range", FUNC_NAME);
if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
{
- if (1 == s->inc && 0 == s->lbnd
- && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd)
- return SCM_ARRAY_V (ra);
+ SCM v = SCM_ARRAY_V (ra);
+ 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)
return scm_make_uve (0L, scm_array_prototype (ra));
}
scm_ra_set_contp (ra);
return ra;
}
+#undef FUNC_NAME
/* args are RA . DIMS */
-SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array);
-
-SCM
-scm_transpose_array (args)
- SCM args;
+SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
+ (SCM ra, SCM args),
+ "Returns an array sharing contents with @var{array}, but with dimensions\n"
+ "arranged in a different order. There must be one @var{dim} argument for\n"
+ "each dimension of @var{array}. @var{dim0}, @var{dim1}, @dots{} should\n"
+ "be integers between 0 and the rank of the array to be returned. Each\n"
+ "integer in that range must appear at least once in the argument list.\n\n"
+ "The values of @var{dim0}, @var{dim1}, @dots{} correspond to dimensions\n"
+ "in the array to be returned, their positions in the argument list to\n"
+ "dimensions of @var{array}. Several @var{dim}s may have the same value,\n"
+ "in which case the returned array will have smaller rank than\n"
+ "@var{array}.\n\n"
+ "examples:\n"
+ "@example\n"
+ "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
+ "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
+ "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
+ " #2((a 4) (b 5) (c 6))\n"
+ "@end example")
+#define FUNC_NAME s_scm_transpose_array
{
- SCM ra, res, vargs, *ve = &vargs;
+ SCM res, vargs, *ve = &vargs;
scm_array_dim *s, *r;
int ndim, i, k;
- SCM_ASSERT (SCM_NNULLP (args), scm_makfrom0str (s_transpose_array),
- SCM_WNA, NULL);
- ra = SCM_CAR (args);
- SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, s_transpose_array);
- args = SCM_CDR (args);
+
+ SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
switch (SCM_TYP7 (ra))
{
default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
+ badarg:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_bvect:
case scm_tc7_string:
case scm_tc7_byvect:
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
- SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)),
- scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ SCM_ASSERT (!SCM_NULLP (args) && SCM_NULLP (SCM_CDR (args)),
+ scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), SCM_CAR (args), SCM_ARG2,
- s_transpose_array);
- SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_OUTOFRANGE,
- s_transpose_array);
+ FUNC_NAME);
+ SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args),
+ SCM_EQ_P (SCM_INUM0, SCM_CAR (args)));
return ra;
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
vargs = scm_vector (args);
- SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
- scm_makfrom0str (s_transpose_array), SCM_WNA, NULL);
+ SCM_ASSERT (SCM_VECTOR_LENGTH (vargs) == SCM_ARRAY_NDIM (ra),
+ scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
ve = SCM_VELTS (vargs);
ndim = 0;
for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
{
SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
- s_transpose_array);
+ FUNC_NAME);
i = SCM_INUM (ve[k]);
- SCM_ASSERT (i >= 0 && i < SCM_ARRAY_NDIM (ra), ve[k],
- SCM_OUTOFRANGE, s_transpose_array);
+ if (i < 0 || i >= SCM_ARRAY_NDIM (ra))
+ scm_out_of_range (FUNC_NAME, ve[k]);
if (ndim < i)
ndim = i;
}
r->inc += s->inc;
}
}
- SCM_ASSERT (ndim <= 0, args, "bad argument list", s_transpose_array);
+ SCM_ASSERT (ndim <= 0, args, "bad argument list", FUNC_NAME);
scm_ra_set_contp (res);
return res;
}
}
+#undef FUNC_NAME
/* args are RA . AXES */
-SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array);
-
-SCM
-scm_enclose_array (axes)
- SCM axes;
+SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
+ (SCM ra, SCM axes),
+ "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
+ "the rank of @var{array}. @var{enclose-array} returns an array\n"
+ "resembling an array of shared arrays. The dimensions of each shared\n"
+ "array are the same as the @var{dim}th dimensions of the original array,\n"
+ "the dimensions of the outer array are the same as those of the original\n"
+ "array that did not match a @var{dim}.\n\n"
+ "An enclosed array is not a general Scheme array. Its elements may not\n"
+ "be set using @code{array-set!}. Two references to the same element of\n"
+ "an enclosed array will be @code{equal?} but will not in general be\n"
+ "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
+ "enclosed array is unspecified.\n\n"
+ "examples:\n"
+ "@example\n"
+ "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
+ " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
+ "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
+ " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
+ "@end example")
+#define FUNC_NAME s_scm_enclose_array
{
- SCM axv, ra, res, ra_inr;
+ SCM axv, res, ra_inr;
scm_array_dim vdim, *s = &vdim;
int ndim, j, k, ninr, noutr;
- SCM_ASSERT (SCM_NIMP (axes), scm_makfrom0str (s_enclose_array), SCM_WNA,
- NULL);
- ra = SCM_CAR (axes);
- axes = SCM_CDR (axes);
- if (SCM_NULLP (axes))
+ if (SCM_NULLP (axes))
axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
ninr = scm_ilength (axes);
+ SCM_ASSERT (0 <= ninr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
ra_inr = scm_make_ra (ninr);
SCM_ASRTGO (SCM_NIMP (ra), badarg1);
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
default:
- badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array);
+ badarg1:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_string:
case scm_tc7_bvect:
case scm_tc7_byvect:
case scm_tc7_vector:
case scm_tc7_wvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
s->lbnd = 0;
- s->ubnd = SCM_LENGTH (ra) - 1;
+ s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1;
s->inc = 1;
SCM_ARRAY_V (ra_inr) = ra;
SCM_ARRAY_BASE (ra_inr) = 0;
break;
}
noutr = ndim - ninr;
- axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
- SCM_ASSERT (0 <= noutr && 0 <= ninr, scm_makfrom0str (s_enclose_array),
- SCM_WNA, NULL);
+ axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0));
+ SCM_ASSERT (0 <= noutr, scm_makfrom0str (FUNC_NAME), SCM_WNA, NULL);
res = scm_make_ra (noutr);
SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
SCM_ARRAY_V (res) = ra_inr;
for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
{
- SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array);
+ SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", FUNC_NAME);
j = SCM_INUM (SCM_CAR (axes));
SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
- SCM_CHARS (axv)[j] = 1;
+ SCM_STRING_CHARS (axv)[j] = 1;
}
for (j = 0, k = 0; k < noutr; k++, j++)
{
- while (SCM_CHARS (axv)[j])
+ while (SCM_STRING_CHARS (axv)[j])
j++;
SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
scm_ra_set_contp (res);
return res;
}
+#undef FUNC_NAME
-SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p);
-
-SCM
-scm_array_in_bounds_p (args)
- SCM args;
+SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
+ (SCM v, SCM args),
+ "Returns @code{#t} if its arguments would be acceptable to array-ref.")
+#define FUNC_NAME s_scm_array_in_bounds_p
{
- SCM v, ind = SCM_EOL;
+ SCM ind = SCM_EOL;
long pos = 0;
register scm_sizet k;
register long j;
scm_array_dim *s;
- SCM_ASSERT (SCM_NIMP (args), scm_makfrom0str (s_array_in_bounds_p),
- SCM_WNA, NULL);
- v = SCM_CAR (args);
- args = SCM_CDR (args);
+
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_NIMP (args))
{
ind = SCM_CAR (args);
args = SCM_CDR (args);
- SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p);
+ SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME);
pos = SCM_INUM (ind);
}
tail:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
- wna: scm_wrong_num_args (scm_makfrom0str (s_array_in_bounds_p));
+ badarg1:SCM_WRONG_TYPE_ARG (1, v);
+ wna: scm_wrong_num_args (scm_makfrom0str (FUNC_NAME));
case scm_tc7_smob:
k = SCM_ARRAY_NDIM (v);
s = SCM_ARRAY_DIMS (v);
ind = SCM_CAR (args);
args = SCM_CDR (args);
s++;
- SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p);
+ SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, FUNC_NAME);
}
SCM_ASRTGO (0 == k, wna);
v = SCM_ARRAY_V (v);
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
case scm_tc7_vector:
case scm_tc7_wvect:
- SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
- return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F;
+ {
+ 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);
+ }
}
}
+#undef FUNC_NAME
-SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
-SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref);
+SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
-SCM
-scm_uniform_vector_ref (v, args)
- SCM v;
- SCM args;
+
+SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
+ (SCM v, SCM args),
+ "@deffnx primitive array-ref v . args\n"
+ "Returns the element at the @code{(index1, index2)} element in @var{array}.")
+#define FUNC_NAME s_scm_uniform_vector_ref
{
long pos;
}
else if (SCM_ARRAYP (v))
{
- pos = scm_aind (v, args, s_uniform_vector_ref);
+ pos = scm_aind (v, args, FUNC_NAME);
v = SCM_ARRAY_V (v);
}
else
{
+ unsigned long int length;
if (SCM_NIMP (args))
-
{
- SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref);
+ SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
pos = SCM_INUM (SCM_CAR (args));
SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
}
else
{
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref);
+ SCM_VALIDATE_INUM (2,args);
pos = SCM_INUM (args);
}
- SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
+ length = SCM_INUM (scm_uniform_vector_length (v));
+ SCM_ASRTGO (pos >= 0 && pos < length, outrng);
}
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
if (SCM_NULLP (args))
return v;
badarg:
- scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
- abort ();
- outrng:scm_out_of_range (s_uniform_vector_ref, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (scm_makfrom0str (s_uniform_vector_ref));
+ SCM_WRONG_TYPE_ARG (1, v);
+ /* not reached */
+
+ 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);
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;
case scm_tc7_string:
- return SCM_MAKICHR (SCM_CHARS (v)[pos]);
+ return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
case scm_tc7_byvect:
- return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- return SCM_MAKINUM (SCM_VELTS (v)[pos]);
-# else
+ return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
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]);
-# endif
+ return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
+ return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
+ return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]);
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
- return scm_makflo (((float *) SCM_CDR (v))[pos]);
-#endif
+ return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_dvect:
- return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
+ return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_cvect:
- return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
- ((double *) SCM_CDR (v))[2 * pos + 1]);
-#endif
+ return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
+ ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_VELTS (v)[pos];
}
}
+#undef FUNC_NAME
/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
tries to recycle conses. (Make *sure* you want them recycled.) */
SCM
-scm_cvref (v, pos, last)
- SCM v;
- scm_sizet pos;
- SCM last;
+scm_cvref (SCM v, scm_sizet pos, SCM last)
+#define FUNC_NAME "scm_cvref"
{
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
- scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
+ SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
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;
case scm_tc7_string:
- return SCM_MAKICHR (SCM_CHARS (v)[pos]);
+ return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
case scm_tc7_byvect:
- return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- return SCM_MAKINUM (SCM_VELTS (v)[pos]);
-# else
+ return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
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]);
-# endif
+ return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
case scm_tc7_svect:
- return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
-#ifdef LONGLONGS
+ return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
+ return scm_long_long2num (((long_long *) SCM_CELL_WORD_1 (v))[pos]);
#endif
-#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) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
{
- SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
+ SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
return last;
}
- return scm_makflo (((float *) SCM_CDR (v))[pos]);
-#endif
+ return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_dvect:
-#ifdef SCM_SINGLES
- if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last))
-#else
- if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
-#endif
+ if (SCM_NIMP (last) && !SCM_EQ_P (last, scm_flo0) && SCM_SLOPPY_REALP (last))
{
- SCM_REAL (last) = ((double *) SCM_CDR (v))[pos];
+ SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
return last;
}
- return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
+ return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
case scm_tc7_cvect:
- if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last))
+ if (SCM_NIMP (last) && SCM_SLOPPY_COMPLEXP (last))
{
- SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
- SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1];
+ SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
+ SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
return last;
}
- return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
- ((double *) SCM_CDR (v))[2 * pos + 1]);
-#endif
+ return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
+ ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
case scm_tc7_vector:
case scm_tc7_wvect:
return SCM_VELTS (v)[pos];
}
}
}
+#undef FUNC_NAME
+
+
+SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
-SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
-SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x);
/* Note that args may be a list or an immediate object, depending which
PROC is used (and it's called from C too). */
-SCM
-scm_array_set_x (v, obj, args)
- SCM v;
- SCM obj;
- SCM args;
+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"
+ "@var{new-value}. The value returned by array-set! is unspecified.")
+#define FUNC_NAME s_scm_array_set_x
{
- long pos;
+ long pos = 0;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_ARRAYP (v))
{
- pos = scm_aind (v, args, s_array_set_x);
+ pos = scm_aind (v, args, FUNC_NAME);
v = SCM_ARRAY_V (v);
}
else
{
+ unsigned long int length;
if (SCM_NIMP (args))
{
SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
- SCM_ARG3, s_array_set_x);
+ SCM_ARG3, FUNC_NAME);
SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
pos = SCM_INUM (SCM_CAR (args));
}
else
{
- SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x);
- pos = SCM_INUM (args);
+ SCM_VALIDATE_INUM_COPY (3,args,pos);
}
- SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
+ length = SCM_INUM (scm_uniform_vector_length (v));
+ SCM_ASRTGO (pos >= 0 && pos < length, outrng);
}
switch (SCM_TYP7 (v))
{
default: badarg1:
- scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
- abort ();
- outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
- wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
+ SCM_WRONG_TYPE_ARG (1, v);
+ /* not reached */
+ 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));
- else if (SCM_BOOL_T == obj)
- SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
+ if (SCM_FALSEP (obj))
+ SCM_BITVEC_CLR(v,pos);
+ else if (SCM_EQ_P (obj, SCM_BOOL_T))
+ SCM_BITVEC_SET(v,pos);
else
- badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x);
+ badobj:SCM_WRONG_TYPE_ARG (2, obj);
break;
case scm_tc7_string:
- SCM_ASRTGO (SCM_ICHRP (obj), badobj);
- SCM_CHARS (v)[pos] = SCM_ICHR (obj);
+ SCM_ASRTGO (SCM_CHARP (obj), badobj);
+ SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj);
break;
case scm_tc7_byvect:
- if (SCM_ICHRP (obj))
- obj = SCM_MAKINUM ((char) SCM_ICHR (obj));
+ if (SCM_CHARP (obj))
+ obj = SCM_MAKINUM ((char) SCM_CHAR (obj));
SCM_ASRTGO (SCM_INUMP (obj), badobj);
- ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
+ ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
break;
-# ifdef SCM_INUMS_ONLY
case scm_tc7_uvect:
- SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
+ SCM_VELTS(v)[pos] = SCM_PACK (scm_num2ulong(obj, (char *)SCM_ARG2, FUNC_NAME));
+ break;
case scm_tc7_ivect:
- SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
-# else
- case scm_tc7_uvect:
- SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break;
- case scm_tc7_ivect:
- SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break;
-# endif
+ SCM_VELTS(v)[pos] = SCM_PACK (scm_num2long(obj, (char *)SCM_ARG2, FUNC_NAME));
break;
-
case scm_tc7_svect:
SCM_ASRTGO (SCM_INUMP (obj), badobj);
- ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
+ ((short *) SCM_CELL_WORD_1 (v))[pos] = SCM_INUM (obj);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
+ ((long_long *) SCM_CELL_WORD_1 (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, FUNC_NAME);
break;
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
- ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
+ ((float *) SCM_CELL_WORD_1 (v))[pos] = (float) scm_num2dbl (obj, FUNC_NAME);
break;
-#endif
case scm_tc7_dvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
- ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
+ ((double *) SCM_CELL_WORD_1 (v))[pos] = scm_num2dbl (obj, FUNC_NAME);
break;
case scm_tc7_cvect:
- SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj);
- ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
- ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
+ 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;
+ } 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);
+ }
break;
-#endif
case scm_tc7_vector:
case scm_tc7_wvect:
SCM_VELTS (v)[pos] = obj;
}
return SCM_UNSPECIFIED;
}
-
-SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
-
-SCM
-scm_array_contents (ra, strict)
- SCM ra;
- SCM strict;
+#undef FUNC_NAME
+
+/* attempts to unroll an array into a one-dimensional array.
+ returns the unrolled array or #f if it can't be done. */
+ /* if strict is not SCM_UNDEFINED, return #f if returned array
+ 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"
+ "@code{#f}. All arrays made by @var{make-array} and\n"
+ "@var{make-uniform-array} may be unrolled, some arrays made by\n"
+ "@var{make-shared-array} may not be.\n\n"
+ "If the optional argument @var{strict} is provided, a shared array will\n"
+ "be returned only if its elements are stored internally contiguous in\n"
+ "memory.")
+#define FUNC_NAME s_scm_array_contents
{
SCM sra;
if (SCM_IMP (ra))
- return SCM_BOOL_F;
- switch SCM_TYP7
- (ra)
+ return SCM_BOOL_F;
+ switch SCM_TYP7 (ra)
{
default:
return SCM_BOOL_F;
case scm_tc7_dvect:
case scm_tc7_cvect:
case scm_tc7_svect:
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
#endif
return ra;
len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
if (!SCM_UNBNDP (strict))
{
- if SCM_ARRAY_BASE
- (ra) return SCM_BOOL_F;
if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
return SCM_BOOL_F;
if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
{
- if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) ||
+ if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
len % SCM_LONG_BIT)
return SCM_BOOL_F;
}
}
- if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
- return SCM_ARRAY_V (ra);
+
+ {
+ SCM v = SCM_ARRAY_V (ra);
+ 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;
+ }
+
sra = scm_make_ra (1);
SCM_ARRAY_DIMS (sra)->lbnd = 0;
SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
}
}
}
+#undef FUNC_NAME
SCM
-scm_ra2contig (ra, copy)
- SCM ra;
- int copy;
+scm_ra2contig (SCM ra, int copy)
{
SCM ret;
long inc = 1;
k = SCM_ARRAY_NDIM (ra);
if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
{
- if (scm_tc7_bvect != SCM_TYP7 (ra))
+ if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
return ra;
- if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) &&
+ if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
0 == len % SCM_LONG_BIT))
return ra;
-SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x);
-
-SCM
-scm_uniform_array_read_x (ra, port_or_fd, start, end)
- SCM ra;
- SCM port_or_fd;
- SCM start;
- SCM end;
+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"
+ "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"
+ "(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"
+ "a specified region of a vector (or linearized array) to be read,\n"
+ "leaving the remainder of the vector unchanged.\n\n"
+ "@code{uniform-array-read!} returns the number of objects read.\n"
+ "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
+ "returned by @code{(current-input-port)}.")
+#define FUNC_NAME s_scm_uniform_array_read_x
{
SCM cra = SCM_UNDEFINED, v = ra;
long sz, vlen, ans;
long cstart = 0;
long cend;
long offset = 0;
+ char *base;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_UNBNDP (port_or_fd))
port_or_fd = scm_cur_inp;
else
SCM_ASSERT (SCM_INUMP (port_or_fd)
- || (SCM_NIMP (port_or_fd) && SCM_OPINFPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, s_uniform_array_read_x);
- vlen = SCM_LENGTH (v);
+ || (SCM_OPINPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+ vlen = SCM_INUM (scm_uniform_vector_length (v));
loop:
switch SCM_TYP7 (v)
{
default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
+ badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
cra = scm_ra2contig (ra, 0);
v = SCM_ARRAY_V (cra);
goto loop;
case scm_tc7_string:
- case scm_tc7_byvect:
+ base = SCM_STRING_CHARS (v);
sz = sizeof (char);
break;
case scm_tc7_bvect:
+ base = (char *) SCM_BITVECTOR_BASE (v);
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);
+ sz = sizeof (char);
+ break;
case scm_tc7_uvect:
case scm_tc7_ivect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long);
break;
case scm_tc7_svect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long_long);
break;
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (float);
break;
-#endif
case scm_tc7_dvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (double);
break;
case scm_tc7_cvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = 2 * sizeof (double);
break;
-#endif
}
-
+
cend = vlen;
if (!SCM_UNBNDP (start))
{
offset =
- scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x);
+ SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
- scm_out_of_range (s_uniform_array_read_x, start);
+ scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
long tend =
- scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x);
+ SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
- scm_out_of_range (s_uniform_array_read_x, end);
+ scm_out_of_range (FUNC_NAME, end);
cend = tend;
}
}
if (SCM_NIMP (port_or_fd))
{
- /* if we have stored a character from the port in our own buffer,
- push it back onto the stream. */
- /* An ungetc before an fread will not work on some systems if
- setbuf(0). do #define NOSETBUF in scmfig.h to fix this. */
- if (SCM_CRDYP (port_or_fd))
+ scm_port *pt = SCM_PTAB_ENTRY (port_or_fd);
+ int remaining = (cend - offset) * sz;
+ char *dest = base + (cstart + offset) * sz;
+
+ if (pt->rw_active == SCM_PORT_WRITE)
+ scm_flush (port_or_fd);
+
+ ans = cend - offset;
+ while (remaining > 0)
{
- ungetc (SCM_CGETUN (port_or_fd), (FILE *)SCM_STREAM (port_or_fd));
- SCM_CLRDY (port_or_fd); /* Clear ungetted char */
+ if (pt->read_pos < pt->read_end)
+ {
+ int to_copy = min (pt->read_end - pt->read_pos,
+ remaining);
+
+ memcpy (dest, pt->read_pos, to_copy);
+ pt->read_pos += to_copy;
+ remaining -= to_copy;
+ dest += to_copy;
+ }
+ else
+ {
+ if (scm_fill_input (port_or_fd) == EOF)
+ {
+ if (remaining % sz != 0)
+ {
+ SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
+ }
+ ans -= remaining / sz;
+ break;
+ }
+ }
}
- SCM_SYSCALL (ans = fread (SCM_CHARS (v) + (cstart + offset) * sz,
- (scm_sizet) sz, (scm_sizet) (cend - offset),
- (FILE *)SCM_STREAM (port_or_fd)));
+
+ if (pt->rw_random)
+ pt->rw_active = SCM_PORT_READ;
}
else /* file descriptor. */
{
SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
- SCM_CHARS (v) + (cstart + offset) * sz,
+ base + (cstart + offset) * sz,
(scm_sizet) (sz * (cend - offset))));
if (ans == -1)
- scm_syserror (s_uniform_array_read_x);
+ SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_LONG_BIT;
- if (v != ra && cra != ra)
+ if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
scm_array_copy_x (cra, ra);
return SCM_MAKINUM (ans);
}
-
-SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write);
-
-SCM
-scm_uniform_array_write (v, port_or_fd, start, end)
- SCM v;
- SCM port_or_fd;
- SCM start;
- SCM end;
+#undef FUNC_NAME
+
+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"
+ "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"
+ "@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
{
long sz, vlen, ans;
long offset = 0;
long cstart = 0;
long cend;
+ char *base;
+
+ port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
SCM_ASRTGO (SCM_NIMP (v), badarg1);
if (SCM_UNBNDP (port_or_fd))
port_or_fd = scm_cur_outp;
else
SCM_ASSERT (SCM_INUMP (port_or_fd)
- || (SCM_NIMP (port_or_fd) && SCM_OPOUTFPORTP (port_or_fd)),
- port_or_fd, SCM_ARG2, s_uniform_array_write);
- vlen = SCM_LENGTH (v);
+ || (SCM_OPOUTPORTP (port_or_fd)),
+ port_or_fd, SCM_ARG2, FUNC_NAME);
+ vlen = SCM_INUM (scm_uniform_vector_length (v));
loop:
switch SCM_TYP7 (v)
{
default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
+ badarg1:SCM_WRONG_TYPE_ARG (1, v);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
v = scm_ra2contig (v, 1);
v = SCM_ARRAY_V (v);
goto loop;
case scm_tc7_string:
- case scm_tc7_byvect:
+ base = SCM_STRING_CHARS (v);
sz = sizeof (char);
break;
case scm_tc7_bvect:
+ base = (char *) SCM_BITVECTOR_BASE (v);
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);
+ sz = sizeof (char);
+ break;
case scm_tc7_uvect:
case scm_tc7_ivect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long);
break;
case scm_tc7_svect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (short);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (long_long);
break;
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (float);
break;
-#endif
case scm_tc7_dvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = sizeof (double);
break;
case scm_tc7_cvect:
+ base = (char *) SCM_UVECTOR_BASE (v);
sz = 2 * sizeof (double);
break;
-#endif
}
cend = vlen;
if (!SCM_UNBNDP (start))
{
offset =
- scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write);
+ SCM_NUM2LONG (3, start);
if (offset < 0 || offset >= cend)
- scm_out_of_range (s_uniform_array_write, start);
+ scm_out_of_range (FUNC_NAME, start);
if (!SCM_UNBNDP (end))
{
long tend =
- scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write);
+ SCM_NUM2LONG (4, end);
if (tend <= offset || tend > cend)
- scm_out_of_range (s_uniform_array_write, end);
+ scm_out_of_range (FUNC_NAME, end);
cend = tend;
}
}
if (SCM_NIMP (port_or_fd))
{
- SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + (cstart + offset) * sz,
- (scm_sizet) sz, (scm_sizet) (cend - offset),
- (FILE *)SCM_STREAM (port_or_fd)));
+ char *source = base + (cstart + offset) * sz;
+
+ ans = cend - offset;
+ scm_lfwrite (source, ans * sz, port_or_fd);
}
else /* file descriptor. */
{
SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
- SCM_CHARS (v) + (cstart + offset) * sz,
+ base + (cstart + offset) * sz,
(scm_sizet) (sz * (cend - offset))));
if (ans == -1)
- scm_syserror (s_uniform_array_write);
+ SCM_SYSERROR;
}
if (SCM_TYP7 (v) == scm_tc7_bvect)
ans *= SCM_LONG_BIT;
return SCM_MAKINUM (ans);
}
+#undef FUNC_NAME
static char cnt_tab[16] =
{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
-SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);
-
-SCM
-scm_bit_count (item, seq)
- SCM item;
- SCM seq;
+SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
+ (SCM b, SCM bitvector),
+ "Returns the number of occurrences of the boolean @var{b} in\n"
+ "@var{bitvector}.")
+#define FUNC_NAME s_scm_bit_count
{
- long i;
- register unsigned long cnt = 0, w;
- SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
- switch SCM_TYP7
- (seq)
- {
- default:
- scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
- case scm_tc7_bvect:
- if (0 == SCM_LENGTH (seq))
- return SCM_INUM0;
- i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
- w = SCM_VELTS (seq)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
- while (!0)
- {
- for (; w; w >>= 4)
- cnt += cnt_tab[w & 0x0f];
- if (0 == i--)
- return SCM_MAKINUM (cnt);
- w = SCM_VELTS (seq)[i];
- if (SCM_FALSEP (item))
- w = ~w;
+ SCM_VALIDATE_BOOL (1, b);
+ SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
+ if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
+ return SCM_INUM0;
+ } else {
+ 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)) {
+ w = ~w;
+ };
+ w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
+ while (1) {
+ while (w) {
+ count += cnt_tab[w & 0x0f];
+ w >>= 4;
+ }
+ if (i == 0) {
+ return SCM_MAKINUM (count);
+ } else {
+ --i;
+ w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
+ if (SCM_FALSEP (b)) {
+ w = ~w;
}
+ }
}
+ }
}
+#undef FUNC_NAME
-SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);
-
-SCM
-scm_bit_position (item, v, k)
- SCM item;
- SCM v;
- SCM k;
+SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
+ (SCM item, SCM v, SCM k),
+ "Returns the minimum index of an occurrence of @var{bool} in @var{bv}\n"
+ "which is at least @var{k}. If no @var{bool} occurs within the specified\n"
+ "range @code{#f} is returned.")
+#define FUNC_NAME s_scm_bit_position
{
- long i, lenw, xbits, pos = SCM_INUM (k);
+ long i, lenw, xbits, pos;
register unsigned long w;
- SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position);
- SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position);
- SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0),
- k, SCM_OUTOFRANGE, s_bit_position);
- if (pos == SCM_LENGTH (v))
+
+ SCM_VALIDATE_BOOL (1, item);
+ SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
+ 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;
- switch SCM_TYP7
- (v)
- {
- default:
- scm_wta (v, (char *) SCM_ARG2, s_bit_position);
- case scm_tc7_bvect:
- if (0 == SCM_LENGTH (v))
- 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];
+
+ 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))
+ w = ~w;
+ xbits = (pos % SCM_LONG_BIT);
+ pos -= xbits;
+ w = ((w >> xbits) << xbits);
+ xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
+ while (!0)
+ {
+ if (w && (i == lenw))
+ w = ((w << xbits) >> xbits);
+ if (w)
+ while (w)
+ switch (w & 0x0f)
+ {
+ default:
+ return SCM_MAKINUM (pos);
+ case 2:
+ case 6:
+ case 10:
+ case 14:
+ return SCM_MAKINUM (pos + 1);
+ case 4:
+ case 12:
+ return SCM_MAKINUM (pos + 2);
+ case 8:
+ return SCM_MAKINUM (pos + 3);
+ case 0:
+ pos += 4;
+ w >>= 4;
+ }
+ if (++i > lenw)
+ break;
+ pos += SCM_LONG_BIT;
+ w = SCM_UNPACK (SCM_VELTS (v)[i]);
if (SCM_FALSEP (item))
w = ~w;
- xbits = (pos % SCM_LONG_BIT);
- pos -= xbits;
- w = ((w >> xbits) << xbits);
- xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT;
- while (!0)
- {
- if (w && (i == lenw))
- w = ((w << xbits) >> xbits);
- if (w)
- while (w)
- switch (w & 0x0f)
- {
- default:
- return SCM_MAKINUM (pos);
- case 2:
- case 6:
- case 10:
- case 14:
- return SCM_MAKINUM (pos + 1);
- case 4:
- case 12:
- return SCM_MAKINUM (pos + 2);
- case 8:
- return SCM_MAKINUM (pos + 3);
- case 0:
- pos += 4;
- w >>= 4;
- }
- if (++i > lenw)
- break;
- pos += SCM_LONG_BIT;
- w = SCM_VELTS (v)[i];
- if (SCM_FALSEP (item))
- w = ~w;
- }
- return SCM_BOOL_F;
}
+ return SCM_BOOL_F;
}
-
-
-SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);
-
-SCM
-scm_bit_set_star_x (v, kv, obj)
- SCM v;
- SCM kv;
- SCM obj;
+#undef FUNC_NAME
+
+
+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.")
+#define FUNC_NAME s_scm_bit_set_star_x
{
register long i, k, vlen;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
+ SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
+ switch SCM_TYP7 (kv)
{
default:
- badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
+ badarg2:SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
- case scm_tc7_bvect:
- vlen = SCM_LENGTH (v);
- if (SCM_BOOL_F == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
- SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
- }
- else if (SCM_BOOL_T == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
- SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
- }
- else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x);
- }
+ vlen = SCM_BITVECTOR_LENGTH (v);
+ if (SCM_FALSEP (obj))
+ 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_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);
+ }
+ else
+ badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
case scm_tc7_bvect:
- 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]);
- 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_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_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
+ SCM_UNPACK (SCM_VELTS (v)[k]) &= ~ SCM_UNPACK(SCM_VELTS (kv)[k]);
+ else if (SCM_EQ_P (obj, SCM_BOOL_T))
+ for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
+ SCM_UNPACK (SCM_VELTS (v)[k]) |= SCM_UNPACK (SCM_VELTS (kv)[k]);
else
goto badarg3;
break;
}
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
-SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);
-
-SCM
-scm_bit_count_star (v, kv, obj)
- SCM v;
- SCM kv;
- SCM obj;
+SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
+ (SCM v, SCM kv, SCM obj),
+ "Returns\n"
+ "@example\n"
+ "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
+ "@end example\n"
+ "@var{bv} is not modified.")
+#define FUNC_NAME s_scm_bit_count_star
{
register long i, vlen, count = 0;
register unsigned long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
+ int fObj = 0;
+
+ SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
SCM_ASRTGO (SCM_NIMP (kv), badarg2);
- switch SCM_TYP7
- (kv)
+ switch SCM_TYP7 (kv)
{
default:
- badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
+ badarg2:
+ SCM_WRONG_TYPE_ARG (2, kv);
case scm_tc7_uvect:
- switch SCM_TYP7
- (v)
- {
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star);
- case scm_tc7_bvect:
- vlen = SCM_LENGTH (v);
- if (SCM_BOOL_F == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
- if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
- count++;
- }
- else if (SCM_BOOL_T == obj)
- for (i = SCM_LENGTH (kv); i;)
- {
- k = SCM_VELTS (kv)[--i];
- SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
- if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
- count++;
- }
- else
- badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star);
- }
+ vlen = SCM_BITVECTOR_LENGTH (v);
+ if (SCM_FALSEP (obj))
+ 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));
+ if (!SCM_BITVEC_REF(v,k))
+ count++;
+ }
+ 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));
+ if (SCM_BITVEC_REF (v,k))
+ count++;
+ }
+ else
+ badarg3:SCM_WRONG_TYPE_ARG (3, obj);
break;
case scm_tc7_bvect:
- SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
- if (0 == SCM_LENGTH (v))
+ 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_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
- obj = (SCM_BOOL_T == obj);
- i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
- k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
- k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
- while (!0)
+ SCM_ASRTGO (SCM_BOOLP (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]));
+ k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
+ 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_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
}
}
return SCM_MAKINUM (count);
}
+#undef FUNC_NAME
-SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);
-
-SCM
-scm_bit_invert_x (v)
- SCM v;
+SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
+ (SCM v),
+ "Modifies @var{bv} by replacing each element with its negation.")
+#define FUNC_NAME s_scm_bit_invert_x
{
- register long k;
- SCM_ASRTGO (SCM_NIMP (v), badarg1);
- k = SCM_LENGTH (v);
- switch SCM_TYP7
- (v)
- {
- case scm_tc7_bvect:
- for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
- SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
- break;
- default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x);
- }
+ long int k;
+
+ SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
+
+ k = SCM_BITVECTOR_LENGTH (v);
+ for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
+ SCM_UNPACK (SCM_VELTS (v)[k]) = ~SCM_UNPACK (SCM_VELTS (v)[k]);
+
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
SCM
-scm_istr2bve (str, len)
- char *str;
- long len;
+scm_istr2bve (char *str, long len)
{
SCM v = scm_make_uve (len, SCM_BOOL_T);
long *data = (long *) SCM_VELTS (v);
-static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));
-
static SCM
-ra2l (ra, base, k)
- SCM ra;
- scm_sizet base;
- scm_sizet k;
+ra2l (SCM ra,scm_sizet base,scm_sizet k)
{
register SCM res = SCM_EOL;
register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
}
-SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);
-
-SCM
-scm_array_to_list (v)
- SCM v;
+SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
+ (SCM v),
+ "Returns a list consisting of all the elements, in order, of @var{array}.")
+#define FUNC_NAME s_scm_array_to_list
{
SCM res = SCM_EOL;
register long k;
SCM_ASRTGO (SCM_NIMP (v), badarg1);
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
default:
- badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list);
+ badarg1:SCM_WRONG_TYPE_ARG (1, v);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
return ra2l (v, SCM_ARRAY_BASE (v), 0);
{
long *data = (long *) SCM_VELTS (v);
register unsigned long mask;
- for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
+ 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 (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
- for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
- res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
+ res = scm_cons (SCM_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);
return res;
}
-# ifdef SCM_INUMS_ONLY
- case scm_tc7_uvect:
- case scm_tc7_ivect:
- {
- long *data = (long *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (SCM_MAKINUM (data[k]), res);
- return res;
- }
-# else
case scm_tc7_uvect: {
long *data = (long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
+ for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_ulong2num(data[k]), res);
return res;
}
case scm_tc7_ivect: {
long *data = (long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
+ for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_long2num(data[k]), res);
return res;
}
-# endif
case scm_tc7_svect: {
short *data;
data = (short *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
+ for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(SCM_MAKINUM (data[k]), res);
return res;
}
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect: {
long_long *data;
data = (long_long *)SCM_VELTS(v);
- for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
+ for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
res = scm_cons(scm_long_long2num(data[k]), res);
return res;
}
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
{
float *data = (float *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makflo (data[k]), res);
+ for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
+ res = scm_cons (scm_make_real (data[k]), res);
return res;
}
-#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
{
double *data = (double *) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makdbl (data[k], 0.0), res);
+ for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
+ res = scm_cons (scm_make_real (data[k]), res);
return res;
}
case scm_tc7_cvect:
{
double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
- for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
- res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
+ for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
+ res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
return res;
}
-#endif /*SCM_FLOATS*/
}
}
+#undef FUNC_NAME
-static char s_bad_ralst[] = "Bad scm_array contents list";
-
-static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));
-
-SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
+static int l2ra(SCM lst, SCM ra, scm_sizet base, scm_sizet k);
-SCM
-scm_list_to_uniform_array (ndim, prot, lst)
- SCM ndim;
- SCM prot;
- SCM lst;
+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"
+ "Returns a uniform array of the type indicated by prototype @var{prot}\n"
+ "with elements the same as those of @var{lst}. Elements must be of the\n"
+ "appropriate type, no coercions are done.")
+#define FUNC_NAME s_scm_list_to_uniform_array
{
SCM shp = SCM_EOL;
SCM row = lst;
SCM ra;
scm_sizet k;
long n;
- SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array);
- k = SCM_INUM (ndim);
+ SCM_VALIDATE_INUM_COPY (1,ndim,k);
while (k--)
{
n = scm_ilength (row);
- SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array);
+ SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
shp = scm_cons (SCM_MAKINUM (n), shp);
if (SCM_NIMP (row))
row = SCM_CAR (row);
}
- ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL);
+ ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
+ SCM_UNDEFINED);
if (SCM_NULLP (shp))
-
{
SCM_ASRTGO (1 == scm_ilength (lst), badlst);
scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
}
if (!SCM_ARRAYP (ra))
{
- for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst))
+ 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_wta (lst, s_bad_ralst, s_list_to_uniform_array);
- return SCM_BOOL_F;
+ badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst));
}
+#undef FUNC_NAME
static int
-l2ra (lst, ra, base, k)
- SCM lst;
- SCM ra;
- scm_sizet base;
- scm_sizet k;
+l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k)
{
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_EOL == lst);
+ return (SCM_NULLP (lst));
if (k < SCM_ARRAY_NDIM (ra) - 1)
{
while (n--)
{
if (SCM_IMP (lst) || SCM_NCONSP (lst))
return 0;
- ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
+ scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
base += inc;
lst = SCM_CDR (lst);
}
if (SCM_NNULLP (lst))
- return 0;
+ return 0;
}
return ok;
}
-static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));
-
static void
-rapr1 (ra, j, k, port, pstate)
- SCM ra;
- scm_sizet j;
- scm_sizet k;
- SCM port;
- scm_print_state *pstate;
+rapr1 (SCM ra,scm_sizet j,scm_sizet k,SCM port,scm_print_state *pstate)
{
long inc = 1;
- long n = SCM_LENGTH (ra);
+ long n = (SCM_TYP7 (ra) == scm_tc7_smob
+ ? 0
+ : SCM_INUM (scm_uniform_vector_length (ra)));
int enclosed = 0;
tail:
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
case scm_tc7_smob:
if (enclosed++)
ra = SCM_ARRAY_V (ra);
goto tail;
default:
+ /* scm_tc7_bvect and scm_tc7_llvect only? */
if (n-- > 0)
scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
for (j += inc; n-- > 0; j += inc)
break;
case scm_tc7_string:
if (n-- > 0)
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
+ scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
if (SCM_WRITINGP (pstate))
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
+ scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
}
else
for (j += inc; n-- > 0; j += inc)
- scm_putc (SCM_CHARS (ra)[j], port);
+ scm_putc (SCM_STRING_CHARS (ra)[j], port);
break;
case scm_tc7_byvect:
if (n-- > 0)
- scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
+ scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
+ scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
}
break;
case scm_tc7_uvect:
+ {
+ char str[11];
+
+ if (n-- > 0)
+ {
+ /* intprint can't handle >= 2^31. */
+ sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
+ scm_puts (str, port);
+ }
+ for (j += inc; n-- > 0; j += inc)
+ {
+ scm_putc (' ', port);
+ sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
+ scm_puts (str, port);
+ }
+ }
case scm_tc7_ivect:
if (n-- > 0)
- scm_intprint (SCM_VELTS (ra)[j], 10, port);
+ scm_intprint (((signed long *) 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 (((signed long *) SCM_VELTS (ra))[j], 10, port);
}
break;
case scm_tc7_svect:
if (n-- > 0)
- scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
+ scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
+ scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
}
break;
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
if (n-- > 0)
{
- SCM z = scm_makflo (1.0);
- SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
+ SCM z = scm_make_real (1.0);
+ SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
+ scm_print_real (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
+ SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
+ scm_print_real (z, port, pstate);
}
}
break;
-#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
if (n-- > 0)
{
- SCM z = scm_makdbl (1.0 / 3.0, 0.0);
- SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
+ SCM z = scm_make_real (1.0 / 3.0);
+ SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
+ scm_print_real (z, port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
- scm_floprint (z, port, pstate);
+ SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
+ scm_print_real (z, port, pstate);
}
}
break;
case scm_tc7_cvect:
if (n-- > 0)
{
- SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
- SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
- SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
+ SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0);
+ SCM_REAL_VALUE (z) =
+ SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
+ SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
+ scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
+ port, pstate);
for (j += inc; n-- > 0; j += inc)
{
scm_putc (' ', port);
- SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
- SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
- scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
+ SCM_REAL_VALUE (z)
+ = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
+ SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
+ scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
+ port, pstate);
}
}
break;
-#endif /*SCM_FLOATS*/
}
}
int
-scm_raprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
{
SCM v = exp;
scm_sizet base = 0;
scm_putc ('#', port);
tail:
- switch SCM_TYP7
- (v)
+ switch SCM_TYP7 (v)
{
case scm_tc7_smob:
{
}
}
case scm_tc7_bvect:
- if (exp == v)
+ if (SCM_EQ_P (exp, v))
{ /* a uve, not an scm_array */
register long i, j, w;
scm_putc ('*', port);
- for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
+ for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
{
- w = SCM_VELTS (exp)[i];
+ scm_bits_t 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_LENGTH (exp) % SCM_LONG_BIT;
+ j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
if (j)
{
- w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
+ w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
for (; j; j--)
{
scm_putc (w & 1 ? '1' : '0', port);
scm_putc ('a', port);
break;
case scm_tc7_byvect:
- scm_puts ("bytes", port);
+ scm_putc ('y', port);
break;
case scm_tc7_uvect:
scm_putc ('u', port);
scm_putc ('e', port);
break;
case scm_tc7_svect:
- scm_puts ("short", port);
+ scm_putc ('h', port);
break;
-#ifdef LONGLONGS
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- scm_puts ("long_long", port);
+ scm_putc ('l', port);
break;
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
scm_putc ('s', port);
break;
-#endif /*SCM_SINGLES*/
case scm_tc7_dvect:
scm_putc ('i', port);
break;
case scm_tc7_cvect:
scm_putc ('c', port);
break;
-#endif /*SCM_FLOATS*/
}
scm_putc ('(', port);
rapr1 (exp, base, 0, port, pstate);
return 1;
}
-SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);
-
-SCM
-scm_array_prototype (ra)
- SCM ra;
+SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
+ (SCM ra),
+ "Returns an object that would produce an array of the same type as\n"
+ "@var{array}, if used as the @var{prototype} for\n"
+ "@code{make-uniform-array}.")
+#define FUNC_NAME s_scm_array_prototype
{
int enclosed = 0;
SCM_ASRTGO (SCM_NIMP (ra), badarg);
loop:
- switch SCM_TYP7
- (ra)
+ switch SCM_TYP7 (ra)
{
default:
- badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype);
+ badarg:SCM_WRONG_TYPE_ARG (1, ra);
case scm_tc7_smob:
SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
if (enclosed++)
case scm_tc7_bvect:
return SCM_BOOL_T;
case scm_tc7_string:
- return SCM_MAKICHR ('a');
+ return SCM_MAKE_CHAR ('a');
case scm_tc7_byvect:
- return SCM_MAKICHR ('\0');
+ return SCM_MAKE_CHAR ('\0');
case scm_tc7_uvect:
return SCM_MAKINUM (1L);
case scm_tc7_ivect:
return SCM_MAKINUM (-1L);
case scm_tc7_svect:
- return SCM_CDR (scm_intern ("s", 1));
-#ifdef LONGLONGS
+ return scm_str2symbol ("s");
+#ifdef HAVE_LONG_LONGS
case scm_tc7_llvect:
- return SCM_CDR (scm_intern ("l", 1));
+ return scm_str2symbol ("l");
#endif
-#ifdef SCM_FLOATS
-#ifdef SCM_SINGLES
case scm_tc7_fvect:
- return scm_makflo (1.0);
-#endif
+ return scm_make_real (1.0);
case scm_tc7_dvect:
- return scm_makdbl (1.0 / 3.0, 0.0);
+ return scm_make_real (1.0 / 3.0);
case scm_tc7_cvect:
- return scm_makdbl (0.0, 1.0);
-#endif
+ return scm_make_complex (0.0, 1.0);
}
}
+#undef FUNC_NAME
-static SCM markra SCM_P ((SCM ptr));
-
static SCM
-markra (ptr)
- SCM ptr;
+array_mark (SCM ptr)
{
- if SCM_GC8MARKP
- (ptr) return SCM_BOOL_F;
- SCM_SETGC8MARK (ptr);
return SCM_ARRAY_V (ptr);
}
-static scm_sizet freera SCM_P ((SCM ptr));
-
static scm_sizet
-freera (ptr)
- SCM ptr;
+array_free (SCM ptr)
{
- scm_must_free (SCM_CHARS (ptr));
+ scm_must_free (SCM_ARRAY_MEM (ptr));
return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
}
-static scm_smobfuns rasmob =
-{markra, freera, scm_raprin1, scm_array_equal_p};
-
-
-/* This must be done after scm_init_scl() */
-
void
scm_init_unif ()
{
-#include "unif.x"
- scm_tc16_array = scm_newsmob (&rasmob);
+ scm_tc16_array = scm_make_smob_type ("array", 0);
+ scm_set_smob_mark (scm_tc16_array, array_mark);
+ 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);
scm_add_feature ("array");
+#ifndef SCM_MAGIC_SNARFER
+#include "libguile/unif.x"
+#endif
}
-#else /* ARRAYS */
-
-
-int
-scm_raprin1 (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
-{
- return 0;
-}
-
-
-SCM
-scm_istr2bve (str, len)
- char *str;
- long len;
-{
- return SCM_BOOL_F;
-}
-
-void
-scm_init_unif ()
-{
-#include "unif.x"
- scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
-}
-
-#endif /* ARRAYS */
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff