Commit | Line | Data |
---|---|---|
80dee77b | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001 Free Software Foundation, Inc. |
73be1d9e MV |
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. | |
ee2a8b9b | 6 | * |
73be1d9e MV |
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. | |
ee2a8b9b | 11 | * |
73be1d9e MV |
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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
15 | */ | |
ee2a8b9b JB |
16 | \f |
17 | ||
18 | /* data initialization and C<->Scheme data conversion */ | |
19 | ||
d3d183b5 RB |
20 | #if HAVE_CONFIG_H |
21 | # include <config.h> | |
22 | #endif | |
23 | ||
a0599745 | 24 | #include "libguile/gh.h" |
bd9e24b3 GH |
25 | #ifdef HAVE_STRING_H |
26 | #include <string.h> | |
27 | #endif | |
ee2a8b9b JB |
28 | |
29 | /* data conversion C->scheme */ | |
bcee10dd | 30 | |
dbb3005d MG |
31 | SCM |
32 | gh_bool2scm (int x) | |
ee2a8b9b | 33 | { |
156dcb09 | 34 | return SCM_BOOL(x); |
ee2a8b9b JB |
35 | } |
36 | SCM | |
37 | gh_int2scm (int x) | |
38 | { | |
39 | return scm_long2num ((long) x); | |
40 | } | |
41 | SCM | |
42 | gh_ulong2scm (unsigned long x) | |
43 | { | |
44 | return scm_ulong2num (x); | |
45 | } | |
46 | SCM | |
47 | gh_long2scm (long x) | |
48 | { | |
49 | return scm_long2num (x); | |
50 | } | |
51 | SCM | |
52 | gh_double2scm (double x) | |
53 | { | |
f8de44c1 | 54 | return scm_make_real (x); |
ee2a8b9b JB |
55 | } |
56 | SCM | |
57 | gh_char2scm (char c) | |
58 | { | |
7866a09b | 59 | return SCM_MAKE_CHAR (c); |
ee2a8b9b JB |
60 | } |
61 | SCM | |
1be6b49c | 62 | gh_str2scm (const char *s, size_t len) |
ee2a8b9b | 63 | { |
36284627 | 64 | return scm_mem2string (s, len); |
ee2a8b9b JB |
65 | } |
66 | SCM | |
6e706938 | 67 | gh_str02scm (const char *s) |
ee2a8b9b JB |
68 | { |
69 | return scm_makfrom0str (s); | |
70 | } | |
71 | /* Copy LEN characters at SRC into the *existing* Scheme string DST, | |
72 | starting at START. START is an index into DST; zero means the | |
73 | beginning of the string. | |
74 | ||
75 | If START + LEN is off the end of DST, signal an out-of-range | |
76 | error. */ | |
77 | void | |
c014a02e | 78 | gh_set_substr (char *src, SCM dst, long start, size_t len) |
ee2a8b9b | 79 | { |
2c92112b | 80 | char *dst_ptr; |
1be6b49c | 81 | size_t dst_len; |
ee2a8b9b | 82 | |
b24b5e13 | 83 | SCM_ASSERT (SCM_STRINGP (dst), dst, SCM_ARG3, "gh_set_substr"); |
fd88bd7c | 84 | |
86c991c2 | 85 | dst_ptr = SCM_STRING_CHARS (dst); |
9fd38a3d | 86 | dst_len = SCM_STRING_LENGTH (dst); |
729dbac3 | 87 | SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); |
fd88bd7c | 88 | |
729dbac3 | 89 | memmove (dst_ptr + start, src, len); |
5d2b97cd | 90 | scm_remember_upto_here_1 (dst); |
ee2a8b9b JB |
91 | } |
92 | ||
93 | /* Return the symbol named SYMBOL_STR. */ | |
94 | SCM | |
4921140c | 95 | gh_symbol2scm (const char *symbol_str) |
ee2a8b9b | 96 | { |
38ae064c | 97 | return scm_str2symbol(symbol_str); |
ee2a8b9b JB |
98 | } |
99 | ||
b774ee1f | 100 | SCM |
c014a02e | 101 | gh_ints2scm (const int *d, long n) |
b774ee1f | 102 | { |
c014a02e | 103 | long i; |
00ffa0e7 | 104 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
b774ee1f | 105 | for (i = 0; i < n; ++i) |
34d19ef6 | 106 | SCM_VECTOR_SET (v, i, (SCM_FIXABLE (d[i]) ? SCM_MAKINUM (d[i]) : scm_i_long2big (d[i]))); |
8f379a8f | 107 | |
0acef67a | 108 | return v; |
3ffc7a36 MD |
109 | } |
110 | ||
111 | SCM | |
c014a02e | 112 | gh_doubles2scm (const double *d, long n) |
3ffc7a36 | 113 | { |
c014a02e | 114 | long i; |
00ffa0e7 | 115 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
0acef67a JB |
116 | |
117 | for(i = 0; i < n; i++) | |
34d19ef6 | 118 | SCM_VECTOR_SET (v, i, scm_make_real (d[i])); |
0acef67a JB |
119 | return v; |
120 | } | |
121 | ||
a5843d44 | 122 | #if SCM_HAVE_ARRAYS |
0acef67a JB |
123 | /* Do not use this function for building normal Scheme vectors, unless |
124 | you arrange for the elements to be protected from GC while you | |
125 | initialize the vector. */ | |
126 | static SCM | |
1be6b49c | 127 | makvect (char *m, size_t len, int type) |
0acef67a | 128 | { |
228a24ef | 129 | return scm_cell (SCM_MAKE_UVECTOR_TAG (len, type), (scm_t_bits) m); |
b774ee1f MD |
130 | } |
131 | ||
3ffc7a36 | 132 | SCM |
c014a02e | 133 | gh_chars2byvect (const char *d, long n) |
3ffc7a36 | 134 | { |
4c9419ac | 135 | char *m = scm_gc_malloc (n * sizeof (char), "vector"); |
3ffc7a36 MD |
136 | memcpy (m, d, n * sizeof (char)); |
137 | return makvect (m, n, scm_tc7_byvect); | |
138 | } | |
139 | ||
140 | SCM | |
c014a02e | 141 | gh_shorts2svect (const short *d, long n) |
3ffc7a36 | 142 | { |
4c9419ac | 143 | char *m = scm_gc_malloc (n * sizeof (short), "vector"); |
3ffc7a36 MD |
144 | memcpy (m, d, n * sizeof (short)); |
145 | return makvect (m, n, scm_tc7_svect); | |
146 | } | |
147 | ||
b774ee1f | 148 | SCM |
c014a02e | 149 | gh_longs2ivect (const long *d, long n) |
b774ee1f | 150 | { |
4c9419ac | 151 | char *m = scm_gc_malloc (n * sizeof (long), "vector"); |
b774ee1f MD |
152 | memcpy (m, d, n * sizeof (long)); |
153 | return makvect (m, n, scm_tc7_ivect); | |
154 | } | |
155 | ||
156 | SCM | |
c014a02e | 157 | gh_ulongs2uvect (const unsigned long *d, long n) |
b774ee1f | 158 | { |
4c9419ac | 159 | char *m = scm_gc_malloc (n * sizeof (unsigned long), "vector"); |
b774ee1f MD |
160 | memcpy (m, d, n * sizeof (unsigned long)); |
161 | return makvect (m, n, scm_tc7_uvect); | |
162 | } | |
163 | ||
164 | SCM | |
c014a02e | 165 | gh_floats2fvect (const float *d, long n) |
b774ee1f | 166 | { |
4c9419ac | 167 | char *m = scm_gc_malloc (n * sizeof (float), "vector"); |
3ffc7a36 MD |
168 | memcpy (m, d, n * sizeof (float)); |
169 | return makvect (m, n, scm_tc7_fvect); | |
b774ee1f MD |
170 | } |
171 | ||
f3a2c4cf | 172 | SCM |
c014a02e | 173 | gh_doubles2dvect (const double *d, long n) |
f3a2c4cf | 174 | { |
4c9419ac | 175 | char *m = scm_gc_malloc (n * sizeof (double), "vector"); |
f3a2c4cf | 176 | memcpy (m, d, n * sizeof (double)); |
b774ee1f | 177 | return makvect (m, n, scm_tc7_dvect); |
f3a2c4cf MD |
178 | } |
179 | #endif | |
ee2a8b9b JB |
180 | |
181 | /* data conversion scheme->C */ | |
182 | int | |
183 | gh_scm2bool (SCM obj) | |
184 | { | |
fbd485ba | 185 | return (SCM_FALSEP (obj)) ? 0 : 1; |
ee2a8b9b JB |
186 | } |
187 | unsigned long | |
188 | gh_scm2ulong (SCM obj) | |
189 | { | |
e4b265d8 | 190 | return scm_num2ulong (obj, SCM_ARG1, "gh_scm2ulong"); |
ee2a8b9b JB |
191 | } |
192 | long | |
193 | gh_scm2long (SCM obj) | |
194 | { | |
e4b265d8 | 195 | return scm_num2long (obj, SCM_ARG1, "gh_scm2long"); |
ee2a8b9b JB |
196 | } |
197 | int | |
198 | gh_scm2int (SCM obj) | |
199 | { | |
1be6b49c | 200 | return (int) scm_num2int (obj, SCM_ARG1, "gh_scm2int"); |
ee2a8b9b JB |
201 | } |
202 | double | |
203 | gh_scm2double (SCM obj) | |
204 | { | |
205 | return scm_num2dbl (obj, "gh_scm2double"); | |
206 | } | |
207 | char | |
208 | gh_scm2char (SCM obj) | |
0e1d5b0a | 209 | #define FUNC_NAME "gh_scm2char" |
ee2a8b9b | 210 | { |
0e1d5b0a | 211 | SCM_VALIDATE_CHAR (SCM_ARG1, obj); |
7866a09b | 212 | return SCM_CHAR (obj); |
ee2a8b9b | 213 | } |
fd336365 | 214 | #undef FUNC_NAME |
ee2a8b9b | 215 | |
3ffc7a36 MD |
216 | /* Convert a vector, weak vector, string, substring or uniform vector |
217 | into an array of chars. If result array in arg 2 is NULL, malloc a | |
d3dd80ab | 218 | new one. If out of memory, return NULL. */ |
3ffc7a36 MD |
219 | char * |
220 | gh_scm2chars (SCM obj, char *m) | |
f3a2c4cf | 221 | { |
c014a02e ML |
222 | long i, n; |
223 | long v; | |
f3a2c4cf | 224 | SCM val; |
1a548472 | 225 | if (SCM_IMP (obj)) |
f3a2c4cf MD |
226 | scm_wrong_type_arg (0, 0, obj); |
227 | switch (SCM_TYP7 (obj)) | |
228 | { | |
229 | case scm_tc7_vector: | |
230 | case scm_tc7_wvect: | |
9fd38a3d | 231 | n = SCM_VECTOR_LENGTH (obj); |
f3a2c4cf MD |
232 | for (i = 0; i < n; ++i) |
233 | { | |
234 | val = SCM_VELTS (obj)[i]; | |
235 | if (SCM_INUMP (val)) | |
3ffc7a36 MD |
236 | { |
237 | v = SCM_INUM (val); | |
238 | if (v < -128 || v > 255) | |
239 | scm_out_of_range (0, obj); | |
240 | } | |
f3a2c4cf | 241 | else |
3ffc7a36 MD |
242 | scm_wrong_type_arg (0, 0, obj); |
243 | } | |
244 | if (m == 0) | |
245 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
246 | if (m == NULL) |
247 | return NULL; | |
3ffc7a36 MD |
248 | for (i = 0; i < n; ++i) |
249 | m[i] = SCM_INUM (SCM_VELTS (obj)[i]); | |
250 | break; | |
a5843d44 | 251 | #if SCM_HAVE_ARRAYS |
3ffc7a36 | 252 | case scm_tc7_byvect: |
b5c2579a DH |
253 | n = SCM_UVECTOR_LENGTH (obj); |
254 | if (m == 0) | |
255 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
256 | if (m == NULL) |
257 | return NULL; | |
b5c2579a DH |
258 | memcpy (m, SCM_VELTS (obj), n * sizeof (char)); |
259 | break; | |
afe5177e | 260 | #endif |
3ffc7a36 | 261 | case scm_tc7_string: |
b5c2579a | 262 | n = SCM_STRING_LENGTH (obj); |
3ffc7a36 MD |
263 | if (m == 0) |
264 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
265 | if (m == NULL) |
266 | return NULL; | |
3ffc7a36 MD |
267 | memcpy (m, SCM_VELTS (obj), n * sizeof (char)); |
268 | break; | |
269 | default: | |
270 | scm_wrong_type_arg (0, 0, obj); | |
271 | } | |
272 | return m; | |
273 | } | |
274 | ||
275 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
276 | shorts. If result array in arg 2 is NULL, malloc a new one. If |
277 | out of memory, return NULL. */ | |
3ffc7a36 MD |
278 | short * |
279 | gh_scm2shorts (SCM obj, short *m) | |
280 | { | |
c014a02e ML |
281 | long i, n; |
282 | long v; | |
3ffc7a36 | 283 | SCM val; |
1a548472 | 284 | if (SCM_IMP (obj)) |
3ffc7a36 MD |
285 | scm_wrong_type_arg (0, 0, obj); |
286 | switch (SCM_TYP7 (obj)) | |
287 | { | |
288 | case scm_tc7_vector: | |
289 | case scm_tc7_wvect: | |
9fd38a3d | 290 | n = SCM_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
291 | for (i = 0; i < n; ++i) |
292 | { | |
293 | val = SCM_VELTS (obj)[i]; | |
294 | if (SCM_INUMP (val)) | |
f3a2c4cf | 295 | { |
3ffc7a36 MD |
296 | v = SCM_INUM (val); |
297 | if (v < -32768 || v > 65535) | |
298 | scm_out_of_range (0, obj); | |
f3a2c4cf | 299 | } |
3ffc7a36 MD |
300 | else |
301 | scm_wrong_type_arg (0, 0, obj); | |
302 | } | |
303 | if (m == 0) | |
304 | m = (short *) malloc (n * sizeof (short)); | |
d3dd80ab MG |
305 | if (m == NULL) |
306 | return NULL; | |
3ffc7a36 MD |
307 | for (i = 0; i < n; ++i) |
308 | m[i] = SCM_INUM (SCM_VELTS (obj)[i]); | |
309 | break; | |
a5843d44 | 310 | #if SCM_HAVE_ARRAYS |
3ffc7a36 | 311 | case scm_tc7_svect: |
9fd38a3d | 312 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
313 | if (m == 0) |
314 | m = (short *) malloc (n * sizeof (short)); | |
d3dd80ab MG |
315 | if (m == NULL) |
316 | return NULL; | |
3ffc7a36 MD |
317 | memcpy (m, SCM_VELTS (obj), n * sizeof (short)); |
318 | break; | |
afe5177e | 319 | #endif |
3ffc7a36 MD |
320 | default: |
321 | scm_wrong_type_arg (0, 0, obj); | |
322 | } | |
323 | return m; | |
324 | } | |
325 | ||
326 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
327 | longs. If result array in arg 2 is NULL, malloc a new one. If out |
328 | of memory, return NULL. */ | |
3ffc7a36 MD |
329 | long * |
330 | gh_scm2longs (SCM obj, long *m) | |
331 | { | |
c014a02e | 332 | long i, n; |
3ffc7a36 | 333 | SCM val; |
1a548472 | 334 | if (SCM_IMP (obj)) |
3ffc7a36 MD |
335 | scm_wrong_type_arg (0, 0, obj); |
336 | switch (SCM_TYP7 (obj)) | |
337 | { | |
338 | case scm_tc7_vector: | |
339 | case scm_tc7_wvect: | |
9fd38a3d | 340 | n = SCM_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
341 | for (i = 0; i < n; ++i) |
342 | { | |
343 | val = SCM_VELTS (obj)[i]; | |
0c95b57d | 344 | if (!SCM_INUMP (val) && !SCM_BIGP (val)) |
3ffc7a36 MD |
345 | scm_wrong_type_arg (0, 0, obj); |
346 | } | |
347 | if (m == 0) | |
348 | m = (long *) malloc (n * sizeof (long)); | |
d3dd80ab MG |
349 | if (m == NULL) |
350 | return NULL; | |
3ffc7a36 MD |
351 | for (i = 0; i < n; ++i) |
352 | { | |
353 | val = SCM_VELTS (obj)[i]; | |
e4b265d8 DH |
354 | m[i] = SCM_INUMP (val) |
355 | ? SCM_INUM (val) | |
356 | : scm_num2long (val, 0, NULL); | |
3ffc7a36 MD |
357 | } |
358 | break; | |
a5843d44 | 359 | #if SCM_HAVE_ARRAYS |
3ffc7a36 MD |
360 | case scm_tc7_ivect: |
361 | case scm_tc7_uvect: | |
9fd38a3d | 362 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
363 | if (m == 0) |
364 | m = (long *) malloc (n * sizeof (long)); | |
d3dd80ab MG |
365 | if (m == NULL) |
366 | return NULL; | |
3ffc7a36 MD |
367 | memcpy (m, SCM_VELTS (obj), n * sizeof (long)); |
368 | break; | |
afe5177e | 369 | #endif |
3ffc7a36 MD |
370 | default: |
371 | scm_wrong_type_arg (0, 0, obj); | |
372 | } | |
373 | return m; | |
374 | } | |
375 | ||
376 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
377 | floats. If result array in arg 2 is NULL, malloc a new one. If |
378 | out of memory, return NULL. */ | |
3ffc7a36 MD |
379 | float * |
380 | gh_scm2floats (SCM obj, float *m) | |
381 | { | |
c014a02e | 382 | long i, n; |
3ffc7a36 | 383 | SCM val; |
1a548472 | 384 | if (SCM_IMP (obj)) |
3ffc7a36 MD |
385 | scm_wrong_type_arg (0, 0, obj); |
386 | switch (SCM_TYP7 (obj)) | |
387 | { | |
388 | case scm_tc7_vector: | |
389 | case scm_tc7_wvect: | |
9fd38a3d | 390 | n = SCM_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
391 | for (i = 0; i < n; ++i) |
392 | { | |
393 | val = SCM_VELTS (obj)[i]; | |
394 | if (!SCM_INUMP (val) | |
0c95b57d | 395 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
396 | scm_wrong_type_arg (0, 0, val); |
397 | } | |
398 | if (m == 0) | |
399 | m = (float *) malloc (n * sizeof (float)); | |
d3dd80ab MG |
400 | if (m == NULL) |
401 | return NULL; | |
3ffc7a36 MD |
402 | for (i = 0; i < n; ++i) |
403 | { | |
404 | val = SCM_VELTS (obj)[i]; | |
405 | if (SCM_INUMP (val)) | |
406 | m[i] = SCM_INUM (val); | |
407 | else if (SCM_BIGP (val)) | |
e4b265d8 | 408 | m[i] = scm_num2long (val, 0, NULL); |
3ffc7a36 | 409 | else |
eb42e2f0 | 410 | m[i] = SCM_REAL_VALUE (val); |
f3a2c4cf MD |
411 | } |
412 | break; | |
a5843d44 | 413 | #if SCM_HAVE_ARRAYS |
f3a2c4cf | 414 | case scm_tc7_fvect: |
9fd38a3d | 415 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
416 | if (m == 0) |
417 | m = (float *) malloc (n * sizeof (float)); | |
d3dd80ab MG |
418 | if (m == NULL) |
419 | return NULL; | |
3ffc7a36 | 420 | memcpy (m, (float *) SCM_VELTS (obj), n * sizeof (float)); |
f3a2c4cf | 421 | break; |
16d35552 | 422 | |
f3a2c4cf | 423 | case scm_tc7_dvect: |
9fd38a3d | 424 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
425 | if (m == 0) |
426 | m = (float*) malloc (n * sizeof (float)); | |
d3dd80ab MG |
427 | if (m == NULL) |
428 | return NULL; | |
f3a2c4cf | 429 | for (i = 0; i < n; ++i) |
3ffc7a36 MD |
430 | m[i] = ((double *) SCM_VELTS (obj))[i]; |
431 | break; | |
432 | #endif | |
433 | default: | |
434 | scm_wrong_type_arg (0, 0, obj); | |
435 | } | |
436 | return m; | |
437 | } | |
438 | ||
439 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
440 | doubles. If result array in arg 2 is NULL, malloc a new one. If |
441 | out of memory, return NULL. */ | |
3ffc7a36 MD |
442 | double * |
443 | gh_scm2doubles (SCM obj, double *m) | |
444 | { | |
c014a02e | 445 | long i, n; |
3ffc7a36 | 446 | SCM val; |
1a548472 | 447 | if (SCM_IMP (obj)) |
3ffc7a36 MD |
448 | scm_wrong_type_arg (0, 0, obj); |
449 | switch (SCM_TYP7 (obj)) | |
450 | { | |
451 | case scm_tc7_vector: | |
452 | case scm_tc7_wvect: | |
9fd38a3d | 453 | n = SCM_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
454 | for (i = 0; i < n; ++i) |
455 | { | |
456 | val = SCM_VELTS (obj)[i]; | |
457 | if (!SCM_INUMP (val) | |
0c95b57d | 458 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
459 | scm_wrong_type_arg (0, 0, val); |
460 | } | |
461 | if (m == 0) | |
462 | m = (double *) malloc (n * sizeof (double)); | |
d3dd80ab MG |
463 | if (m == NULL) |
464 | return NULL; | |
3ffc7a36 MD |
465 | for (i = 0; i < n; ++i) |
466 | { | |
467 | val = SCM_VELTS (obj)[i]; | |
468 | if (SCM_INUMP (val)) | |
469 | m[i] = SCM_INUM (val); | |
470 | else if (SCM_BIGP (val)) | |
e4b265d8 | 471 | m[i] = scm_num2long (val, 0, NULL); |
3ffc7a36 | 472 | else |
eb42e2f0 | 473 | m[i] = SCM_REAL_VALUE (val); |
3ffc7a36 MD |
474 | } |
475 | break; | |
a5843d44 | 476 | #if SCM_HAVE_ARRAYS |
3ffc7a36 | 477 | case scm_tc7_fvect: |
9fd38a3d | 478 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
479 | if (m == 0) |
480 | m = (double *) malloc (n * sizeof (double)); | |
d3dd80ab MG |
481 | if (m == NULL) |
482 | return NULL; | |
3ffc7a36 MD |
483 | for (i = 0; i < n; ++i) |
484 | m[i] = ((float *) SCM_VELTS (obj))[i]; | |
485 | break; | |
16d35552 | 486 | |
3ffc7a36 | 487 | case scm_tc7_dvect: |
9fd38a3d | 488 | n = SCM_UVECTOR_LENGTH (obj); |
3ffc7a36 MD |
489 | if (m == 0) |
490 | m = (double*) malloc (n * sizeof (double)); | |
d3dd80ab MG |
491 | if (m == NULL) |
492 | return NULL; | |
3ffc7a36 | 493 | memcpy (m, SCM_VELTS (obj), n * sizeof (double)); |
f3a2c4cf MD |
494 | break; |
495 | #endif | |
496 | default: | |
497 | scm_wrong_type_arg (0, 0, obj); | |
498 | } | |
499 | return m; | |
500 | } | |
501 | ||
ee2a8b9b JB |
502 | /* string conversions between C and Scheme */ |
503 | ||
504 | /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a | |
505 | new copy of its contents, followed by a null byte. If lenp is | |
506 | non-null, set *lenp to the string's length. | |
507 | ||
508 | This function uses malloc to obtain storage for the copy; the | |
d3dd80ab MG |
509 | caller is responsible for freeing it. If out of memory, NULL is |
510 | returned. | |
ee2a8b9b JB |
511 | |
512 | Note that Scheme strings may contain arbitrary data, including null | |
513 | characters. This means that null termination is not a reliable way | |
514 | to determine the length of the returned value. However, the | |
515 | function always copies the complete contents of STR, and sets | |
516 | *LEN_P to the true length of the string (when LEN_P is non-null). */ | |
517 | char * | |
1be6b49c | 518 | gh_scm2newstr (SCM str, size_t *lenp) |
ee2a8b9b JB |
519 | { |
520 | char *ret_str; | |
1be6b49c | 521 | size_t len; |
ee2a8b9b | 522 | |
9fd38a3d | 523 | SCM_ASSERT (SCM_STRINGP (str), str, SCM_ARG3, "gh_scm2newstr"); |
ee2a8b9b | 524 | |
9fd38a3d | 525 | len = SCM_STRING_LENGTH (str); |
ee2a8b9b | 526 | |
d3dd80ab MG |
527 | ret_str = (char *) malloc ((len + 1) * sizeof (char)); |
528 | if (ret_str == NULL) | |
529 | return NULL; | |
ee2a8b9b | 530 | /* so we copy tmp_str to ret_str, which is what we will allocate */ |
34f0f2b8 | 531 | memcpy (ret_str, SCM_STRING_CHARS (str), len); |
5d2b97cd | 532 | scm_remember_upto_here_1 (str); |
ee2a8b9b JB |
533 | /* now make sure we null-terminate it */ |
534 | ret_str[len] = '\0'; | |
535 | ||
ee2a8b9b JB |
536 | if (lenp != NULL) |
537 | { | |
538 | *lenp = len; | |
539 | } | |
540 | ||
541 | return ret_str; | |
542 | } | |
543 | ||
544 | ||
545 | /* Copy LEN characters at START from the Scheme string SRC to memory | |
546 | at DST. START is an index into SRC; zero means the beginning of | |
547 | the string. DST has already been allocated by the caller. | |
548 | ||
549 | If START + LEN is off the end of SRC, silently truncate the source | |
550 | region to fit the string. If truncation occurs, the corresponding | |
551 | area of DST is left unchanged. */ | |
552 | void | |
c014a02e | 553 | gh_get_substr (SCM src, char *dst, long start, size_t len) |
ee2a8b9b | 554 | { |
1be6b49c | 555 | size_t src_len, effective_length; |
9fd38a3d | 556 | SCM_ASSERT (SCM_STRINGP (src), src, SCM_ARG3, "gh_get_substr"); |
ee2a8b9b | 557 | |
9fd38a3d | 558 | src_len = SCM_STRING_LENGTH (src); |
ee2a8b9b | 559 | effective_length = (len < src_len) ? len : src_len; |
34f0f2b8 | 560 | memcpy (dst + start, SCM_STRING_CHARS (src), effective_length * sizeof (char)); |
ee2a8b9b | 561 | /* FIXME: must signal an error if len > src_len */ |
5d2b97cd | 562 | scm_remember_upto_here_1 (src); |
ee2a8b9b JB |
563 | } |
564 | ||
565 | ||
566 | /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a | |
567 | pointer to a string with the symbol characters "identifier", | |
568 | followed by a null byte. If lenp is non-null, set *lenp to the | |
569 | string's length. | |
570 | ||
571 | This function uses malloc to obtain storage for the copy; the | |
d3dd80ab MG |
572 | caller is responsible for freeing it. If out of memory, NULL is |
573 | returned.*/ | |
ee2a8b9b | 574 | char * |
1be6b49c | 575 | gh_symbol2newstr (SCM sym, size_t *lenp) |
ee2a8b9b JB |
576 | { |
577 | char *ret_str; | |
1be6b49c | 578 | size_t len; |
ee2a8b9b | 579 | |
b24b5e13 | 580 | SCM_ASSERT (SCM_SYMBOLP (sym), sym, SCM_ARG3, "gh_scm2newsymbol"); |
ee2a8b9b | 581 | |
9fd38a3d | 582 | len = SCM_SYMBOL_LENGTH (sym); |
ee2a8b9b | 583 | |
d3dd80ab MG |
584 | ret_str = (char *) malloc ((len + 1) * sizeof (char)); |
585 | if (ret_str == NULL) | |
586 | return NULL; | |
b24b5e13 | 587 | /* so we copy sym to ret_str, which is what we will allocate */ |
86c991c2 | 588 | memcpy (ret_str, SCM_SYMBOL_CHARS (sym), len); |
5d2b97cd | 589 | scm_remember_upto_here_1 (sym); |
ee2a8b9b JB |
590 | /* now make sure we null-terminate it */ |
591 | ret_str[len] = '\0'; | |
592 | ||
ee2a8b9b JB |
593 | if (lenp != NULL) |
594 | { | |
595 | *lenp = len; | |
596 | } | |
597 | ||
598 | return ret_str; | |
599 | } | |
600 | ||
601 | ||
602 | /* create a new vector of the given length, all initialized to the | |
603 | given value */ | |
e5eece74 MG |
604 | SCM |
605 | gh_make_vector (SCM len, SCM fill) | |
ee2a8b9b | 606 | { |
a8741caa | 607 | return scm_make_vector (len, fill); |
ee2a8b9b JB |
608 | } |
609 | ||
610 | /* set the given element of the given vector to the given value */ | |
611 | SCM | |
956328d2 | 612 | gh_vector_set_x (SCM vec, SCM pos, SCM val) |
ee2a8b9b JB |
613 | { |
614 | return scm_vector_set_x (vec, pos, val); | |
615 | } | |
616 | ||
617 | /* retrieve the given element of the given vector */ | |
618 | SCM | |
e5eece74 | 619 | gh_vector_ref (SCM vec, SCM pos) |
ee2a8b9b JB |
620 | { |
621 | return scm_vector_ref (vec, pos); | |
622 | } | |
623 | ||
624 | /* returns the length of the given vector */ | |
c014a02e | 625 | unsigned long |
ee2a8b9b JB |
626 | gh_vector_length (SCM v) |
627 | { | |
c014a02e | 628 | return (unsigned long) SCM_VECTOR_LENGTH (v); |
ee2a8b9b | 629 | } |
35379308 | 630 | |
a5843d44 | 631 | #if SCM_HAVE_ARRAYS |
ef5d3ae1 MG |
632 | /* uniform vector support */ |
633 | ||
634 | /* returns the length as a C unsigned long integer */ | |
c014a02e | 635 | unsigned long |
ef5d3ae1 MG |
636 | gh_uniform_vector_length (SCM v) |
637 | { | |
c014a02e | 638 | return (unsigned long) SCM_UVECTOR_LENGTH (v); |
ef5d3ae1 MG |
639 | } |
640 | ||
641 | /* gets the given element from a uniform vector; ilist is a list (or | |
642 | possibly a single integer) of indices, and its length is the | |
643 | dimension of the uniform vector */ | |
644 | SCM | |
645 | gh_uniform_vector_ref (SCM v, SCM ilist) | |
646 | { | |
647 | return scm_uniform_vector_ref (v, ilist); | |
648 | } | |
649 | ||
650 | /* sets an individual element in a uniform vector */ | |
651 | /* SCM */ | |
652 | /* gh_list_to_uniform_array ( */ | |
afe5177e | 653 | #endif |
ef5d3ae1 | 654 | |
35379308 JB |
655 | /* Data lookups between C and Scheme |
656 | ||
657 | Look up a symbol with a given name, and return the object to which | |
658 | it is bound. gh_lookup examines the Guile top level, and | |
659 | gh_module_lookup checks the module namespace specified by the | |
660 | `vec' argument. | |
661 | ||
662 | The return value is the Scheme object to which SNAME is bound, or | |
07de6c47 MV |
663 | SCM_UNDEFINED if SNAME is not bound in the given context. |
664 | */ | |
35379308 JB |
665 | |
666 | SCM | |
bcee10dd | 667 | gh_lookup (const char *sname) |
35379308 | 668 | { |
abc235ad | 669 | return gh_module_lookup (scm_current_module (), sname); |
35379308 JB |
670 | } |
671 | ||
abc235ad | 672 | |
35379308 | 673 | SCM |
abc235ad MV |
674 | gh_module_lookup (SCM module, const char *sname) |
675 | #define FUNC_NAME "gh_module_lookup" | |
35379308 | 676 | { |
86d31dfe | 677 | SCM sym, var; |
abc235ad MV |
678 | |
679 | SCM_VALIDATE_MODULE (SCM_ARG1, module); | |
680 | ||
98347362 | 681 | sym = scm_str2symbol (sname); |
86d31dfe MV |
682 | var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); |
683 | if (var != SCM_BOOL_F) | |
684 | return SCM_VARIABLE_REF (var); | |
35379308 JB |
685 | else |
686 | return SCM_UNDEFINED; | |
687 | } | |
abc235ad | 688 | #undef FUNC_NAME |
89e00824 ML |
689 | |
690 | /* | |
691 | Local Variables: | |
692 | c-file-style: "gnu" | |
693 | End: | |
694 | */ |