X-Git-Url: https://git.donarmstrong.com/?a=blobdiff_plain;f=guile18%2Flibguile%2Fgh_data.c;fp=guile18%2Flibguile%2Fgh_data.c;h=101d0fbb39affa14437c25d0938f9d86a6b58541;hb=139c38d9204dd07f6b235f83bae644faedbc63fd;hp=0000000000000000000000000000000000000000;hpb=652ed35a2013489d0a14fede6307cd2595abb2c4;p=lilypond.git diff --git a/guile18/libguile/gh_data.c b/guile18/libguile/gh_data.c new file mode 100644 index 0000000000..101d0fbb39 --- /dev/null +++ b/guile18/libguile/gh_data.c @@ -0,0 +1,659 @@ +/* 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 + */ + + +/* data initialization and C<->Scheme data conversion */ + +#ifdef 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_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: +*/