-/* Copyright (C) 1995,1996,1987 Free Software Foundation, Inc.
-
- * This program is free software; you can redistribute it and/or modify
- * it under the terms of the GNU General Public License as published by
- * the Free Software Foundation; either version 2, or (at your option)
- * any later version.
- *
- * This program is distributed in the hope that it will be useful,
- * but WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- * GNU General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
- *
- * As a special exception, the Free Software Foundation gives permission
- * for additional uses of the text contained in its release of GUILE.
- *
- * The exception is that, if you link the GUILE library with other files
- * to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public License.
- * Your use of that executable is in no way restricted on account of
- * linking the GUILE library code into it.
- *
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public License.
- *
- * This exception applies only to the code released by the
- * Free Software Foundation under the name GUILE. If you copy
- * code from other Free Software Foundation releases into a copy of
- * GUILE, as the General Public License permits, the exception does
- * not apply to the code that you add in this way. To avoid misleading
- * anyone as to the status of such modified files, you must delete
- * this exception notice from them.
- *
- * 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.
- */
-\f
-
-/* data initialization and C<->Scheme data conversion */
-
-#include <stdio.h>
-
-#include <gh.h>
-
-/* data conversion C->scheme */
-SCM
-gh_int2scmb (int x)
-{
- return (x ? SCM_BOOL_T : SCM_BOOL_F);
-}
-SCM
-gh_int2scm (int x)
-{
- return scm_long2num ((long) x);
-}
-SCM
-gh_ulong2scm (unsigned long x)
-{
- return scm_ulong2num (x);
-}
-SCM
-gh_long2scm (long x)
-{
- return scm_long2num (x);
-}
-SCM
-gh_double2scm (double x)
-{
- return scm_makdbl (x, 0.0);
-}
-SCM
-gh_char2scm (char c)
-{
- return SCM_MAKICHR (c);
-}
-SCM
-gh_str2scm (char *s, int len)
-{
- return scm_makfromstr (s, len, 0);
-}
-SCM
-gh_str02scm (char *s)
-{
- return scm_makfrom0str (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 (char *src, SCM dst, int start, int len)
-{
- char *dst_ptr, dst_len, effective_length;
-
- SCM_ASSERT (SCM_NIMP (dst) && SCM_STRINGP (dst), dst, SCM_ARG3,
- "gh_set_substr");
- scm_protect_object (dst);
- dst_ptr = SCM_CHARS (dst);
- dst_len = SCM_LENGTH (dst);
- effective_length = (len < dst_len) ? len : dst_len;
- memcpy (dst_ptr + start, src, effective_length);
- /* FIXME: must signal an error if len > dst_len */
- scm_unprotect_object (dst);
-}
-
-/* Return the symbol named SYMBOL_STR. */
-SCM
-gh_symbol2scm (char *symbol_str)
-{
- return SCM_CAR (scm_intern (symbol_str, strlen (symbol_str)));
-}
-
-
-/* data conversion scheme->C */
-int
-gh_scm2bool (SCM obj)
-{
- return ((obj) == SCM_BOOL_F) ? 0 : 1;
-}
-unsigned long
-gh_scm2ulong (SCM obj)
-{
- return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong");
-}
-long
-gh_scm2long (SCM obj)
-{
- return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long");
-}
-int
-gh_scm2int (SCM obj)
-{
- /* NOTE: possible loss of precision here */
- return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int");
-}
-double
-gh_scm2double (SCM obj)
-{
- return scm_num2dbl (obj, "gh_scm2double");
-}
-char
-gh_scm2char (SCM obj)
-{
- return SCM_ICHR (obj);
-}
-
-/* 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.
-
- 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, int *lenp)
-{
- char *ret_str;
- int len;
-
- SCM_ASSERT (SCM_NIMP (str) && SCM_STRINGP (str), str, SCM_ARG3,
- "gh_scm2newstr");
-
- /* protect str from GC while we copy off its data */
- scm_protect_object (str);
-
- len = SCM_LENGTH (str);
-
- ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
- "gh_scm2newstr");
- /* so we copy tmp_str to ret_str, which is what we will allocate */
- memcpy (ret_str, SCM_CHARS (str), len);
- /* now make sure we null-terminate it */
- ret_str[len] = '\0';
-
- scm_unprotect_object (str);
-
- if (lenp != NULL)
- {
- *lenp = len;
- }
-
- 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, int start, int len)
-{
- int src_len, effective_length;
- SCM_ASSERT (SCM_NIMP (src) && SCM_STRINGP (src), src, SCM_ARG3,
- "gh_get_substr");
-
- scm_protect_object (src);
- src_len = SCM_LENGTH (src);
- effective_length = (len < src_len) ? len : src_len;
- memcpy (dst + start, SCM_CHARS (src), effective_length * sizeof (char));
- /* FIXME: must signal an error if len > src_len */
- scm_unprotect_object (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. */
-char *
-gh_symbol2newstr (SCM sym, int *lenp)
-{
- char *ret_str;
- int len;
-
- SCM_ASSERT (SCM_NIMP (sym) && SCM_SYMBOLP (sym), sym, SCM_ARG3,
- "gh_scm2newsymbol");
-
- /* protect str from GC while we copy off its data */
- scm_protect_object (sym);
-
- len = SCM_LENGTH (sym);
-
- ret_str = (char *) scm_must_malloc ((len + 1) * sizeof (char),
- "gh_symbol2newstr");
- /* so we copy tmp_str to ret_str, which is what we will allocate */
- memcpy (ret_str, SCM_CHARS (sym), len);
- /* now make sure we null-terminate it */
- ret_str[len] = '\0';
-
- scm_unprotect_object (sym);
-
- if (lenp != NULL)
- {
- *lenp = len;
- }
-
- return ret_str;
-}
-
-
-/* create a new vector of the given length, all initialized to the
- given value */
-SCM
-gh_vector (SCM length, SCM val)
-{
- return scm_make_vector (length, val, SCM_UNDEFINED);
-}
-
-/* set the given element of the given vector to the given value */
-SCM
-gh_vset (SCM vec, SCM pos, SCM val)
-{
- return scm_vector_set_x (vec, pos, val);
-}
-
-/* retrieve the given element of the given vector */
-SCM
-gh_vref (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 gh_scm2ulong (scm_vector_length (v));
-}
-
-/* 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. [FIXME:
- should this be SCM_UNSPECIFIED? Can a symbol ever legitimately be
- bound to SCM_UNDEFINED or SCM_UNSPECIFIED? What is the difference?
- -twp] */
-
-SCM
-gh_lookup (char *sname)
-{
- return gh_module_lookup (SCM_BOOL_F, sname);
-}
-
-SCM
-gh_module_lookup (SCM vec, char *sname)
-{
- SCM sym = gh_symbol2scm (sname);
- if ((scm_symbol_bound_p (vec, sym)) == SCM_BOOL_T)
- return scm_symbol_binding (vec, sym);
- else
- return SCM_UNDEFINED;
-}
+/* 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 */
+
+#if 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:
+*/
HCoop / bpt / guile.git / blobdiff