-/* this file is #include'd (x times) by convert.c */
-
-/* FIXME: Should we use exported wrappers for malloc (and free), which
- * allow windows DLLs to call the correct freeing function? */
-
-
-/* Convert a vector, weak vector, (if possible string, substring), list
- or uniform vector into an C array. If result array in argument 2 is
- NULL, malloc() a new one. If out of memory, return NULL. */
-#define FUNC_NAME SCM2CTYPES_FN
-CTYPE *
-SCM2CTYPES (SCM obj, CTYPE *data)
-{
- long i, n;
- SCM val;
-
- SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),
- obj, SCM_ARG1, FUNC_NAME);
-
- if (SCM_NFALSEP (scm_list_p (obj)))
- {
- SCM list = obj;
- for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
- {
- val = SCM_CAR (list);
-#if defined (CTYPEMIN) && defined (CTYPEMAX)
- if (SCM_INUMP (val))
- {
- long v = SCM_INUM (val);
- SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
- }
- else
-#elif defined (FLOATTYPE1)
- if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
-#else
- if (!SCM_INUMP (val) && !SCM_BIGP (val))
-#endif
- SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
- }
- if (data == NULL)
- data = (CTYPE *) malloc (n * sizeof (CTYPE));
- if (data == NULL)
- return NULL;
-
- list = obj;
- for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
- {
- val = SCM_CAR (list);
- if (SCM_INUMP (val))
- data[i] = SCM_INUM (val);
- else if (SCM_BIGP (val))
- data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
-#ifdef FLOATTYPE1
- else
- data[i] = (CTYPE) SCM_REAL_VALUE (val);
-#endif
- }
- return data;
- }
-
- switch (SCM_TYP7 (obj))
- {
- case scm_tc7_vector:
- case scm_tc7_wvect:
- n = SCM_VECTOR_LENGTH (obj);
- for (i = 0; i < n; i++)
- {
- val = SCM_VELTS (obj)[i];
-
-#if defined (CTYPEMIN) && defined (CTYPEMAX)
- if (SCM_INUMP (val))
- {
- long v = SCM_INUM (val);
- SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX);
- }
- else
-#elif defined (FLOATTYPE1)
- if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val)))
-#else
- if (!SCM_INUMP (val) && !SCM_BIGP (val))
-#endif
- SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
- }
- if (data == NULL)
- data = (CTYPE *) malloc (n * sizeof (CTYPE));
- if (data == NULL)
- return NULL;
- for (i = 0; i < n; i++)
- {
- val = SCM_VELTS (obj)[i];
- if (SCM_INUMP (val))
- data[i] = (CTYPE) SCM_INUM (val);
- else if (SCM_BIGP (val))
- data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
-#ifdef FLOATTYPE1
- else
- data[i] = (CTYPE) SCM_REAL_VALUE (val);
-#endif
- }
- break;
-
-#ifdef HAVE_ARRAYS
- case ARRAYTYPE1:
-#ifdef ARRAYTYPE2
- case ARRAYTYPE2:
-#endif
- n = SCM_UVECTOR_LENGTH (obj);
- if (data == NULL)
- data = (CTYPE *) malloc (n * sizeof (CTYPE));
- if (data == NULL)
- return NULL;
-#ifdef FLOATTYPE2
- if (SCM_TYP7 (obj) == ARRAYTYPE2)
- {
- for (i = 0; i < n; i++)
- data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i];
- }
- else
-#endif
- memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
- break;
-#endif /* HAVE_ARRAYS */
-
-#ifdef STRINGTYPE
- case scm_tc7_string:
- n = SCM_STRING_LENGTH (obj);
- if (data == NULL)
- data = (CTYPE *) malloc (n * sizeof (CTYPE));
- if (data == NULL)
- return NULL;
- memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
- break;
-#endif /* STRINGTYPE */
-
- default:
- SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
- }
- return data;
-}
-#undef FUNC_NAME
-
-
-#if HAVE_ARRAYS
-
-/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
- of memory. */
-#define FUNC_NAME CTYPES2UVECT_FN
-SCM
-CTYPES2UVECT (const CTYPE *data, long n)
-{
- char *v;
-
- SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
- n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
- v = scm_gc_malloc (sizeof (CTYPE) * n, "vector");
- memcpy (v, data, n * sizeof (CTYPE));
- return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
-}
-#undef FUNC_NAME
-
-#ifdef UVECTTYPE2
-#define FUNC_NAME CTYPES2UVECT_FN2
-SCM
-CTYPES2UVECT2 (const unsigned CTYPE *data, long n)
-{
- char *v;
-
- SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
- n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
- v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector");
- memcpy (v, data, n * sizeof (unsigned CTYPE));
- return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v);
-}
-#undef FUNC_NAME
-#endif /* UVECTTYPE2 */
-
-#endif /* HAVE_ARRAYS */
-
-/* Converts a C array into a vector. */
-#define FUNC_NAME CTYPES2SCM_FN
-SCM
-CTYPES2SCM (const CTYPE *data, long n)
-{
- long i;
- SCM v, *velts;
-
- SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
- n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
- v = scm_c_make_vector (n, SCM_UNSPECIFIED);
- velts = SCM_VELTS (v);
- for (i = 0; i < n; i++)
-#ifdef FLOATTYPE1
- velts[i] = scm_make_real ((double) data[i]);
-#elif defined (CTYPEFIXABLE)
- velts[i] = SCM_MAKINUM (data[i]);
-#else
- velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) :
- scm_i_long2big (data[i]));
-#endif
- return v;
-}
-#undef FUNC_NAME
-
-/* cleanup of conditionals */
-#undef SCM2CTYPES
-#undef SCM2CTYPES_FN
-#undef CTYPES2SCM
-#undef CTYPES2SCM_FN
-#undef CTYPE
-#undef CTYPES2UVECT
-#undef CTYPES2UVECT_FN
-#ifdef CTYPEFIXABLE
-#undef CTYPEFIXABLE
-#endif
-#undef UVECTTYPE
-#ifdef UVECTTYPE2
-#undef CTYPES2UVECT2
-#undef CTYPES2UVECT_FN2
-#undef UVECTTYPE2
-#endif
-#ifdef CTYPEMIN
-#undef CTYPEMIN
-#endif
-#ifdef CTYPEMAX
-#undef CTYPEMAX
-#endif
-#undef ARRAYTYPE1
-#ifdef ARRAYTYPE2
-#undef ARRAYTYPE2
-#endif
-#ifdef FLOATTYPE1
-#undef FLOATTYPE1
-#endif
-#ifdef FLOATTYPE2
-#undef FLOATTYPE2
-#endif
-#ifdef STRINGTYPE
-#undef STRINGTYPE
-#endif
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* this file is #include'd (x times) by convert.c */
+
+/* You need to define the following macros before including this
+ template. They are undefined at the end of this file to give a
+ clean slate for the next inclusion.
+
+ - CTYPE
+
+ The type of an element of the C array, for example 'char'.
+
+ - FROM_CTYPE
+
+ The function that converts a CTYPE to a SCM, for example
+ scm_from_char.
+
+ - UVEC_TAG
+
+ The tag of a suitable uniform vector that can hold the CTYPE, for
+ example 's8'.
+
+ - UVEC_CTYPE
+
+ The C type of an element of the uniform vector, for example
+ scm_t_int8.
+
+ - SCM2CTYPES
+
+ The name of the 'SCM-to-C' function, for example scm_c_scm2chars.
+
+ - CTYPES2SCM
+
+ The name of the 'C-to-SCM' function, for example, scm_c_chars2scm.
+
+ - CTYPES2UVECT
+
+ The name of the 'C-to-uniform-vector' function, for example
+ scm_c_chars2byvect. It will create a uniform vector of kind
+ UVEC_TAG.
+
+ - CTYPES2UVECT_2
+
+ The name of a second 'C-to-uniform-vector' function. Leave
+ undefined if you want only one such function.
+
+ - CTYPE_2
+ - UVEC_TAG_2
+ - UVEC_CTYPE_2
+
+ The tag and C type of the second kind of uniform vector, for use
+ with the function described above.
+
+*/
+
+/* The first level does not expand macros in the arguments. */
+#define paste(a1,a2,a3) a1##a2##a3
+#define stringify(a) #a
+
+/* But the second level does. */
+#define F(pre,T,suf) paste(pre,T,suf)
+#define S(T) stringify(T)
+
+/* Convert a vector, list or uniform vector into a C array. If the
+ result array in argument 2 is NULL, malloc() a new one.
+*/
+
+CTYPE *
+SCM2CTYPES (SCM obj, CTYPE *data)
+{
+ scm_t_array_handle handle;
+ size_t i, len;
+ ssize_t inc;
+ const UVEC_CTYPE *uvec_elements;
+
+ obj = F(scm_any_to_,UVEC_TAG,vector) (obj);
+ uvec_elements = F(scm_,UVEC_TAG,vector_elements) (obj, &handle, &len, &inc);
+
+ if (data == NULL)
+ data = scm_malloc (len * sizeof (CTYPE));
+ for (i = 0; i < len; i++, uvec_elements += inc)
+ data[i] = uvec_elements[i];
+
+ scm_array_handle_release (&handle);
+
+ return data;
+}
+
+/* Converts a C array into a vector. */
+
+SCM
+CTYPES2SCM (const CTYPE *data, long n)
+{
+ long i;
+ SCM v;
+
+ v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+
+ for (i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (v, i, FROM_CTYPE (data[i]));
+
+ return v;
+}
+
+/* Converts a C array into a uniform vector. */
+
+SCM
+CTYPES2UVECT (const CTYPE *data, long n)
+{
+ scm_t_array_handle handle;
+ long i;
+ SCM uvec;
+ UVEC_CTYPE *uvec_elements;
+
+ uvec = F(scm_make_,UVEC_TAG,vector) (scm_from_long (n), SCM_UNDEFINED);
+ uvec_elements = F(scm_,UVEC_TAG,vector_writable_elements) (uvec, &handle,
+ NULL, NULL);
+ for (i = 0; i < n; i++)
+ uvec_elements[i] = data[i];
+
+ scm_array_handle_release (&handle);
+
+ return uvec;
+}
+
+#ifdef CTYPE2UVECT_2
+
+SCM
+CTYPES2UVECT_2 (const CTYPE_2 *data, long n)
+{
+ scm_t_array_handle handle;
+ long i;
+ SCM uvec;
+ UVEC_CTYPE_2 *uvec_elements;
+
+ uvec = F(scm_make_,UVEC_TAG_2,vector) (scm_from_long (n), SCM_UNDEFINED);
+ uvec_elements = F(scm_,UVEC_TAG_2,vector_writable_elements) (uvec, &handle,
+ NULL, NULL);
+
+ for (i = 0; i < n; i++)
+ uvec_elements[i] = data[i];
+
+ scm_array_handle_release (&handle);
+
+ return uvec;
+}
+
+#endif
+
+#undef paste
+#undef stringify
+#undef F
+#undef S
+
+#undef CTYPE
+#undef FROM_CTYPE
+#undef UVEC_TAG
+#undef UVEC_CTYPE
+#undef SCM2CTYPES
+#undef CTYPES2SCM
+#undef CTYPES2UVECT
+#ifdef CTYPES2UVECT_2
+#undef CTYPES2UVECT_2
+#undef CTYPE_2
+#undef UVEC_TAG_2
+#undef UVEC_CTYPE_2
+#endif
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff