5 |
|
|
6 |
|
|
7 |
/* Convert a vector, weak vector, (if possible string, substring), list |
/* Convert a vector, weak vector, (if possible string, substring), list |
8 |
or uniform vector into an C array. If result array in argument 2 is |
or uniform vector into an C array. If the result array in argument 2 |
9 |
NULL, malloc() a new one. If out of memory, return NULL. */ |
is NULL, malloc() a new one. If out of memory, return NULL. */ |
10 |
#define FUNC_NAME SCM2CTYPES_FN |
#define FUNC_NAME SCM2CTYPES_FN |
11 |
CTYPE * |
CTYPE * |
12 |
SCM2CTYPES (SCM obj, CTYPE *data) |
SCM2CTYPES (SCM obj, CTYPE *data) |
17 |
SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)), |
SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)), |
18 |
obj, SCM_ARG1, FUNC_NAME); |
obj, SCM_ARG1, FUNC_NAME); |
19 |
|
|
20 |
|
/* list conversion */ |
21 |
if (SCM_NFALSEP (scm_list_p (obj))) |
if (SCM_NFALSEP (scm_list_p (obj))) |
22 |
{ |
{ |
23 |
|
/* traverse the given list and validate the range of each member */ |
24 |
SCM list = obj; |
SCM list = obj; |
25 |
for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++) |
for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++) |
26 |
{ |
{ |
27 |
val = SCM_CAR (list); |
val = SCM_CAR (list); |
28 |
#if defined (CTYPEMIN) && defined (CTYPEMAX) |
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS |
29 |
|
/* check integer ranges */ |
30 |
if (SCM_INUMP (val)) |
if (SCM_INUMP (val)) |
31 |
{ |
{ |
32 |
long v = SCM_INUM (val); |
scm_t_signed_bits v = SCM_INUM (val); |
33 |
SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); |
CTYPE c = (CTYPE) v; |
34 |
|
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); |
35 |
} |
} |
36 |
else |
/* check big number ranges */ |
37 |
#elif defined (FLOATTYPE1) |
else if (SCM_BIGP (val)) |
38 |
if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) |
{ |
39 |
|
scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME); |
40 |
|
CTYPE c = (CTYPE) v; |
41 |
|
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); |
42 |
|
} |
43 |
|
else |
44 |
|
/* check float types */ |
45 |
|
#elif defined (FLOATTYPE) |
46 |
|
/* real values, big numbers and immediate values are valid |
47 |
|
for float conversions */ |
48 |
|
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) |
49 |
#else |
#else |
50 |
if (!SCM_INUMP (val) && !SCM_BIGP (val)) |
if (!SCM_BIGP (val) && !SCM_INUMP (val)) |
51 |
#endif |
#endif /* FLOATTYPE */ |
52 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, val); |
53 |
} |
} |
54 |
|
|
55 |
|
/* allocate new memory if necessary */ |
56 |
if (data == NULL) |
if (data == NULL) |
57 |
data = (CTYPE *) malloc (n * sizeof (CTYPE)); |
{ |
58 |
if (data == NULL) |
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) |
59 |
return NULL; |
return NULL; |
60 |
|
} |
61 |
|
|
62 |
|
/* traverse the list once more and convert each member */ |
63 |
list = obj; |
list = obj; |
64 |
for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++) |
for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++) |
65 |
{ |
{ |
66 |
val = SCM_CAR (list); |
val = SCM_CAR (list); |
67 |
if (SCM_INUMP (val)) |
if (SCM_INUMP (val)) |
68 |
data[i] = SCM_INUM (val); |
data[i] = (CTYPE) SCM_INUM (val); |
69 |
else if (SCM_BIGP (val)) |
else if (SCM_BIGP (val)) |
70 |
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); |
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); |
71 |
#ifdef FLOATTYPE1 |
#if defined (FLOATTYPE) |
72 |
else |
else |
73 |
data[i] = (CTYPE) SCM_REAL_VALUE (val); |
data[i] = (CTYPE) SCM_REAL_VALUE (val); |
74 |
#endif |
#endif |
76 |
return data; |
return data; |
77 |
} |
} |
78 |
|
|
79 |
|
/* other conversions */ |
80 |
switch (SCM_TYP7 (obj)) |
switch (SCM_TYP7 (obj)) |
81 |
{ |
{ |
82 |
|
/* vectors and weak vectors */ |
83 |
case scm_tc7_vector: |
case scm_tc7_vector: |
84 |
case scm_tc7_wvect: |
case scm_tc7_wvect: |
85 |
n = SCM_VECTOR_LENGTH (obj); |
n = SCM_VECTOR_LENGTH (obj); |
86 |
|
/* traverse the given vector and validate each member */ |
87 |
for (i = 0; i < n; i++) |
for (i = 0; i < n; i++) |
88 |
{ |
{ |
89 |
val = SCM_VELTS (obj)[i]; |
val = SCM_VELTS (obj)[i]; |
90 |
|
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS |
91 |
#if defined (CTYPEMIN) && defined (CTYPEMAX) |
/* check integer ranges */ |
92 |
if (SCM_INUMP (val)) |
if (SCM_INUMP (val)) |
93 |
{ |
{ |
94 |
long v = SCM_INUM (val); |
scm_t_signed_bits v = SCM_INUM (val); |
95 |
SCM_ASSERT_RANGE (SCM_ARG1, obj, v >= CTYPEMIN && v <= CTYPEMAX); |
CTYPE c = (CTYPE) v; |
96 |
|
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); |
97 |
} |
} |
98 |
|
/* check big number ranges */ |
99 |
|
else if (SCM_BIGP (val)) |
100 |
|
{ |
101 |
|
scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME); |
102 |
|
CTYPE c = (CTYPE) v; |
103 |
|
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c); |
104 |
|
} |
105 |
else |
else |
106 |
#elif defined (FLOATTYPE1) |
/* check float types */ |
107 |
if (!SCM_INUMP (val) && !(SCM_BIGP (val) || SCM_REALP (val))) |
#elif defined (FLOATTYPE) |
108 |
|
/* real values, big numbers and immediate values are valid |
109 |
|
for float conversions */ |
110 |
|
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val)) |
111 |
#else |
#else |
112 |
if (!SCM_INUMP (val) && !SCM_BIGP (val)) |
if (!SCM_BIGP (val) && !SCM_INUMP (val)) |
113 |
#endif |
#endif /* FLOATTYPE */ |
114 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, val); |
115 |
} |
} |
116 |
|
|
117 |
|
/* allocate new memory if necessary */ |
118 |
if (data == NULL) |
if (data == NULL) |
119 |
data = (CTYPE *) malloc (n * sizeof (CTYPE)); |
{ |
120 |
if (data == NULL) |
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) |
121 |
return NULL; |
return NULL; |
122 |
|
} |
123 |
|
|
124 |
|
/* traverse the vector once more and convert each member */ |
125 |
for (i = 0; i < n; i++) |
for (i = 0; i < n; i++) |
126 |
{ |
{ |
127 |
val = SCM_VELTS (obj)[i]; |
val = SCM_VELTS (obj)[i]; |
129 |
data[i] = (CTYPE) SCM_INUM (val); |
data[i] = (CTYPE) SCM_INUM (val); |
130 |
else if (SCM_BIGP (val)) |
else if (SCM_BIGP (val)) |
131 |
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); |
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME); |
132 |
#ifdef FLOATTYPE1 |
#if defined (FLOATTYPE) |
133 |
else |
else |
134 |
data[i] = (CTYPE) SCM_REAL_VALUE (val); |
data[i] = (CTYPE) SCM_REAL_VALUE (val); |
135 |
#endif |
#endif |
137 |
break; |
break; |
138 |
|
|
139 |
#ifdef HAVE_ARRAYS |
#ifdef HAVE_ARRAYS |
140 |
case ARRAYTYPE1: |
/* array conversions (uniform vectors) */ |
141 |
#ifdef ARRAYTYPE2 |
case ARRAYTYPE: |
142 |
case ARRAYTYPE2: |
#ifdef ARRAYTYPE_OPTIONAL |
143 |
|
case ARRAYTYPE_OPTIONAL: |
144 |
#endif |
#endif |
145 |
n = SCM_UVECTOR_LENGTH (obj); |
n = SCM_UVECTOR_LENGTH (obj); |
146 |
|
|
147 |
|
/* allocate new memory if necessary */ |
148 |
if (data == NULL) |
if (data == NULL) |
149 |
data = (CTYPE *) malloc (n * sizeof (CTYPE)); |
{ |
150 |
if (data == NULL) |
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) |
151 |
return NULL; |
return NULL; |
152 |
#ifdef FLOATTYPE2 |
} |
153 |
if (SCM_TYP7 (obj) == ARRAYTYPE2) |
|
154 |
|
#ifdef FLOATTYPE_OPTIONAL |
155 |
|
/* float <-> double conversions */ |
156 |
|
if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL) |
157 |
{ |
{ |
158 |
for (i = 0; i < n; i++) |
for (i = 0; i < n; i++) |
159 |
data[i] = ((FLOATTYPE2 *) SCM_UVECTOR_BASE (obj))[i]; |
data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i]; |
160 |
} |
} |
161 |
else |
else |
162 |
#endif |
#endif |
163 |
|
/* copy whole array */ |
164 |
memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); |
memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE)); |
165 |
break; |
break; |
166 |
#endif /* HAVE_ARRAYS */ |
#endif /* HAVE_ARRAYS */ |
167 |
|
|
168 |
#ifdef STRINGTYPE |
#if SIZEOF_CTYPE == 1 |
169 |
case scm_tc7_string: |
case scm_tc7_string: |
170 |
n = SCM_STRING_LENGTH (obj); |
n = SCM_STRING_LENGTH (obj); |
171 |
if (data == NULL) |
if (data == NULL) |
172 |
data = (CTYPE *) malloc (n * sizeof (CTYPE)); |
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL) |
173 |
if (data == NULL) |
return NULL; |
|
return NULL; |
|
174 |
memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); |
memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE)); |
175 |
break; |
break; |
176 |
#endif /* STRINGTYPE */ |
#endif |
177 |
|
|
178 |
default: |
default: |
179 |
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); |
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj); |
193 |
{ |
{ |
194 |
char *v; |
char *v; |
195 |
|
|
196 |
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), |
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), |
197 |
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); |
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); |
198 |
v = scm_gc_malloc (sizeof (CTYPE) * n, "vector"); |
v = scm_gc_malloc (n * sizeof (CTYPE), "uvect"); |
199 |
memcpy (v, data, n * sizeof (CTYPE)); |
memcpy (v, data, n * sizeof (CTYPE)); |
200 |
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); |
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v); |
201 |
} |
} |
202 |
#undef FUNC_NAME |
#undef FUNC_NAME |
203 |
|
|
204 |
#ifdef UVECTTYPE2 |
#ifdef UVECTTYPE_OPTIONAL |
205 |
#define FUNC_NAME CTYPES2UVECT_FN2 |
#define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL |
206 |
SCM |
SCM |
207 |
CTYPES2UVECT2 (const unsigned CTYPE *data, long n) |
CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n) |
208 |
{ |
{ |
209 |
char *v; |
char *v; |
210 |
|
|
211 |
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), |
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n), |
212 |
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); |
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH); |
213 |
v = scm_gc_malloc (sizeof (unsigned CTYPE) * n, "vector"); |
v = scm_gc_malloc (n * sizeof (unsigned CTYPE) * n, "uvect"); |
214 |
memcpy (v, data, n * sizeof (unsigned CTYPE)); |
memcpy (v, data, n * sizeof (unsigned CTYPE)); |
215 |
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE2), (scm_t_bits) v); |
return scm_alloc_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL), |
216 |
|
(scm_t_bits) v); |
217 |
} |
} |
218 |
#undef FUNC_NAME |
#undef FUNC_NAME |
219 |
#endif /* UVECTTYPE2 */ |
#endif /* UVECTTYPE_OPTIONAL */ |
220 |
|
|
221 |
#endif /* HAVE_ARRAYS */ |
#endif /* HAVE_ARRAYS */ |
222 |
|
|
223 |
|
|
224 |
/* Converts a C array into a vector. */ |
/* Converts a C array into a vector. */ |
225 |
#define FUNC_NAME CTYPES2SCM_FN |
#define FUNC_NAME CTYPES2SCM_FN |
226 |
SCM |
SCM |
234 |
v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
v = scm_c_make_vector (n, SCM_UNSPECIFIED); |
235 |
velts = SCM_VELTS (v); |
velts = SCM_VELTS (v); |
236 |
for (i = 0; i < n; i++) |
for (i = 0; i < n; i++) |
237 |
#ifdef FLOATTYPE1 |
#ifdef FLOATTYPE |
238 |
velts[i] = scm_make_real ((double) data[i]); |
velts[i] = scm_make_real ((double) data[i]); |
|
#elif defined (CTYPEFIXABLE) |
|
|
velts[i] = SCM_MAKINUM (data[i]); |
|
239 |
#else |
#else |
240 |
velts[i] = (SCM_FIXABLE (data[i]) ? SCM_MAKINUM (data[i]) : |
velts[i] = SCM_MAKINUM (data[i]); |
|
scm_i_long2big (data[i])); |
|
241 |
#endif |
#endif |
242 |
return v; |
return v; |
243 |
} |
} |
251 |
#undef CTYPE |
#undef CTYPE |
252 |
#undef CTYPES2UVECT |
#undef CTYPES2UVECT |
253 |
#undef CTYPES2UVECT_FN |
#undef CTYPES2UVECT_FN |
|
#ifdef CTYPEFIXABLE |
|
|
#undef CTYPEFIXABLE |
|
|
#endif |
|
254 |
#undef UVECTTYPE |
#undef UVECTTYPE |
255 |
#ifdef UVECTTYPE2 |
#ifdef UVECTTYPE_OPTIONAL |
256 |
#undef CTYPES2UVECT2 |
#undef CTYPES2UVECT_OPTIONAL |
257 |
#undef CTYPES2UVECT_FN2 |
#undef CTYPES2UVECT_FN_OPTIONAL |
258 |
#undef UVECTTYPE2 |
#undef UVECTTYPE_OPTIONAL |
259 |
#endif |
#endif |
260 |
#ifdef CTYPEMIN |
#undef SIZEOF_CTYPE |
261 |
#undef CTYPEMIN |
#undef ARRAYTYPE |
262 |
#endif |
#ifdef ARRAYTYPE_OPTIONAL |
263 |
#ifdef CTYPEMAX |
#undef ARRAYTYPE_OPTIONAL |
|
#undef CTYPEMAX |
|
|
#endif |
|
|
#undef ARRAYTYPE1 |
|
|
#ifdef ARRAYTYPE2 |
|
|
#undef ARRAYTYPE2 |
|
|
#endif |
|
|
#ifdef FLOATTYPE1 |
|
|
#undef FLOATTYPE1 |
|
264 |
#endif |
#endif |
265 |
#ifdef FLOATTYPE2 |
#ifdef FLOATTYPE |
266 |
#undef FLOATTYPE2 |
#undef FLOATTYPE |
267 |
#endif |
#endif |
268 |
#ifdef STRINGTYPE |
#ifdef FLOATTYPE_OPTIONAL |
269 |
#undef STRINGTYPE |
#undef FLOATTYPE_OPTIONAL |
270 |
#endif |
#endif |
271 |
|
|
272 |
/* |
/* |