1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
|
/* this file is #include'd (x times) by convert.c */
/* Convert a vector, weak vector, (if possible string, substring), list
or uniform vector into an C array. If the result array in argument 2
is NULL, malloc() a new one. If out of memory, return NULL. */
#define FUNC_NAME SCM2CTYPES_FN
CTYPE *
SCM2CTYPES (SCM obj, CTYPE *data)
{
long i, n;
SCM val;
SCM_ASSERT (SCM_NIMP (obj) || SCM_NFALSEP (scm_list_p (obj)),
obj, SCM_ARG1, FUNC_NAME);
/* list conversion */
if (SCM_NFALSEP (scm_list_p (obj)))
{
/* traverse the given list and validate the range of each member */
SCM list = obj;
for (n = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), n++)
{
val = SCM_CAR (list);
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
/* check integer ranges */
if (SCM_INUMP (val))
{
scm_t_signed_bits v = SCM_INUM (val);
CTYPE c = (CTYPE) v;
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
}
/* check big number ranges */
else if (SCM_BIGP (val))
{
scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME);
CTYPE c = (CTYPE) v;
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
}
else
/* check float types */
#elif defined (FLOATTYPE)
/* real values, big numbers and immediate values are valid
for float conversions */
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val))
#else
if (!SCM_BIGP (val) && !SCM_INUMP (val))
#endif /* FLOATTYPE */
SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
}
/* allocate new memory if necessary */
if (data == NULL)
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
return NULL;
/* traverse the list once more and convert each member */
list = obj;
for (i = 0; SCM_NFALSEP (scm_pair_p (list)); list = SCM_CDR (list), i++)
{
val = SCM_CAR (list);
if (SCM_INUMP (val))
data[i] = (CTYPE) SCM_INUM (val);
else if (SCM_BIGP (val))
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
#if defined (FLOATTYPE)
else
data[i] = (CTYPE) SCM_REAL_VALUE (val);
#endif
}
return data;
}
/* other conversions */
switch (SCM_TYP7 (obj))
{
/* vectors and weak vectors */
case scm_tc7_vector:
case scm_tc7_wvect:
n = SCM_VECTOR_LENGTH (obj);
/* traverse the given vector and validate each member */
for (i = 0; i < n; i++)
{
val = SCM_VELTS (obj)[i];
#if SIZEOF_CTYPE && SIZEOF_CTYPE < SIZEOF_SCM_T_BITS
/* check integer ranges */
if (SCM_INUMP (val))
{
scm_t_signed_bits v = SCM_INUM (val);
CTYPE c = (CTYPE) v;
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
}
/* check big number ranges */
else if (SCM_BIGP (val))
{
scm_t_signed_bits v = scm_num2long (val, SCM_ARG1, FUNC_NAME);
CTYPE c = (CTYPE) v;
SCM_ASSERT_RANGE (SCM_ARG1, val, v != (scm_t_signed_bits) c);
}
else
/* check float types */
#elif defined (FLOATTYPE)
/* real values, big numbers and immediate values are valid
for float conversions */
if (!SCM_REALP (val) && !SCM_BIGP (val) && !SCM_INUMP (val))
#else
if (!SCM_BIGP (val) && !SCM_INUMP (val))
#endif /* FLOATTYPE */
SCM_WRONG_TYPE_ARG (SCM_ARG1, val);
}
/* allocate new memory if necessary */
if (data == NULL)
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
return NULL;
/* traverse the vector once more and convert each member */
for (i = 0; i < n; i++)
{
val = SCM_VELTS (obj)[i];
if (SCM_INUMP (val))
data[i] = (CTYPE) SCM_INUM (val);
else if (SCM_BIGP (val))
data[i] = (CTYPE) scm_num2long (val, SCM_ARG1, FUNC_NAME);
#if defined (FLOATTYPE)
else
data[i] = (CTYPE) SCM_REAL_VALUE (val);
#endif
}
break;
#ifdef HAVE_ARRAYS
/* array conversions (uniform vectors) */
case ARRAYTYPE:
#ifdef ARRAYTYPE_OPTIONAL
case ARRAYTYPE_OPTIONAL:
#endif
n = SCM_UVECTOR_LENGTH (obj);
/* allocate new memory if necessary */
if (data == NULL)
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
return NULL;
#ifdef FLOATTYPE_OPTIONAL
/* float <-> double conversions */
if (SCM_TYP7 (obj) == ARRAYTYPE_OPTIONAL)
{
for (i = 0; i < n; i++)
data[i] = ((FLOATTYPE_OPTIONAL *) SCM_UVECTOR_BASE (obj))[i];
}
else
#endif
#if SIZEOF_CTYPE != SIZEOF_ARRAYTYPE
/* copy array element by element */
for (i = 0; i < n; i++)
data[i] = (CTYPE) ((ARRAYCTYPE *) SCM_UVECTOR_BASE (obj))[i];
#else
/* copy whole array */
memcpy (data, (CTYPE *) SCM_UVECTOR_BASE (obj), n * sizeof (CTYPE));
#endif
break;
#endif /* HAVE_ARRAYS */
#if SIZEOF_CTYPE == 1
case scm_tc7_string:
n = SCM_STRING_LENGTH (obj);
if (data == NULL)
if ((data = (CTYPE *) malloc (n * sizeof (CTYPE))) == NULL)
return NULL;
memcpy (data, SCM_STRING_CHARS (obj), n * sizeof (CTYPE));
break;
#endif
default:
SCM_WRONG_TYPE_ARG (SCM_ARG1, obj);
}
return data;
}
#undef FUNC_NAME
#if HAVE_ARRAYS
/* Converts a C array into a uniform vector, returns SCM_UNDEFINED if out
of memory. */
#define FUNC_NAME CTYPES2UVECT_FN
SCM
CTYPES2UVECT (const CTYPE *data, long n)
{
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
UVECTCTYPE *v;
long i;
#else
char *v;
#endif
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
for (i = 0; i < n; i++)
v[i] = (UVECTCTYPE) data[i];
#else
v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
memcpy (v, data, n * sizeof (CTYPE));
#endif
return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE), (scm_t_bits) v);
}
#undef FUNC_NAME
#ifdef UVECTTYPE_OPTIONAL
#define FUNC_NAME CTYPES2UVECT_FN_OPTIONAL
SCM
CTYPES2UVECT_OPTIONAL (const unsigned CTYPE *data, long n)
{
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
unsigned UVECTCTYPE *v;
long i;
#else
char *v;
#endif
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
n > 0 && n <= SCM_UVECTOR_MAX_LENGTH);
#if SIZEOF_CTYPE != SIZEOF_UVECTTYPE
v = scm_gc_malloc (n * SIZEOF_UVECTTYPE, "uvect");
for (i = 0; i < n; i++)
v[i] = (unsigned UVECTCTYPE) data[i];
#else
v = scm_gc_malloc (n * sizeof (CTYPE), "uvect");
memcpy (v, data, n * sizeof (CTYPE));
#endif
return scm_cell (SCM_MAKE_UVECTOR_TAG (n, UVECTTYPE_OPTIONAL),
(scm_t_bits) v);
}
#undef FUNC_NAME
#endif /* UVECTTYPE_OPTIONAL */
#endif /* HAVE_ARRAYS */
/* Converts a C array into a vector. */
#define FUNC_NAME CTYPES2SCM_FN
SCM
CTYPES2SCM (const CTYPE *data, long n)
{
long i;
SCM v, *velts;
SCM_ASSERT_RANGE (SCM_ARG2, scm_long2num (n),
n > 0 && n <= SCM_VECTOR_MAX_LENGTH);
v = scm_c_make_vector (n, SCM_UNSPECIFIED);
velts = SCM_VELTS (v);
for (i = 0; i < n; i++)
#ifdef FLOATTYPE
velts[i] = scm_make_real ((double) data[i]);
#else
velts[i] = SCM_MAKINUM (data[i]);
#endif
return v;
}
#undef FUNC_NAME
/* cleanup of conditionals */
#undef SCM2CTYPES
#undef SCM2CTYPES_FN
#undef CTYPES2SCM
#undef CTYPES2SCM_FN
#undef CTYPE
#undef CTYPES2UVECT
#undef CTYPES2UVECT_FN
#undef UVECTTYPE
#ifdef UVECTTYPE_OPTIONAL
#undef CTYPES2UVECT_OPTIONAL
#undef CTYPES2UVECT_FN_OPTIONAL
#undef UVECTTYPE_OPTIONAL
#endif
#undef SIZEOF_CTYPE
#undef SIZEOF_UVECTTYPE
#undef SIZEOF_ARRAYTYPE
#undef ARRAYTYPE
#ifdef ARRAYTYPE_OPTIONAL
#undef ARRAYTYPE_OPTIONAL
#endif
#ifdef FLOATTYPE
#undef FLOATTYPE
#endif
#ifdef FLOATTYPE_OPTIONAL
#undef FLOATTYPE_OPTIONAL
#endif
#ifdef UVECTCTYPE
#undef UVECTCTYPE
#endif
#ifdef ARRAYCTYPE
#undef ARRAYCTYPE
#endif
/*
Local Variables:
c-file-style: "gnu"
End:
*/
|
