Commit | Line | Data |
---|---|---|
f76c6bb2 | 1 | /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2004 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 | 28 | |
bbe6ba23 MV |
29 | #include <assert.h> |
30 | ||
ee2a8b9b | 31 | /* data conversion C->scheme */ |
bcee10dd | 32 | |
dbb3005d MG |
33 | SCM |
34 | gh_bool2scm (int x) | |
ee2a8b9b | 35 | { |
7888309b | 36 | return scm_from_bool(x); |
ee2a8b9b JB |
37 | } |
38 | SCM | |
39 | gh_int2scm (int x) | |
40 | { | |
b9bd8526 | 41 | return scm_from_long ((long) x); |
ee2a8b9b JB |
42 | } |
43 | SCM | |
44 | gh_ulong2scm (unsigned long x) | |
45 | { | |
b9bd8526 | 46 | return scm_from_ulong (x); |
ee2a8b9b JB |
47 | } |
48 | SCM | |
49 | gh_long2scm (long x) | |
50 | { | |
b9bd8526 | 51 | return scm_from_long (x); |
ee2a8b9b JB |
52 | } |
53 | SCM | |
54 | gh_double2scm (double x) | |
55 | { | |
d9a67fc4 | 56 | return scm_from_double (x); |
ee2a8b9b JB |
57 | } |
58 | SCM | |
59 | gh_char2scm (char c) | |
60 | { | |
7866a09b | 61 | return SCM_MAKE_CHAR (c); |
ee2a8b9b JB |
62 | } |
63 | SCM | |
1be6b49c | 64 | gh_str2scm (const char *s, size_t len) |
ee2a8b9b | 65 | { |
f76c6bb2 | 66 | return scm_from_locale_stringn (s, len); |
ee2a8b9b JB |
67 | } |
68 | SCM | |
6e706938 | 69 | gh_str02scm (const char *s) |
ee2a8b9b | 70 | { |
f76c6bb2 | 71 | return scm_from_locale_string (s); |
ee2a8b9b JB |
72 | } |
73 | /* Copy LEN characters at SRC into the *existing* Scheme string DST, | |
74 | starting at START. START is an index into DST; zero means the | |
75 | beginning of the string. | |
76 | ||
77 | If START + LEN is off the end of DST, signal an out-of-range | |
78 | error. */ | |
79 | void | |
f76c6bb2 | 80 | gh_set_substr (const char *src, SCM dst, long start, size_t len) |
ee2a8b9b | 81 | { |
2c92112b | 82 | char *dst_ptr; |
1be6b49c | 83 | size_t dst_len; |
ee2a8b9b | 84 | |
f76c6bb2 | 85 | SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr"); |
fd88bd7c | 86 | |
f76c6bb2 | 87 | dst_len = scm_i_string_length (dst); |
729dbac3 | 88 | SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); |
f76c6bb2 MV |
89 | |
90 | dst_ptr = scm_i_string_writable_chars (dst); | |
729dbac3 | 91 | memmove (dst_ptr + start, src, len); |
f76c6bb2 | 92 | scm_i_string_stop_writing (); |
5d2b97cd | 93 | scm_remember_upto_here_1 (dst); |
ee2a8b9b JB |
94 | } |
95 | ||
96 | /* Return the symbol named SYMBOL_STR. */ | |
97 | SCM | |
4921140c | 98 | gh_symbol2scm (const char *symbol_str) |
ee2a8b9b | 99 | { |
f76c6bb2 | 100 | return scm_from_locale_symbol(symbol_str); |
ee2a8b9b JB |
101 | } |
102 | ||
b774ee1f | 103 | SCM |
c014a02e | 104 | gh_ints2scm (const int *d, long n) |
b774ee1f | 105 | { |
c014a02e | 106 | long i; |
00ffa0e7 | 107 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
b774ee1f | 108 | for (i = 0; i < n; ++i) |
4057a3e0 | 109 | SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i])); |
8f379a8f | 110 | |
0acef67a | 111 | return v; |
3ffc7a36 MD |
112 | } |
113 | ||
114 | SCM | |
c014a02e | 115 | gh_doubles2scm (const double *d, long n) |
3ffc7a36 | 116 | { |
c014a02e | 117 | long i; |
00ffa0e7 | 118 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
0acef67a JB |
119 | |
120 | for(i = 0; i < n; i++) | |
4057a3e0 | 121 | SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i])); |
0acef67a JB |
122 | return v; |
123 | } | |
124 | ||
b774ee1f | 125 | |
3ffc7a36 | 126 | SCM |
c014a02e | 127 | gh_chars2byvect (const char *d, long n) |
3ffc7a36 | 128 | { |
bbe6ba23 | 129 | char *m = scm_malloc (n); |
3ffc7a36 | 130 | memcpy (m, d, n * sizeof (char)); |
bbe6ba23 | 131 | return scm_take_s8vector (m, n); |
3ffc7a36 MD |
132 | } |
133 | ||
134 | SCM | |
c014a02e | 135 | gh_shorts2svect (const short *d, long n) |
3ffc7a36 | 136 | { |
bbe6ba23 | 137 | char *m = scm_malloc (n * sizeof (short)); |
3ffc7a36 | 138 | memcpy (m, d, n * sizeof (short)); |
bbe6ba23 MV |
139 | assert (sizeof (scm_t_int16) == sizeof (short)); |
140 | return scm_take_s16vector ((scm_t_int16 *)m, n); | |
3ffc7a36 MD |
141 | } |
142 | ||
b774ee1f | 143 | SCM |
c014a02e | 144 | gh_longs2ivect (const long *d, long n) |
b774ee1f | 145 | { |
bbe6ba23 | 146 | char *m = scm_malloc (n * sizeof (long)); |
b774ee1f | 147 | memcpy (m, d, n * sizeof (long)); |
bbe6ba23 MV |
148 | assert (sizeof (scm_t_int32) == sizeof (long)); |
149 | return scm_take_s32vector ((scm_t_int32 *)m, n); | |
b774ee1f MD |
150 | } |
151 | ||
152 | SCM | |
c014a02e | 153 | gh_ulongs2uvect (const unsigned long *d, long n) |
b774ee1f | 154 | { |
bbe6ba23 | 155 | char *m = scm_malloc (n * sizeof (unsigned long)); |
b774ee1f | 156 | memcpy (m, d, n * sizeof (unsigned long)); |
bbe6ba23 MV |
157 | assert (sizeof (scm_t_uint32) == sizeof (unsigned long)); |
158 | return scm_take_u32vector ((scm_t_uint32 *)m, n); | |
b774ee1f MD |
159 | } |
160 | ||
161 | SCM | |
c014a02e | 162 | gh_floats2fvect (const float *d, long n) |
b774ee1f | 163 | { |
bbe6ba23 | 164 | char *m = scm_malloc (n * sizeof (float)); |
3ffc7a36 | 165 | memcpy (m, d, n * sizeof (float)); |
bbe6ba23 | 166 | return scm_take_f32vector ((float *)m, n); |
b774ee1f MD |
167 | } |
168 | ||
f3a2c4cf | 169 | SCM |
c014a02e | 170 | gh_doubles2dvect (const double *d, long n) |
f3a2c4cf | 171 | { |
bbe6ba23 | 172 | char *m = scm_malloc (n * sizeof (double)); |
f3a2c4cf | 173 | memcpy (m, d, n * sizeof (double)); |
bbe6ba23 | 174 | return scm_take_f64vector ((double *)m, n); |
f3a2c4cf | 175 | } |
ee2a8b9b JB |
176 | |
177 | /* data conversion scheme->C */ | |
178 | int | |
179 | gh_scm2bool (SCM obj) | |
180 | { | |
7888309b | 181 | return (scm_is_false (obj)) ? 0 : 1; |
ee2a8b9b JB |
182 | } |
183 | unsigned long | |
184 | gh_scm2ulong (SCM obj) | |
185 | { | |
b9bd8526 | 186 | return scm_to_ulong (obj); |
ee2a8b9b JB |
187 | } |
188 | long | |
189 | gh_scm2long (SCM obj) | |
190 | { | |
b9bd8526 | 191 | return scm_to_long (obj); |
ee2a8b9b JB |
192 | } |
193 | int | |
194 | gh_scm2int (SCM obj) | |
195 | { | |
b9bd8526 | 196 | return scm_to_int (obj); |
ee2a8b9b JB |
197 | } |
198 | double | |
199 | gh_scm2double (SCM obj) | |
200 | { | |
d9a67fc4 | 201 | return scm_to_double (obj); |
ee2a8b9b JB |
202 | } |
203 | char | |
204 | gh_scm2char (SCM obj) | |
0e1d5b0a | 205 | #define FUNC_NAME "gh_scm2char" |
ee2a8b9b | 206 | { |
0e1d5b0a | 207 | SCM_VALIDATE_CHAR (SCM_ARG1, obj); |
7866a09b | 208 | return SCM_CHAR (obj); |
ee2a8b9b | 209 | } |
fd336365 | 210 | #undef FUNC_NAME |
ee2a8b9b | 211 | |
3ffc7a36 MD |
212 | /* Convert a vector, weak vector, string, substring or uniform vector |
213 | into an array of chars. If result array in arg 2 is NULL, malloc a | |
d3dd80ab | 214 | new one. If out of memory, return NULL. */ |
3ffc7a36 MD |
215 | char * |
216 | gh_scm2chars (SCM obj, char *m) | |
f3a2c4cf | 217 | { |
c014a02e ML |
218 | long i, n; |
219 | long v; | |
f3a2c4cf | 220 | SCM val; |
1a548472 | 221 | if (SCM_IMP (obj)) |
f3a2c4cf MD |
222 | scm_wrong_type_arg (0, 0, obj); |
223 | switch (SCM_TYP7 (obj)) | |
224 | { | |
225 | case scm_tc7_vector: | |
226 | case scm_tc7_wvect: | |
4057a3e0 | 227 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
f3a2c4cf MD |
228 | for (i = 0; i < n; ++i) |
229 | { | |
4057a3e0 | 230 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 231 | if (SCM_I_INUMP (val)) |
3ffc7a36 | 232 | { |
e11e83f3 | 233 | v = SCM_I_INUM (val); |
3ffc7a36 MD |
234 | if (v < -128 || v > 255) |
235 | scm_out_of_range (0, obj); | |
236 | } | |
f3a2c4cf | 237 | else |
3ffc7a36 MD |
238 | scm_wrong_type_arg (0, 0, obj); |
239 | } | |
240 | if (m == 0) | |
241 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
242 | if (m == NULL) |
243 | return NULL; | |
3ffc7a36 | 244 | for (i = 0; i < n; ++i) |
4057a3e0 | 245 | m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i)); |
3ffc7a36 | 246 | break; |
2a7bd738 MV |
247 | case scm_tc7_smob: |
248 | if (scm_is_true (scm_s8vector_p (obj))) | |
249 | { | |
4057a3e0 MV |
250 | scm_t_array_handle handle; |
251 | size_t len; | |
252 | ssize_t inc; | |
253 | const scm_t_int8 *elts; | |
254 | ||
255 | elts = scm_s8vector_elements (obj, &handle, &len, &inc); | |
256 | if (inc != 1) | |
257 | scm_misc_error (NULL, "only contiguous vectors are supported: ~a", | |
258 | scm_list_1 (obj)); | |
2a7bd738 | 259 | if (m == 0) |
4057a3e0 | 260 | m = (char *) malloc (len); |
c8857a4d MV |
261 | if (m != NULL) |
262 | memcpy (m, elts, len); | |
263 | scm_array_handle_release (&handle); | |
2a7bd738 MV |
264 | if (m == NULL) |
265 | return NULL; | |
2a7bd738 MV |
266 | break; |
267 | } | |
268 | else | |
269 | goto wrong_type; | |
3ffc7a36 | 270 | case scm_tc7_string: |
f76c6bb2 | 271 | n = scm_i_string_length (obj); |
3ffc7a36 MD |
272 | if (m == 0) |
273 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
274 | if (m == NULL) |
275 | return NULL; | |
f76c6bb2 | 276 | memcpy (m, scm_i_string_chars (obj), n * sizeof (char)); |
3ffc7a36 MD |
277 | break; |
278 | default: | |
2a7bd738 | 279 | wrong_type: |
3ffc7a36 MD |
280 | scm_wrong_type_arg (0, 0, obj); |
281 | } | |
282 | return m; | |
283 | } | |
284 | ||
bbe6ba23 MV |
285 | static void * |
286 | scm2whatever (SCM obj, void *m, size_t size) | |
287 | { | |
4057a3e0 MV |
288 | scm_t_array_handle handle; |
289 | size_t len; | |
290 | ssize_t inc; | |
291 | const void *elts; | |
292 | ||
293 | elts = scm_uniform_vector_elements (obj, &handle, &len, &inc); | |
294 | ||
295 | if (inc != 1) | |
296 | scm_misc_error (NULL, "only contiguous vectors can be converted: ~a", | |
297 | scm_list_1 (obj)); | |
298 | ||
bbe6ba23 | 299 | if (m == 0) |
4057a3e0 | 300 | m = malloc (len * sizeof (size)); |
c8857a4d MV |
301 | if (m != NULL) |
302 | memcpy (m, elts, len * size); | |
303 | ||
304 | scm_array_handle_release (&handle); | |
305 | ||
bbe6ba23 MV |
306 | return m; |
307 | } | |
308 | ||
309 | #define SCM2WHATEVER(obj,pred,utype,mtype) \ | |
310 | if (scm_is_true (pred (obj))) \ | |
311 | { \ | |
312 | assert (sizeof (utype) == sizeof (mtype)); \ | |
313 | return (mtype *)scm2whatever (obj, m, sizeof (utype)); \ | |
314 | } | |
315 | ||
3ffc7a36 | 316 | /* Convert a vector, weak vector or uniform vector into an array of |
d3dd80ab MG |
317 | shorts. If result array in arg 2 is NULL, malloc a new one. If |
318 | out of memory, return NULL. */ | |
3ffc7a36 MD |
319 | short * |
320 | gh_scm2shorts (SCM obj, short *m) | |
321 | { | |
c014a02e ML |
322 | long i, n; |
323 | long v; | |
3ffc7a36 | 324 | SCM val; |
1a548472 | 325 | if (SCM_IMP (obj)) |
3ffc7a36 | 326 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
327 | |
328 | SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short) | |
329 | ||
3ffc7a36 MD |
330 | switch (SCM_TYP7 (obj)) |
331 | { | |
332 | case scm_tc7_vector: | |
333 | case scm_tc7_wvect: | |
4057a3e0 | 334 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
335 | for (i = 0; i < n; ++i) |
336 | { | |
4057a3e0 | 337 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 338 | if (SCM_I_INUMP (val)) |
f3a2c4cf | 339 | { |
e11e83f3 | 340 | v = SCM_I_INUM (val); |
3ffc7a36 MD |
341 | if (v < -32768 || v > 65535) |
342 | scm_out_of_range (0, obj); | |
f3a2c4cf | 343 | } |
3ffc7a36 MD |
344 | else |
345 | scm_wrong_type_arg (0, 0, obj); | |
346 | } | |
347 | if (m == 0) | |
348 | m = (short *) malloc (n * sizeof (short)); | |
d3dd80ab MG |
349 | if (m == NULL) |
350 | return NULL; | |
3ffc7a36 | 351 | for (i = 0; i < n; ++i) |
4057a3e0 | 352 | m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i)); |
3ffc7a36 | 353 | break; |
3ffc7a36 MD |
354 | default: |
355 | scm_wrong_type_arg (0, 0, obj); | |
356 | } | |
357 | return m; | |
358 | } | |
359 | ||
360 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
361 | longs. If result array in arg 2 is NULL, malloc a new one. If out |
362 | of memory, return NULL. */ | |
3ffc7a36 MD |
363 | long * |
364 | gh_scm2longs (SCM obj, long *m) | |
365 | { | |
c014a02e | 366 | long i, n; |
3ffc7a36 | 367 | SCM val; |
1a548472 | 368 | if (SCM_IMP (obj)) |
3ffc7a36 | 369 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
370 | |
371 | SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long) | |
372 | ||
3ffc7a36 MD |
373 | switch (SCM_TYP7 (obj)) |
374 | { | |
375 | case scm_tc7_vector: | |
376 | case scm_tc7_wvect: | |
4057a3e0 | 377 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
378 | for (i = 0; i < n; ++i) |
379 | { | |
4057a3e0 | 380 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 381 | if (!SCM_I_INUMP (val) && !SCM_BIGP (val)) |
3ffc7a36 MD |
382 | scm_wrong_type_arg (0, 0, obj); |
383 | } | |
384 | if (m == 0) | |
385 | m = (long *) malloc (n * sizeof (long)); | |
d3dd80ab MG |
386 | if (m == NULL) |
387 | return NULL; | |
3ffc7a36 MD |
388 | for (i = 0; i < n; ++i) |
389 | { | |
4057a3e0 | 390 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
391 | m[i] = SCM_I_INUMP (val) |
392 | ? SCM_I_INUM (val) | |
b9bd8526 | 393 | : scm_to_long (val); |
3ffc7a36 MD |
394 | } |
395 | break; | |
3ffc7a36 MD |
396 | default: |
397 | scm_wrong_type_arg (0, 0, obj); | |
398 | } | |
399 | return m; | |
400 | } | |
401 | ||
402 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
403 | floats. If result array in arg 2 is NULL, malloc a new one. If |
404 | out of memory, return NULL. */ | |
3ffc7a36 MD |
405 | float * |
406 | gh_scm2floats (SCM obj, float *m) | |
407 | { | |
c014a02e | 408 | long i, n; |
3ffc7a36 | 409 | SCM val; |
1a548472 | 410 | if (SCM_IMP (obj)) |
3ffc7a36 | 411 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
412 | |
413 | /* XXX - f64vectors are rejected now. | |
414 | */ | |
415 | SCM2WHATEVER (obj, scm_f32vector_p, float, float) | |
416 | ||
3ffc7a36 MD |
417 | switch (SCM_TYP7 (obj)) |
418 | { | |
419 | case scm_tc7_vector: | |
420 | case scm_tc7_wvect: | |
4057a3e0 | 421 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
422 | for (i = 0; i < n; ++i) |
423 | { | |
4057a3e0 | 424 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 425 | if (!SCM_I_INUMP (val) |
0c95b57d | 426 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
427 | scm_wrong_type_arg (0, 0, val); |
428 | } | |
429 | if (m == 0) | |
430 | m = (float *) malloc (n * sizeof (float)); | |
d3dd80ab MG |
431 | if (m == NULL) |
432 | return NULL; | |
3ffc7a36 MD |
433 | for (i = 0; i < n; ++i) |
434 | { | |
4057a3e0 | 435 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
436 | if (SCM_I_INUMP (val)) |
437 | m[i] = SCM_I_INUM (val); | |
3ffc7a36 | 438 | else if (SCM_BIGP (val)) |
b9bd8526 | 439 | m[i] = scm_to_long (val); |
3ffc7a36 | 440 | else |
eb42e2f0 | 441 | m[i] = SCM_REAL_VALUE (val); |
f3a2c4cf MD |
442 | } |
443 | break; | |
3ffc7a36 MD |
444 | default: |
445 | scm_wrong_type_arg (0, 0, obj); | |
446 | } | |
447 | return m; | |
448 | } | |
449 | ||
450 | /* Convert a vector, weak vector or uniform vector into an array of | |
d3dd80ab MG |
451 | doubles. If result array in arg 2 is NULL, malloc a new one. If |
452 | out of memory, return NULL. */ | |
3ffc7a36 MD |
453 | double * |
454 | gh_scm2doubles (SCM obj, double *m) | |
455 | { | |
c014a02e | 456 | long i, n; |
3ffc7a36 | 457 | SCM val; |
1a548472 | 458 | if (SCM_IMP (obj)) |
3ffc7a36 | 459 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
460 | |
461 | /* XXX - f32vectors are rejected now. | |
462 | */ | |
463 | SCM2WHATEVER (obj, scm_f64vector_p, double, double) | |
464 | ||
3ffc7a36 MD |
465 | switch (SCM_TYP7 (obj)) |
466 | { | |
467 | case scm_tc7_vector: | |
468 | case scm_tc7_wvect: | |
4057a3e0 | 469 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
470 | for (i = 0; i < n; ++i) |
471 | { | |
4057a3e0 | 472 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 473 | if (!SCM_I_INUMP (val) |
0c95b57d | 474 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
475 | scm_wrong_type_arg (0, 0, val); |
476 | } | |
477 | if (m == 0) | |
478 | m = (double *) malloc (n * sizeof (double)); | |
d3dd80ab MG |
479 | if (m == NULL) |
480 | return NULL; | |
3ffc7a36 MD |
481 | for (i = 0; i < n; ++i) |
482 | { | |
4057a3e0 | 483 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
484 | if (SCM_I_INUMP (val)) |
485 | m[i] = SCM_I_INUM (val); | |
3ffc7a36 | 486 | else if (SCM_BIGP (val)) |
b9bd8526 | 487 | m[i] = scm_to_long (val); |
3ffc7a36 | 488 | else |
eb42e2f0 | 489 | m[i] = SCM_REAL_VALUE (val); |
3ffc7a36 MD |
490 | } |
491 | break; | |
16d35552 | 492 | |
f3a2c4cf MD |
493 | default: |
494 | scm_wrong_type_arg (0, 0, obj); | |
495 | } | |
496 | return m; | |
497 | } | |
498 | ||
ee2a8b9b JB |
499 | /* string conversions between C and Scheme */ |
500 | ||
501 | /* gh_scm2newstr() -- Given a Scheme string STR, return a pointer to a | |
502 | new copy of its contents, followed by a null byte. If lenp is | |
503 | non-null, set *lenp to the string's length. | |
504 | ||
505 | This function uses malloc to obtain storage for the copy; the | |
d3dd80ab MG |
506 | caller is responsible for freeing it. If out of memory, NULL is |
507 | returned. | |
ee2a8b9b JB |
508 | |
509 | Note that Scheme strings may contain arbitrary data, including null | |
510 | characters. This means that null termination is not a reliable way | |
511 | to determine the length of the returned value. However, the | |
512 | function always copies the complete contents of STR, and sets | |
513 | *LEN_P to the true length of the string (when LEN_P is non-null). */ | |
514 | char * | |
1be6b49c | 515 | gh_scm2newstr (SCM str, size_t *lenp) |
ee2a8b9b JB |
516 | { |
517 | char *ret_str; | |
ee2a8b9b | 518 | |
79c98b33 MV |
519 | /* We can't use scm_to_locale_stringn directly since it does not |
520 | guarantee null-termination when lenp is non-NULL. | |
521 | */ | |
ee2a8b9b | 522 | |
79c98b33 MV |
523 | ret_str = scm_to_locale_string (str); |
524 | if (lenp) | |
f76c6bb2 | 525 | *lenp = scm_i_string_length (str); |
ee2a8b9b JB |
526 | return ret_str; |
527 | } | |
528 | ||
ee2a8b9b JB |
529 | /* Copy LEN characters at START from the Scheme string SRC to memory |
530 | at DST. START is an index into SRC; zero means the beginning of | |
531 | the string. DST has already been allocated by the caller. | |
532 | ||
533 | If START + LEN is off the end of SRC, silently truncate the source | |
534 | region to fit the string. If truncation occurs, the corresponding | |
535 | area of DST is left unchanged. */ | |
536 | void | |
c014a02e | 537 | gh_get_substr (SCM src, char *dst, long start, size_t len) |
ee2a8b9b | 538 | { |
1be6b49c | 539 | size_t src_len, effective_length; |
f76c6bb2 | 540 | SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr"); |
ee2a8b9b | 541 | |
f76c6bb2 | 542 | src_len = scm_i_string_length (src); |
ee2a8b9b | 543 | effective_length = (len < src_len) ? len : src_len; |
f76c6bb2 | 544 | memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char)); |
ee2a8b9b | 545 | /* FIXME: must signal an error if len > src_len */ |
5d2b97cd | 546 | scm_remember_upto_here_1 (src); |
ee2a8b9b JB |
547 | } |
548 | ||
549 | ||
550 | /* gh_scm2newsymbol() -- Given a Scheme symbol 'identifier, return a | |
551 | pointer to a string with the symbol characters "identifier", | |
552 | followed by a null byte. If lenp is non-null, set *lenp to the | |
553 | string's length. | |
554 | ||
555 | This function uses malloc to obtain storage for the copy; the | |
d3dd80ab MG |
556 | caller is responsible for freeing it. If out of memory, NULL is |
557 | returned.*/ | |
ee2a8b9b | 558 | char * |
1be6b49c | 559 | gh_symbol2newstr (SCM sym, size_t *lenp) |
ee2a8b9b | 560 | { |
f76c6bb2 | 561 | return gh_scm2newstr (scm_symbol_to_string (sym), lenp); |
ee2a8b9b JB |
562 | } |
563 | ||
564 | ||
565 | /* create a new vector of the given length, all initialized to the | |
566 | given value */ | |
e5eece74 MG |
567 | SCM |
568 | gh_make_vector (SCM len, SCM fill) | |
ee2a8b9b | 569 | { |
a8741caa | 570 | return scm_make_vector (len, fill); |
ee2a8b9b JB |
571 | } |
572 | ||
573 | /* set the given element of the given vector to the given value */ | |
574 | SCM | |
956328d2 | 575 | gh_vector_set_x (SCM vec, SCM pos, SCM val) |
ee2a8b9b JB |
576 | { |
577 | return scm_vector_set_x (vec, pos, val); | |
578 | } | |
579 | ||
580 | /* retrieve the given element of the given vector */ | |
581 | SCM | |
e5eece74 | 582 | gh_vector_ref (SCM vec, SCM pos) |
ee2a8b9b JB |
583 | { |
584 | return scm_vector_ref (vec, pos); | |
585 | } | |
586 | ||
587 | /* returns the length of the given vector */ | |
c014a02e | 588 | unsigned long |
ee2a8b9b JB |
589 | gh_vector_length (SCM v) |
590 | { | |
4057a3e0 | 591 | return (unsigned long) scm_c_vector_length (v); |
ee2a8b9b | 592 | } |
35379308 | 593 | |
ef5d3ae1 MG |
594 | /* uniform vector support */ |
595 | ||
596 | /* returns the length as a C unsigned long integer */ | |
c014a02e | 597 | unsigned long |
ef5d3ae1 MG |
598 | gh_uniform_vector_length (SCM v) |
599 | { | |
65b39e8a | 600 | return (unsigned long) scm_c_uniform_vector_length (v); |
ef5d3ae1 MG |
601 | } |
602 | ||
603 | /* gets the given element from a uniform vector; ilist is a list (or | |
604 | possibly a single integer) of indices, and its length is the | |
605 | dimension of the uniform vector */ | |
606 | SCM | |
607 | gh_uniform_vector_ref (SCM v, SCM ilist) | |
608 | { | |
609 | return scm_uniform_vector_ref (v, ilist); | |
610 | } | |
611 | ||
612 | /* sets an individual element in a uniform vector */ | |
613 | /* SCM */ | |
614 | /* gh_list_to_uniform_array ( */ | |
ef5d3ae1 | 615 | |
35379308 JB |
616 | /* Data lookups between C and Scheme |
617 | ||
618 | Look up a symbol with a given name, and return the object to which | |
619 | it is bound. gh_lookup examines the Guile top level, and | |
620 | gh_module_lookup checks the module namespace specified by the | |
621 | `vec' argument. | |
622 | ||
623 | The return value is the Scheme object to which SNAME is bound, or | |
07de6c47 MV |
624 | SCM_UNDEFINED if SNAME is not bound in the given context. |
625 | */ | |
35379308 JB |
626 | |
627 | SCM | |
bcee10dd | 628 | gh_lookup (const char *sname) |
35379308 | 629 | { |
abc235ad | 630 | return gh_module_lookup (scm_current_module (), sname); |
35379308 JB |
631 | } |
632 | ||
abc235ad | 633 | |
35379308 | 634 | SCM |
abc235ad MV |
635 | gh_module_lookup (SCM module, const char *sname) |
636 | #define FUNC_NAME "gh_module_lookup" | |
35379308 | 637 | { |
86d31dfe | 638 | SCM sym, var; |
abc235ad MV |
639 | |
640 | SCM_VALIDATE_MODULE (SCM_ARG1, module); | |
641 | ||
f76c6bb2 | 642 | sym = scm_from_locale_symbol (sname); |
86d31dfe MV |
643 | var = scm_sym2var (sym, scm_module_lookup_closure (module), SCM_BOOL_F); |
644 | if (var != SCM_BOOL_F) | |
645 | return SCM_VARIABLE_REF (var); | |
35379308 JB |
646 | else |
647 | return SCM_UNDEFINED; | |
648 | } | |
abc235ad | 649 | #undef FUNC_NAME |
89e00824 ML |
650 | |
651 | /* | |
652 | Local Variables: | |
653 | c-file-style: "gnu" | |
654 | End: | |
655 | */ |