*
* 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
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
*/
\f
#include <string.h>
#endif
+#include <assert.h>
+
+#if SCM_ENABLE_DEPRECATED
+
/* data conversion C->scheme */
SCM
long i;
SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for (i = 0; i < n; ++i)
- SCM_VECTOR_SET (v, i, scm_from_int (d[i]));
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
return v;
}
SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for(i = 0; i < n; i++)
- SCM_VECTOR_SET (v, i, scm_from_double (d[i]));
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
return v;
}
-#if SCM_HAVE_ARRAYS
-/* Do not use this function for building normal Scheme vectors, unless
- you arrange for the elements to be protected from GC while you
- initialize the vector. */
-static SCM
-makvect (char *m, size_t len, int type)
-{
- return scm_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m);
-}
SCM
gh_chars2byvect (const char *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (char), "vector");
+ char *m = scm_malloc (n);
memcpy (m, d, n * sizeof (char));
- return makvect (m, n, scm_tc7_byvect);
+ return scm_take_s8vector ((scm_t_int8 *)m, n);
}
SCM
gh_shorts2svect (const short *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (short), "vector");
+ char *m = scm_malloc (n * sizeof (short));
memcpy (m, d, n * sizeof (short));
- return makvect (m, n, scm_tc7_svect);
+ assert (sizeof (scm_t_int16) == sizeof (short));
+ return scm_take_s16vector ((scm_t_int16 *)m, n);
}
SCM
gh_longs2ivect (const long *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (long), "vector");
+ char *m = scm_malloc (n * sizeof (long));
memcpy (m, d, n * sizeof (long));
- return makvect (m, n, scm_tc7_ivect);
+ assert (sizeof (scm_t_int32) == sizeof (long));
+ return scm_take_s32vector ((scm_t_int32 *)m, n);
}
SCM
gh_ulongs2uvect (const unsigned long *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (unsigned long), "vector");
+ char *m = scm_malloc (n * sizeof (unsigned long));
memcpy (m, d, n * sizeof (unsigned long));
- return makvect (m, n, scm_tc7_uvect);
+ assert (sizeof (scm_t_uint32) == sizeof (unsigned long));
+ return scm_take_u32vector ((scm_t_uint32 *)m, n);
}
SCM
gh_floats2fvect (const float *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (float), "vector");
+ char *m = scm_malloc (n * sizeof (float));
memcpy (m, d, n * sizeof (float));
- return makvect (m, n, scm_tc7_fvect);
+ return scm_take_f32vector ((float *)m, n);
}
SCM
gh_doubles2dvect (const double *d, long n)
{
- char *m = scm_gc_malloc (n * sizeof (double), "vector");
+ char *m = scm_malloc (n * sizeof (double));
memcpy (m, d, n * sizeof (double));
- return makvect (m, n, scm_tc7_dvect);
+ return scm_take_f64vector ((double *)m, n);
}
-#endif
/* data conversion scheme->C */
int
{
case scm_tc7_vector:
case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
{
v = SCM_I_INUM (val);
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
- m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]);
- break;
-#if SCM_HAVE_ARRAYS
- case scm_tc7_byvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (char *) malloc (n * sizeof (char));
- if (m == NULL)
- return NULL;
- memcpy (m, SCM_VELTS (obj), n * sizeof (char));
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
break;
-#endif
+ case scm_tc7_smob:
+ if (scm_is_true (scm_s8vector_p (obj)))
+ {
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ const scm_t_int8 *elts;
+
+ elts = scm_s8vector_elements (obj, &handle, &len, &inc);
+ if (inc != 1)
+ scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
+ scm_list_1 (obj));
+ if (m == 0)
+ m = (char *) malloc (len);
+ if (m != NULL)
+ memcpy (m, elts, len);
+ scm_array_handle_release (&handle);
+ if (m == NULL)
+ return NULL;
+ break;
+ }
+ else
+ goto wrong_type;
case scm_tc7_string:
n = scm_i_string_length (obj);
if (m == 0)
memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
break;
default:
+ wrong_type:
scm_wrong_type_arg (0, 0, obj);
}
return m;
}
+static void *
+scm2whatever (SCM obj, void *m, size_t size)
+{
+ scm_t_array_handle handle;
+ size_t len;
+ ssize_t inc;
+ const void *elts;
+
+ elts = scm_uniform_vector_elements (obj, &handle, &len, &inc);
+
+ if (inc != 1)
+ scm_misc_error (NULL, "only contiguous vectors can be converted: ~a",
+ scm_list_1 (obj));
+
+ if (m == 0)
+ m = malloc (len * sizeof (size));
+ if (m != NULL)
+ memcpy (m, elts, len * size);
+
+ scm_array_handle_release (&handle);
+
+ return m;
+}
+
+#define SCM2WHATEVER(obj,pred,utype,mtype) \
+ if (scm_is_true (pred (obj))) \
+ { \
+ assert (sizeof (utype) == sizeof (mtype)); \
+ return (mtype *)scm2whatever (obj, m, sizeof (utype)); \
+ }
+
/* Convert a vector, weak vector or uniform vector into an array of
shorts. If result array in arg 2 is NULL, malloc a new one. If
out of memory, return NULL. */
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
+
+ SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short)
+
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
{
v = SCM_I_INUM (val);
if (m == NULL)
return NULL;
for (i = 0; i < n; ++i)
- m[i] = SCM_I_INUM (SCM_VELTS (obj)[i]);
- break;
-#if SCM_HAVE_ARRAYS
- case scm_tc7_svect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (short *) malloc (n * sizeof (short));
- if (m == NULL)
- return NULL;
- memcpy (m, SCM_VELTS (obj), n * sizeof (short));
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
+
+ SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long)
+
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
scm_wrong_type_arg (0, 0, obj);
}
return NULL;
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
m[i] = SCM_I_INUMP (val)
? SCM_I_INUM (val)
: scm_to_long (val);
}
break;
-#if SCM_HAVE_ARRAYS
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (long *) malloc (n * sizeof (long));
- if (m == NULL)
- return NULL;
- memcpy (m, SCM_VELTS (obj), n * sizeof (long));
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
+
+ /* XXX - f64vectors are rejected now.
+ */
+ SCM2WHATEVER (obj, scm_f32vector_p, float, float)
+
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val)
&& !(SCM_BIGP (val) || SCM_REALP (val)))
scm_wrong_type_arg (0, 0, val);
return NULL;
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
m[i] = SCM_I_INUM (val);
else if (SCM_BIGP (val))
m[i] = SCM_REAL_VALUE (val);
}
break;
-#if SCM_HAVE_ARRAYS
- case scm_tc7_fvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (float *) malloc (n * sizeof (float));
- if (m == NULL)
- return NULL;
- memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float));
- break;
-
- case scm_tc7_dvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (float*) malloc (n * sizeof (float));
- if (m == NULL)
- return NULL;
- for (i = 0; i < n; ++i)
- m[i] = ((double *) SCM_VELTS (obj))[i];
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
SCM val;
if (SCM_IMP (obj))
scm_wrong_type_arg (0, 0, obj);
+
+ /* XXX - f32vectors are rejected now.
+ */
+ SCM2WHATEVER (obj, scm_f64vector_p, double, double)
+
switch (SCM_TYP7 (obj))
{
case scm_tc7_vector:
case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (!SCM_I_INUMP (val)
&& !(SCM_BIGP (val) || SCM_REALP (val)))
scm_wrong_type_arg (0, 0, val);
return NULL;
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
if (SCM_I_INUMP (val))
m[i] = SCM_I_INUM (val);
else if (SCM_BIGP (val))
m[i] = SCM_REAL_VALUE (val);
}
break;
-#if SCM_HAVE_ARRAYS
- case scm_tc7_fvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (double *) malloc (n * sizeof (double));
- if (m == NULL)
- return NULL;
- for (i = 0; i < n; ++i)
- m[i] = ((float *) SCM_VELTS (obj))[i];
- break;
- case scm_tc7_dvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (double*) malloc (n * sizeof (double));
- if (m == NULL)
- return NULL;
- memcpy (m, SCM_VELTS (obj), n * sizeof (double));
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
unsigned long
gh_vector_length (SCM v)
{
- return (unsigned long) SCM_VECTOR_LENGTH (v);
+ return (unsigned long) scm_c_vector_length (v);
}
-#if SCM_HAVE_ARRAYS
/* uniform vector support */
/* returns the length as a C unsigned long integer */
unsigned long
gh_uniform_vector_length (SCM v)
{
- return (unsigned long) SCM_UVECTOR_LENGTH (v);
+ return (unsigned long) scm_c_uniform_vector_length (v);
}
/* gets the given element from a uniform vector; ilist is a list (or
/* sets an individual element in a uniform vector */
/* SCM */
/* gh_list_to_uniform_array ( */
-#endif
/* Data lookups between C and Scheme
}
#undef FUNC_NAME
+#endif /* SCM_ENABLE_DEPRECATED */
+
/*
Local Variables:
c-file-style: "gnu"
HCoop / bpt / guile.git / blobdiff