1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004, 2006 Free Software Foundation, Inc.
2 * This library is free software; you can redistribute it and/or
3 * modify it under the terms of the GNU Lesser General Public
4 * License as published by the Free Software Foundation; either
5 * version 2.1 of the License, or (at your option) any later version.
7 * This library is distributed in the hope that it will be useful,
8 * but WITHOUT ANY WARRANTY; without even the implied warranty of
9 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
10 * Lesser General Public License for more details.
12 * You should have received a copy of the GNU Lesser General Public
13 * License along with this library; if not, write to the Free Software
14 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18 /* data initialization and C<->Scheme data conversion */
24 #include "libguile/gh.h"
31 #if SCM_ENABLE_DEPRECATED
33 /* data conversion C->scheme */
38 return scm_from_bool(x);
43 return scm_from_long ((long) x);
46 gh_ulong2scm (unsigned long x)
48 return scm_from_ulong (x);
53 return scm_from_long (x);
56 gh_double2scm (double x)
58 return scm_from_double (x);
63 return SCM_MAKE_CHAR (c);
66 gh_str2scm (const char *s, size_t len)
68 return scm_from_locale_stringn (s, len);
71 gh_str02scm (const char *s)
73 return scm_from_locale_string (s);
75 /* Copy LEN characters at SRC into the *existing* Scheme string DST,
76 starting at START. START is an index into DST; zero means the
77 beginning of the string.
79 If START + LEN is off the end of DST, signal an out-of-range
82 gh_set_substr (const char *src, SCM dst, long start, size_t len)
87 SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
89 dst_len = scm_i_string_length (dst);
90 SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
92 dst_ptr = scm_i_string_writable_chars (dst);
93 memmove (dst_ptr + start, src, len);
94 scm_i_string_stop_writing ();
95 scm_remember_upto_here_1 (dst);
98 /* Return the symbol named SYMBOL_STR. */
100 gh_symbol2scm (const char *symbol_str)
102 return scm_from_locale_symbol(symbol_str);
106 gh_ints2scm (const int *d, long n)
109 SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
110 for (i = 0; i < n; ++i)
111 SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i]));
117 gh_doubles2scm (const double *d, long n)
120 SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
122 for(i = 0; i < n; i++)
123 SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
129 gh_chars2byvect (const char *d, long n)
131 char *m = scm_malloc (n);
132 memcpy (m, d, n * sizeof (char));
133 return scm_take_s8vector ((scm_t_int8 *)m, n);
137 gh_shorts2svect (const short *d, long n)
139 char *m = scm_malloc (n * sizeof (short));
140 memcpy (m, d, n * sizeof (short));
141 assert (sizeof (scm_t_int16) == sizeof (short));
142 return scm_take_s16vector ((scm_t_int16 *)m, n);
146 gh_longs2ivect (const long *d, long n)
148 char *m = scm_malloc (n * sizeof (long));
149 memcpy (m, d, n * sizeof (long));
150 assert (sizeof (scm_t_int32) == sizeof (long));
151 return scm_take_s32vector ((scm_t_int32 *)m, n);
155 gh_ulongs2uvect (const unsigned long *d, long n)
157 char *m = scm_malloc (n * sizeof (unsigned long));
158 memcpy (m, d, n * sizeof (unsigned long));
159 assert (sizeof (scm_t_uint32) == sizeof (unsigned long));
160 return scm_take_u32vector ((scm_t_uint32 *)m, n);
164 gh_floats2fvect (const float *d, long n)
166 char *m = scm_malloc (n * sizeof (float));
167 memcpy (m, d, n * sizeof (float));
168 return scm_take_f32vector ((float *)m, n);
172 gh_doubles2dvect (const double *d, long n)
174 char *m = scm_malloc (n * sizeof (double));
175 memcpy (m, d, n * sizeof (double));
176 return scm_take_f64vector ((double *)m, n);
179 /* data conversion scheme->C */
181 gh_scm2bool (SCM obj)
183 return (scm_is_false (obj)) ? 0 : 1;
186 gh_scm2ulong (SCM obj)
188 return scm_to_ulong (obj);
191 gh_scm2long (SCM obj)
193 return scm_to_long (obj);
198 return scm_to_int (obj);
201 gh_scm2double (SCM obj)
203 return scm_to_double (obj);
206 gh_scm2char (SCM obj)
207 #define FUNC_NAME "gh_scm2char"
209 SCM_VALIDATE_CHAR (SCM_ARG1, obj);
210 return SCM_CHAR (obj);
214 /* Convert a vector, weak vector, string, substring or uniform vector
215 into an array of chars. If result array in arg 2 is NULL, malloc a
216 new one. If out of memory, return NULL. */
218 gh_scm2chars (SCM obj, char *m)
224 scm_wrong_type_arg (0, 0, obj);
225 switch (SCM_TYP7 (obj))
229 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
230 for (i = 0; i < n; ++i)
232 val = SCM_SIMPLE_VECTOR_REF (obj, i);
233 if (SCM_I_INUMP (val))
235 v = SCM_I_INUM (val);
236 if (v < -128 || v > 255)
237 scm_out_of_range (0, obj);
240 scm_wrong_type_arg (0, 0, obj);
243 m = (char *) malloc (n * sizeof (char));
246 for (i = 0; i < n; ++i)
247 m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
250 if (scm_is_true (scm_s8vector_p (obj)))
252 scm_t_array_handle handle;
255 const scm_t_int8 *elts;
257 elts = scm_s8vector_elements (obj, &handle, &len, &inc);
259 scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
262 m = (char *) malloc (len);
264 memcpy (m, elts, len);
265 scm_array_handle_release (&handle);
273 n = scm_i_string_length (obj);
275 m = (char *) malloc (n * sizeof (char));
278 memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
282 scm_wrong_type_arg (0, 0, obj);
288 scm2whatever (SCM obj, void *m, size_t size)
290 scm_t_array_handle handle;
295 elts = scm_uniform_vector_elements (obj, &handle, &len, &inc);
298 scm_misc_error (NULL, "only contiguous vectors can be converted: ~a",
302 m = malloc (len * sizeof (size));
304 memcpy (m, elts, len * size);
306 scm_array_handle_release (&handle);
311 #define SCM2WHATEVER(obj,pred,utype,mtype) \
312 if (scm_is_true (pred (obj))) \
314 assert (sizeof (utype) == sizeof (mtype)); \
315 return (mtype *)scm2whatever (obj, m, sizeof (utype)); \
318 /* Convert a vector, weak vector or uniform vector into an array of
319 shorts. If result array in arg 2 is NULL, malloc a new one. If
320 out of memory, return NULL. */
322 gh_scm2shorts (SCM obj, short *m)
328 scm_wrong_type_arg (0, 0, obj);
330 SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short)
332 switch (SCM_TYP7 (obj))
336 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
337 for (i = 0; i < n; ++i)
339 val = SCM_SIMPLE_VECTOR_REF (obj, i);
340 if (SCM_I_INUMP (val))
342 v = SCM_I_INUM (val);
343 if (v < -32768 || v > 65535)
344 scm_out_of_range (0, obj);
347 scm_wrong_type_arg (0, 0, obj);
350 m = (short *) malloc (n * sizeof (short));
353 for (i = 0; i < n; ++i)
354 m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
357 scm_wrong_type_arg (0, 0, obj);
362 /* Convert a vector, weak vector or uniform vector into an array of
363 longs. If result array in arg 2 is NULL, malloc a new one. If out
364 of memory, return NULL. */
366 gh_scm2longs (SCM obj, long *m)
371 scm_wrong_type_arg (0, 0, obj);
373 SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long)
375 switch (SCM_TYP7 (obj))
379 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
380 for (i = 0; i < n; ++i)
382 val = SCM_SIMPLE_VECTOR_REF (obj, i);
383 if (!SCM_I_INUMP (val) && !SCM_BIGP (val))
384 scm_wrong_type_arg (0, 0, obj);
387 m = (long *) malloc (n * sizeof (long));
390 for (i = 0; i < n; ++i)
392 val = SCM_SIMPLE_VECTOR_REF (obj, i);
393 m[i] = SCM_I_INUMP (val)
399 scm_wrong_type_arg (0, 0, obj);
404 /* Convert a vector, weak vector or uniform vector into an array of
405 floats. If result array in arg 2 is NULL, malloc a new one. If
406 out of memory, return NULL. */
408 gh_scm2floats (SCM obj, float *m)
413 scm_wrong_type_arg (0, 0, obj);
415 /* XXX - f64vectors are rejected now.
417 SCM2WHATEVER (obj, scm_f32vector_p, float, float)
419 switch (SCM_TYP7 (obj))
423 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
424 for (i = 0; i < n; ++i)
426 val = SCM_SIMPLE_VECTOR_REF (obj, i);
427 if (!SCM_I_INUMP (val)
428 && !(SCM_BIGP (val) || SCM_REALP (val)))
429 scm_wrong_type_arg (0, 0, val);
432 m = (float *) malloc (n * sizeof (float));
435 for (i = 0; i < n; ++i)
437 val = SCM_SIMPLE_VECTOR_REF (obj, i);
438 if (SCM_I_INUMP (val))
439 m[i] = SCM_I_INUM (val);
440 else if (SCM_BIGP (val))
441 m[i] = scm_to_long (val);
443 m[i] = SCM_REAL_VALUE (val);
447 scm_wrong_type_arg (0, 0, obj);
452 /* Convert a vector, weak vector or uniform vector into an array of
453 doubles. If result array in arg 2 is NULL, malloc a new one. If
454 out of memory, return NULL. */
456 gh_scm2doubles (SCM obj, double *m)
461 scm_wrong_type_arg (0, 0, obj);
463 /* XXX - f32vectors are rejected now.
465 SCM2WHATEVER (obj, scm_f64vector_p, double, double)
467 switch (SCM_TYP7 (obj))
471 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
472 for (i = 0; i < n; ++i)
474 val = SCM_SIMPLE_VECTOR_REF (obj, i);
475 if (!SCM_I_INUMP (val)
476 && !(SCM_BIGP (val) || SCM_REALP (val)))
477 scm_wrong_type_arg (0, 0, val);
480 m = (double *) malloc (n * sizeof (double));
483 for (i = 0; i < n; ++i)
485 val = SCM_SIMPLE_VECTOR_REF (obj, i);
486 if (SCM_I_INUMP (val))
487 m[i] = SCM_I_INUM (val);
488 else if (SCM_BIGP (val))
489 m[i] = scm_to_long (val);
491 m[i] = SCM_REAL_VALUE (val);
496 scm_wrong_type_arg (0, 0, obj);
501 /* string conversions between C and Scheme */
503 /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a
504 new copy of its contents, followed by a null byte. If lenp is
505 non-null, set *lenp to the string's length.
507 This function uses malloc to obtain storage for the copy; the
508 caller is responsible for freeing it. If out of memory, NULL is
511 Note that Scheme strings may contain arbitrary data, including null
512 characters. This means that null termination is not a reliable way
513 to determine the length of the returned value. However, the
514 function always copies the complete contents of STR, and sets
515 *LEN_P to the true length of the string (when LEN_P is non-null). */
517 gh_scm2newstr (SCM str, size_t *lenp)
521 /* We can't use scm_to_locale_stringn directly since it does not
522 guarantee null-termination when lenp is non-NULL.
525 ret_str = scm_to_locale_string (str);
527 *lenp = scm_i_string_length (str);
531 /* Copy LEN characters at START from the Scheme string SRC to memory
532 at DST. START is an index into SRC; zero means the beginning of
533 the string. DST has already been allocated by the caller.
535 If START + LEN is off the end of SRC, silently truncate the source
536 region to fit the string. If truncation occurs, the corresponding
537 area of DST is left unchanged. */
539 gh_get_substr (SCM src, char *dst, long start, size_t len)
541 size_t src_len, effective_length;
542 SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
544 src_len = scm_i_string_length (src);
545 effective_length = (len < src_len) ? len : src_len;
546 memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char));
547 /* FIXME: must signal an error if len > src_len */
548 scm_remember_upto_here_1 (src);
552 /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a
553 pointer to a string with the symbol characters "identifier",
554 followed by a null byte. If lenp is non-null, set *lenp to the
557 This function uses malloc to obtain storage for the copy; the
558 caller is responsible for freeing it. If out of memory, NULL is
561 gh_symbol2newstr (SCM sym, size_t *lenp)
563 return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
567 /* create a new vector of the given length, all initialized to the
570 gh_make_vector (SCM len, SCM fill)
572 return scm_make_vector (len, fill);
575 /* set the given element of the given vector to the given value */
577 gh_vector_set_x (SCM vec, SCM pos, SCM val)
579 return scm_vector_set_x (vec, pos, val);
582 /* retrieve the given element of the given vector */
584 gh_vector_ref (SCM vec, SCM pos)
586 return scm_vector_ref (vec, pos);
589 /* returns the length of the given vector */
591 gh_vector_length (SCM v)
593 return (unsigned long) scm_c_vector_length (v);
596 /* uniform vector support */
598 /* returns the length as a C unsigned long integer */
600 gh_uniform_vector_length (SCM v)
602 return (unsigned long) scm_c_uniform_vector_length (v);
605 /* gets the given element from a uniform vector; ilist is a list (or
606 possibly a single integer) of indices, and its length is the
607 dimension of the uniform vector */
609 gh_uniform_vector_ref (SCM v, SCM ilist)
611 return scm_uniform_vector_ref (v, ilist);
614 /* sets an individual element in a uniform vector */
616 /* gh_list_to_uniform_array ( */
618 /* Data lookups between C and Scheme
620 Look up a symbol with a given name, and return the object to which
621 it is bound. gh_lookup examines the Guile top level, and
622 gh_module_lookup checks the module namespace specified by the
625 The return value is the Scheme object to which SNAME is bound, or
626 SCM_UNDEFINED if SNAME is not bound in the given context.
630 gh_lookup (const char *sname)
632 return gh_module_lookup (scm_current_module (), sname);
637 gh_module_lookup (SCM module, const char *sname)
638 #define FUNC_NAME "gh_module_lookup"
642 SCM_VALIDATE_MODULE (SCM_ARG1, module);
644 sym = scm_from_locale_symbol (sname);
645 var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F);
646 if (var != SCM_BOOL_F)
647 return SCM_VARIABLE_REF (var);
649 return SCM_UNDEFINED;
653 #endif /* SCM_ENABLE_DEPRECATED */