X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/f8de44c154ea87436f8c8a635b4ea72bd4d65ea4..aa092c5d7f83a9b5d0cd5d168f1d4e45a42de25a:/libguile/gh_data.c diff --git a/libguile/gh_data.c b/libguile/gh_data.c index 4d7a55af4..d0423f7dd 100644 --- a/libguile/gh_data.c +++ b/libguile/gh_data.c @@ -1,83 +1,61 @@ -/* 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 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 + */ /* data initialization and C<->Scheme data conversion */ -#include +#if HAVE_CONFIG_H +# include +#endif #include "libguile/gh.h" #ifdef HAVE_STRING_H #include #endif +#include + +#if SCM_ENABLE_DEPRECATED + /* data conversion C->scheme */ -SCM -gh_int2scmb (int x) /* this is being phased out */ -{ - return SCM_BOOL(x); -} + 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) @@ -85,14 +63,14 @@ 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 @@ -101,180 +79,160 @@ gh_str02scm (const char *s) 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_is_string (dst), dst, SCM_ARG3, "gh_set_substr"); - SCM_ASSERT (SCM_STRINGP (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_CHARS (dst); - dst_len = SCM_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_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 (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 (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 (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 (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 (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 (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 (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) +#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. */ + 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_NIMP (obj)) + 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_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); } @@ -283,46 +241,105 @@ gh_scm2chars (SCM obj, char *m) } 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: -#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_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_NIMP (obj)) + 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_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); } @@ -331,17 +348,11 @@ gh_scm2shorts (SCM obj, short *m) } 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_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); } @@ -349,42 +360,41 @@ gh_scm2shorts (SCM obj, short *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. */ + 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_NIMP (obj)) + 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_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_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); } @@ -392,55 +402,47 @@ gh_scm2longs (SCM obj, long *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. */ + 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_NIMP (obj)) + 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_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_REALPART (val); + m[i] = SCM_REAL_VALUE (val); } break; -#ifdef HAVE_ARRAYS - case scm_tc7_fvect: - n = SCM_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_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); } @@ -448,55 +450,48 @@ gh_scm2floats (SCM obj, float *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. */ + 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_NIMP (obj)) + 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_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_REALPART (val); + m[i] = SCM_REAL_VALUE (val); } break; -#ifdef HAVE_ARRAYS - case scm_tc7_fvect: - n = SCM_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_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); } @@ -510,7 +505,8 @@ gh_scm2doubles (SCM obj, double *m) 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 @@ -518,37 +514,20 @@ gh_scm2doubles (SCM obj, double *m) 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_ROSTRINGP (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_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. @@ -557,18 +536,16 @@ gh_scm2newstr (SCM str, int *lenp) 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_ROSTRINGP (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_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); } @@ -578,36 +555,12 @@ gh_get_substr (SCM src, char *dst, int start, int len) 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_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; + return gh_scm2newstr (scm_symbol_to_string (sym), lenp); } @@ -637,17 +590,16 @@ gh_vector_ref (SCM vec, SCM pos) 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 @@ -662,7 +614,6 @@ gh_uniform_vector_ref (SCM v, SCM ilist) /* sets an individual element in a uniform vector */ /* SCM */ /* gh_list_to_uniform_array ( */ -#endif /* Data lookups between C and Scheme @@ -672,26 +623,34 @@ gh_uniform_vector_ref (SCM v, SCM ilist) `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 (char *sname) +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, char *sname) +gh_module_lookup (SCM module, const char *sname) +#define FUNC_NAME "gh_module_lookup" { - SCM sym = gh_symbol2scm (sname); - if (SCM_TRUE_P (scm_symbol_bound_p (vec, sym))) - 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: