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.
6 *
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.
11 *
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
15 */
16
17
18 /* data initialization and C<->Scheme data conversion */
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include "libguile/gh.h"
25 #ifdef HAVE_STRING_H
26 #include <string.h>
27 #endif
28
29 #include <assert.h>
30
31 #if SCM_ENABLE_DEPRECATED
32
33 /* data conversion C->scheme */
34
35 SCM
gh_bool2scm(int x)36 gh_bool2scm (int x)
37 {
38 return scm_from_bool(x);
39 }
40 SCM
gh_int2scm(int x)41 gh_int2scm (int x)
42 {
43 return scm_from_long ((long) x);
44 }
45 SCM
gh_ulong2scm(unsigned long x)46 gh_ulong2scm (unsigned long x)
47 {
48 return scm_from_ulong (x);
49 }
50 SCM
gh_long2scm(long x)51 gh_long2scm (long x)
52 {
53 return scm_from_long (x);
54 }
55 SCM
gh_double2scm(double x)56 gh_double2scm (double x)
57 {
58 return scm_from_double (x);
59 }
60 SCM
gh_char2scm(char c)61 gh_char2scm (char c)
62 {
63 return SCM_MAKE_CHAR (c);
64 }
65 SCM
gh_str2scm(const char * s,size_t len)66 gh_str2scm (const char *s, size_t len)
67 {
68 return scm_from_locale_stringn (s, len);
69 }
70 SCM
gh_str02scm(const char * s)71 gh_str02scm (const char *s)
72 {
73 return scm_from_locale_string (s);
74 }
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.
78
79 If START + LEN is off the end of DST, signal an out-of-range
80 error. */
81 void
gh_set_substr(const char * src,SCM dst,long start,size_t len)82 gh_set_substr (const char *src, SCM dst, long start, size_t len)
83 {
84 char *dst_ptr;
85 size_t dst_len;
86
87 SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr");
88
89 dst_len = scm_i_string_length (dst);
90 SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr");
91
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);
96 }
97
98 /* Return the symbol named SYMBOL_STR. */
99 SCM
gh_symbol2scm(const char * symbol_str)100 gh_symbol2scm (const char *symbol_str)
101 {
102 return scm_from_locale_symbol(symbol_str);
103 }
104
105 SCM
gh_ints2scm(const int * d,long n)106 gh_ints2scm (const int *d, long n)
107 {
108 long i;
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]));
112
113 return v;
114 }
115
116 SCM
gh_doubles2scm(const double * d,long n)117 gh_doubles2scm (const double *d, long n)
118 {
119 long i;
120 SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED);
121
122 for(i = 0; i < n; i++)
123 SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i]));
124 return v;
125 }
126
127
128 SCM
gh_chars2byvect(const char * d,long n)129 gh_chars2byvect (const char *d, long n)
130 {
131 char *m = scm_malloc (n);
132 memcpy (m, d, n * sizeof (char));
133 return scm_take_s8vector ((scm_t_int8 *)m, n);
134 }
135
136 SCM
gh_shorts2svect(const short * d,long n)137 gh_shorts2svect (const short *d, long n)
138 {
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);
143 }
144
145 SCM
gh_longs2ivect(const long * d,long n)146 gh_longs2ivect (const long *d, long n)
147 {
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);
152 }
153
154 SCM
gh_ulongs2uvect(const unsigned long * d,long n)155 gh_ulongs2uvect (const unsigned long *d, long n)
156 {
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);
161 }
162
163 SCM
gh_floats2fvect(const float * d,long n)164 gh_floats2fvect (const float *d, long n)
165 {
166 char *m = scm_malloc (n * sizeof (float));
167 memcpy (m, d, n * sizeof (float));
168 return scm_take_f32vector ((float *)m, n);
169 }
170
171 SCM
gh_doubles2dvect(const double * d,long n)172 gh_doubles2dvect (const double *d, long n)
173 {
174 char *m = scm_malloc (n * sizeof (double));
175 memcpy (m, d, n * sizeof (double));
176 return scm_take_f64vector ((double *)m, n);
177 }
178
179 /* data conversion scheme->C */
180 int
gh_scm2bool(SCM obj)181 gh_scm2bool (SCM obj)
182 {
183 return (scm_is_false (obj)) ? 0 : 1;
184 }
185 unsigned long
gh_scm2ulong(SCM obj)186 gh_scm2ulong (SCM obj)
187 {
188 return scm_to_ulong (obj);
189 }
190 long
gh_scm2long(SCM obj)191 gh_scm2long (SCM obj)
192 {
193 return scm_to_long (obj);
194 }
195 int
gh_scm2int(SCM obj)196 gh_scm2int (SCM obj)
197 {
198 return scm_to_int (obj);
199 }
200 double
gh_scm2double(SCM obj)201 gh_scm2double (SCM obj)
202 {
203 return scm_to_double (obj);
204 }
205 char
gh_scm2char(SCM obj)206 gh_scm2char (SCM obj)
207 #define FUNC_NAME "gh_scm2char"
208 {
209 SCM_VALIDATE_CHAR (SCM_ARG1, obj);
210 return SCM_CHAR (obj);
211 }
212 #undef FUNC_NAME
213
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. */
217 char *
gh_scm2chars(SCM obj,char * m)218 gh_scm2chars (SCM obj, char *m)
219 {
220 long i, n;
221 long v;
222 SCM val;
223 if (SCM_IMP (obj))
224 scm_wrong_type_arg (0, 0, obj);
225 switch (SCM_TYP7 (obj))
226 {
227 case scm_tc7_vector:
228 case scm_tc7_wvect:
229 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
230 for (i = 0; i < n; ++i)
231 {
232 val = SCM_SIMPLE_VECTOR_REF (obj, i);
233 if (SCM_I_INUMP (val))
234 {
235 v = SCM_I_INUM (val);
236 if (v < -128 || v > 255)
237 scm_out_of_range (0, obj);
238 }
239 else
240 scm_wrong_type_arg (0, 0, obj);
241 }
242 if (m == 0)
243 m = (char *) malloc (n * sizeof (char));
244 if (m == NULL)
245 return NULL;
246 for (i = 0; i < n; ++i)
247 m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
248 break;
249 case scm_tc7_smob:
250 if (scm_is_true (scm_s8vector_p (obj)))
251 {
252 scm_t_array_handle handle;
253 size_t len;
254 ssize_t inc;
255 const scm_t_int8 *elts;
256
257 elts = scm_s8vector_elements (obj, &handle, &len, &inc);
258 if (inc != 1)
259 scm_misc_error (NULL, "only contiguous vectors are supported: ~a",
260 scm_list_1 (obj));
261 if (m == 0)
262 m = (char *) malloc (len);
263 if (m != NULL)
264 memcpy (m, elts, len);
265 scm_array_handle_release (&handle);
266 if (m == NULL)
267 return NULL;
268 break;
269 }
270 else
271 goto wrong_type;
272 case scm_tc7_string:
273 n = scm_i_string_length (obj);
274 if (m == 0)
275 m = (char *) malloc (n * sizeof (char));
276 if (m == NULL)
277 return NULL;
278 memcpy (m, scm_i_string_chars (obj), n * sizeof (char));
279 break;
280 default:
281 wrong_type:
282 scm_wrong_type_arg (0, 0, obj);
283 }
284 return m;
285 }
286
287 static void *
scm2whatever(SCM obj,void * m,size_t size)288 scm2whatever (SCM obj, void *m, size_t size)
289 {
290 scm_t_array_handle handle;
291 size_t len;
292 ssize_t inc;
293 const void *elts;
294
295 elts = scm_uniform_vector_elements (obj, &handle, &len, &inc);
296
297 if (inc != 1)
298 scm_misc_error (NULL, "only contiguous vectors can be converted: ~a",
299 scm_list_1 (obj));
300
301 if (m == 0)
302 m = malloc (len * sizeof (size));
303 if (m != NULL)
304 memcpy (m, elts, len * size);
305
306 scm_array_handle_release (&handle);
307
308 return m;
309 }
310
311 #define SCM2WHATEVER(obj,pred,utype,mtype) \
312 if (scm_is_true (pred (obj))) \
313 { \
314 assert (sizeof (utype) == sizeof (mtype)); \
315 return (mtype *)scm2whatever (obj, m, sizeof (utype)); \
316 }
317
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. */
321 short *
gh_scm2shorts(SCM obj,short * m)322 gh_scm2shorts (SCM obj, short *m)
323 {
324 long i, n;
325 long v;
326 SCM val;
327 if (SCM_IMP (obj))
328 scm_wrong_type_arg (0, 0, obj);
329
330 SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short)
331
332 switch (SCM_TYP7 (obj))
333 {
334 case scm_tc7_vector:
335 case scm_tc7_wvect:
336 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
337 for (i = 0; i < n; ++i)
338 {
339 val = SCM_SIMPLE_VECTOR_REF (obj, i);
340 if (SCM_I_INUMP (val))
341 {
342 v = SCM_I_INUM (val);
343 if (v < -32768 || v > 65535)
344 scm_out_of_range (0, obj);
345 }
346 else
347 scm_wrong_type_arg (0, 0, obj);
348 }
349 if (m == 0)
350 m = (short *) malloc (n * sizeof (short));
351 if (m == NULL)
352 return NULL;
353 for (i = 0; i < n; ++i)
354 m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i));
355 break;
356 default:
357 scm_wrong_type_arg (0, 0, obj);
358 }
359 return m;
360 }
361
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. */
365 long *
gh_scm2longs(SCM obj,long * m)366 gh_scm2longs (SCM obj, long *m)
367 {
368 long i, n;
369 SCM val;
370 if (SCM_IMP (obj))
371 scm_wrong_type_arg (0, 0, obj);
372
373 SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long)
374
375 switch (SCM_TYP7 (obj))
376 {
377 case scm_tc7_vector:
378 case scm_tc7_wvect:
379 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
380 for (i = 0; i < n; ++i)
381 {
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);
385 }
386 if (m == 0)
387 m = (long *) malloc (n * sizeof (long));
388 if (m == NULL)
389 return NULL;
390 for (i = 0; i < n; ++i)
391 {
392 val = SCM_SIMPLE_VECTOR_REF (obj, i);
393 m[i] = SCM_I_INUMP (val)
394 ? SCM_I_INUM (val)
395 : scm_to_long (val);
396 }
397 break;
398 default:
399 scm_wrong_type_arg (0, 0, obj);
400 }
401 return m;
402 }
403
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. */
407 float *
gh_scm2floats(SCM obj,float * m)408 gh_scm2floats (SCM obj, float *m)
409 {
410 long i, n;
411 SCM val;
412 if (SCM_IMP (obj))
413 scm_wrong_type_arg (0, 0, obj);
414
415 /* XXX - f64vectors are rejected now.
416 */
417 SCM2WHATEVER (obj, scm_f32vector_p, float, float)
418
419 switch (SCM_TYP7 (obj))
420 {
421 case scm_tc7_vector:
422 case scm_tc7_wvect:
423 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
424 for (i = 0; i < n; ++i)
425 {
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);
430 }
431 if (m == 0)
432 m = (float *) malloc (n * sizeof (float));
433 if (m == NULL)
434 return NULL;
435 for (i = 0; i < n; ++i)
436 {
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);
442 else
443 m[i] = SCM_REAL_VALUE (val);
444 }
445 break;
446 default:
447 scm_wrong_type_arg (0, 0, obj);
448 }
449 return m;
450 }
451
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. */
455 double *
gh_scm2doubles(SCM obj,double * m)456 gh_scm2doubles (SCM obj, double *m)
457 {
458 long i, n;
459 SCM val;
460 if (SCM_IMP (obj))
461 scm_wrong_type_arg (0, 0, obj);
462
463 /* XXX - f32vectors are rejected now.
464 */
465 SCM2WHATEVER (obj, scm_f64vector_p, double, double)
466
467 switch (SCM_TYP7 (obj))
468 {
469 case scm_tc7_vector:
470 case scm_tc7_wvect:
471 n = SCM_SIMPLE_VECTOR_LENGTH (obj);
472 for (i = 0; i < n; ++i)
473 {
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);
478 }
479 if (m == 0)
480 m = (double *) malloc (n * sizeof (double));
481 if (m == NULL)
482 return NULL;
483 for (i = 0; i < n; ++i)
484 {
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);
490 else
491 m[i] = SCM_REAL_VALUE (val);
492 }
493 break;
494
495 default:
496 scm_wrong_type_arg (0, 0, obj);
497 }
498 return m;
499 }
500
501 /* string conversions between C and Scheme */
502
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.
506
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
509 returned.
510
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). */
516 char *
gh_scm2newstr(SCM str,size_t * lenp)517 gh_scm2newstr (SCM str, size_t *lenp)
518 {
519 char *ret_str;
520
521 /* We can't use scm_to_locale_stringn directly since it does not
522 guarantee null-termination when lenp is non-NULL.
523 */
524
525 ret_str = scm_to_locale_string (str);
526 if (lenp)
527 *lenp = scm_i_string_length (str);
528 return ret_str;
529 }
530
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.
534
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. */
538 void
gh_get_substr(SCM src,char * dst,long start,size_t len)539 gh_get_substr (SCM src, char *dst, long start, size_t len)
540 {
541 size_t src_len, effective_length;
542 SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr");
543
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);
549 }
550
551
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
555 string's length.
556
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
559 returned.*/
560 char *
gh_symbol2newstr(SCM sym,size_t * lenp)561 gh_symbol2newstr (SCM sym, size_t *lenp)
562 {
563 return gh_scm2newstr (scm_symbol_to_string (sym), lenp);
564 }
565
566
567 /* create a new vector of the given length, all initialized to the
568 given value */
569 SCM
gh_make_vector(SCM len,SCM fill)570 gh_make_vector (SCM len, SCM fill)
571 {
572 return scm_make_vector (len, fill);
573 }
574
575 /* set the given element of the given vector to the given value */
576 SCM
gh_vector_set_x(SCM vec,SCM pos,SCM val)577 gh_vector_set_x (SCM vec, SCM pos, SCM val)
578 {
579 return scm_vector_set_x (vec, pos, val);
580 }
581
582 /* retrieve the given element of the given vector */
583 SCM
gh_vector_ref(SCM vec,SCM pos)584 gh_vector_ref (SCM vec, SCM pos)
585 {
586 return scm_vector_ref (vec, pos);
587 }
588
589 /* returns the length of the given vector */
590 unsigned long
gh_vector_length(SCM v)591 gh_vector_length (SCM v)
592 {
593 return (unsigned long) scm_c_vector_length (v);
594 }
595
596 /* uniform vector support */
597
598 /* returns the length as a C unsigned long integer */
599 unsigned long
gh_uniform_vector_length(SCM v)600 gh_uniform_vector_length (SCM v)
601 {
602 return (unsigned long) scm_c_uniform_vector_length (v);
603 }
604
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 */
608 SCM
gh_uniform_vector_ref(SCM v,SCM ilist)609 gh_uniform_vector_ref (SCM v, SCM ilist)
610 {
611 return scm_uniform_vector_ref (v, ilist);
612 }
613
614 /* sets an individual element in a uniform vector */
615 /* SCM */
616 /* gh_list_to_uniform_array ( */
617
618 /* Data lookups between C and Scheme
619
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
623 `vec' argument.
624
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.
627 */
628
629 SCM
gh_lookup(const char * sname)630 gh_lookup (const char *sname)
631 {
632 return gh_module_lookup (scm_current_module (), sname);
633 }
634
635
636 SCM
gh_module_lookup(SCM module,const char * sname)637 gh_module_lookup (SCM module, const char *sname)
638 #define FUNC_NAME "gh_module_lookup"
639 {
640 SCM sym, var;
641
642 SCM_VALIDATE_MODULE (SCM_ARG1, module);
643
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);
648 else
649 return SCM_UNDEFINED;
650 }
651 #undef FUNC_NAME
652
653 #endif /* SCM_ENABLE_DEPRECATED */
654
655 /*
656 Local Variables:
657 c-file-style: "gnu"
658 End:
659 */
660