1 /*
2 * vector.c - vector implementation
3 *
4 * Copyright (c) 2000-2020 Shiro Kawai <shiro@acm.org>
5 *
6 * Redistribution and use in source and binary forms, with or without
7 * modification, are permitted provided that the following conditions
8 * are met:
9 *
10 * 1. Redistributions of source code must retain the above copyright
11 * notice, this list of conditions and the following disclaimer.
12 *
13 * 2. Redistributions in binary form must reproduce the above copyright
14 * notice, this list of conditions and the following disclaimer in the
15 * documentation and/or other materials provided with the distribution.
16 *
17 * 3. Neither the name of the authors nor the names of its contributors
18 * may be used to endorse or promote products derived from this
19 * software without specific prior written permission.
20 *
21 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
22 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
23 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
24 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
25 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
26 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
27 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
28 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
29 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
30 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
31 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
32 */
33
34 #define LIBGAUCHE_BODY
35 #include "gauche.h"
36 #include "gauche/priv/writerP.h"
37
38 /* Catch integer overflow.
39 NB: If total size is too big, GC_malloc aborts. But we have to prevent
40 total size from overflowing before passed to GC_malloc.
41
42 We'll try to allocate size*eltsize (+ up to two words of header).
43 The GC's malloc routine first round it up to GC allocation unit boundary
44 (8 or 16 bytes). If there's not enough heap, then it tries to expand
45 the heap by the size rounded up to the pagesize. We don't want the final
46 value overflows signed long.
47 (In reality, expanding heap with close to LONG_MAX surely fails, so it
48 should suffice to avoid overflow before calling GC_MALLOC. But it won't
49 harm to have a bit of margin here...)
50 */
check_size(ScmSmallInt size,int eltsize)51 static void check_size(ScmSmallInt size, int eltsize)
52 {
53 if (size >= (ScmSmallInt)((LONG_MAX - 0x400000)/eltsize)) {
54 Scm_Error("Size too big: %ld", size);
55 }
56 }
57
58 /*=====================================================================
59 * Generic vectors
60 */
61
62 /*
63 * Constructor
64 */
65
vector_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx)66 static void vector_print(ScmObj obj, ScmPort *port, ScmWriteContext *ctx)
67 {
68 SCM_PUTZ("#(", -1, port);
69 for (int i=0; i<SCM_VECTOR_SIZE(obj); i++) {
70 if (i != 0) SCM_PUTC(' ', port);
71 Scm_Write(SCM_VECTOR_ELEMENT(obj, i), SCM_OBJ(port),
72 Scm_WriteContextMode(ctx));
73 }
74 SCM_PUTZ(")", -1, port);
75 }
76
vector_compare(ScmObj x,ScmObj y,int equalp)77 static int vector_compare(ScmObj x, ScmObj y, int equalp)
78 {
79 if (equalp) {
80 /* Vector equality is handled in Scm_Eq* and will never come
81 here, but just in case. */
82 return Scm_EqualP(x, y)? 0 : 1;
83 }
84 /* Follow srfi-114 */
85 ScmWord xlen = SCM_VECTOR_SIZE(x);
86 ScmWord ylen = SCM_VECTOR_SIZE(y);
87 if (xlen < ylen) return -1;
88 if (xlen > ylen) return 1;
89 for (int i=0; i<xlen; i++) {
90 int r = Scm_Compare(SCM_VECTOR_ELEMENT(x, i),
91 SCM_VECTOR_ELEMENT(y, i));
92 if (r != 0) return r;
93 }
94 return 0;
95 }
96
97
98 SCM_DEFINE_BUILTIN_CLASS_FLAGS(Scm_VectorClass, vector_print, vector_compare,
99 NULL, NULL, SCM_CLASS_SEQUENCE_CPL,
100 SCM_CLASS_AGGREGATE);
101
make_vector(ScmSmallInt size)102 static ScmVector *make_vector(ScmSmallInt size)
103 {
104 check_size(size, sizeof(ScmObj));
105 ScmVector *v = SCM_NEW2(ScmVector *,
106 sizeof(ScmVector) + sizeof(ScmObj)*(size-1));
107 SCM_SET_CLASS(v, SCM_CLASS_VECTOR);
108 #if GAUCHE_API_VERSION >= 1000
109 v->size_flags = (size << 1);
110 #else
111 v->size = size;
112 #endif
113 return v;
114 }
115
Scm_MakeVector(ScmSmallInt size,ScmObj fill)116 ScmObj Scm_MakeVector(ScmSmallInt size, ScmObj fill)
117 {
118 if (size < 0) {
119 Scm_Error("vector size must be a positive integer, but got %d", size);
120 }
121 ScmVector *v = make_vector(size);
122 if (SCM_UNBOUNDP(fill)) fill = SCM_UNDEFINED;
123 for (ScmSmallInt i=0; i<size; i++) v->elements[i] = fill;
124 return SCM_OBJ(v);
125 }
126
Scm_ListToVector(ScmObj l,ScmSmallInt start,ScmSmallInt end)127 ScmObj Scm_ListToVector(ScmObj l, ScmSmallInt start, ScmSmallInt end)
128 {
129 ScmVector *v;
130
131 if (end < 0) {
132 ScmSmallInt size = Scm_Length(l);
133 if (size < 0) Scm_Error("bad list: %S", l);
134 SCM_CHECK_START_END(start, end, size);
135 v = make_vector(size - start);
136 } else {
137 SCM_CHECK_START_END(start, end, end);
138 v = make_vector(end - start);
139 }
140 ScmObj e = Scm_ListTail(l, start, SCM_UNBOUND);
141 for (ScmSmallInt i=0; i<end-start; i++, e=SCM_CDR(e)) {
142 if (!SCM_PAIRP(e)) {
143 Scm_Error("list too short: %S", l);
144 }
145 v->elements[i] = SCM_CAR(e);
146 }
147 return SCM_OBJ(v);
148 }
149
Scm_VectorToList(ScmVector * v,ScmSmallInt start,ScmSmallInt end)150 ScmObj Scm_VectorToList(ScmVector *v, ScmSmallInt start, ScmSmallInt end)
151 {
152 ScmWord len = SCM_VECTOR_SIZE(v);
153 SCM_CHECK_START_END(start, end, len);
154 return Scm_ArrayToList(SCM_VECTOR_ELEMENTS(v)+start,
155 end-start);
156 }
157
158 /*
159 * Accessors
160 */
161
162 /* NB: we're permissive about the out-of-range index here; the strict
163 check (for Scheme routines) should be done in the stub file, since
164 Scheme version may receive bignum, which can't be passed to C API. */
165
Scm_VectorRef(ScmVector * vec,ScmSmallInt i,ScmObj fallback)166 ScmObj Scm_VectorRef(ScmVector *vec, ScmSmallInt i, ScmObj fallback)
167 {
168 if (i < 0 || i >= SCM_VECTOR_SIZE(vec)) return fallback;
169 return vec->elements[i];
170 }
171
Scm_VectorSet(ScmVector * vec,ScmSmallInt i,ScmObj obj)172 ScmObj Scm_VectorSet(ScmVector *vec, ScmSmallInt i, ScmObj obj)
173 {
174 SCM_VECTOR_CHECK_MUTABLE(vec);
175 if (i >= 0 && i < SCM_VECTOR_SIZE(vec)) vec->elements[i] = obj;
176 return obj;
177 }
178
Scm_VectorFill(ScmVector * vec,ScmObj fill,ScmSmallInt start,ScmSmallInt end)179 ScmObj Scm_VectorFill(ScmVector *vec, ScmObj fill,
180 ScmSmallInt start, ScmSmallInt end)
181 {
182 SCM_VECTOR_CHECK_MUTABLE(vec);
183 ScmSmallInt len = SCM_VECTOR_SIZE(vec);
184 SCM_CHECK_START_END(start, end, len);
185 for (ScmSmallInt i=start; i < end; i++) {
186 SCM_VECTOR_ELEMENT(vec, i) = fill;
187 }
188 return SCM_OBJ(vec);
189 }
190
Scm_VectorCopy(ScmVector * vec,ScmSmallInt start,ScmSmallInt end,ScmObj fill)191 ScmObj Scm_VectorCopy(ScmVector *vec,
192 ScmSmallInt start, ScmSmallInt end, ScmObj fill)
193 {
194 ScmSmallInt len = SCM_VECTOR_SIZE(vec);
195 ScmVector *v = NULL;
196 if (end < 0) end = len;
197 if (end < start) {
198 Scm_Error("vector-copy: start (%ld) is greater than end (%ld)",
199 start, end);
200 } else if (end == start) {
201 v = make_vector(0);
202 } else {
203 if (SCM_UNBOUNDP(fill)) fill = SCM_UNDEFINED;
204 v = make_vector(end - start);
205 for (ScmSmallInt i=0; i<end-start; i++) {
206 if (i+start < 0 || i+start >= len) {
207 SCM_VECTOR_ELEMENT(v, i) = fill;
208 } else {
209 SCM_VECTOR_ELEMENT(v, i) = SCM_VECTOR_ELEMENT(vec, i+start);
210 }
211 }
212 }
213 return SCM_OBJ(v);
214 }
215
216 /*=====================================================================
217 * Uniform vectors
218 */
219
220 /*
221 * Class stuff
222 */
223 static ScmClass *uvector_cpl[] = {
224 SCM_CLASS_STATIC_PTR(Scm_UVectorClass),
225 SCM_CLASS_STATIC_PTR(Scm_SequenceClass),
226 SCM_CLASS_STATIC_PTR(Scm_CollectionClass),
227 SCM_CLASS_STATIC_PTR(Scm_TopClass),
228 NULL
229 };
230
231 SCM_DEFINE_BUILTIN_CLASS(Scm_UVectorClass, NULL, NULL, NULL, NULL,
232 uvector_cpl+1);
233
234 #define DEF_UVCLASS(TAG, tag) \
235 static void SCM_CPP_CAT3(print_,tag,vector)(ScmObj obj, ScmPort *out, \
236 ScmWriteContext *ctx); \
237 static int SCM_CPP_CAT3(compare_,tag,vector)(ScmObj x, ScmObj y, int equalp); \
238 SCM_DEFINE_BUILTIN_CLASS_FLAGS(SCM_CPP_CAT3(Scm_,TAG,VectorClass), \
239 SCM_CPP_CAT3(print_,tag,vector), \
240 SCM_CPP_CAT3(compare_,tag,vector), \
241 NULL, NULL, uvector_cpl, \
242 SCM_CLASS_AGGREGATE);
243
DEF_UVCLASS(S8,s8)244 DEF_UVCLASS(S8, s8)
245 DEF_UVCLASS(U8, u8)
246 DEF_UVCLASS(S16, s16)
247 DEF_UVCLASS(U16, u16)
248 DEF_UVCLASS(S32, s32)
249 DEF_UVCLASS(U32, u32)
250 DEF_UVCLASS(S64, s64)
251 DEF_UVCLASS(U64, u64)
252 DEF_UVCLASS(F16, f16)
253 DEF_UVCLASS(F32, f32)
254 DEF_UVCLASS(F64, f64)
255 DEF_UVCLASS(C32, c32)
256 DEF_UVCLASS(C64, c64)
257 DEF_UVCLASS(C128, c128)
258
259 /*
260 * Some generic APIs
261 */
262 ScmUVectorType Scm_UVectorType(ScmClass *klass)
263 {
264 if (SCM_EQ(klass, SCM_CLASS_S8VECTOR)) return SCM_UVECTOR_S8;
265 if (SCM_EQ(klass, SCM_CLASS_U8VECTOR)) return SCM_UVECTOR_U8;
266 if (SCM_EQ(klass, SCM_CLASS_S16VECTOR)) return SCM_UVECTOR_S16;
267 if (SCM_EQ(klass, SCM_CLASS_U16VECTOR)) return SCM_UVECTOR_U16;
268 if (SCM_EQ(klass, SCM_CLASS_S32VECTOR)) return SCM_UVECTOR_S32;
269 if (SCM_EQ(klass, SCM_CLASS_U32VECTOR)) return SCM_UVECTOR_U32;
270 if (SCM_EQ(klass, SCM_CLASS_S64VECTOR)) return SCM_UVECTOR_S64;
271 if (SCM_EQ(klass, SCM_CLASS_U64VECTOR)) return SCM_UVECTOR_U64;
272 if (SCM_EQ(klass, SCM_CLASS_F16VECTOR)) return SCM_UVECTOR_F16;
273 if (SCM_EQ(klass, SCM_CLASS_F32VECTOR)) return SCM_UVECTOR_F32;
274 if (SCM_EQ(klass, SCM_CLASS_F64VECTOR)) return SCM_UVECTOR_F64;
275 if (SCM_EQ(klass, SCM_CLASS_C32VECTOR)) return SCM_UVECTOR_C32;
276 if (SCM_EQ(klass, SCM_CLASS_C64VECTOR)) return SCM_UVECTOR_C64;
277 if (SCM_EQ(klass, SCM_CLASS_C128VECTOR)) return SCM_UVECTOR_C128;
278 else return SCM_UVECTOR_INVALID;
279 }
280
Scm_UVectorTypeName(int type)281 const char *Scm_UVectorTypeName(int type) /* for error msgs etc. */
282 {
283 switch (type) {
284 case SCM_UVECTOR_S8: return "s8vector";
285 case SCM_UVECTOR_U8: return "u8vector";
286 case SCM_UVECTOR_S16: return "s16vector";
287 case SCM_UVECTOR_U16: return "u16vector";
288 case SCM_UVECTOR_S32: return "s32vector";
289 case SCM_UVECTOR_U32: return "u32vector";
290 case SCM_UVECTOR_S64: return "s64vector";
291 case SCM_UVECTOR_U64: return "u64vector";
292 case SCM_UVECTOR_F16: return "f16vector";
293 case SCM_UVECTOR_F32: return "f32vector";
294 case SCM_UVECTOR_F64: return "f64vector";
295 case SCM_UVECTOR_C32: return "c32vector";
296 case SCM_UVECTOR_C64: return "c64vector";
297 case SCM_UVECTOR_C128: return "c128vector";
298 default: return "invalid type of uvector (possibly implementation error)";
299 }
300 }
301
302 /* Returns the size of element of the uvector of given class */
Scm_UVectorElementSize(ScmClass * klass)303 int Scm_UVectorElementSize(ScmClass *klass)
304 {
305 static const int sizes[] = { 1, 1, 2, 2, 4, 4, 8, 8,
306 2, sizeof(float), sizeof(double), -1,
307 sizeof(ScmHalfComplex),
308 sizeof(ScmFloatComplex),
309 sizeof(ScmDoubleComplex),
310 -1 };
311 int ind = (int)Scm_UVectorType(klass);
312 if (ind >= 0) return sizes[ind];
313 return -1;
314 }
315
316 /* Returns the size of the vector body in bytes */
Scm_UVectorSizeInBytes(ScmUVector * uv)317 int Scm_UVectorSizeInBytes(ScmUVector *uv)
318 {
319 return SCM_UVECTOR_SIZE(uv) * Scm_UVectorElementSize(Scm_ClassOf(SCM_OBJ(uv)));
320 }
321
322 /* Generic constructor */
Scm_MakeUVectorFull(ScmClass * klass,ScmSmallInt size,void * init,int immutable,void * owner)323 ScmObj Scm_MakeUVectorFull(ScmClass *klass, ScmSmallInt size, void *init,
324 int immutable, void *owner)
325 {
326 int eltsize = Scm_UVectorElementSize(klass);
327 SCM_ASSERT(eltsize >= 1);
328 ScmUVector *vec = SCM_NEW(ScmUVector);
329 SCM_SET_CLASS(vec, klass);
330 if (init) {
331 vec->elements = init; /* trust the caller */
332 } else {
333 check_size(size, eltsize);
334 vec->elements = SCM_NEW_ATOMIC2(void*, size*eltsize);
335 }
336 vec->size_flags = (size << 1)|(immutable?1:0);
337 vec->owner = owner;
338 return SCM_OBJ(vec);
339 }
340
Scm_MakeUVector(ScmClass * klass,ScmSmallInt size,void * init)341 ScmObj Scm_MakeUVector(ScmClass *klass, ScmSmallInt size, void *init)
342 {
343 return Scm_MakeUVectorFull(klass, size, init, FALSE, NULL);
344 }
345
Scm_ListToUVector(ScmClass * klass,ScmObj list,int clamp)346 ScmObj Scm_ListToUVector(ScmClass *klass, ScmObj list, int clamp)
347 {
348 ScmUVectorType type = Scm_UVectorType(klass);
349 if (type < 0) Scm_Error("uvector class required, but got: %S", klass);
350 ScmSize length = Scm_Length(list);
351 if (length < 0) Scm_Error("improper list not allowed: %S", list);
352 if (length > SCM_SMALL_INT_MAX) Scm_Error("list is too long: %,,,,100S", list);
353
354 ScmUVector *v = (ScmUVector*)Scm_MakeUVector(klass,
355 (ScmSmallInt)length,
356 NULL);
357 ScmObj cp = list;
358 for (ScmSize i=0; i<length; i++, cp = SCM_CDR(cp)) {
359 switch (type) {
360 case SCM_UVECTOR_S8:
361 SCM_S8VECTOR_ELEMENTS(v)[i] =
362 (int8_t)Scm_GetInteger8Clamp(SCM_CAR(cp), clamp, NULL);
363 break;
364 case SCM_UVECTOR_U8:
365 SCM_U8VECTOR_ELEMENTS(v)[i] =
366 (uint8_t)Scm_GetIntegerU8Clamp(SCM_CAR(cp), clamp, NULL);
367 break;
368 case SCM_UVECTOR_S16:
369 SCM_S16VECTOR_ELEMENTS(v)[i] =
370 (int16_t)Scm_GetInteger16Clamp(SCM_CAR(cp), clamp, NULL);
371 break;
372 case SCM_UVECTOR_U16:
373 SCM_U16VECTOR_ELEMENTS(v)[i] =
374 (uint16_t)Scm_GetIntegerU16Clamp(SCM_CAR(cp), clamp, NULL);
375 break;
376 case SCM_UVECTOR_S32:
377 SCM_S32VECTOR_ELEMENTS(v)[i] =
378 (int32_t)Scm_GetInteger32Clamp(SCM_CAR(cp), clamp, NULL);
379 break;
380 case SCM_UVECTOR_U32:
381 SCM_U32VECTOR_ELEMENTS(v)[i] =
382 (uint32_t)Scm_GetIntegerU32Clamp(SCM_CAR(cp), clamp, NULL);
383 break;
384 case SCM_UVECTOR_S64:
385 SCM_S64VECTOR_ELEMENTS(v)[i] =
386 (int64_t)Scm_GetInteger64Clamp(SCM_CAR(cp), clamp, NULL);
387 break;
388 case SCM_UVECTOR_U64:
389 SCM_U64VECTOR_ELEMENTS(v)[i] =
390 (uint64_t)Scm_GetIntegerU64Clamp(SCM_CAR(cp), clamp, NULL);
391 break;
392 case SCM_UVECTOR_F16:
393 SCM_F16VECTOR_ELEMENTS(v)[i] =
394 (ScmHalfFloat)Scm_DoubleToHalf(Scm_GetDouble(SCM_CAR(cp)));
395 break;
396 case SCM_UVECTOR_F32:
397 SCM_F32VECTOR_ELEMENTS(v)[i] =
398 (float)Scm_GetDouble(SCM_CAR(cp));
399 break;
400 case SCM_UVECTOR_F64:
401 SCM_F64VECTOR_ELEMENTS(v)[i] = Scm_GetDouble(SCM_CAR(cp));
402 break;
403 case SCM_UVECTOR_C32:
404 SCM_C32VECTOR_ELEMENTS(v)[i] = Scm_GetHalfComplex(SCM_CAR(cp));
405 break;
406 case SCM_UVECTOR_C64:
407 SCM_C64VECTOR_ELEMENTS(v)[i] = Scm_GetFloatComplex(SCM_CAR(cp));
408 break;
409 case SCM_UVECTOR_C128:
410 SCM_C128VECTOR_ELEMENTS(v)[i] = Scm_GetDoubleComplex(SCM_CAR(cp));
411 break;
412 default:
413 Scm_Error("[internal error] unknown uvector type given to Scm_ListToUVector");
414 }
415 }
416 return SCM_OBJ(v);
417 }
418
419 /* Generic accessor, intended to be called from VM loop.
420 (As the 'VM' in the name suggests, the return value of this API
421 should immediately be passed to VM. See comments on FFX in gauche/number.h)
422 */
Scm_VMUVectorRef(ScmUVector * v,int t,ScmSmallInt k,ScmObj fallback)423 ScmObj Scm_VMUVectorRef(ScmUVector *v, int t, ScmSmallInt k, ScmObj fallback)
424 {
425 SCM_ASSERT(Scm_UVectorType(SCM_CLASS_OF(v)) == t);
426 if (k < 0 || k >= SCM_UVECTOR_SIZE(v)) {
427 if (SCM_UNBOUNDP(fallback)) {
428 Scm_Error("%s-ref index out of range: %ld",
429 Scm_UVectorTypeName(t), k);
430 }
431 return fallback;
432 }
433 switch (t) {
434 case SCM_UVECTOR_S8: return SCM_MAKE_INT(SCM_S8VECTOR_ELEMENT(v, k));
435 case SCM_UVECTOR_U8: return SCM_MAKE_INT(SCM_U8VECTOR_ELEMENT(v, k));
436 case SCM_UVECTOR_S16: return SCM_MAKE_INT(SCM_S16VECTOR_ELEMENT(v, k));
437 case SCM_UVECTOR_U16: return SCM_MAKE_INT(SCM_U16VECTOR_ELEMENT(v, k));
438 case SCM_UVECTOR_S32: return Scm_MakeInteger(SCM_S32VECTOR_ELEMENT(v, k));
439 case SCM_UVECTOR_U32: return Scm_MakeIntegerU(SCM_U32VECTOR_ELEMENT(v, k));
440 case SCM_UVECTOR_S64: return Scm_MakeInteger64(SCM_S64VECTOR_ELEMENT(v, k));
441 case SCM_UVECTOR_U64: return Scm_MakeIntegerU64(SCM_U64VECTOR_ELEMENT(v, k));
442 case SCM_UVECTOR_F16:
443 return Scm_VMReturnFlonum(Scm_HalfToDouble(SCM_F16VECTOR_ELEMENT(v, k)));
444 case SCM_UVECTOR_F32:
445 return Scm_VMReturnFlonum((double)(SCM_F32VECTOR_ELEMENT(v, k)));
446 case SCM_UVECTOR_F64:
447 return Scm_VMReturnFlonum(SCM_F64VECTOR_ELEMENT(v, k));
448 case SCM_UVECTOR_C32:
449 return Scm_HalfComplexToComplex(SCM_C32VECTOR_ELEMENT(v, k));
450 case SCM_UVECTOR_C64:
451 return Scm_FloatComplexToComplex(SCM_C64VECTOR_ELEMENT(v, k));
452 case SCM_UVECTOR_C128:
453 return Scm_DoubleComplexToComplex(SCM_C128VECTOR_ELEMENT(v, k));
454 default:
455 Scm_Error("[internal error] unknown uvector type given to Scm_VMUVectorRef");
456 return SCM_UNDEFINED; /* dummy */
457 }
458 }
459
460 /* Generic modifier */
Scm_UVectorSet(ScmUVector * v,int t,ScmSmallInt k,ScmObj val,int clamp)461 ScmObj Scm_UVectorSet(ScmUVector *v, int t, ScmSmallInt k, ScmObj val, int clamp)
462 {
463 SCM_ASSERT(Scm_UVectorType(SCM_CLASS_OF(v)) == t);
464 SCM_UVECTOR_CHECK_MUTABLE(SCM_OBJ(v));
465 if (k < 0 || k >= SCM_UVECTOR_SIZE(v)) {
466 Scm_Error("%s-set! index out of range: %ld", Scm_UVectorTypeName(t), k);
467 }
468 switch (t) {
469 case SCM_UVECTOR_S8:
470 SCM_S8VECTOR_ELEMENTS(v)[k] = Scm_GetInteger8Clamp(val, clamp, NULL);
471 break;
472 case SCM_UVECTOR_U8:
473 SCM_U8VECTOR_ELEMENTS(v)[k] = Scm_GetIntegerU8Clamp(val, clamp, NULL);
474 break;
475 case SCM_UVECTOR_S16:
476 SCM_S16VECTOR_ELEMENTS(v)[k] = Scm_GetInteger16Clamp(val, clamp, NULL);
477 break;
478 case SCM_UVECTOR_U16:
479 SCM_U16VECTOR_ELEMENTS(v)[k] = Scm_GetIntegerU16Clamp(val, clamp, NULL);
480 break;
481 case SCM_UVECTOR_S32:
482 SCM_S32VECTOR_ELEMENTS(v)[k] = Scm_GetInteger32Clamp(val, clamp, NULL);
483 break;
484 case SCM_UVECTOR_U32:
485 SCM_U32VECTOR_ELEMENTS(v)[k] = Scm_GetIntegerU32Clamp(val, clamp, NULL);
486 break;
487 case SCM_UVECTOR_S64:
488 SCM_S64VECTOR_ELEMENTS(v)[k] = Scm_GetInteger64Clamp(val, clamp, NULL);
489 break;
490 case SCM_UVECTOR_U64:
491 SCM_U64VECTOR_ELEMENTS(v)[k] = Scm_GetIntegerU64Clamp(val, clamp, NULL);
492 break;
493 case SCM_UVECTOR_F16:
494 SCM_F16VECTOR_ELEMENTS(v)[k] = Scm_DoubleToHalf(Scm_GetDouble(val));
495 break;
496 case SCM_UVECTOR_F32:
497 SCM_F32VECTOR_ELEMENTS(v)[k] = (float)Scm_GetDouble(val);
498 break;
499 case SCM_UVECTOR_F64:
500 SCM_F64VECTOR_ELEMENTS(v)[k] = Scm_GetDouble(val);
501 break;
502 case SCM_UVECTOR_C32:
503 SCM_C32VECTOR_ELEMENTS(v)[k] = Scm_GetHalfComplex(val);
504 break;
505 case SCM_UVECTOR_C64:
506 SCM_C64VECTOR_ELEMENTS(v)[k] = Scm_GetFloatComplex(val);
507 break;
508 case SCM_UVECTOR_C128:
509 SCM_C128VECTOR_ELEMENTS(v)[k] = Scm_GetDoubleComplex(val);
510 break;
511 default:
512 Scm_Error("[internal error] unknown uvector type given to Scm_VMUVectorRef");
513 }
514 return SCM_UNDEFINED;
515 }
516
517 /*
518 * Inidividual constructors for convenience
519 */
520 #define DEF_UVCTOR_FILL(tag, T) \
521 ScmObj SCM_CPP_CAT3(Scm_Make,tag,Vector)(ScmSmallInt size, T fill) \
522 { \
523 ScmUVector *u = \
524 (ScmUVector*)Scm_MakeUVector(SCM_CPP_CAT3(SCM_CLASS_,tag,VECTOR),\
525 size, NULL); \
526 T *elts = SCM_CPP_CAT3(SCM_,tag,VECTOR_ELEMENTS)(u); \
527 for (ScmSmallInt i=0; i<size; i++) *elts++ = fill; \
528 return SCM_OBJ(u); \
529 }
530
531 #define DEF_UVCTOR_ARRAY(tag, T) \
532 ScmObj SCM_CPP_CAT3(Scm_Make,tag,VectorFromArray)(ScmSmallInt size, \
533 const T array[]) \
534 { \
535 check_size(size, sizeof(T)); \
536 T *z = SCM_NEW_ATOMIC_ARRAY(T, size); \
537 memcpy(z, array, size*sizeof(T)); \
538 return Scm_MakeUVector(SCM_CPP_CAT3(SCM_CLASS_,tag,VECTOR), \
539 size, (void*)z); \
540 } \
541 ScmObj SCM_CPP_CAT3(Scm_Make,tag,VectorFromArrayShared)(ScmSmallInt size,\
542 T array[]) \
543 { \
544 return Scm_MakeUVector(SCM_CPP_CAT3(SCM_CLASS_,tag,VECTOR), \
545 size, (void*)array); \
546 }
547
548 /* NB: For u8vector and s8vector we can let memset() to fill the
549 contents, expecting it's optimized. */
Scm_MakeS8Vector(ScmSmallInt size,int8_t fill)550 ScmObj Scm_MakeS8Vector(ScmSmallInt size, int8_t fill)
551 {
552 ScmUVector *u =
553 (ScmUVector*)Scm_MakeUVector(SCM_CLASS_S8VECTOR, size, NULL);
554 (void)memset(SCM_S8VECTOR_ELEMENTS(u), fill, size);
555 return SCM_OBJ(u);
556 }
557
Scm_MakeU8Vector(ScmSmallInt size,uint8_t fill)558 ScmObj Scm_MakeU8Vector(ScmSmallInt size, uint8_t fill)
559 {
560 ScmUVector *u =
561 (ScmUVector*)Scm_MakeUVector(SCM_CLASS_U8VECTOR, size, NULL);
562 (void)memset(SCM_U8VECTOR_ELEMENTS(u), fill, size);
563 return SCM_OBJ(u);
564 }
565
DEF_UVCTOR_FILL(S16,int16_t)566 DEF_UVCTOR_FILL(S16, int16_t)
567 DEF_UVCTOR_FILL(U16, uint16_t)
568 DEF_UVCTOR_FILL(S32, int32_t)
569 DEF_UVCTOR_FILL(U32, uint32_t)
570 DEF_UVCTOR_FILL(S64, int64_t)
571 DEF_UVCTOR_FILL(U64, uint64_t)
572 DEF_UVCTOR_FILL(F16, ScmHalfFloat)
573 DEF_UVCTOR_FILL(F32, float)
574 DEF_UVCTOR_FILL(F64, double)
575 DEF_UVCTOR_FILL(C32, ScmHalfComplex)
576 DEF_UVCTOR_FILL(C64, ScmFloatComplex)
577 DEF_UVCTOR_FILL(C128,ScmDoubleComplex)
578
579 DEF_UVCTOR_ARRAY(S8, int8_t)
580 DEF_UVCTOR_ARRAY(U8, uint8_t)
581 DEF_UVCTOR_ARRAY(S16, int16_t)
582 DEF_UVCTOR_ARRAY(U16, uint16_t)
583 DEF_UVCTOR_ARRAY(S32, int32_t)
584 DEF_UVCTOR_ARRAY(U32, uint32_t)
585 DEF_UVCTOR_ARRAY(S64, int64_t)
586 DEF_UVCTOR_ARRAY(U64, uint64_t)
587 DEF_UVCTOR_ARRAY(F16, ScmHalfFloat)
588 DEF_UVCTOR_ARRAY(F32, float)
589 DEF_UVCTOR_ARRAY(F64, double)
590 DEF_UVCTOR_ARRAY(C32, ScmHalfComplex)
591 DEF_UVCTOR_ARRAY(C64, ScmFloatComplex)
592 DEF_UVCTOR_ARRAY(C128,ScmDoubleComplex)
593
594 /*
595 * Reader
596 */
597 ScmObj Scm_ReadUVector(ScmPort *port, const char *tag, ScmReadContext *ctx)
598 {
599 ScmChar c;
600 SCM_GETC(c, port);
601 if (c != '(') Scm_Error("bad uniform vector syntax for %s", tag);
602 ScmObj list = Scm_ReadList(SCM_OBJ(port), ')');
603 ScmClass *klass = NULL;
604 if (strcmp(tag, "s8") == 0) klass = SCM_CLASS_S8VECTOR;
605 else if (strcmp(tag, "u8") == 0) klass = SCM_CLASS_U8VECTOR;
606 else if (strcmp(tag, "s16") == 0) klass = SCM_CLASS_S16VECTOR;
607 else if (strcmp(tag, "u16") == 0) klass = SCM_CLASS_U16VECTOR;
608 else if (strcmp(tag, "s32") == 0) klass = SCM_CLASS_S32VECTOR;
609 else if (strcmp(tag, "u32") == 0) klass = SCM_CLASS_U32VECTOR;
610 else if (strcmp(tag, "s64") == 0) klass = SCM_CLASS_S64VECTOR;
611 else if (strcmp(tag, "u64") == 0) klass = SCM_CLASS_U64VECTOR;
612 else if (strcmp(tag, "f16") == 0) klass = SCM_CLASS_F16VECTOR;
613 else if (strcmp(tag, "f32") == 0) klass = SCM_CLASS_F32VECTOR;
614 else if (strcmp(tag, "f64") == 0) klass = SCM_CLASS_F64VECTOR;
615 else if (strcmp(tag, "c32") == 0) klass = SCM_CLASS_C32VECTOR;
616 else if (strcmp(tag, "c64") == 0) klass = SCM_CLASS_C64VECTOR;
617 else if (strcmp(tag, "c128") == 0) klass = SCM_CLASS_C128VECTOR;
618 else Scm_Error("invalid unform vector tag: %s", tag);
619
620 ScmObj uv = Scm_ListToUVector(klass, list, 0);
621
622 /* If we are reading source file, let literal uvectors be immutable. */
623 if (Scm_ReadContextLiteralImmutable(ctx)) {
624 SCM_UVECTOR_IMMUTABLE_SET(uv, TRUE);
625 }
626 return uv;
627 }
628
629 /*
630 * Class-dependent functions
631 */
632
633 /* printer */
634
635 #define DEF_PRINT(TAG, tag, T, pr) \
636 static void SCM_CPP_CAT3(print_,tag,vector)(ScmObj obj, \
637 ScmPort *out, \
638 ScmWriteContext *ctx) \
639 { \
640 const ScmWriteControls *wp = \
641 Scm_GetWriteControls(ctx, Scm_PortWriteState(out)); \
642 Scm_Printf(out, "#"#tag"("); \
643 for (int i=0; i<SCM_CPP_CAT3(SCM_,TAG,VECTOR_SIZE)(obj); i++) { \
644 T elt = SCM_CPP_CAT3(SCM_,TAG,VECTOR_ELEMENTS)(obj)[i]; \
645 if (i != 0) Scm_Printf(out, " "); \
646 if (wp->printLength >= 0 && i >= wp->printLength) { \
647 Scm_Printf(out, "..."); \
648 break; \
649 } \
650 pr(out, elt); \
651 } \
652 Scm_Printf(out, ")"); \
653 }
654
655 #define spr(out, elt) Scm_Printf(out, "%d", elt)
656 #define upr(out, elt) Scm_Printf(out, "%u", elt)
657 #define fpr(out, elt) Scm_PrintDouble(out, (double)elt, 0)
658 #define c32pr(out, elt) \
659 do { \
660 Scm_PrintDouble(out, Scm_HalfToDouble(SCM_HALF_COMPLEX_REAL(elt)), 0); \
661 Scm_Putz("+", 1, out); \
662 Scm_PrintDouble(out, Scm_HalfToDouble(SCM_HALF_COMPLEX_IMAG(elt)), 0); \
663 Scm_Putz("i", 1, out); \
664 } while (0)
665 #define c64pr(out, elt) \
666 do { \
667 Scm_PrintDouble(out, (double)crealf(elt), 0); \
668 Scm_Putz("+", 1, out); \
669 Scm_PrintDouble(out, (double)cimagf(elt), 0); \
670 Scm_Putz("i", 1, out); \
671 } while (0)
672 #define c128pr(out, elt) \
673 do { \
674 Scm_PrintDouble(out, creal(elt), 0); \
675 Scm_Putz("+", 1, out); \
676 Scm_PrintDouble(out, cimag(elt), 0); \
677 Scm_Putz("i", 1, out); \
678 } while (0)
679
680
s64pr(ScmPort * out,int64_t elt)681 static inline void s64pr(ScmPort *out, int64_t elt)
682 {
683 #if SIZEOF_LONG == 4
684 char buf[50];
685 snprintf(buf, 50, "%lld", elt);
686 Scm_Printf(out, "%s", buf);
687 #else
688 Scm_Printf(out, "%ld", elt);
689 #endif
690 }
691
u64pr(ScmPort * out,uint64_t elt)692 static inline void u64pr(ScmPort *out, uint64_t elt)
693 {
694 #if SIZEOF_LONG == 4
695 char buf[50];
696 snprintf(buf, 50, "%llu", elt);
697 Scm_Printf(out, "%s", buf);
698 #else
699 Scm_Printf(out, "%lu", elt);
700 #endif
701 }
702
f16pr(ScmPort * out,ScmHalfFloat elt)703 static inline void f16pr(ScmPort *out, ScmHalfFloat elt)
704 {
705 Scm_PrintDouble(out, Scm_HalfToDouble(elt), 0);
706 }
707
DEF_PRINT(S8,s8,int8_t,spr)708 DEF_PRINT(S8, s8, int8_t, spr)
709 DEF_PRINT(U8, u8, uint8_t, upr)
710 DEF_PRINT(S16, s16, int16_t, spr)
711 DEF_PRINT(U16, u16, uint16_t, upr)
712 DEF_PRINT(S32, s32, int32_t, spr)
713 DEF_PRINT(U32, u32, uint32_t, upr)
714 DEF_PRINT(S64, s64, int64_t, s64pr)
715 DEF_PRINT(U64, u64, uint64_t, u64pr)
716 DEF_PRINT(F16, f16, ScmHalfFloat, f16pr)
717 DEF_PRINT(F32, f32, float, fpr)
718 DEF_PRINT(F64, f64, double, fpr)
719 DEF_PRINT(C32, c32, ScmHalfComplex, c32pr)
720 DEF_PRINT(C64, c64, ScmFloatComplex, c64pr)
721 DEF_PRINT(C128, c128, ScmDoubleComplex, c128pr)
722
723
724 /* comparer */
725
726 #define DEF_CMP(TAG, tag, T, eq, lt) \
727 static int SCM_CPP_CAT3(compare_,tag,vector)(ScmObj x, ScmObj y, int equalp) \
728 { \
729 ScmSmallInt xlen = SCM_CPP_CAT3(SCM_,TAG,VECTOR_SIZE)(x); \
730 ScmSmallInt ylen = SCM_CPP_CAT3(SCM_,TAG,VECTOR_SIZE)(y); \
731 if (equalp) { \
732 if (xlen != ylen) return -1; \
733 for (ScmSmallInt i=0; i<xlen; i++) { \
734 T xx = SCM_CPP_CAT3(SCM_,TAG,VECTOR_ELEMENTS)(x)[i]; \
735 T yy = SCM_CPP_CAT3(SCM_,TAG,VECTOR_ELEMENTS)(y)[i]; \
736 if (!eq(xx,yy)) return -1; \
737 } \
738 return 0; \
739 } else { \
740 if (xlen != ylen) return (xlen < ylen) ? -1 : 1; \
741 for (ScmSmallInt i=0; i<xlen; i++) { \
742 T xx = SCM_CPP_CAT3(SCM_,TAG,VECTOR_ELEMENTS)(x)[i]; \
743 T yy = SCM_CPP_CAT3(SCM_,TAG,VECTOR_ELEMENTS)(y)[i]; \
744 if (lt(xx, yy)) return -1; \
745 if (!eq(xx,yy)) return 1; \
746 } \
747 return 0; \
748 } \
749 }
750
751 #define common_eqv(x, y) ((x)==(y))
752 #define common_lt(x, y) ((x)<(y))
753
754 #define f16eqv(a, b) SCM_HALF_FLOAT_CMP(==, a, b)
755 #define f16lt(a, b) SCM_HALF_FLOAT_CMP(<, a, b)
756
757 static inline int c32eqv(ScmHalfComplex x, ScmHalfComplex y)
758 {
759 return (SCM_HALF_FLOAT_CMP(==, x.r, y.r)
760 && SCM_HALF_FLOAT_CMP(==, x.i, y.i));
761 }
762
c32lt(ScmHalfComplex x,ScmHalfComplex y)763 static inline int c32lt(ScmHalfComplex x, ScmHalfComplex y)
764 {
765 return (SCM_HALF_FLOAT_CMP(<, x.r, y.r)
766 || (SCM_HALF_FLOAT_CMP(==, x.r, y.r)
767 && SCM_HALF_FLOAT_CMP(<, x.i, y.i)));
768 }
769
c64lt(ScmFloatComplex x,ScmFloatComplex y)770 static inline int c64lt(ScmFloatComplex x, ScmFloatComplex y)
771 {
772 return (crealf(x) < crealf(y)
773 || (crealf(x) == crealf(y)
774 && cimagf(x) < cimagf(y)));
775 }
776
c128lt(ScmDoubleComplex x,ScmDoubleComplex y)777 static inline int c128lt(ScmDoubleComplex x, ScmDoubleComplex y)
778 {
779 return (creal(x) < creal(y)
780 || (creal(x) == creal(y)
781 && cimag(x) < cimag(y)));
782 }
783
784
DEF_CMP(S8,s8,int8_t,common_eqv,common_lt)785 DEF_CMP(S8, s8, int8_t, common_eqv, common_lt)
786 DEF_CMP(U8, u8, uint8_t, common_eqv, common_lt)
787 DEF_CMP(S16, s16, int16_t, common_eqv, common_lt)
788 DEF_CMP(U16, u16, uint16_t, common_eqv, common_lt)
789 DEF_CMP(S32, s32, int32_t, common_eqv, common_lt)
790 DEF_CMP(U32, u32, uint32_t, common_eqv, common_lt)
791 DEF_CMP(S64, s64, int64_t, common_eqv, common_lt)
792 DEF_CMP(U64, u64, uint64_t, common_eqv, common_lt)
793 DEF_CMP(F16, f16, ScmHalfFloat, f16eqv, f16lt)
794 DEF_CMP(F32, f32, float, common_eqv, common_lt)
795 DEF_CMP(F64, f64, double, common_eqv, common_lt)
796 DEF_CMP(C32, c32, ScmHalfComplex, c32eqv, c32lt)
797 DEF_CMP(C64, c64, ScmFloatComplex, common_eqv, c64lt)
798 DEF_CMP(C128, c128, ScmDoubleComplex, common_eqv, c128lt)
799
800 /*=====================================================================
801 * Bitvectors
802 */
803
804 static void bitvector_write_int(ScmBitvector *v, int prefix, ScmPort *port)
805 {
806 if (prefix) Scm_Putz("#*", -1, port);
807 for (int i=0; i<SCM_BITVECTOR_SIZE(v); i++) {
808 if (SCM_BITS_TEST(v->bits, i)) SCM_PUTC('1', port);
809 else SCM_PUTC('0', port);
810 }
811 }
812
bitvector_print(ScmObj obj,ScmPort * port,ScmWriteContext * ctx SCM_UNUSED)813 static void bitvector_print(ScmObj obj,
814 ScmPort *port,
815 ScmWriteContext *ctx SCM_UNUSED)
816 {
817 bitvector_write_int(SCM_BITVECTOR(obj), TRUE, port);
818 }
819
bitvector_compare(ScmObj x,ScmObj y,int equalp SCM_UNUSED)820 static int bitvector_compare(ScmObj x, ScmObj y, int equalp SCM_UNUSED)
821 {
822 SCM_ASSERT(SCM_BITVECTORP(x)&&SCM_BITVECTORP(y));
823 ScmBits *bx = SCM_BITVECTOR_BITS(x);
824 ScmBits *by = SCM_BITVECTOR_BITS(y);
825 ScmWord xlen = SCM_BITVECTOR_SIZE(x);
826 ScmWord ylen = SCM_BITVECTOR_SIZE(y);
827
828 /* NB: The ordering is somewhat counterintuitive, for the bits are
829 stored in little-endian. That is, #*0100 comes after #*1000.
830 This is a lot faster. Srfi-178 doesn't define the ordering. */
831 if (xlen < ylen) return -1;
832 if (xlen > ylen) return 1;
833 size_t nw = SCM_BITS_NUM_WORDS(xlen);
834 for (size_t i = 0; i < nw; i++, bx++, by++) {
835 if (*bx < *by) return -1;
836 if (*bx > *by) return 1;
837 }
838 return 0;
839 }
840
841 SCM_DEFINE_BUILTIN_CLASS_FLAGS(Scm_BitvectorClass,
842 bitvector_print, bitvector_compare,
843 NULL, NULL, SCM_CLASS_SEQUENCE_CPL,
844 SCM_CLASS_AGGREGATE);
845
846
Scm_Bit2Int(ScmObj bit)847 int Scm_Bit2Int(ScmObj bit)
848 {
849 if (SCM_EQ(bit, SCM_TRUE) || SCM_EQ(bit, SCM_MAKE_INT(1))) return 1;
850 if (SCM_FALSEP(bit) || SCM_EQ(bit, SCM_MAKE_INT(0))) return 0;
851 Scm_Error("bit value must be 0, 1, #f or #t, but got: %S", bit);
852 return 0; /* dummy */
853 }
854
Scm_Bit2Bool(ScmObj bit)855 ScmObj Scm_Bit2Bool(ScmObj bit)
856 {
857 if (SCM_EQ(bit, SCM_TRUE) || SCM_EQ(bit, SCM_MAKE_INT(1))) return SCM_TRUE;
858 if (SCM_FALSEP(bit) || SCM_EQ(bit, SCM_MAKE_INT(0))) return SCM_FALSE;
859 Scm_Error("bit value must be 0, 1, #f or #t, but got: %S", bit);
860 return SCM_UNDEFINED; /* dummy */
861 }
862
863 /* init can be 0, 1, #f or #t. */
Scm_MakeBitvector(ScmSmallInt size,ScmObj init)864 ScmObj Scm_MakeBitvector(ScmSmallInt size, ScmObj init)
865 {
866 if (size < 0) {
867 Scm_Error("bitvector size must be a positive integer, but got %d", size);
868 }
869 ScmBitvector *v = SCM_NEW(ScmBitvector);
870 SCM_SET_CLASS(v, SCM_CLASS_BITVECTOR);
871 v->size_flags = (size << 1);
872 v->bits = Scm_MakeBits(size);
873
874 int fill = Scm_Bit2Int(init);
875 Scm_BitsFill(v->bits, 0, size, fill);
876 return SCM_OBJ(v);
877 }
878
Scm_ListToBitvector(ScmObj lis)879 ScmObj Scm_ListToBitvector(ScmObj lis)
880 {
881 ScmSmallInt len = Scm_Length(lis);
882 if (len < 0) {
883 Scm_Error("proper list required, but got: %S", lis);
884 }
885
886 ScmBitvector *v = SCM_BITVECTOR(Scm_MakeBitvector(len, SCM_FALSE));
887 ScmObj cp;
888 ScmSmallInt i = 0;
889 SCM_FOR_EACH(cp, lis) {
890 if (Scm_Bit2Int(SCM_CAR(cp))) SCM_BITS_SET(v->bits, i);
891 else SCM_BITS_RESET(v->bits, i);
892 i++;
893 }
894 return SCM_OBJ(v);
895 }
896
897 /* Parse string of 0's and 1's to a bitvector. If PREFIX is true,
898 "#*" prefix is assumed. Returns #f if unparsable. */
899
Scm_StringToBitvector(ScmString * s,int prefix)900 ScmObj Scm_StringToBitvector(ScmString *s, int prefix)
901 {
902 const ScmStringBody *b = SCM_STRING_BODY(s);
903 const char *p = SCM_STRING_BODY_START(b);
904 /* multibyte string can't be a bitvector literal. */
905 if (SCM_STRING_BODY_SIZE(b) != SCM_STRING_BODY_LENGTH(b)) return SCM_FALSE;
906 ScmSmallInt len = SCM_STRING_BODY_LENGTH(b);
907
908 if (prefix) {
909 if (len < 2) return SCM_FALSE;
910 if (strncmp(p, "#*", 2) != 0) return SCM_FALSE;
911 p += 2;
912 len -= 2;
913 }
914
915 ScmBitvector *v = SCM_BITVECTOR(Scm_MakeBitvector(len, SCM_FALSE));
916 int i = 0;
917 for (; i < len; p++, i++) {
918 if (*p == '0') SCM_BITS_RESET(v->bits, i);
919 else if (*p == '1') SCM_BITS_SET(v->bits, i);
920 else return SCM_FALSE;
921 }
922 return SCM_OBJ(v);
923 }
924
Scm_BitvectorToString(ScmBitvector * v,int prefix)925 ScmObj Scm_BitvectorToString(ScmBitvector *v, int prefix)
926 {
927 ScmObj out = Scm_MakeOutputStringPort(TRUE);
928 bitvector_write_int(v, prefix, SCM_PORT(out));
929 return Scm_GetOutputString(SCM_PORT(out), 0);
930 }
931
Scm_BitvectorCopy(ScmBitvector * v,ScmSmallInt start,ScmSmallInt end)932 ScmObj Scm_BitvectorCopy(ScmBitvector *v, ScmSmallInt start, ScmSmallInt end)
933 {
934 ScmSmallInt size = SCM_BITVECTOR_SIZE(v);
935 SCM_CHECK_START_END(start, end, size);
936 ScmBitvector *vv = SCM_BITVECTOR(Scm_MakeBitvector(end-start, SCM_FALSE));
937 Scm_BitsCopyX(vv->bits, 0, v->bits, start, end);
938 return SCM_OBJ(vv);
939 }
940
Scm_BitvectorCopyX(ScmBitvector * dest,ScmSmallInt dstart,ScmBitvector * src,ScmSmallInt sstart,ScmSmallInt send)941 ScmObj Scm_BitvectorCopyX(ScmBitvector *dest, ScmSmallInt dstart,
942 ScmBitvector *src,
943 ScmSmallInt sstart, ScmSmallInt send)
944 {
945 SCM_BITVECTOR_CHECK_MUTABLE(dest);
946 ScmSmallInt ssize = SCM_BITVECTOR_SIZE(src);
947 SCM_CHECK_START_END(sstart, send, ssize);
948 ScmSmallInt dsize = SCM_BITVECTOR_SIZE(dest);
949 ScmSmallInt dend = dstart + send - sstart;
950 if (dstart > dsize || dstart < 0 || dend > dsize) {
951 Scm_Error("destination index out of range (size=%ld, start=%ld, end=%ld)",
952 dsize, dstart, dend);
953 }
954
955 Scm_BitsCopyX(dest->bits, dstart, src->bits, sstart, send);
956 return SCM_OBJ(dest);
957 }
958
959
960 /*=====================================================================
961 * Utility
962 */
963
Scm_GetBytes(ScmObj obj,ScmSize * size)964 const uint8_t *Scm_GetBytes(ScmObj obj, ScmSize *size)
965 {
966 if (SCM_UVECTORP(obj)) {
967 *size = Scm_UVectorSizeInBytes(SCM_UVECTOR(obj));
968 return (const uint8_t*)SCM_UVECTOR_ELEMENTS(obj);
969 } else if (SCM_STRINGP(obj)) {
970 ScmSmallInt s;
971 const char *z = Scm_GetStringContent(SCM_STRING(obj), &s, 0, 0);
972 *size = s;
973 return (const uint8_t*)z;
974 } else {
975 *size = 0;
976 return 0;
977 }
978 }
979