--- /dev/null
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+ */
+\f
+
+/* data initialization and C<->Scheme data conversion */
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/gh.h"
+#ifdef HAVE_STRING_H
+#include <string.h>
+#endif
+
+#include <assert.h>
+
+#if SCM_ENABLE_DEPRECATED
+
+/* data conversion C->scheme */
+
+SCM
+gh_bool2scm (int x)
+{
+ return scm_from_bool(x);
+}
+SCM
+gh_int2scm (int x)
+{
+ return scm_from_long ((long) x);
+}
+SCM
+gh_ulong2scm (unsigned long x)
+{
+ return scm_from_ulong (x);
+}
+SCM
+gh_long2scm (long x)
+{
+ return scm_from_long (x);
+}
+SCM
+gh_double2scm (double x)
+{
+ return scm_from_double (x);
+}
+SCM
+gh_char2scm (char c)
+{
+ return SCM_MAKE_CHAR (c);
+}
+SCM
+gh_str2scm (const char *s, size_t len)
+{
+ return scm_from_locale_stringn (s, len);
+}
+SCM
+gh_str02scm (const char *s)
+{
+ return scm_from_locale_string (s);
+}
+/* Copy LEN characters at SRC into the *existing* Scheme string DST,
+ starting at START. START is an index into DST; zero means the
+ beginning of the string.
+
+ If START + LEN is off the end of DST, signal an out-of-range
+ error. */
+void
+gh_set_substr (const char *src, SCM dst, long start, size_t len)
+{
+ char *dst_ptr;
+ size_t dst_len;
+
+ SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
+
+ dst_len = scm_i_string_length (dst);
+ SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
+
+ dst_ptr = scm_i_string_writable_chars (dst);
+ memmove (dst_ptr + start, src, len);
+ scm_i_string_stop_writing ();
+ scm_remember_upto_here_1 (dst);
+}
+
+/* Return the symbol named SYMBOL_STR. */
+SCM
+gh_symbol2scm (const char *symbol_str)
+{
+ return scm_from_locale_symbol(symbol_str);
+}
+
+SCM
+gh_ints2scm (const int *d, long n)
+{
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+ for (i = 0; i < n; ++i)
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
+
+ return v;
+}
+
+SCM
+gh_doubles2scm (const double *d, long n)
+{
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
+
+ for(i = 0; i < n; i++)
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
+ return v;
+}
+
+
+SCM
+gh_chars2byvect (const char *d, long n)
+{
+ char *m = scm_malloc (n);
+ memcpy (m, d, n * sizeof (char));
+ return scm_take_s8vector ((scm_t_int8 *)m, n);
+}
+
+SCM
+gh_shorts2svect (const short *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (short));
+ memcpy (m, d, n * sizeof (short));
+ 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_malloc (n * sizeof (long));
+ memcpy (m, d, n * sizeof (long));
+ 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_malloc (n * sizeof (unsigned long));
+ memcpy (m, d, n * sizeof (unsigned long));
+ 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_malloc (n * sizeof (float));
+ memcpy (m, d, n * sizeof (float));
+ return scm_take_f32vector ((float *)m, n);
+}
+
+SCM
+gh_doubles2dvect (const double *d, long n)
+{
+ char *m = scm_malloc (n * sizeof (double));
+ memcpy (m, d, n * sizeof (double));
+ return scm_take_f64vector ((double *)m, n);
+}
+
+/* data conversion scheme->C */
+int
+gh_scm2bool (SCM obj)
+{
+ return (scm_is_false (obj)) ? 0 : 1;
+}
+unsigned long
+gh_scm2ulong (SCM obj)
+{
+ return scm_to_ulong (obj);
+}
+long
+gh_scm2long (SCM obj)
+{
+ return scm_to_long (obj);
+}
+int
+gh_scm2int (SCM obj)
+{
+ return scm_to_int (obj);
+}
+double
+gh_scm2double (SCM obj)
+{
+ return scm_to_double (obj);
+}
+char
+gh_scm2char (SCM obj)
+#define FUNC_NAME "gh_scm2char"
+{
+ SCM_VALIDATE_CHAR (SCM_ARG1, obj);
+ return SCM_CHAR (obj);
+}
+#undef FUNC_NAME
+
+/* Convert a vector, weak vector, string, substring or uniform vector
+ into an array of chars. If result array in arg 2 is NULL, malloc a
+ new one. If out of memory, return NULL. */
+char *
+gh_scm2chars (SCM obj, char *m)
+{
+ long i, n;
+ long v;
+ SCM val;
+ if (SCM_IMP (obj))
+ scm_wrong_type_arg (0, 0, obj);
+ switch (SCM_TYP7 (obj))
+ {
+ case scm_tc7_vector:
+ case scm_tc7_wvect:
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ {
+ v = SCM_I_INUM (val);
+ if (v < -128 || v > 255)
+ scm_out_of_range (0, obj);
+ }
+ else
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (char *) malloc (n * sizeof (char));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
+ break;
+ 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)
+ m = (char *) malloc (n * sizeof (char));
+ if (m == NULL)
+ return NULL;
+ 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. */
+short *
+gh_scm2shorts (SCM obj, short *m)
+{
+ long i, n;
+ long v;
+ 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_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
+ {
+ v = SCM_I_INUM (val);
+ if (v < -32768 || v > 65535)
+ scm_out_of_range (0, obj);
+ }
+ else
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (short *) malloc (n * sizeof (short));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ longs. If result array in arg 2 is NULL, malloc a new one. If out
+ of memory, return NULL. */
+long *
+gh_scm2longs (SCM obj, long *m)
+{
+ long i, n;
+ 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_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ if (m == 0)
+ m = (long *) malloc (n * sizeof (long));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++i)
+ {
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ m[i] = SCM_I_INUMP (val)
+ ? SCM_I_INUM (val)
+ : scm_to_long (val);
+ }
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ floats. If result array in arg 2 is NULL, malloc a new one. If
+ out of memory, return NULL. */
+float *
+gh_scm2floats (SCM obj, float *m)
+{
+ long i, n;
+ 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_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++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);
+ }
+ if (m == 0)
+ m = (float *) malloc (n * sizeof (float));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++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_to_long (val);
+ else
+ m[i] = SCM_REAL_VALUE (val);
+ }
+ break;
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* Convert a vector, weak vector or uniform vector into an array of
+ doubles. If result array in arg 2 is NULL, malloc a new one. If
+ out of memory, return NULL. */
+double *
+gh_scm2doubles (SCM obj, double *m)
+{
+ long i, n;
+ 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_SIMPLE_VECTOR_LENGTH (obj);
+ for (i = 0; i < n; ++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);
+ }
+ if (m == 0)
+ m = (double *) malloc (n * sizeof (double));
+ if (m == NULL)
+ return NULL;
+ for (i = 0; i < n; ++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_to_long (val);
+ else
+ m[i] = SCM_REAL_VALUE (val);
+ }
+ break;
+
+ default:
+ scm_wrong_type_arg (0, 0, obj);
+ }
+ return m;
+}
+
+/* string conversions between C and Scheme */
+
+/* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
+ new copy of its contents, followed by a null byte. If lenp is
+ non-null, set *lenp to the string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it. If out of memory, NULL is
+ returned.
+
+ Note that Scheme strings may contain arbitrary data, including null
+ characters. This means that null termination is not a reliable way
+ to determine the length of the returned value. However, the
+ function always copies the complete contents of STR, and sets
+ *LEN_P to the true length of the string (when LEN_P is non-null). */
+char *
+gh_scm2newstr (SCM str, size_t *lenp)
+{
+ char *ret_str;
+
+ /* We can't use scm_to_locale_stringn directly since it does not
+ guarantee null-termination when lenp is non-NULL.
+ */
+
+ ret_str = scm_to_locale_string (str);
+ if (lenp)
+ *lenp = scm_i_string_length (str);
+ return ret_str;
+}
+
+/* Copy LEN characters at START from the Scheme string SRC to memory
+ at DST. START is an index into SRC; zero means the beginning of
+ the string. DST has already been allocated by the caller.
+
+ If START + LEN is off the end of SRC, silently truncate the source
+ region to fit the string. If truncation occurs, the corresponding
+ area of DST is left unchanged. */
+void
+gh_get_substr (SCM src, char *dst, long start, size_t len)
+{
+ size_t src_len, effective_length;
+ SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
+
+ src_len = scm_i_string_length (src);
+ effective_length = (len < src_len) ? len : src_len;
+ memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
+ /* FIXME: must signal an error if len > src_len */
+ scm_remember_upto_here_1 (src);
+}
+
+
+/* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
+ pointer to a string with the symbol characters "identifier",
+ followed by a null byte. If lenp is non-null, set *lenp to the
+ string's length.
+
+ This function uses malloc to obtain storage for the copy; the
+ caller is responsible for freeing it. If out of memory, NULL is
+ returned.*/
+char *
+gh_symbol2newstr (SCM sym, size_t *lenp)
+{
+ return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
+}
+
+
+/* create a new vector of the given length, all initialized to the
+ given value */
+SCM
+gh_make_vector (SCM len, SCM fill)
+{
+ return scm_make_vector (len, fill);
+}
+
+/* set the given element of the given vector to the given value */
+SCM
+gh_vector_set_x (SCM vec, SCM pos, SCM val)
+{
+ return scm_vector_set_x (vec, pos, val);
+}
+
+/* retrieve the given element of the given vector */
+SCM
+gh_vector_ref (SCM vec, SCM pos)
+{
+ return scm_vector_ref (vec, pos);
+}
+
+/* returns the length of the given vector */
+unsigned long
+gh_vector_length (SCM v)
+{
+ return (unsigned long) scm_c_vector_length (v);
+}
+
+/* uniform vector support */
+
+/* returns the length as a C unsigned long integer */
+unsigned long
+gh_uniform_vector_length (SCM v)
+{
+ return (unsigned long) scm_c_uniform_vector_length (v);
+}
+
+/* gets the given element from a uniform vector; ilist is a list (or
+ possibly a single integer) of indices, and its length is the
+ dimension of the uniform vector */
+SCM
+gh_uniform_vector_ref (SCM v, SCM ilist)
+{
+ return scm_uniform_vector_ref (v, ilist);
+}
+
+/* sets an individual element in a uniform vector */
+/* SCM */
+/* gh_list_to_uniform_array ( */
+
+/* Data lookups between C and Scheme
+
+ Look up a symbol with a given name, and return the object to which
+ it is bound. gh_lookup examines the Guile top level, and
+ gh_module_lookup checks the module namespace specified by the
+ `vec' argument.
+
+ The return value is the Scheme object to which SNAME is bound, or
+ SCM_UNDEFINED if SNAME is not bound in the given context.
+ */
+
+SCM
+gh_lookup (const char *sname)
+{
+ return gh_module_lookup (scm_current_module (), sname);
+}
+
+
+SCM
+gh_module_lookup (SCM module, const char *sname)
+#define FUNC_NAME "gh_module_lookup"
+{
+ SCM sym, var;
+
+ SCM_VALIDATE_MODULE (SCM_ARG1, module);
+
+ sym = scm_from_locale_symbol (sname);
+ var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
+ if (var != SCM_BOOL_F)
+ return SCM_VARIABLE_REF (var);
+ else
+ return SCM_UNDEFINED;
+}
+#undef FUNC_NAME
+
+#endif /* SCM_ENABLE_DEPRECATED */
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
projects / lilypond.git / blobdiff