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 | |
92205699 | 14 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 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 | ||
5c56ebe1 MV |
31 | #if SCM_ENABLE_DEPRECATED |
32 | ||
ee2a8b9b | 33 | /* data conversion C->scheme */ |
bcee10dd | 34 | |
dbb3005d MG |
35 | SCM |
36 | gh_bool2scm (int x) | |
ee2a8b9b | 37 | { |
7888309b | 38 | return scm_from_bool(x); |
ee2a8b9b JB |
39 | } |
40 | SCM | |
41 | gh_int2scm (int x) | |
42 | { | |
b9bd8526 | 43 | return scm_from_long ((long) x); |
ee2a8b9b JB |
44 | } |
45 | SCM | |
46 | gh_ulong2scm (unsigned long x) | |
47 | { | |
b9bd8526 | 48 | return scm_from_ulong (x); |
ee2a8b9b JB |
49 | } |
50 | SCM | |
51 | gh_long2scm (long x) | |
52 | { | |
b9bd8526 | 53 | return scm_from_long (x); |
ee2a8b9b JB |
54 | } |
55 | SCM | |
56 | gh_double2scm (double x) | |
57 | { | |
d9a67fc4 | 58 | return scm_from_double (x); |
ee2a8b9b JB |
59 | } |
60 | SCM | |
61 | gh_char2scm (char c) | |
62 | { | |
7866a09b | 63 | return SCM_MAKE_CHAR (c); |
ee2a8b9b JB |
64 | } |
65 | SCM | |
1be6b49c | 66 | gh_str2scm (const char *s, size_t len) |
ee2a8b9b | 67 | { |
f76c6bb2 | 68 | return scm_from_locale_stringn (s, len); |
ee2a8b9b JB |
69 | } |
70 | SCM | |
6e706938 | 71 | gh_str02scm (const char *s) |
ee2a8b9b | 72 | { |
f76c6bb2 | 73 | return scm_from_locale_string (s); |
ee2a8b9b JB |
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 | |
f76c6bb2 | 82 | gh_set_substr (const char *src, SCM dst, long start, size_t len) |
ee2a8b9b | 83 | { |
2c92112b | 84 | char *dst_ptr; |
1be6b49c | 85 | size_t dst_len; |
ee2a8b9b | 86 | |
f76c6bb2 | 87 | SCM_ASSERT (scm_is_string (dst), dst, SCM_ARG3, "gh_set_substr"); |
fd88bd7c | 88 | |
f76c6bb2 | 89 | dst_len = scm_i_string_length (dst); |
729dbac3 | 90 | SCM_ASSERT (start + len <= dst_len, dst, SCM_ARG4, "gh_set_substr"); |
f76c6bb2 MV |
91 | |
92 | dst_ptr = scm_i_string_writable_chars (dst); | |
729dbac3 | 93 | memmove (dst_ptr + start, src, len); |
f76c6bb2 | 94 | scm_i_string_stop_writing (); |
5d2b97cd | 95 | scm_remember_upto_here_1 (dst); |
ee2a8b9b JB |
96 | } |
97 | ||
98 | /* Return the symbol named SYMBOL_STR. */ | |
99 | SCM | |
4921140c | 100 | gh_symbol2scm (const char *symbol_str) |
ee2a8b9b | 101 | { |
f76c6bb2 | 102 | return scm_from_locale_symbol(symbol_str); |
ee2a8b9b JB |
103 | } |
104 | ||
b774ee1f | 105 | SCM |
c014a02e | 106 | gh_ints2scm (const int *d, long n) |
b774ee1f | 107 | { |
c014a02e | 108 | long i; |
00ffa0e7 | 109 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
b774ee1f | 110 | for (i = 0; i < n; ++i) |
4057a3e0 | 111 | SCM_SIMPLE_VECTOR_SET (v, i, scm_from_int (d[i])); |
8f379a8f | 112 | |
0acef67a | 113 | return v; |
3ffc7a36 MD |
114 | } |
115 | ||
116 | SCM | |
c014a02e | 117 | gh_doubles2scm (const double *d, long n) |
3ffc7a36 | 118 | { |
c014a02e | 119 | long i; |
00ffa0e7 | 120 | SCM v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
0acef67a JB |
121 | |
122 | for(i = 0; i < n; i++) | |
4057a3e0 | 123 | SCM_SIMPLE_VECTOR_SET (v, i, scm_from_double (d[i])); |
0acef67a JB |
124 | return v; |
125 | } | |
126 | ||
b774ee1f | 127 | |
3ffc7a36 | 128 | SCM |
c014a02e | 129 | gh_chars2byvect (const char *d, long n) |
3ffc7a36 | 130 | { |
bbe6ba23 | 131 | char *m = scm_malloc (n); |
3ffc7a36 | 132 | memcpy (m, d, n * sizeof (char)); |
5a6d139b | 133 | return scm_take_s8vector ((scm_t_int8 *)m, n); |
3ffc7a36 MD |
134 | } |
135 | ||
136 | SCM | |
c014a02e | 137 | gh_shorts2svect (const short *d, long n) |
3ffc7a36 | 138 | { |
bbe6ba23 | 139 | char *m = scm_malloc (n * sizeof (short)); |
3ffc7a36 | 140 | memcpy (m, d, n * sizeof (short)); |
bbe6ba23 MV |
141 | assert (sizeof (scm_t_int16) == sizeof (short)); |
142 | return scm_take_s16vector ((scm_t_int16 *)m, n); | |
3ffc7a36 MD |
143 | } |
144 | ||
b774ee1f | 145 | SCM |
c014a02e | 146 | gh_longs2ivect (const long *d, long n) |
b774ee1f | 147 | { |
bbe6ba23 | 148 | char *m = scm_malloc (n * sizeof (long)); |
b774ee1f | 149 | memcpy (m, d, n * sizeof (long)); |
bbe6ba23 MV |
150 | assert (sizeof (scm_t_int32) == sizeof (long)); |
151 | return scm_take_s32vector ((scm_t_int32 *)m, n); | |
b774ee1f MD |
152 | } |
153 | ||
154 | SCM | |
c014a02e | 155 | gh_ulongs2uvect (const unsigned long *d, long n) |
b774ee1f | 156 | { |
bbe6ba23 | 157 | char *m = scm_malloc (n * sizeof (unsigned long)); |
b774ee1f | 158 | memcpy (m, d, n * sizeof (unsigned long)); |
bbe6ba23 MV |
159 | assert (sizeof (scm_t_uint32) == sizeof (unsigned long)); |
160 | return scm_take_u32vector ((scm_t_uint32 *)m, n); | |
b774ee1f MD |
161 | } |
162 | ||
163 | SCM | |
c014a02e | 164 | gh_floats2fvect (const float *d, long n) |
b774ee1f | 165 | { |
bbe6ba23 | 166 | char *m = scm_malloc (n * sizeof (float)); |
3ffc7a36 | 167 | memcpy (m, d, n * sizeof (float)); |
bbe6ba23 | 168 | return scm_take_f32vector ((float *)m, n); |
b774ee1f MD |
169 | } |
170 | ||
f3a2c4cf | 171 | SCM |
c014a02e | 172 | gh_doubles2dvect (const double *d, long n) |
f3a2c4cf | 173 | { |
bbe6ba23 | 174 | char *m = scm_malloc (n * sizeof (double)); |
f3a2c4cf | 175 | memcpy (m, d, n * sizeof (double)); |
bbe6ba23 | 176 | return scm_take_f64vector ((double *)m, n); |
f3a2c4cf | 177 | } |
ee2a8b9b JB |
178 | |
179 | /* data conversion scheme->C */ | |
180 | int | |
181 | gh_scm2bool (SCM obj) | |
182 | { | |
7888309b | 183 | return (scm_is_false (obj)) ? 0 : 1; |
ee2a8b9b JB |
184 | } |
185 | unsigned long | |
186 | gh_scm2ulong (SCM obj) | |
187 | { | |
b9bd8526 | 188 | return scm_to_ulong (obj); |
ee2a8b9b JB |
189 | } |
190 | long | |
191 | gh_scm2long (SCM obj) | |
192 | { | |
b9bd8526 | 193 | return scm_to_long (obj); |
ee2a8b9b JB |
194 | } |
195 | int | |
196 | gh_scm2int (SCM obj) | |
197 | { | |
b9bd8526 | 198 | return scm_to_int (obj); |
ee2a8b9b JB |
199 | } |
200 | double | |
201 | gh_scm2double (SCM obj) | |
202 | { | |
d9a67fc4 | 203 | return scm_to_double (obj); |
ee2a8b9b JB |
204 | } |
205 | char | |
206 | gh_scm2char (SCM obj) | |
0e1d5b0a | 207 | #define FUNC_NAME "gh_scm2char" |
ee2a8b9b | 208 | { |
0e1d5b0a | 209 | SCM_VALIDATE_CHAR (SCM_ARG1, obj); |
7866a09b | 210 | return SCM_CHAR (obj); |
ee2a8b9b | 211 | } |
fd336365 | 212 | #undef FUNC_NAME |
ee2a8b9b | 213 | |
3ffc7a36 MD |
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 | |
d3dd80ab | 216 | new one. If out of memory, return NULL. */ |
3ffc7a36 MD |
217 | char * |
218 | gh_scm2chars (SCM obj, char *m) | |
f3a2c4cf | 219 | { |
c014a02e ML |
220 | long i, n; |
221 | long v; | |
f3a2c4cf | 222 | SCM val; |
1a548472 | 223 | if (SCM_IMP (obj)) |
f3a2c4cf MD |
224 | scm_wrong_type_arg (0, 0, obj); |
225 | switch (SCM_TYP7 (obj)) | |
226 | { | |
227 | case scm_tc7_vector: | |
228 | case scm_tc7_wvect: | |
4057a3e0 | 229 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
f3a2c4cf MD |
230 | for (i = 0; i < n; ++i) |
231 | { | |
4057a3e0 | 232 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 233 | if (SCM_I_INUMP (val)) |
3ffc7a36 | 234 | { |
e11e83f3 | 235 | v = SCM_I_INUM (val); |
3ffc7a36 MD |
236 | if (v < -128 || v > 255) |
237 | scm_out_of_range (0, obj); | |
238 | } | |
f3a2c4cf | 239 | else |
3ffc7a36 MD |
240 | scm_wrong_type_arg (0, 0, obj); |
241 | } | |
242 | if (m == 0) | |
243 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
244 | if (m == NULL) |
245 | return NULL; | |
3ffc7a36 | 246 | for (i = 0; i < n; ++i) |
4057a3e0 | 247 | m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i)); |
3ffc7a36 | 248 | break; |
2a7bd738 MV |
249 | case scm_tc7_smob: |
250 | if (scm_is_true (scm_s8vector_p (obj))) | |
251 | { | |
4057a3e0 MV |
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)); | |
2a7bd738 | 261 | if (m == 0) |
4057a3e0 | 262 | m = (char *) malloc (len); |
c8857a4d MV |
263 | if (m != NULL) |
264 | memcpy (m, elts, len); | |
265 | scm_array_handle_release (&handle); | |
2a7bd738 MV |
266 | if (m == NULL) |
267 | return NULL; | |
2a7bd738 MV |
268 | break; |
269 | } | |
270 | else | |
271 | goto wrong_type; | |
3ffc7a36 | 272 | case scm_tc7_string: |
f76c6bb2 | 273 | n = scm_i_string_length (obj); |
3ffc7a36 MD |
274 | if (m == 0) |
275 | m = (char *) malloc (n * sizeof (char)); | |
d3dd80ab MG |
276 | if (m == NULL) |
277 | return NULL; | |
f76c6bb2 | 278 | memcpy (m, scm_i_string_chars (obj), n * sizeof (char)); |
3ffc7a36 MD |
279 | break; |
280 | default: | |
2a7bd738 | 281 | wrong_type: |
3ffc7a36 MD |
282 | scm_wrong_type_arg (0, 0, obj); |
283 | } | |
284 | return m; | |
285 | } | |
286 | ||
bbe6ba23 MV |
287 | static void * |
288 | scm2whatever (SCM obj, void *m, size_t size) | |
289 | { | |
4057a3e0 MV |
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 | ||
bbe6ba23 | 301 | if (m == 0) |
4057a3e0 | 302 | m = malloc (len * sizeof (size)); |
c8857a4d MV |
303 | if (m != NULL) |
304 | memcpy (m, elts, len * size); | |
305 | ||
306 | scm_array_handle_release (&handle); | |
307 | ||
bbe6ba23 MV |
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 | ||
3ffc7a36 | 318 | /* Convert a vector, weak vector or uniform vector into an array of |
d3dd80ab MG |
319 | shorts. If result array in arg 2 is NULL, malloc a new one. If |
320 | out of memory, return NULL. */ | |
3ffc7a36 MD |
321 | short * |
322 | gh_scm2shorts (SCM obj, short *m) | |
323 | { | |
c014a02e ML |
324 | long i, n; |
325 | long v; | |
3ffc7a36 | 326 | SCM val; |
1a548472 | 327 | if (SCM_IMP (obj)) |
3ffc7a36 | 328 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
329 | |
330 | SCM2WHATEVER (obj, scm_s16vector_p, scm_t_int16, short) | |
331 | ||
3ffc7a36 MD |
332 | switch (SCM_TYP7 (obj)) |
333 | { | |
334 | case scm_tc7_vector: | |
335 | case scm_tc7_wvect: | |
4057a3e0 | 336 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
337 | for (i = 0; i < n; ++i) |
338 | { | |
4057a3e0 | 339 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 340 | if (SCM_I_INUMP (val)) |
f3a2c4cf | 341 | { |
e11e83f3 | 342 | v = SCM_I_INUM (val); |
3ffc7a36 MD |
343 | if (v < -32768 || v > 65535) |
344 | scm_out_of_range (0, obj); | |
f3a2c4cf | 345 | } |
3ffc7a36 MD |
346 | else |
347 | scm_wrong_type_arg (0, 0, obj); | |
348 | } | |
349 | if (m == 0) | |
350 | m = (short *) malloc (n * sizeof (short)); | |
d3dd80ab MG |
351 | if (m == NULL) |
352 | return NULL; | |
3ffc7a36 | 353 | for (i = 0; i < n; ++i) |
4057a3e0 | 354 | m[i] = SCM_I_INUM (SCM_SIMPLE_VECTOR_REF (obj, i)); |
3ffc7a36 | 355 | break; |
3ffc7a36 MD |
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 | |
d3dd80ab MG |
363 | longs. If result array in arg 2 is NULL, malloc a new one. If out |
364 | of memory, return NULL. */ | |
3ffc7a36 MD |
365 | long * |
366 | gh_scm2longs (SCM obj, long *m) | |
367 | { | |
c014a02e | 368 | long i, n; |
3ffc7a36 | 369 | SCM val; |
1a548472 | 370 | if (SCM_IMP (obj)) |
3ffc7a36 | 371 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
372 | |
373 | SCM2WHATEVER (obj, scm_s32vector_p, scm_t_int32, long) | |
374 | ||
3ffc7a36 MD |
375 | switch (SCM_TYP7 (obj)) |
376 | { | |
377 | case scm_tc7_vector: | |
378 | case scm_tc7_wvect: | |
4057a3e0 | 379 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
380 | for (i = 0; i < n; ++i) |
381 | { | |
4057a3e0 | 382 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 383 | if (!SCM_I_INUMP (val) && !SCM_BIGP (val)) |
3ffc7a36 MD |
384 | scm_wrong_type_arg (0, 0, obj); |
385 | } | |
386 | if (m == 0) | |
387 | m = (long *) malloc (n * sizeof (long)); | |
d3dd80ab MG |
388 | if (m == NULL) |
389 | return NULL; | |
3ffc7a36 MD |
390 | for (i = 0; i < n; ++i) |
391 | { | |
4057a3e0 | 392 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
393 | m[i] = SCM_I_INUMP (val) |
394 | ? SCM_I_INUM (val) | |
b9bd8526 | 395 | : scm_to_long (val); |
3ffc7a36 MD |
396 | } |
397 | break; | |
3ffc7a36 MD |
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 | |
d3dd80ab MG |
405 | floats. If result array in arg 2 is NULL, malloc a new one. If |
406 | out of memory, return NULL. */ | |
3ffc7a36 MD |
407 | float * |
408 | gh_scm2floats (SCM obj, float *m) | |
409 | { | |
c014a02e | 410 | long i, n; |
3ffc7a36 | 411 | SCM val; |
1a548472 | 412 | if (SCM_IMP (obj)) |
3ffc7a36 | 413 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
414 | |
415 | /* XXX - f64vectors are rejected now. | |
416 | */ | |
417 | SCM2WHATEVER (obj, scm_f32vector_p, float, float) | |
418 | ||
3ffc7a36 MD |
419 | switch (SCM_TYP7 (obj)) |
420 | { | |
421 | case scm_tc7_vector: | |
422 | case scm_tc7_wvect: | |
4057a3e0 | 423 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
424 | for (i = 0; i < n; ++i) |
425 | { | |
4057a3e0 | 426 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 427 | if (!SCM_I_INUMP (val) |
0c95b57d | 428 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
429 | scm_wrong_type_arg (0, 0, val); |
430 | } | |
431 | if (m == 0) | |
432 | m = (float *) malloc (n * sizeof (float)); | |
d3dd80ab MG |
433 | if (m == NULL) |
434 | return NULL; | |
3ffc7a36 MD |
435 | for (i = 0; i < n; ++i) |
436 | { | |
4057a3e0 | 437 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
438 | if (SCM_I_INUMP (val)) |
439 | m[i] = SCM_I_INUM (val); | |
3ffc7a36 | 440 | else if (SCM_BIGP (val)) |
b9bd8526 | 441 | m[i] = scm_to_long (val); |
3ffc7a36 | 442 | else |
eb42e2f0 | 443 | m[i] = SCM_REAL_VALUE (val); |
f3a2c4cf MD |
444 | } |
445 | break; | |
3ffc7a36 MD |
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 | |
d3dd80ab MG |
453 | doubles. If result array in arg 2 is NULL, malloc a new one. If |
454 | out of memory, return NULL. */ | |
3ffc7a36 MD |
455 | double * |
456 | gh_scm2doubles (SCM obj, double *m) | |
457 | { | |
c014a02e | 458 | long i, n; |
3ffc7a36 | 459 | SCM val; |
1a548472 | 460 | if (SCM_IMP (obj)) |
3ffc7a36 | 461 | scm_wrong_type_arg (0, 0, obj); |
bbe6ba23 MV |
462 | |
463 | /* XXX - f32vectors are rejected now. | |
464 | */ | |
465 | SCM2WHATEVER (obj, scm_f64vector_p, double, double) | |
466 | ||
3ffc7a36 MD |
467 | switch (SCM_TYP7 (obj)) |
468 | { | |
469 | case scm_tc7_vector: | |
470 | case scm_tc7_wvect: | |
4057a3e0 | 471 | n = SCM_SIMPLE_VECTOR_LENGTH (obj); |
3ffc7a36 MD |
472 | for (i = 0; i < n; ++i) |
473 | { | |
4057a3e0 | 474 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 | 475 | if (!SCM_I_INUMP (val) |
0c95b57d | 476 | && !(SCM_BIGP (val) || SCM_REALP (val))) |
3ffc7a36 MD |
477 | scm_wrong_type_arg (0, 0, val); |
478 | } | |
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 | { | |
4057a3e0 | 485 | val = SCM_SIMPLE_VECTOR_REF (obj, i); |
e11e83f3 MV |
486 | if (SCM_I_INUMP (val)) |
487 | m[i] = SCM_I_INUM (val); | |
3ffc7a36 | 488 | else if (SCM_BIGP (val)) |
b9bd8526 | 489 | m[i] = scm_to_long (val); |
3ffc7a36 | 490 | else |
eb42e2f0 | 491 | m[i] = SCM_REAL_VALUE (val); |
3ffc7a36 MD |
492 | } |
493 | break; | |
16d35552 | 494 | |
f3a2c4cf MD |
495 | default: |
496 | scm_wrong_type_arg (0, 0, obj); | |
497 | } | |
498 | return m; | |
499 | } | |
500 | ||
ee2a8b9b JB |
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 | |
d3dd80ab MG |
508 | caller is responsible for freeing it. If out of memory, NULL is |
509 | returned. | |
ee2a8b9b JB |
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 * | |
1be6b49c | 517 | gh_scm2newstr (SCM str, size_t *lenp) |
ee2a8b9b JB |
518 | { |
519 | char *ret_str; | |
ee2a8b9b | 520 | |
79c98b33 MV |
521 | /* We can't use scm_to_locale_stringn directly since it does not |
522 | guarantee null-termination when lenp is non-NULL. | |
523 | */ | |
ee2a8b9b | 524 | |
79c98b33 MV |
525 | ret_str = scm_to_locale_string (str); |
526 | if (lenp) | |
f76c6bb2 | 527 | *lenp = scm_i_string_length (str); |
ee2a8b9b JB |
528 | return ret_str; |
529 | } | |
530 | ||
ee2a8b9b JB |
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 | |
c014a02e | 539 | gh_get_substr (SCM src, char *dst, long start, size_t len) |
ee2a8b9b | 540 | { |
1be6b49c | 541 | size_t src_len, effective_length; |
f76c6bb2 | 542 | SCM_ASSERT (scm_is_string (src), src, SCM_ARG3, "gh_get_substr"); |
ee2a8b9b | 543 | |
f76c6bb2 | 544 | src_len = scm_i_string_length (src); |
ee2a8b9b | 545 | effective_length = (len < src_len) ? len : src_len; |
f76c6bb2 | 546 | memcpy (dst + start, scm_i_string_chars (src), effective_length * sizeof (char)); |
ee2a8b9b | 547 | /* FIXME: must signal an error if len > src_len */ |
5d2b97cd | 548 | scm_remember_upto_here_1 (src); |
ee2a8b9b JB |
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 | |
d3dd80ab MG |
558 | caller is responsible for freeing it. If out of memory, NULL is |
559 | returned.*/ | |
ee2a8b9b | 560 | char * |
1be6b49c | 561 | gh_symbol2newstr (SCM sym, size_t *lenp) |
ee2a8b9b | 562 | { |
f76c6bb2 | 563 | return gh_scm2newstr (scm_symbol_to_string (sym), lenp); |
ee2a8b9b JB |
564 | } |
565 | ||
566 | ||
567 | /* create a new vector of the given length, all initialized to the | |
568 | given value */ | |
e5eece74 MG |
569 | SCM |
570 | gh_make_vector (SCM len, SCM fill) | |
ee2a8b9b | 571 | { |
a8741caa | 572 | return scm_make_vector (len, fill); |
ee2a8b9b JB |
573 | } |
574 | ||
575 | /* set the given element of the given vector to the given value */ | |
576 | SCM | |
956328d2 | 577 | gh_vector_set_x (SCM vec, SCM pos, SCM val) |
ee2a8b9b JB |
578 | { |
579 | return scm_vector_set_x (vec, pos, val); | |
580 | } | |
581 | ||
582 | /* retrieve the given element of the given vector */ | |
583 | SCM | |
e5eece74 | 584 | gh_vector_ref (SCM vec, SCM pos) |
ee2a8b9b JB |
585 | { |
586 | return scm_vector_ref (vec, pos); | |
587 | } | |
588 | ||
589 | /* returns the length of the given vector */ | |
c014a02e | 590 | unsigned long |
ee2a8b9b JB |
591 | gh_vector_length (SCM v) |
592 | { | |
4057a3e0 | 593 | return (unsigned long) scm_c_vector_length (v); |
ee2a8b9b | 594 | } |
35379308 | 595 | |
ef5d3ae1 MG |
596 | /* uniform vector support */ |
597 | ||
598 | /* returns the length as a C unsigned long integer */ | |
c014a02e | 599 | unsigned long |
ef5d3ae1 MG |
600 | gh_uniform_vector_length (SCM v) |
601 | { | |
65b39e8a | 602 | return (unsigned long) scm_c_uniform_vector_length (v); |
ef5d3ae1 MG |
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 | |
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 ( */ | |
ef5d3ae1 | 617 | |
35379308 JB |
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 | |
07de6c47 MV |
626 | SCM_UNDEFINED if SNAME is not bound in the given context. |
627 | */ | |
35379308 JB |
628 | |
629 | SCM | |
bcee10dd | 630 | gh_lookup (const char *sname) |
35379308 | 631 | { |
abc235ad | 632 | return gh_module_lookup (scm_current_module (), sname); |
35379308 JB |
633 | } |
634 | ||
abc235ad | 635 | |
35379308 | 636 | SCM |
abc235ad MV |
637 | gh_module_lookup (SCM module, const char *sname) |
638 | #define FUNC_NAME "gh_module_lookup" | |
35379308 | 639 | { |
86d31dfe | 640 | SCM sym, var; |
abc235ad MV |
641 | |
642 | SCM_VALIDATE_MODULE (SCM_ARG1, module); | |
643 | ||
f76c6bb2 | 644 | sym = scm_from_locale_symbol (sname); |
86d31dfe MV |
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); | |
35379308 JB |
648 | else |
649 | return SCM_UNDEFINED; | |
650 | } | |
abc235ad | 651 | #undef FUNC_NAME |
89e00824 | 652 | |
5c56ebe1 MV |
653 | #endif /* SCM_ENABLE_DEPRECATED */ |
654 | ||
89e00824 ML |
655 | /* |
656 | Local Variables: | |
657 | c-file-style: "gnu" | |
658 | End: | |
659 | */ |