-/* Copyright (C) 1995,1996,1997,1998, 1999, 2000 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, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 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.
+/* 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 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.
+ * 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.
*
- * 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. */
+ * 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 */
-#include <stdio.h>
+#if HAVE_CONFIG_H
+# include <config.h>
+#endif
#include "libguile/gh.h"
#ifdef HAVE_STRING_H
#include <string.h>
#endif
-/* data conversion C->scheme */
-
-#if (SCM_DEBUG_DEPRECATED == 0)
+#include <assert.h>
-SCM
-gh_int2scmb (int x) /* this is being phased out */
-{
- return SCM_BOOL(x);
-}
+#if SCM_ENABLE_DEPRECATED
-#endif /* SCM_DEBUG_DEPRECATED == 0 */
+/* data conversion C->scheme */
SCM
gh_bool2scm (int x)
{
- return SCM_BOOL(x);
+ return scm_from_bool(x);
}
SCM
gh_int2scm (int x)
{
- return scm_long2num ((long) x);
+ return scm_from_long ((long) x);
}
SCM
gh_ulong2scm (unsigned long x)
{
- return scm_ulong2num (x);
+ return scm_from_ulong (x);
}
SCM
gh_long2scm (long x)
{
- return scm_long2num (x);
+ return scm_from_long (x);
}
SCM
gh_double2scm (double x)
{
- return scm_make_real (x);
+ return scm_from_double (x);
}
SCM
gh_char2scm (char c)
return SCM_MAKE_CHAR (c);
}
SCM
-gh_str2scm (const char *s, int len)
+gh_str2scm (const char *s, size_t len)
{
- return scm_makfromstr (s, len, 0);
+ return scm_from_locale_stringn (s, len);
}
SCM
gh_str02scm (const char *s)
{
- return scm_makfrom0str (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
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)
+gh_set_substr (const char *src, SCM dst, long start, size_t len)
{
char *dst_ptr;
- unsigned long dst_len;
- unsigned long effective_length;
+ size_t dst_len;
- SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3,
- "gh_set_substr");
+ SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
- dst_ptr = SCM_STRING_CHARS (dst);
- dst_len = SCM_STRING_LENGTH (dst);
- SCM_ASSERT (len >= 0 && (unsigned) len <= dst_len,
- dst, SCM_ARG4, "gh_set_substr");
-
- scm_protect_object (dst);
- effective_length = ((unsigned) len < dst_len) ? len : dst_len;
- memmove (dst_ptr + start, src, effective_length);
- scm_unprotect_object (dst);
+ 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_CAR (scm_intern (symbol_str, strlen (symbol_str)));
+ return scm_from_locale_symbol(symbol_str);
}
SCM
-gh_ints2scm (int *d, int n)
+gh_ints2scm (const int *d, long n)
{
- int i;
- SCM v = scm_make_vector(SCM_MAKINUM(n), SCM_UNSPECIFIED);
- SCM *velts = SCM_VELTS(v);
-
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for (i = 0; i < n; ++i)
- velts[i] = (d[i] >= SCM_MOST_NEGATIVE_FIXNUM
- && d[i] <= SCM_MOST_POSITIVE_FIXNUM
- ? SCM_MAKINUM (d[i])
- : scm_long2big (d[i]));
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
+
return v;
}
SCM
-gh_doubles2scm (const double *d, int n)
+gh_doubles2scm (const double *d, long n)
{
- int i;
- SCM v = scm_make_vector(SCM_MAKINUM(n), SCM_UNSPECIFIED);
- SCM *velts = SCM_VELTS(v);
+ long i;
+ SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
for(i = 0; i < n; i++)
- velts[i] = scm_make_real (d[i]);
+ SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
return v;
}
-#ifdef 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, int len, int type)
-{
- SCM ans;
- SCM_NEWCELL (ans);
- SCM_DEFER_INTS;
- SCM_SETCHARS (ans, m);
- SCM_SETLENGTH (ans, len, type);
- SCM_ALLOW_INTS;
- return ans;
-}
SCM
-gh_chars2byvect (const char *d, int n)
+gh_chars2byvect (const char *d, long n)
{
- char *m = scm_must_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, int n)
+gh_shorts2svect (const short *d, long n)
{
- char *m = scm_must_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, int n)
+gh_longs2ivect (const long *d, long n)
{
- char *m = scm_must_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, int n)
+gh_ulongs2uvect (const unsigned long *d, long n)
{
- char *m = scm_must_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, int n)
+gh_floats2fvect (const float *d, long n)
{
- char *m = scm_must_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, int n)
+gh_doubles2dvect (const double *d, long n)
{
- char *m = scm_must_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
gh_scm2bool (SCM obj)
{
- return (SCM_FALSEP (obj)) ? 0 : 1;
+ return (scm_is_false (obj)) ? 0 : 1;
}
unsigned long
gh_scm2ulong (SCM obj)
{
- return scm_num2ulong (obj, (char *) SCM_ARG1, "gh_scm2ulong");
+ return scm_to_ulong (obj);
}
long
gh_scm2long (SCM obj)
{
- return scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2long");
+ return scm_to_long (obj);
}
int
gh_scm2int (SCM obj)
{
- /* NOTE: possible loss of precision here */
- return (int) scm_num2long (obj, (char *) SCM_ARG1, "gh_scm2int");
+ return scm_to_int (obj);
}
double
gh_scm2double (SCM obj)
{
- return scm_num2dbl (obj, "gh_scm2double");
+ return scm_to_double (obj);
}
char
gh_scm2char (SCM obj)
SCM_VALIDATE_CHAR (SCM_ARG1, obj);
return SCM_CHAR (obj);
}
-#undef FUNC_NAME;
+#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. */
+ new one. If out of memory, return NULL. */
char *
gh_scm2chars (SCM obj, char *m)
{
- int i, n;
+ long i, n;
long v;
SCM val;
if (SCM_IMP (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];
- if (SCM_INUMP (val))
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
{
- v = SCM_INUM (val);
+ v = SCM_I_INUM (val);
if (v < -128 || v > 255)
scm_out_of_range (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_INUM (SCM_VELTS (obj)[i]);
+ m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
break;
-#ifdef HAVE_ARRAYS
- case scm_tc7_byvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (char *) malloc (n * sizeof (char));
- memcpy (m, SCM_VELTS (obj), n * sizeof (char));
- 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:
- case scm_tc7_substring:
- n = SCM_STRING_LENGTH (obj);
+ n = scm_i_string_length (obj);
if (m == 0)
m = (char *) malloc (n * sizeof (char));
- memcpy (m, SCM_VELTS (obj), 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. */
+ 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)
{
- int i, n;
+ 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_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
- if (SCM_INUMP (val))
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ if (SCM_I_INUMP (val))
{
- v = SCM_INUM (val);
+ v = SCM_I_INUM (val);
if (v < -32768 || v > 65535)
scm_out_of_range (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_INUM (SCM_VELTS (obj)[i]);
- break;
-#ifdef HAVE_ARRAYS
- case scm_tc7_svect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (short *) malloc (n * sizeof (short));
- 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);
}
}
/* 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. */
+ 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)
{
- int i, n;
+ 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_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
- if (!SCM_INUMP (val) && !SCM_BIGP (val))
+ 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_VELTS (obj)[i];
- m[i] = SCM_INUMP (val) ? SCM_INUM (val) : scm_num2long (val, 0, 0);
+ val = SCM_SIMPLE_VECTOR_REF (obj, i);
+ m[i] = SCM_I_INUMP (val)
+ ? SCM_I_INUM (val)
+ : scm_to_long (val);
}
break;
-#ifdef HAVE_ARRAYS
- case scm_tc7_ivect:
- case scm_tc7_uvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (long *) malloc (n * sizeof (long));
- memcpy (m, SCM_VELTS (obj), n * sizeof (long));
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
}
/* 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. */
+ 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)
{
- int i, n;
+ 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_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
- if (!SCM_INUMP (val)
+ 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_VELTS (obj)[i];
- if (SCM_INUMP (val))
- m[i] = SCM_INUM (val);
+ 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_num2long (val, 0, 0);
+ m[i] = scm_to_long (val);
else
m[i] = SCM_REAL_VALUE (val);
}
break;
-#ifdef HAVE_ARRAYS
- case scm_tc7_fvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (float *) malloc (n * sizeof (float));
- 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));
- for (i = 0; i < n; ++i)
- m[i] = ((double *) SCM_VELTS (obj))[i];
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
}
/* 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. */
+ 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)
{
- int i, n;
+ 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_VECTOR_LENGTH (obj);
+ n = SCM_SIMPLE_VECTOR_LENGTH (obj);
for (i = 0; i < n; ++i)
{
- val = SCM_VELTS (obj)[i];
- if (!SCM_INUMP (val)
+ 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_VELTS (obj)[i];
- if (SCM_INUMP (val))
- m[i] = SCM_INUM (val);
+ 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_num2long (val, 0, 0);
+ m[i] = scm_to_long (val);
else
m[i] = SCM_REAL_VALUE (val);
}
break;
-#ifdef HAVE_ARRAYS
- case scm_tc7_fvect:
- n = SCM_UVECTOR_LENGTH (obj);
- if (m == 0)
- m = (double *) malloc (n * sizeof (double));
- 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));
- memcpy (m, SCM_VELTS (obj), n * sizeof (double));
- break;
-#endif
default:
scm_wrong_type_arg (0, 0, obj);
}
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.
+ 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
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)
+gh_scm2newstr (SCM str, size_t *lenp)
{
char *ret_str;
- int len;
-
- SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr");
-
- /* protect str from GC while we copy off its data */
- scm_protect_object (str);
- len = SCM_STRING_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_ROCHARS (str), len); /* test ROCHARS here -twp */
- /* now make sure we null-terminate it */
- ret_str[len] = '\0';
-
- scm_unprotect_object (str);
-
- if (lenp != NULL)
- {
- *lenp = len;
- }
+ /* 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.
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)
+gh_get_substr (SCM src, char *dst, long start, size_t len)
{
- int src_len, effective_length;
- SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr");
+ size_t src_len, effective_length;
+ SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
- scm_protect_object (src);
- src_len = SCM_STRING_LENGTH (src);
+ src_len = scm_i_string_length (src);
effective_length = (len < src_len) ? len : src_len;
- memcpy (dst + start, SCM_ROCHARS (src), effective_length * sizeof (char));
+ memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
/* FIXME: must signal an error if len > src_len */
- scm_unprotect_object (src);
+ scm_remember_upto_here_1 (src);
}
string's length.
This function uses malloc to obtain storage for the copy; the
- caller is responsible for freeing it. */
+ caller is responsible for freeing it. If out of memory, NULL is
+ returned.*/
char *
-gh_symbol2newstr (SCM sym, int *lenp)
+gh_symbol2newstr (SCM sym, size_t *lenp)
{
- char *ret_str;
- int len;
-
- SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3,
- "gh_scm2newsymbol");
-
- /* protect str from GC while we copy off its data */
- scm_protect_object (sym);
-
- len = SCM_SYMBOL_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_SYMBOL_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;
+ return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
}
unsigned long
gh_vector_length (SCM v)
{
- return gh_scm2ulong (scm_vector_length (v));
+ return (unsigned long) scm_c_vector_length (v);
}
-#ifdef HAVE_ARRAYS
/* uniform vector support */
/* returns the length as a C unsigned long integer */
unsigned long
gh_uniform_vector_length (SCM v)
{
- return gh_scm2ulong (scm_uniform_vector_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
`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_UNDEFINED if SNAME is not bound in the given context.
+ */
SCM
gh_lookup (const char *sname)
{
- return gh_module_lookup (SCM_BOOL_F, sname);
+ return gh_module_lookup (scm_current_module (), sname);
}
+
SCM
-gh_module_lookup (SCM vec, const char *sname)
+gh_module_lookup (SCM module, const char *sname)
+#define FUNC_NAME "gh_module_lookup"
{
- SCM sym = gh_symbol2scm (sname);
- if (SCM_EQ_P (scm_symbol_bound_p (vec, sym), SCM_BOOL_T))
- return scm_symbol_binding (vec, sym);
+ 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:
HCoop / bpt / guile.git / blobdiff