HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* numbers.h (SCM_MAKINUM, SCM_I_MAKINUM): Renamed SCM_MAKINUM to
[bpt/guile.git] / srfi / srfi-4.c
CommitLineData
71ca65d9
MG		 1/* srfi-4.c --- Homogeneous numeric vector datatypes.
2 *
c0967f56 3 * Copyright (C) 2001, 2004 Free Software Foundation, Inc.
645f5e0e 4 *
73be1d9e
MV		 5 * This library is free software; you can redistribute it and/or
6 * modify it under the terms of the GNU Lesser General Public
7 * License as published by the Free Software Foundation; either
8 * version 2.1 of the License, or (at your option) any later version.
645f5e0e 9 *
73be1d9e
MV		 10 * This library is distributed in the hope that it will be useful,
11 * but WITHOUT ANY WARRANTY; without even the implied warranty of
71ca65d9 12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e 13 * Lesser General Public License for more details.
645f5e0e 14 *
73be1d9e
MV		 15 * You should have received a copy of the GNU Lesser General Public
16 * License along with this library; if not, write to the Free Software
17 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
18 */
71ca65d9
MG		 19
20#include <libguile.h>
21
22#include "srfi-4.h"
23
24
25/* For brevity and maintainability, we define our own types for the
26 various integer and floating point types. */
e583edd0
RB		 27typedef scm_t_uint8 int_u8;
28typedef scm_t_int8 int_s8;
29typedef scm_t_uint16 int_u16;
30typedef scm_t_int16 int_s16;
31typedef scm_t_uint32 int_u32;
32typedef scm_t_int32 int_s32;
33
9d9536fd 34#if SCM_HAVE_T_UINT64
e583edd0 35typedef scm_t_uint64 int_u64;
9d9536fd
RB		 36#endif /* SCM_HAVE_T_UINT64 */
37
38#if SCM_HAVE_T_INT64
e583edd0
RB		 39typedef scm_t_int64 int_s64;
40#endif /* SCM_HAVE_T_INT64 */
41
71ca65d9
MG		 42typedef float float_f32;
43typedef double float_f64;
44
2c4df451 45
71ca65d9
MG		 46/* Smob type code for homogeneous numeric vectors. */
47int scm_tc16_uvec = 0;
48
49
50/* Accessor macros for the three components of a homogeneous numeric
51 vector:
52 - The type tag (one of the symbolic constants below).
53 - The vector's length (counted in elements).
54 - The address of the data area (holding the elements of the
55 vector). */
56#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
57#define SCM_UVEC_LENGTH(u) (SCM_CELL_WORD_2(u))
58#define SCM_UVEC_BASE(u) (SCM_CELL_OBJECT_3(u))
59
60
61/* Symbolic constants encoding the various types of homogeneous
62 numeric vectors. */
63#define SCM_UVEC_U8 0
64#define SCM_UVEC_S8 1
65#define SCM_UVEC_U16 2
66#define SCM_UVEC_S16 3
67#define SCM_UVEC_U32 4
68#define SCM_UVEC_S32 5
69#define SCM_UVEC_U64 6
70#define SCM_UVEC_S64 7
71#define SCM_UVEC_F32 8
72#define SCM_UVEC_F64 9
73
74
75/* This array maps type tags to the size of the elements. */
c0967f56 76static const int uvec_sizes[10] = {1, 1, 2, 2, 4, 4, 8, 8, 4, 8};
71ca65d9
MG		 77
78
9150491d 79#if SCM_HAVE_T_INT64
6b513f46
RB		 80
81// This is a modified version of scm_iint2str and should go away once
82// we have a public scm_print_integer or similar.
83
84static void
85print_int64 (scm_t_int64 num, SCM port)
86{
87 char num_buf[SCM_INTBUFLEN];
88 char *p = num_buf;
89 const int rad = 10;
90 size_t num_chars = 1;
91 size_t i;
92 scm_t_uint64 n = (num < 0) ? -num : num;
93
94 for (n /= rad; n > 0; n /= rad)
95 num_chars++;
96
97 i = num_chars;
98 if (num < 0)
99 {
100 *p++ = '-';
101 num_chars++;
102 n = -num;
103 }
104 else
105 n = num;
106 while (i--)
107 {
108 int d = n % rad;
109
110 n /= rad;
111 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
112 }
113
114 scm_lfwrite (num_buf, num_chars, port);
115}
116
117#endif /* SCM_HAVE_T_INT64 */
118
9150491d 119#if SCM_HAVE_T_UINT64
6b513f46
RB		 120
121// This is a modified version of scm_iint2str and should go away once
122// we have a public scm_print_integer or similar.
123
124static void
125print_uint64 (scm_t_uint64 num, SCM port)
126{
127 char num_buf[SCM_INTBUFLEN];
128 char *p = num_buf;
129 const int rad = 10;
130 size_t num_chars = 1;
131 size_t i;
132 scm_t_uint64 n = num;
133
134 for (n /= rad; n > 0; n /= rad)
135 num_chars++;
136
137 i = num_chars;
138 n = num;
139 while (i--)
140 {
141 int d = n % rad;
142
143 n /= rad;
144 p[i] = d + ((d < 10) ? '0' : 'a' - 10);
145 }
146
147 scm_lfwrite (num_buf, num_chars, port);
148}
149
150#endif /* SCM_HAVE_T_UINT64 */
151
71ca65d9
MG		 152/* ================================================================ */
153/* SMOB procedures. */
154/* ================================================================ */
155
156
157/* Smob print hook for homogeneous vectors. */
158static int
159uvec_print (SCM uvec, SCM port, scm_print_state *pstate SCM_UNUSED)
160{
6b513f46
RB		 161 union {
162 int_u8 *u8;
163 int_s8 *s8;
164 int_u16 *u16;
165 int_s16 *s16;
166 int_u32 *u32;
167 int_s32 *s32;
168#if SCM_HAVE_T_UINT64
169 int_u64 *u64;
71ca65d9 170#endif
6b513f46
RB		 171#if SCM_HAVE_T_INT64
172 int_s64 *s64;
173#endif
174 float_f32 *f32;
175 float_f64 *f64;
176 } np;
71ca65d9 177
6b513f46
RB		 178 scm_t_bits i = 0; // since SCM_UVEC_LENGTH will return something this size.
179 const scm_t_bits uvlen = SCM_UVEC_LENGTH (uvec);
180 char *tagstr;
181 void *uptr = SCM_UVEC_BASE (uvec);
71ca65d9 182
6b513f46
RB		 183 switch (SCM_UVEC_TYPE (uvec))
184 {
185 case SCM_UVEC_U8: tagstr = "u8"; np.u8 = (int_u8 *) uptr; break;
186 case SCM_UVEC_S8: tagstr = "s8"; np.s8 = (int_s8 *) uptr; break;
187 case SCM_UVEC_U16: tagstr = "u16"; np.u16 = (int_u16 *) uptr; break;
188 case SCM_UVEC_S16: tagstr = "s16"; np.s16 = (int_s16 *) uptr; break;
189 case SCM_UVEC_U32: tagstr = "u32"; np.u32 = (int_u32 *) uptr; break;
190 case SCM_UVEC_S32: tagstr = "s32"; np.s32 = (int_s32 *) uptr; break;
191#if SCM_HAVE_T_UINT64
192 case SCM_UVEC_U64: tagstr = "u64"; np.u64 = (int_u64 *) uptr; break;
193#endif
194#if SCM_HAVE_T_INT64
195 case SCM_UVEC_S64: tagstr = "s64"; np.s64 = (int_s64 *) uptr; break;
196#endif
197 case SCM_UVEC_F32: tagstr = "f32"; np.f32 = (float_f32 *) uptr; break;
198 case SCM_UVEC_F64: tagstr = "f64"; np.f64 = (float_f64 *) uptr; break;
71ca65d9
MG		 199 default:
200 abort (); /* Sanity check. */
6b513f46
RB		 201 break;
202 }
203
204 scm_putc ('#', port);
205 scm_puts (tagstr, port);
206 scm_putc ('(', port);
207
208 while (i < uvlen)
209 {
210 if (i != 0) scm_puts (" ", port);
211 switch (SCM_UVEC_TYPE (uvec))
212 {
213 case SCM_UVEC_U8: scm_intprint (*np.u8, 10, port); np.u8++; break;
214 case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
215 case SCM_UVEC_U16: scm_intprint (*np.u16, 10, port); np.u16++; break;
216 case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
217 case SCM_UVEC_U32: scm_intprint (*np.u32, 10, port); np.u32++; break;
218 case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
219#if SCM_HAVE_T_UINT64
220 case SCM_UVEC_U64: print_uint64(*np.u64, port); np.u64++; break;
221#endif
222#if SCM_HAVE_T_INT64
223 case SCM_UVEC_S64: print_int64(*np.s64, port); np.s64++; break;
224#endif
225 case SCM_UVEC_F32: scm_iprin1 (scm_make_real (*np.f32), port, pstate);
226 np.f32++;
227 break;
228 case SCM_UVEC_F64: scm_iprin1 (scm_make_real (*np.f64), port, pstate);
229 np.f64++;
230 break;
231 default:
232 abort (); /* Sanity check. */
233 break;
71ca65d9 234 }
6b513f46
RB		 235 i++;
236 }
237 scm_remember_upto_here_1 (uvec);
238 scm_puts (")", port);
71ca65d9
MG		 239 return 1;
240}
241
242
243/* Smob free hook for homogeneous numeric vectors. */
244static size_t
245uvec_free (SCM uvec)
246{
6c70aef1
MV		 247 scm_gc_free (SCM_UVEC_BASE (uvec),
248 SCM_UVEC_LENGTH (uvec) * uvec_sizes[SCM_UVEC_TYPE (uvec)],
249 "uvec");
250 return 0;
71ca65d9
MG		 251}
252
253
254/* ================================================================ */
255/* Utility procedures. */
256/* ================================================================ */
257
258
259/* Create a new, uninitialized homogeneous numeric vector of type TYPE
260 with space for LEN elements. */
261static SCM
262make_uvec (const char * func_name, int type, int len)
263{
264 void * p;
645f5e0e 265
6c70aef1 266 p = scm_gc_malloc (len * uvec_sizes[type], "uvec");
71ca65d9
MG		 267 SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, p);
268}
269
270
271/* ================================================================ */
272/* U8 procedures. */
273/* ================================================================ */
274
275
645f5e0e 276SCM_DEFINE (scm_u8vector_p, "u8vector?", 1, 0, 0,
71ca65d9
MG		 277 (SCM obj),
278 "Return @code{#t} if @var{obj} is a vector of type u8,\n"
279 "@code{#f} otherwise.")
280#define FUNC_NAME s_scm_u8vector_p
281{
00874d5f
MV		 282 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
283 SCM_UVEC_TYPE (obj) == SCM_UVEC_U8);
71ca65d9
MG		 284}
285#undef FUNC_NAME
286
287
645f5e0e 288SCM_DEFINE (scm_make_u8vector, "make-u8vector", 1, 1, 0,
71ca65d9
MG		 289 (SCM n, SCM fill),
290 "Create a newly allocated homogeneous numeric vector which can\n"
291 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
292 "initialize the elements, otherwise the contents of the vector\n"
293 "is unspecified.")
294#define FUNC_NAME s_scm_make_u8vector
295{
296 SCM uvec;
297 int_u8 * p;
298 int_u8 f;
299 int count;
300
301 SCM_VALIDATE_INUM (1, n);
302 count = SCM_INUM (n);
303 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, count);
304 if (SCM_UNBNDP (fill))
305 f = 0;
306 else
307 {
308 unsigned int s = scm_num2uint (fill, 2, FUNC_NAME);
309 f = s;
310 if ((unsigned int) f != s)
93ccaef0 311 scm_out_of_range_pos (FUNC_NAME, fill, SCM_I_MAKINUM (2));
71ca65d9
MG		 312 }
313 p = (int_u8 *) SCM_UVEC_BASE (uvec);
314 while (count-- > 0)
315 *p++ = f;
316 return uvec;
317}
318#undef FUNC_NAME
319
320
645f5e0e 321SCM_DEFINE (scm_u8vector, "u8vector", 0, 0, 1,
71ca65d9
MG		 322 (SCM l),
323 "Create a newly allocated homogeneous numeric vector containing\n"
324 "all argument values.")
325#define FUNC_NAME s_scm_u8vector
326{
327 SCM_VALIDATE_REST_ARGUMENT (l);
328 return scm_list_to_u8vector (l);
329}
330#undef FUNC_NAME
331
332
645f5e0e 333SCM_DEFINE (scm_u8vector_length, "u8vector-length", 1, 0, 0,
71ca65d9
MG		 334 (SCM uvec),
335 "Return the number of elements in the homogeneous numeric vector\n"
336 "@var{uvec}.")
337#define FUNC_NAME s_scm_u8vector_length
338{
339 SCM_VALIDATE_SMOB (1, uvec, uvec);
340 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
341 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
342 return scm_int2num (SCM_UVEC_LENGTH (uvec));
343}
344#undef FUNC_NAME
345
346
645f5e0e 347SCM_DEFINE (scm_u8vector_ref, "u8vector-ref", 2, 0, 0,
71ca65d9
MG		 348 (SCM uvec, SCM index),
349 "Return the element at @var{index} in the homogeneous numeric\n"
350 "vector @var{uvec}.")
351#define FUNC_NAME s_scm_u8vector_ref
352{
353 int idx;
354
355 SCM_VALIDATE_SMOB (1, uvec, uvec);
356 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
357 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
358
359 idx = scm_num2int (index, 2, FUNC_NAME);
360 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 361 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 362
363 return scm_short2num (((int_u8 *) SCM_UVEC_BASE (uvec))[idx]);
364}
365#undef FUNC_NAME
366
367
645f5e0e 368SCM_DEFINE (scm_u8vector_set_x, "u8vector-set!", 3, 0, 0,
71ca65d9
MG		 369 (SCM uvec, SCM index, SCM value),
370 "Set the element at @var{index} in the homogeneous numeric\n"
371 "vector @var{uvec} to @var{value}. The return value is not\n"
372 "specified.")
373#define FUNC_NAME s_scm_u8vector_ref
374{
375 int idx;
376 int_u8 f;
377 unsigned int s;
378
379 SCM_VALIDATE_SMOB (1, uvec, uvec);
380 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
381 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
382
383 idx = scm_num2int (index, 2, FUNC_NAME);
384 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 385 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 386
387 s = scm_num2uint (value, 3, FUNC_NAME);
388 f = s;
389 if ((unsigned int) f != s)
93ccaef0 390 scm_out_of_range_pos (FUNC_NAME, value, SCM_I_MAKINUM (3));
71ca65d9
MG		 391
392 ((int_u8 *) SCM_UVEC_BASE (uvec))[idx] = f;
393 return SCM_UNSPECIFIED;
394}
395#undef FUNC_NAME
396
397
645f5e0e 398SCM_DEFINE (scm_u8vector_to_list, "u8vector->list", 1, 0, 0,
71ca65d9
MG		 399 (SCM uvec),
400 "Convert the homogeneous numeric vector @var{uvec} to a list.")
401#define FUNC_NAME s_scm_u8vector_to_list
402{
403 int idx;
404 int_u8 * p;
405 SCM res = SCM_EOL;
406
407 SCM_VALIDATE_SMOB (1, uvec, uvec);
408 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U8)
409 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
410
411 idx = SCM_UVEC_LENGTH (uvec);
412 p = (int_u8 *) SCM_UVEC_BASE (uvec) + idx;
413 while (idx-- > 0)
414 {
415 p--;
93ccaef0 416 res = scm_cons (SCM_I_MAKINUM (*p), res);
71ca65d9
MG		 417 }
418 return res;
419}
420#undef FUNC_NAME
421
422
423SCM_DEFINE (scm_list_to_u8vector, "list->u8vector", 1, 0, 0,
424 (SCM l),
425 "Convert the list @var{l}, which must only contain unsigned\n"
426 "8-bit values, to a numeric homogeneous vector.")
427#define FUNC_NAME s_scm_list_to_u8vector
428{
429 SCM uvec;
430 SCM tmp;
431 int_u8 * p;
432 int n;
433 int arg_pos = 1;
434
435 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
436
437 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U8, n);
438 p = (int_u8 *) SCM_UVEC_BASE (uvec);
439 tmp = l;
440 while (SCM_CONSP (tmp))
441 {
442 int_u8 f;
443 unsigned int s = scm_num2uint (SCM_CAR (tmp), 2, FUNC_NAME);
444 f = s;
445 if ((unsigned int) f != s)
446 scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
447 *p++ = f;
448 tmp = SCM_CDR (tmp);
449 arg_pos++;
450 }
451 scm_remember_upto_here_1 (l);
452 return uvec;
453}
454#undef FUNC_NAME
455
456
457/* ================================================================ */
458/* S8 procedures. */
459/* ================================================================ */
460
461
645f5e0e 462SCM_DEFINE (scm_s8vector_p, "s8vector?", 1, 0, 0,
71ca65d9
MG		 463 (SCM obj),
464 "Return @code{#t} if @var{obj} is a vector of type s8,\n"
465 "@code{#f} otherwise.")
466#define FUNC_NAME s_scm_s8vector_p
467{
00874d5f
MV		 468 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
469 SCM_UVEC_TYPE (obj) == SCM_UVEC_S8);
71ca65d9
MG		 470}
471#undef FUNC_NAME
472
473
645f5e0e 474SCM_DEFINE (scm_make_s8vector, "make-s8vector", 1, 1, 0,
71ca65d9
MG		 475 (SCM n, SCM fill),
476 "Create a newly allocated homogeneous numeric vector which can\n"
477 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
478 "initialize the elements, otherwise the contents of the vector\n"
479 "is unspecified.")
480#define FUNC_NAME s_scm_make_s8vector
481{
482 SCM uvec;
483 int_s8 * p;
484 int_s8 f;
485 int count;
486
487 SCM_VALIDATE_INUM (1, n);
488 count = SCM_INUM (n);
489 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, count);
490 if (SCM_UNBNDP (fill))
491 f = 0;
492 else
493 {
494 signed int s = scm_num2int (fill, 2, FUNC_NAME);
495 f = s;
496 if ((signed int) f != s)
93ccaef0 497 scm_out_of_range_pos (FUNC_NAME, fill, SCM_I_MAKINUM (2));
71ca65d9
MG		 498 }
499 p = (int_s8 *) SCM_UVEC_BASE (uvec);
500 while (count-- > 0)
501 *p++ = f;
502 return uvec;
503}
504#undef FUNC_NAME
505
506
645f5e0e 507SCM_DEFINE (scm_s8vector, "s8vector", 0, 0, 1,
71ca65d9
MG		 508 (SCM l),
509 "Create a newly allocated homogeneous numeric vector containing\n"
510 "all argument values.")
511#define FUNC_NAME s_scm_s8vector
512{
513 SCM_VALIDATE_REST_ARGUMENT (l);
514 return scm_list_to_s8vector (l);
515}
516#undef FUNC_NAME
517
518
645f5e0e 519SCM_DEFINE (scm_s8vector_length, "s8vector-length", 1, 0, 0,
71ca65d9
MG		 520 (SCM uvec),
521 "Return the number of elements in the homogeneous numeric vector\n"
522 "@var{uvec}.")
523#define FUNC_NAME s_scm_s8vector_length
524{
525 SCM_VALIDATE_SMOB (1, uvec, uvec);
526 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
527 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
528 return scm_int2num (SCM_UVEC_LENGTH (uvec));
529}
530#undef FUNC_NAME
531
532
645f5e0e 533SCM_DEFINE (scm_s8vector_ref, "s8vector-ref", 2, 0, 0,
71ca65d9
MG		 534 (SCM uvec, SCM index),
535 "Return the element at @var{index} in the homogeneous numeric\n"
536 "vector @var{uvec}.")
537#define FUNC_NAME s_scm_s8vector_ref
538{
539 int idx;
540
541 SCM_VALIDATE_SMOB (1, uvec, uvec);
542 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
543 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
544
545 idx = scm_num2int (index, 2, FUNC_NAME);
546 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 547 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 548
549 return scm_short2num (((int_s8 *) SCM_UVEC_BASE (uvec))[idx]);
550}
551#undef FUNC_NAME
552
553
645f5e0e 554SCM_DEFINE (scm_s8vector_set_x, "s8vector-set!", 3, 0, 0,
71ca65d9
MG		 555 (SCM uvec, SCM index, SCM value),
556 "Set the element at @var{index} in the homogeneous numeric\n"
557 "vector @var{uvec} to @var{value}. The return value is not\n"
558 "specified.")
559#define FUNC_NAME s_scm_s8vector_ref
560{
561 int idx;
562 int_s8 f;
563 signed int s;
564
565 SCM_VALIDATE_SMOB (1, uvec, uvec);
566 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
567 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
568
569 idx = scm_num2int (index, 2, FUNC_NAME);
570 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 571 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 572
573 s = scm_num2int (value, 3, FUNC_NAME);
574 f = s;
575 if ((signed int) f != s)
93ccaef0 576 scm_out_of_range_pos (FUNC_NAME, value, SCM_I_MAKINUM (3));
71ca65d9
MG		 577
578 ((int_s8 *) SCM_UVEC_BASE (uvec))[idx] = f;
579 return SCM_UNSPECIFIED;
580}
581#undef FUNC_NAME
582
583
645f5e0e 584SCM_DEFINE (scm_s8vector_to_list, "s8vector->list", 1, 0, 0,
71ca65d9
MG		 585 (SCM uvec),
586 "Convert the homogeneous numeric vector @var{uvec} to a list.")
587#define FUNC_NAME s_scm_s8vector_to_list
588{
589 int idx;
590 int_s8 * p;
591 SCM res = SCM_EOL;
592
593 SCM_VALIDATE_SMOB (1, uvec, uvec);
594 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S8)
595 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
596
597 idx = SCM_UVEC_LENGTH (uvec);
598 p = (int_s8 *) SCM_UVEC_BASE (uvec) + idx;
599 while (idx-- > 0)
600 {
601 p--;
93ccaef0 602 res = scm_cons (SCM_I_MAKINUM (*p), res);
71ca65d9
MG		 603 }
604 return res;
605}
606#undef FUNC_NAME
607
608
609SCM_DEFINE (scm_list_to_s8vector, "list->s8vector", 1, 0, 0,
610 (SCM l),
611 "Convert the list @var{l}, which must only contain signed\n"
612 "8-bit values, to a numeric homogeneous vector.")
613#define FUNC_NAME s_scm_list_to_s8vector
614{
615 SCM uvec;
616 SCM tmp;
617 int_s8 * p;
618 int n;
619 int arg_pos = 1;
620
621 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
622
623 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S8, n);
624 p = (int_s8 *) SCM_UVEC_BASE (uvec);
625 tmp = l;
626 while (SCM_CONSP (tmp))
627 {
628 int_s8 f;
629 signed int s;
630
631 s = scm_num2int (SCM_CAR (tmp), 2, FUNC_NAME);
632 f = s;
633 if ((signed int) f != s)
634 scm_out_of_range (FUNC_NAME, SCM_CAR (tmp));
635 *p++ = f;
636 tmp = SCM_CDR (tmp);
637 arg_pos++;
638 }
639 scm_remember_upto_here_1 (l);
640 return uvec;
641}
642#undef FUNC_NAME
643
644
645/* ================================================================ */
646/* U16 procedures. */
647/* ================================================================ */
648
649
645f5e0e 650SCM_DEFINE (scm_u16vector_p, "u16vector?", 1, 0, 0,
71ca65d9
MG		 651 (SCM obj),
652 "Return @code{#t} if @var{obj} is a vector of type u16,\n"
653 "@code{#f} otherwise.")
654#define FUNC_NAME s_scm_u16vector_p
655{
00874d5f
MV		 656 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
657 SCM_UVEC_TYPE (obj) == SCM_UVEC_U16);
71ca65d9
MG		 658}
659#undef FUNC_NAME
660
661
645f5e0e 662SCM_DEFINE (scm_make_u16vector, "make-u16vector", 1, 1, 0,
71ca65d9
MG		 663 (SCM n, SCM fill),
664 "Create a newly allocated homogeneous numeric vector which can\n"
665 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
666 "initialize the elements, otherwise the contents of the vector\n"
667 "is unspecified.")
668#define FUNC_NAME s_scm_make_u16vector
669{
670 SCM uvec;
671 int_u16 * p;
672 int_u16 f;
673 int count;
674
675 SCM_VALIDATE_INUM (1, n);
676 count = SCM_INUM (n);
677 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, count);
678 if (SCM_UNBNDP (fill))
679 f = 0;
680 else
681 f = scm_num2ushort (fill, 2, FUNC_NAME);
682 p = (int_u16 *) SCM_UVEC_BASE (uvec);
683 while (count-- > 0)
684 *p++ = f;
685 return uvec;
686}
687#undef FUNC_NAME
688
689
645f5e0e 690SCM_DEFINE (scm_u16vector, "u16vector", 0, 0, 1,
71ca65d9
MG		 691 (SCM l),
692 "Create a newly allocated homogeneous numeric vector containing\n"
693 "all argument values.")
694#define FUNC_NAME s_scm_u16vector
695{
696 SCM_VALIDATE_REST_ARGUMENT (l);
697 return scm_list_to_u16vector (l);
698}
699#undef FUNC_NAME
700
701
645f5e0e 702SCM_DEFINE (scm_u16vector_length, "u16vector-length", 1, 0, 0,
71ca65d9
MG		 703 (SCM uvec),
704 "Return the number of elements in the homogeneous numeric vector\n"
705 "@var{uvec}.")
706#define FUNC_NAME s_scm_u16vector_length
707{
708 SCM_VALIDATE_SMOB (1, uvec, uvec);
709 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
710 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
711 return scm_int2num (SCM_UVEC_LENGTH (uvec));
712}
713#undef FUNC_NAME
714
715
645f5e0e 716SCM_DEFINE (scm_u16vector_ref, "u16vector-ref", 2, 0, 0,
71ca65d9
MG		 717 (SCM uvec, SCM index),
718 "Return the element at @var{index} in the homogeneous numeric\n"
719 "vector @var{uvec}.")
720#define FUNC_NAME s_scm_u16vector_ref
721{
722 int idx;
723
724 SCM_VALIDATE_SMOB (1, uvec, uvec);
725 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
726 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
727
728 idx = scm_num2int (index, 2, FUNC_NAME);
729 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 730 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 731
732 return scm_ushort2num (((int_u16 *) SCM_UVEC_BASE (uvec))[idx]);
733}
734#undef FUNC_NAME
735
736
645f5e0e 737SCM_DEFINE (scm_u16vector_set_x, "u16vector-set!", 3, 0, 0,
71ca65d9
MG		 738 (SCM uvec, SCM index, SCM value),
739 "Set the element at @var{index} in the homogeneous numeric\n"
740 "vector @var{uvec} to @var{value}. The return value is not\n"
741 "specified.")
742#define FUNC_NAME s_scm_u16vector_ref
743{
744 int idx;
745 int_u16 f;
746
747 SCM_VALIDATE_SMOB (1, uvec, uvec);
748 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
749 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
750
751 idx = scm_num2int (index, 2, FUNC_NAME);
752 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 753 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 754
755 f = scm_num2ushort (value, 3, FUNC_NAME);
756
757 ((int_u16 *) SCM_UVEC_BASE (uvec))[idx] = f;
758 return SCM_UNSPECIFIED;
759}
760#undef FUNC_NAME
761
762
645f5e0e 763SCM_DEFINE (scm_u16vector_to_list, "u16vector->list", 1, 0, 0,
71ca65d9
MG		 764 (SCM uvec),
765 "Convert the homogeneous numeric vector @var{uvec} to a list.")
766#define FUNC_NAME s_scm_u16vector_to_list
767{
768 int idx;
769 int_u16 * p;
770 SCM res = SCM_EOL;
771
772 SCM_VALIDATE_SMOB (1, uvec, uvec);
773 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U16)
774 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
775
776 idx = SCM_UVEC_LENGTH (uvec);
777 p = (int_u16 *) SCM_UVEC_BASE (uvec) + idx;
778 while (idx-- > 0)
779 {
780 p--;
93ccaef0 781 res = scm_cons (SCM_I_MAKINUM (*p), res);
71ca65d9
MG		 782 }
783 return res;
784}
785#undef FUNC_NAME
786
787
788SCM_DEFINE (scm_list_to_u16vector, "list->u16vector", 1, 0, 0,
789 (SCM l),
790 "Convert the list @var{l}, which must only contain unsigned\n"
791 "16-bit values, to a numeric homogeneous vector.")
792#define FUNC_NAME s_scm_list_to_u16vector
793{
794 SCM uvec;
795 int_u16 * p;
796 int n;
797 int arg_pos = 1;
798
799 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
800
801 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U16, n);
802 p = (int_u16 *) SCM_UVEC_BASE (uvec);
803 while (SCM_CONSP (l))
804 {
805 int_u16 f = scm_num2ushort (SCM_CAR (l), 2, FUNC_NAME);
806 *p++ = f;
807 l = SCM_CDR (l);
808 arg_pos++;
809 }
810 return uvec;
811}
812#undef FUNC_NAME
813
814
815/* ================================================================ */
816/* S16 procedures. */
817/* ================================================================ */
818
819
645f5e0e 820SCM_DEFINE (scm_s16vector_p, "s16vector?", 1, 0, 0,
71ca65d9
MG		 821 (SCM obj),
822 "Return @code{#t} if @var{obj} is a vector of type s16,\n"
823 "@code{#f} otherwise.")
824#define FUNC_NAME s_scm_s16vector_p
825{
00874d5f
MV		 826 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
827 SCM_UVEC_TYPE (obj) == SCM_UVEC_S16);
71ca65d9
MG		 828}
829#undef FUNC_NAME
830
831
645f5e0e 832SCM_DEFINE (scm_make_s16vector, "make-s16vector", 1, 1, 0,
71ca65d9
MG		 833 (SCM n, SCM fill),
834 "Create a newly allocated homogeneous numeric vector which can\n"
835 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
836 "initialize the elements, otherwise the contents of the vector\n"
837 "is unspecified.")
838#define FUNC_NAME s_scm_make_s16vector
839{
840 SCM uvec;
841 int_s16 * p;
842 int_s16 f;
843 int count;
844
845 SCM_VALIDATE_INUM (1, n);
846 count = SCM_INUM (n);
847 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, count);
848 if (SCM_UNBNDP (fill))
849 f = 0;
850 else
851 f = scm_num2short (fill, 2, FUNC_NAME);
852 p = (int_s16 *) SCM_UVEC_BASE (uvec);
853 while (count-- > 0)
854 *p++ = f;
855 return uvec;
856}
857#undef FUNC_NAME
858
859
645f5e0e 860SCM_DEFINE (scm_s16vector, "s16vector", 0, 0, 1,
71ca65d9
MG		 861 (SCM l),
862 "Create a newly allocated homogeneous numeric vector containing\n"
863 "all argument values.")
864#define FUNC_NAME s_scm_s16vector
865{
866 SCM_VALIDATE_REST_ARGUMENT (l);
867 return scm_list_to_s16vector (l);
868}
869#undef FUNC_NAME
870
871
645f5e0e 872SCM_DEFINE (scm_s16vector_length, "s16vector-length", 1, 0, 0,
71ca65d9
MG		 873 (SCM uvec),
874 "Return the number of elements in the homogeneous numeric vector\n"
875 "@var{uvec}.")
876#define FUNC_NAME s_scm_s16vector_length
877{
878 SCM_VALIDATE_SMOB (1, uvec, uvec);
879 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
880 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
881 return scm_int2num (SCM_UVEC_LENGTH (uvec));
882}
883#undef FUNC_NAME
884
885
645f5e0e 886SCM_DEFINE (scm_s16vector_ref, "s16vector-ref", 2, 0, 0,
71ca65d9
MG		 887 (SCM uvec, SCM index),
888 "Return the element at @var{index} in the homogeneous numeric\n"
889 "vector @var{uvec}.")
890#define FUNC_NAME s_scm_s16vector_ref
891{
892 int idx;
893
894 SCM_VALIDATE_SMOB (1, uvec, uvec);
895 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
896 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
897
898 idx = scm_num2int (index, 2, FUNC_NAME);
899 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 900 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 901
902 return scm_short2num (((int_s16 *) SCM_UVEC_BASE (uvec))[idx]);
903}
904#undef FUNC_NAME
905
906
645f5e0e 907SCM_DEFINE (scm_s16vector_set_x, "s16vector-set!", 3, 0, 0,
71ca65d9
MG		 908 (SCM uvec, SCM index, SCM value),
909 "Set the element at @var{index} in the homogeneous numeric\n"
910 "vector @var{uvec} to @var{value}. The return value is not\n"
911 "specified.")
912#define FUNC_NAME s_scm_s16vector_ref
913{
914 int idx;
915 int_s16 f;
916
917 SCM_VALIDATE_SMOB (1, uvec, uvec);
918 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
919 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
920
921 idx = scm_num2int (index, 2, FUNC_NAME);
922 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 923 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 924
925 f = scm_num2short (value, 3, FUNC_NAME);
926
927 ((int_s16 *) SCM_UVEC_BASE (uvec))[idx] = f;
928 return SCM_UNSPECIFIED;
929}
930#undef FUNC_NAME
931
932
645f5e0e 933SCM_DEFINE (scm_s16vector_to_list, "s16vector->list", 1, 0, 0,
71ca65d9
MG		 934 (SCM uvec),
935 "Convert the homogeneous numeric vector @var{uvec} to a list.")
936#define FUNC_NAME s_scm_s16vector_to_list
937{
938 int idx;
939 int_s16 * p;
940 SCM res = SCM_EOL;
941
942 SCM_VALIDATE_SMOB (1, uvec, uvec);
943 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S16)
944 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
945
946 idx = SCM_UVEC_LENGTH (uvec);
947 p = (int_s16 *) SCM_UVEC_BASE (uvec) + idx;
948 while (idx-- > 0)
949 {
950 p--;
93ccaef0 951 res = scm_cons (SCM_I_MAKINUM (*p), res);
71ca65d9
MG		 952 }
953 return res;
954}
955#undef FUNC_NAME
956
957
958SCM_DEFINE (scm_list_to_s16vector, "list->s16vector", 1, 0, 0,
959 (SCM l),
960 "Convert the list @var{l}, which must only contain signed\n"
961 "16-bit values, to a numeric homogeneous vector.")
962#define FUNC_NAME s_scm_list_to_s16vector
963{
964 SCM uvec;
965 SCM tmp;
966 int_s16 * p;
967 int n;
968 int arg_pos = 1;
969
970 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
971
972 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S16, n);
973 p = (int_s16 *) SCM_UVEC_BASE (uvec);
974 tmp = l;
975 while (SCM_CONSP (tmp))
976 {
977 int_s16 f = scm_num2short (SCM_CAR (tmp), 2, FUNC_NAME);
978 *p++ = f;
979 tmp = SCM_CDR (tmp);
980 arg_pos++;
981 }
982 scm_remember_upto_here_1 (l);
983 return uvec;
984}
985#undef FUNC_NAME
986
987
988/* ================================================================ */
989/* U32 procedures. */
990/* ================================================================ */
991
992
645f5e0e 993SCM_DEFINE (scm_u32vector_p, "u32vector?", 1, 0, 0,
71ca65d9
MG		 994 (SCM obj),
995 "Return @code{#t} if @var{obj} is a vector of type u32,\n"
996 "@code{#f} otherwise.")
997#define FUNC_NAME s_scm_u32vector_p
998{
00874d5f
MV		 999 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1000 SCM_UVEC_TYPE (obj) == SCM_UVEC_U32);
71ca65d9
MG		 1001}
1002#undef FUNC_NAME
1003
1004
645f5e0e 1005SCM_DEFINE (scm_make_u32vector, "make-u32vector", 1, 1, 0,
71ca65d9
MG		 1006 (SCM n, SCM fill),
1007 "Create a newly allocated homogeneous numeric vector which can\n"
1008 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1009 "initialize the elements, otherwise the contents of the vector\n"
1010 "is unspecified.")
1011#define FUNC_NAME s_scm_make_u32vector
1012{
1013 SCM uvec;
1014 int_u32 * p;
1015 int_u32 f;
1016 int count;
1017
1018 SCM_VALIDATE_INUM (1, n);
1019 count = SCM_INUM (n);
1020 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, count);
1021 if (SCM_UNBNDP (fill))
1022 f = 0;
1023 else
1024 f = scm_num2uint (fill, 2, FUNC_NAME);
1025 p = (int_u32 *) SCM_UVEC_BASE (uvec);
1026 while (count-- > 0)
1027 *p++ = f;
1028 return uvec;
1029}
1030#undef FUNC_NAME
1031
1032
645f5e0e 1033SCM_DEFINE (scm_u32vector, "u32vector", 0, 0, 1,
71ca65d9
MG		 1034 (SCM l),
1035 "Create a newly allocated homogeneous numeric vector containing\n"
1036 "all argument values.")
1037#define FUNC_NAME s_scm_u32vector
1038{
1039 SCM_VALIDATE_REST_ARGUMENT (l);
1040 return scm_list_to_u32vector (l);
1041}
1042#undef FUNC_NAME
1043
1044
645f5e0e 1045SCM_DEFINE (scm_u32vector_length, "u32vector-length", 1, 0, 0,
71ca65d9
MG		 1046 (SCM uvec),
1047 "Return the number of elements in the homogeneous numeric vector\n"
1048 "@var{uvec}.")
1049#define FUNC_NAME s_scm_u32vector_length
1050{
1051 SCM_VALIDATE_SMOB (1, uvec, uvec);
1052 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1053 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1054 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1055}
1056#undef FUNC_NAME
1057
1058
645f5e0e 1059SCM_DEFINE (scm_u32vector_ref, "u32vector-ref", 2, 0, 0,
71ca65d9
MG		 1060 (SCM uvec, SCM index),
1061 "Return the element at @var{index} in the homogeneous numeric\n"
1062 "vector @var{uvec}.")
1063#define FUNC_NAME s_scm_u32vector_ref
1064{
1065 int idx;
1066
1067 SCM_VALIDATE_SMOB (1, uvec, uvec);
1068 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1069 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1070
1071 idx = scm_num2int (index, 2, FUNC_NAME);
1072 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1073 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1074
1075 return scm_uint2num (((int_u32 *) SCM_UVEC_BASE (uvec))[idx]);
1076}
1077#undef FUNC_NAME
1078
1079
645f5e0e 1080SCM_DEFINE (scm_u32vector_set_x, "u32vector-set!", 3, 0, 0,
71ca65d9
MG		 1081 (SCM uvec, SCM index, SCM value),
1082 "Set the element at @var{index} in the homogeneous numeric\n"
1083 "vector @var{uvec} to @var{value}. The return value is not\n"
1084 "specified.")
1085#define FUNC_NAME s_scm_u32vector_ref
1086{
1087 int idx;
1088 int_u32 f;
1089
1090 SCM_VALIDATE_SMOB (1, uvec, uvec);
1091 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1092 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1093
1094 idx = scm_num2int (index, 2, FUNC_NAME);
1095 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1096 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1097
1098 f = scm_num2uint (value, 3, FUNC_NAME);
1099
1100 ((int_u32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1101 return SCM_UNSPECIFIED;
1102}
1103#undef FUNC_NAME
1104
1105
645f5e0e 1106SCM_DEFINE (scm_u32vector_to_list, "u32vector->list", 1, 0, 0,
71ca65d9
MG		 1107 (SCM uvec),
1108 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1109#define FUNC_NAME s_scm_u32vector_to_list
1110{
1111 int idx;
1112 int_u32 * p;
1113 SCM res = SCM_EOL;
1114
1115 SCM_VALIDATE_SMOB (1, uvec, uvec);
1116 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U32)
1117 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1118
1119 idx = SCM_UVEC_LENGTH (uvec);
1120 p = (int_u32 *) SCM_UVEC_BASE (uvec) + idx;
1121 while (idx-- > 0)
1122 {
1123 p--;
1124 res = scm_cons (scm_uint2num (*p), res);
1125 }
1126 return res;
1127}
1128#undef FUNC_NAME
1129
1130
1131SCM_DEFINE (scm_list_to_u32vector, "list->u32vector", 1, 0, 0,
1132 (SCM l),
1133 "Convert the list @var{l}, which must only contain unsigned\n"
1134 "32-bit values, to a numeric homogeneous vector.")
1135#define FUNC_NAME s_scm_list_to_u32vector
1136{
1137 SCM uvec;
1138 int_u32 * p;
1139 int n;
1140 int arg_pos = 1;
1141
1142 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1143
1144 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U32, n);
1145 p = (int_u32 *) SCM_UVEC_BASE (uvec);
1146 while (SCM_CONSP (l))
1147 {
1148 int_u32 f;
1149 f = scm_num2uint (SCM_CAR (l), 2, FUNC_NAME);
1150 *p++ = f;
1151 l = SCM_CDR (l);
1152 arg_pos++;
1153 }
1154 return uvec;
1155}
1156#undef FUNC_NAME
1157
1158
1159/* ================================================================ */
1160/* S32 procedures. */
1161/* ================================================================ */
1162
1163
645f5e0e 1164SCM_DEFINE (scm_s32vector_p, "s32vector?", 1, 0, 0,
71ca65d9
MG		 1165 (SCM obj),
1166 "Return @code{#t} if @var{obj} is a vector of type s32,\n"
1167 "@code{#f} otherwise.")
1168#define FUNC_NAME s_scm_s32vector_p
1169{
00874d5f
MV		 1170 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1171 SCM_UVEC_TYPE (obj) == SCM_UVEC_S32);
71ca65d9
MG		 1172}
1173#undef FUNC_NAME
1174
1175
645f5e0e 1176SCM_DEFINE (scm_make_s32vector, "make-s32vector", 1, 1, 0,
71ca65d9
MG		 1177 (SCM n, SCM fill),
1178 "Create a newly allocated homogeneous numeric vector which can\n"
1179 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1180 "initialize the elements, otherwise the contents of the vector\n"
1181 "is unspecified.")
1182#define FUNC_NAME s_scm_make_s32vector
1183{
1184 SCM uvec;
1185 int_s32 * p;
1186 int_s32 f;
1187 int count;
1188
1189 SCM_VALIDATE_INUM (1, n);
1190 count = SCM_INUM (n);
1191 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, count);
1192 if (SCM_UNBNDP (fill))
1193 f = 0;
1194 else
1195 f = scm_num2int (fill, 2, FUNC_NAME);
1196 p = (int_s32 *) SCM_UVEC_BASE (uvec);
1197 while (count-- > 0)
1198 *p++ = f;
1199 return uvec;
1200}
1201#undef FUNC_NAME
1202
1203
645f5e0e 1204SCM_DEFINE (scm_s32vector, "s32vector", 0, 0, 1,
71ca65d9
MG		 1205 (SCM l),
1206 "Create a newly allocated homogeneous numeric vector containing\n"
1207 "all argument values.")
1208#define FUNC_NAME s_scm_s32vector
1209{
1210 SCM_VALIDATE_REST_ARGUMENT (l);
1211 return scm_list_to_s32vector (l);
1212}
1213#undef FUNC_NAME
1214
1215
645f5e0e 1216SCM_DEFINE (scm_s32vector_length, "s32vector-length", 1, 0, 0,
71ca65d9
MG		 1217 (SCM uvec),
1218 "Return the number of elements in the homogeneous numeric vector\n"
1219 "@var{uvec}.")
1220#define FUNC_NAME s_scm_s32vector_length
1221{
1222 SCM_VALIDATE_SMOB (1, uvec, uvec);
1223 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1224 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1225 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1226}
1227#undef FUNC_NAME
1228
1229
645f5e0e 1230SCM_DEFINE (scm_s32vector_ref, "s32vector-ref", 2, 0, 0,
71ca65d9
MG		 1231 (SCM uvec, SCM index),
1232 "Return the element at @var{index} in the homogeneous numeric\n"
1233 "vector @var{uvec}.")
1234#define FUNC_NAME s_scm_s32vector_ref
1235{
1236 int idx;
1237
1238 SCM_VALIDATE_SMOB (1, uvec, uvec);
1239 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1240 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1241
1242 idx = scm_num2int (index, 2, FUNC_NAME);
1243 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1244 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1245
1246 return scm_int2num (((int_s32 *) SCM_UVEC_BASE (uvec))[idx]);
1247}
1248#undef FUNC_NAME
1249
1250
645f5e0e 1251SCM_DEFINE (scm_s32vector_set_x, "s32vector-set!", 3, 0, 0,
71ca65d9
MG		 1252 (SCM uvec, SCM index, SCM value),
1253 "Set the element at @var{index} in the homogeneous numeric\n"
1254 "vector @var{uvec} to @var{value}. The return value is not\n"
1255 "specified.")
1256#define FUNC_NAME s_scm_s32vector_ref
1257{
1258 int idx;
1259 int_s32 f;
1260
1261 SCM_VALIDATE_SMOB (1, uvec, uvec);
1262 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1263 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1264
1265 idx = scm_num2int (index, 2, FUNC_NAME);
1266 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1267 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1268
1269 f = scm_num2int (value, 3, FUNC_NAME);
1270
1271 ((int_s32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1272 return SCM_UNSPECIFIED;
1273}
1274#undef FUNC_NAME
1275
1276
645f5e0e 1277SCM_DEFINE (scm_s32vector_to_list, "s32vector->list", 1, 0, 0,
71ca65d9
MG		 1278 (SCM uvec),
1279 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1280#define FUNC_NAME s_scm_s32vector_to_list
1281{
1282 int idx;
1283 int_s32 * p;
1284 SCM res = SCM_EOL;
1285
1286 SCM_VALIDATE_SMOB (1, uvec, uvec);
1287 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S32)
1288 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1289
1290 idx = SCM_UVEC_LENGTH (uvec);
1291 p = (int_s32 *) SCM_UVEC_BASE (uvec) + idx;
1292 while (idx-- > 0)
1293 {
1294 p--;
1295 res = scm_cons (scm_int2num (*p), res);
1296 }
1297 return res;
1298}
1299#undef FUNC_NAME
1300
1301
1302SCM_DEFINE (scm_list_to_s32vector, "list->s32vector", 1, 0, 0,
1303 (SCM l),
1304 "Convert the list @var{l}, which must only contain signed\n"
1305 "32-bit values, to a numeric homogeneous vector.")
1306#define FUNC_NAME s_scm_list_to_s32vector
1307{
1308 SCM uvec;
1309 int_s32 * p;
1310 int n;
1311 int arg_pos = 1;
1312
1313 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1314
1315 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S32, n);
1316 p = (int_s32 *) SCM_UVEC_BASE (uvec);
1317 while (SCM_CONSP (l))
1318 {
1319 int_s32 f;
1320 f = scm_num2int (SCM_CAR (l), 2, FUNC_NAME);
1321 *p++ = f;
1322 l = SCM_CDR (l);
1323 arg_pos++;
1324 }
1325 return uvec;
1326}
1327#undef FUNC_NAME
1328
1329
9150491d 1330#if SCM_HAVE_T_INT64
71ca65d9
MG		 1331
1332/* ================================================================ */
1333/* U64 procedures. */
1334/* ================================================================ */
1335
1336
645f5e0e 1337SCM_DEFINE (scm_u64vector_p, "u64vector?", 1, 0, 0,
71ca65d9
MG		 1338 (SCM obj),
1339 "Return @code{#t} if @var{obj} is a vector of type u64,\n"
1340 "@code{#f} otherwise.")
1341#define FUNC_NAME s_scm_u64vector_p
1342{
00874d5f
MV		 1343 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1344 SCM_UVEC_TYPE (obj) == SCM_UVEC_U64);
71ca65d9
MG		 1345}
1346#undef FUNC_NAME
1347
1348
645f5e0e 1349SCM_DEFINE (scm_make_u64vector, "make-u64vector", 1, 1, 0,
71ca65d9
MG		 1350 (SCM n, SCM fill),
1351 "Create a newly allocated homogeneous numeric vector which can\n"
1352 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1353 "initialize the elements, otherwise the contents of the vector\n"
1354 "is unspecified.")
1355#define FUNC_NAME s_scm_make_u64vector
1356{
1357 SCM uvec;
1358 int_u64 * p;
1359 int_u64 f;
1360 int count;
1361
1362 SCM_VALIDATE_INUM (1, n);
1363 count = SCM_INUM (n);
1364 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, count);
1365 if (SCM_UNBNDP (fill))
1366 f = 0;
1367 else
1368 f = scm_num2ulong_long (fill, 2, FUNC_NAME);
1369 p = (int_u64 *) SCM_UVEC_BASE (uvec);
1370 while (count-- > 0)
1371 *p++ = f;
1372 return uvec;
1373}
1374#undef FUNC_NAME
1375
1376
645f5e0e 1377SCM_DEFINE (scm_u64vector, "u64vector", 0, 0, 1,
71ca65d9
MG		 1378 (SCM l),
1379 "Create a newly allocated homogeneous numeric vector containing\n"
1380 "all argument values.")
1381#define FUNC_NAME s_scm_u64vector
1382{
1383 SCM_VALIDATE_REST_ARGUMENT (l);
1384 return scm_list_to_u64vector (l);
1385}
1386#undef FUNC_NAME
1387
1388
645f5e0e 1389SCM_DEFINE (scm_u64vector_length, "u64vector-length", 1, 0, 0,
71ca65d9
MG		 1390 (SCM uvec),
1391 "Return the number of elements in the homogeneous numeric vector\n"
1392 "@var{uvec}.")
1393#define FUNC_NAME s_scm_u64vector_length
1394{
1395 SCM_VALIDATE_SMOB (1, uvec, uvec);
1396 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1397 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1398 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1399}
1400#undef FUNC_NAME
1401
1402
645f5e0e 1403SCM_DEFINE (scm_u64vector_ref, "u64vector-ref", 2, 0, 0,
71ca65d9
MG		 1404 (SCM uvec, SCM index),
1405 "Return the element at @var{index} in the homogeneous numeric\n"
1406 "vector @var{uvec}.")
1407#define FUNC_NAME s_scm_u64vector_ref
1408{
1409 int idx;
1410
1411 SCM_VALIDATE_SMOB (1, uvec, uvec);
1412 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1413 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1414
1415 idx = scm_num2int (index, 2, FUNC_NAME);
1416 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1417 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1418
1419 return scm_ulong_long2num (((int_u64 *) SCM_UVEC_BASE (uvec))[idx]);
1420}
1421#undef FUNC_NAME
1422
1423
645f5e0e 1424SCM_DEFINE (scm_u64vector_set_x, "u64vector-set!", 3, 0, 0,
71ca65d9
MG		 1425 (SCM uvec, SCM index, SCM value),
1426 "Set the element at @var{index} in the homogeneous numeric\n"
1427 "vector @var{uvec} to @var{value}. The return value is not\n"
1428 "specified.")
1429#define FUNC_NAME s_scm_u64vector_ref
1430{
1431 int idx;
1432 int_u64 f;
1433
1434 SCM_VALIDATE_SMOB (1, uvec, uvec);
1435 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1436 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1437
1438 idx = scm_num2int (index, 2, FUNC_NAME);
1439 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1440 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1441
1442 f = scm_num2ulong_long (value, 3, FUNC_NAME);
1443
1444 ((int_u64 *) SCM_UVEC_BASE (uvec))[idx] = f;
1445 return SCM_UNSPECIFIED;
1446}
1447#undef FUNC_NAME
1448
1449
645f5e0e 1450SCM_DEFINE (scm_u64vector_to_list, "u64vector->list", 1, 0, 0,
71ca65d9
MG		 1451 (SCM uvec),
1452 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1453#define FUNC_NAME s_scm_u64vector_to_list
1454{
1455 int idx;
1456 int_u64 * p;
1457 SCM res = SCM_EOL;
1458
1459 SCM_VALIDATE_SMOB (1, uvec, uvec);
1460 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_U64)
1461 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1462
1463 idx = SCM_UVEC_LENGTH (uvec);
1464 p = (int_u64 *) SCM_UVEC_BASE (uvec) + idx;
1465 while (idx-- > 0)
1466 {
1467 p--;
1468 res = scm_cons (scm_long_long2num (*p), res);
1469 }
1470 return res;
1471}
1472#undef FUNC_NAME
1473
1474
1475SCM_DEFINE (scm_list_to_u64vector, "list->u64vector", 1, 0, 0,
1476 (SCM l),
1477 "Convert the list @var{l}, which must only contain unsigned\n"
1478 "64-bit values, to a numeric homogeneous vector.")
1479#define FUNC_NAME s_scm_list_to_u64vector
1480{
1481 SCM uvec;
1482 int_u64 * p;
1483 int n;
1484 int arg_pos = 1;
1485
1486 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1487
1488 uvec = make_uvec (FUNC_NAME, SCM_UVEC_U64, n);
1489 p = (int_u64 *) SCM_UVEC_BASE (uvec);
1490 while (SCM_CONSP (l))
1491 {
1492 int_u64 f;
1493 f = scm_num2ulong_long (SCM_CAR (l), 2, FUNC_NAME);
1494 *p++ = f;
1495 l = SCM_CDR (l);
1496 arg_pos++;
1497 }
1498 return uvec;
1499}
1500#undef FUNC_NAME
1501
1502
1503/* ================================================================ */
1504/* S64 procedures. */
1505/* ================================================================ */
1506
1507
645f5e0e 1508SCM_DEFINE (scm_s64vector_p, "s64vector?", 1, 0, 0,
71ca65d9
MG		 1509 (SCM obj),
1510 "Return @code{#t} if @var{obj} is a vector of type s64,\n"
1511 "@code{#f} otherwise.")
1512#define FUNC_NAME s_scm_s64vector_p
1513{
00874d5f
MV		 1514 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1515 SCM_UVEC_TYPE (obj) == SCM_UVEC_S64);
71ca65d9
MG		 1516}
1517#undef FUNC_NAME
1518
1519
645f5e0e 1520SCM_DEFINE (scm_make_s64vector, "make-s64vector", 1, 1, 0,
71ca65d9
MG		 1521 (SCM n, SCM fill),
1522 "Create a newly allocated homogeneous numeric vector which can\n"
1523 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1524 "initialize the elements, otherwise the contents of the vector\n"
1525 "is unspecified.")
1526#define FUNC_NAME s_scm_make_s64vector
1527{
1528 SCM uvec;
1529 int_s64 * p;
1530 int_s64 f;
1531 int count;
1532
1533 SCM_VALIDATE_INUM (1, n);
1534 count = SCM_INUM (n);
1535 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, count);
1536 if (SCM_UNBNDP (fill))
1537 f = 0;
1538 else
1539 f = scm_num2long_long (fill, 2, FUNC_NAME);
1540 p = (int_s64 *) SCM_UVEC_BASE (uvec);
1541 while (count-- > 0)
1542 *p++ = f;
1543 return uvec;
1544}
1545#undef FUNC_NAME
1546
1547
645f5e0e 1548SCM_DEFINE (scm_s64vector, "s64vector", 0, 0, 1,
71ca65d9
MG		 1549 (SCM l),
1550 "Create a newly allocated homogeneous numeric vector containing\n"
1551 "all argument values.")
1552#define FUNC_NAME s_scm_s64vector
1553{
1554 SCM_VALIDATE_REST_ARGUMENT (l);
1555 return scm_list_to_s64vector (l);
1556}
1557#undef FUNC_NAME
1558
1559
645f5e0e 1560SCM_DEFINE (scm_s64vector_length, "s64vector-length", 1, 0, 0,
71ca65d9
MG		 1561 (SCM uvec),
1562 "Return the number of elements in the homogeneous numeric vector\n"
1563 "@var{uvec}.")
1564#define FUNC_NAME s_scm_s64vector_length
1565{
1566 SCM_VALIDATE_SMOB (1, uvec, uvec);
1567 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1568 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1569 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1570}
1571#undef FUNC_NAME
1572
1573
645f5e0e 1574SCM_DEFINE (scm_s64vector_ref, "s64vector-ref", 2, 0, 0,
71ca65d9
MG		 1575 (SCM uvec, SCM index),
1576 "Return the element at @var{index} in the homogeneous numeric\n"
1577 "vector @var{uvec}.")
1578#define FUNC_NAME s_scm_s64vector_ref
1579{
1580 int idx;
1581
1582 SCM_VALIDATE_SMOB (1, uvec, uvec);
1583 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1584 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1585
1586 idx = scm_num2int (index, 2, FUNC_NAME);
1587 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1588 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1589
1590 return scm_long_long2num (((int_s64 *) SCM_UVEC_BASE (uvec))[idx]);
1591}
1592#undef FUNC_NAME
1593
1594
645f5e0e 1595SCM_DEFINE (scm_s64vector_set_x, "s64vector-set!", 3, 0, 0,
71ca65d9
MG		 1596 (SCM uvec, SCM index, SCM value),
1597 "Set the element at @var{index} in the homogeneous numeric\n"
1598 "vector @var{uvec} to @var{value}. The return value is not\n"
1599 "specified.")
1600#define FUNC_NAME s_scm_s64vector_ref
1601{
1602 int idx;
1603 int_s64 f;
1604
1605 SCM_VALIDATE_SMOB (1, uvec, uvec);
1606 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1607 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1608
1609 idx = scm_num2int (index, 2, FUNC_NAME);
1610 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1611 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1612
1613 f = scm_num2long_long (value, 3, FUNC_NAME);
1614
1615 ((int_s64 *) SCM_UVEC_BASE (uvec))[idx] = f;
1616 return SCM_UNSPECIFIED;
1617}
1618#undef FUNC_NAME
1619
1620
645f5e0e 1621SCM_DEFINE (scm_s64vector_to_list, "s64vector->list", 1, 0, 0,
71ca65d9
MG		 1622 (SCM uvec),
1623 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1624#define FUNC_NAME s_scm_s64vector_to_list
1625{
1626 int idx;
1627 int_s64 * p;
1628 SCM res = SCM_EOL;
1629
1630 SCM_VALIDATE_SMOB (1, uvec, uvec);
1631 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_S64)
1632 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1633
1634 idx = SCM_UVEC_LENGTH (uvec);
1635 p = (int_s64 *) SCM_UVEC_BASE (uvec) + idx;
1636 while (idx-- > 0)
1637 {
1638 p--;
1639 res = scm_cons (scm_long_long2num (*p), res);
1640 }
1641 return res;
1642}
1643#undef FUNC_NAME
1644
1645
1646SCM_DEFINE (scm_list_to_s64vector, "list->s64vector", 1, 0, 0,
1647 (SCM l),
1648 "Convert the list @var{l}, which must only contain signed\n"
1649 "64-bit values, to a numeric homogeneous vector.")
1650#define FUNC_NAME s_scm_list_to_s64vector
1651{
1652 SCM uvec;
1653 int_s64 * p;
1654 int n;
1655 int arg_pos = 1;
1656
1657 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1658
1659 uvec = make_uvec (FUNC_NAME, SCM_UVEC_S64, n);
1660 p = (int_s64 *) SCM_UVEC_BASE (uvec);
1661 while (SCM_CONSP (l))
1662 {
1663 int_s64 f;
1664 f = scm_num2long_long (SCM_CAR (l), 2, FUNC_NAME);
1665 *p++ = f;
1666 l = SCM_CDR (l);
1667 arg_pos++;
1668 }
1669 return uvec;
1670}
1671#undef FUNC_NAME
1672
e583edd0 1673#endif /* SCM_HAVE_T_INT64 */
71ca65d9
MG		 1674
1675
1676/* ================================================================ */
1677/* F32 procedures. */
1678/* ================================================================ */
1679
1680
645f5e0e 1681SCM_DEFINE (scm_f32vector_p, "f32vector?", 1, 0, 0,
71ca65d9
MG		 1682 (SCM obj),
1683 "Return @code{#t} if @var{obj} is a vector of type f32,\n"
1684 "@code{#f} otherwise.")
1685#define FUNC_NAME s_scm_f32vector_p
1686{
00874d5f
MV		 1687 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1688 SCM_UVEC_TYPE (obj) == SCM_UVEC_F32);
71ca65d9
MG		 1689}
1690#undef FUNC_NAME
1691
1692
645f5e0e 1693SCM_DEFINE (scm_make_f32vector, "make-f32vector", 1, 1, 0,
71ca65d9
MG		 1694 (SCM n, SCM fill),
1695 "Create a newly allocated homogeneous numeric vector which can\n"
1696 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1697 "initialize the elements, otherwise the contents of the vector\n"
1698 "is unspecified.")
1699#define FUNC_NAME s_scm_make_f32vector
1700{
1701 SCM uvec;
1702 float_f32 * p;
1703 float_f32 f;
1704 int count;
1705
1706 SCM_VALIDATE_INUM (1, n);
1707 count = SCM_INUM (n);
1708 uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, count);
1709 if (SCM_UNBNDP (fill))
1710 f = 0;
1711 else
1712 {
1713 double d = scm_num2dbl (fill, FUNC_NAME);
1714 f = d;
1715#if 0
1716 /* This test somehow fails for even the simplest inexact
1717 numbers, like 3.1. Must find out how to check properly. */
1718 if (f != d)
93ccaef0 1719 scm_out_of_range_pos (FUNC_NAME, fill, SCM_I_MAKINUM (2));
71ca65d9
MG		 1720#endif /* 0 */
1721 }
1722 p = (float_f32 *) SCM_UVEC_BASE (uvec);
1723 while (count-- > 0)
1724 *p++ = f;
1725 return uvec;
1726}
1727#undef FUNC_NAME
1728
1729
645f5e0e 1730SCM_DEFINE (scm_f32vector, "f32vector", 0, 0, 1,
71ca65d9
MG		 1731 (SCM l),
1732 "Create a newly allocated homogeneous numeric vector containing\n"
1733 "all argument values.")
1734#define FUNC_NAME s_scm_f32vector
1735{
1736 SCM_VALIDATE_REST_ARGUMENT (l);
1737 return scm_list_to_f32vector (l);
1738}
1739#undef FUNC_NAME
1740
1741
645f5e0e 1742SCM_DEFINE (scm_f32vector_length, "f32vector-length", 1, 0, 0,
71ca65d9
MG		 1743 (SCM uvec),
1744 "Return the number of elements in the homogeneous numeric vector\n"
1745 "@var{uvec}.")
1746#define FUNC_NAME s_scm_f32vector_length
1747{
1748 SCM_VALIDATE_SMOB (1, uvec, uvec);
1749 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1750 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1751 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1752}
1753#undef FUNC_NAME
1754
1755
645f5e0e 1756SCM_DEFINE (scm_f32vector_ref, "f32vector-ref", 2, 0, 0,
71ca65d9
MG		 1757 (SCM uvec, SCM index),
1758 "Return the element at @var{index} in the homogeneous numeric\n"
1759 "vector @var{uvec}.")
1760#define FUNC_NAME s_scm_f32vector_ref
1761{
1762 int idx;
1763
1764 SCM_VALIDATE_SMOB (1, uvec, uvec);
1765 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1766 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1767
1768 idx = scm_num2int (index, 2, FUNC_NAME);
1769 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1770 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1771
1772 return scm_make_real (((float_f32 *) SCM_UVEC_BASE (uvec))[idx]);
1773}
1774#undef FUNC_NAME
1775
1776
645f5e0e 1777SCM_DEFINE (scm_f32vector_set_x, "f32vector-set!", 3, 0, 0,
71ca65d9
MG		 1778 (SCM uvec, SCM index, SCM value),
1779 "Set the element at @var{index} in the homogeneous numeric\n"
1780 "vector @var{uvec} to @var{value}. The return value is not\n"
1781 "specified.")
1782#define FUNC_NAME s_scm_f32vector_ref
1783{
1784 int idx;
1785 float_f32 f;
1786 double d;
1787
1788 SCM_VALIDATE_SMOB (1, uvec, uvec);
1789 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1790 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1791
1792 idx = scm_num2int (index, 2, FUNC_NAME);
1793 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1794 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1795
1796 d = scm_num2dbl (value, FUNC_NAME);
1797 f = d;
1798#if 0
1799 /* This test somehow fails for even the simplest inexact
1800 numbers, like 3.1. Must find out how to check properly. */
1801 if (f != d)
93ccaef0 1802 scm_out_of_range_pos (FUNC_NAME, value, SCM_I_MAKINUM (3));
71ca65d9
MG		 1803#endif /* 0 */
1804
1805 ((float_f32 *) SCM_UVEC_BASE (uvec))[idx] = f;
1806 return SCM_UNSPECIFIED;
1807}
1808#undef FUNC_NAME
1809
1810
645f5e0e 1811SCM_DEFINE (scm_f32vector_to_list, "f32vector->list", 1, 0, 0,
71ca65d9
MG		 1812 (SCM uvec),
1813 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1814#define FUNC_NAME s_scm_f32vector_to_list
1815{
1816 int idx;
1817 float_f32 * p;
1818 SCM res = SCM_EOL;
1819
1820 SCM_VALIDATE_SMOB (1, uvec, uvec);
1821 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F32)
1822 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1823
1824 idx = SCM_UVEC_LENGTH (uvec);
1825 p = (float_f32 *) SCM_UVEC_BASE (uvec) + idx;
1826 while (idx-- > 0)
1827 {
1828 p--;
1829 res = scm_cons (scm_make_real (*p), res);
1830 }
1831 return res;
1832}
1833#undef FUNC_NAME
1834
1835
1836SCM_DEFINE (scm_list_to_f32vector, "list->f32vector", 1, 0, 0,
1837 (SCM l),
1838 "Convert the list @var{l}, which must only contain unsigned\n"
1839 "8-bit values, to a numeric homogeneous vector.")
1840#define FUNC_NAME s_scm_list_to_f32vector
1841{
1842 SCM uvec;
1843 float_f32 * p;
1844 int n;
1845 int arg_pos = 1;
1846
1847 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
1848
1849 uvec = make_uvec (FUNC_NAME, SCM_UVEC_F32, n);
1850 p = (float_f32 *) SCM_UVEC_BASE (uvec);
1851 while (SCM_CONSP (l))
1852 {
1853 float_f32 f;
1854 double d;
1855 d = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
1856 f = d;
1857#if 0
1858 /* This test somehow fails for even the simplest inexact
1859 numbers, like 3.1. Must find out how to check properly. */
1860 if (d != f)
93ccaef0 1861 scm_out_of_range_pos (FUNC_NAME, l, SCM_I_MAKINUM (1));
71ca65d9
MG		 1862#endif /* 0 */
1863 *p++ = f;
1864 l = SCM_CDR (l);
1865 arg_pos++;
1866 }
1867 return uvec;
1868}
1869#undef FUNC_NAME
1870
1871
1872/* ================================================================ */
1873/* F64 procedures. */
1874/* ================================================================ */
1875
1876
645f5e0e 1877SCM_DEFINE (scm_f64vector_p, "f64vector?", 1, 0, 0,
71ca65d9
MG		 1878 (SCM obj),
1879 "Return @code{#t} if @var{obj} is a vector of type f64,\n"
1880 "@code{#f} otherwise.")
1881#define FUNC_NAME s_scm_f64vector_p
1882{
00874d5f
MV		 1883 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj) &&
1884 SCM_UVEC_TYPE (obj) == SCM_UVEC_F64);
71ca65d9
MG		 1885}
1886#undef FUNC_NAME
1887
1888
645f5e0e 1889SCM_DEFINE (scm_make_f64vector, "make-f64vector", 1, 1, 0,
71ca65d9
MG		 1890 (SCM n, SCM fill),
1891 "Create a newly allocated homogeneous numeric vector which can\n"
1892 "hold @var{len} elements. If @var{fill} is given, it is used to\n"
1893 "initialize the elements, otherwise the contents of the vector\n"
1894 "is unspecified.")
1895#define FUNC_NAME s_scm_make_f64vector
1896{
1897 SCM uvec;
1898 float_f64 * p;
1899 float_f64 f;
1900 int count;
1901
1902 SCM_VALIDATE_INUM (1, n);
1903 count = SCM_INUM (n);
1904 uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, count);
1905 if (SCM_UNBNDP (fill))
1906 f = 0;
1907 else
1908 f = scm_num2dbl (fill, FUNC_NAME);
1909 p = (float_f64 *) SCM_UVEC_BASE (uvec);
1910 while (count-- > 0)
1911 *p++ = f;
1912 return uvec;
1913}
1914#undef FUNC_NAME
1915
1916
645f5e0e 1917SCM_DEFINE (scm_f64vector, "f64vector", 0, 0, 1,
71ca65d9
MG		 1918 (SCM l),
1919 "Create a newly allocated homogeneous numeric vector containing\n"
1920 "all argument values.")
1921#define FUNC_NAME s_scm_f64vector
1922{
1923 SCM_VALIDATE_REST_ARGUMENT (l);
1924 return scm_list_to_f64vector (l);
1925}
1926#undef FUNC_NAME
1927
1928
645f5e0e 1929SCM_DEFINE (scm_f64vector_length, "f64vector-length", 1, 0, 0,
71ca65d9
MG		 1930 (SCM uvec),
1931 "Return the number of elements in the homogeneous numeric vector\n"
1932 "@var{uvec}.")
1933#define FUNC_NAME s_scm_f64vector_length
1934{
1935 SCM_VALIDATE_SMOB (1, uvec, uvec);
1936 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
1937 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1938 return scm_int2num (SCM_UVEC_LENGTH (uvec));
1939}
1940#undef FUNC_NAME
1941
1942
645f5e0e 1943SCM_DEFINE (scm_f64vector_ref, "f64vector-ref", 2, 0, 0,
71ca65d9
MG		 1944 (SCM uvec, SCM index),
1945 "Return the element at @var{index} in the homogeneous numeric\n"
1946 "vector @var{uvec}.")
1947#define FUNC_NAME s_scm_f64vector_ref
1948{
1949 int idx;
1950
1951 SCM_VALIDATE_SMOB (1, uvec, uvec);
1952 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
1953 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1954
1955 idx = scm_num2int (index, 2, FUNC_NAME);
1956 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1957 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1958
1959 return scm_make_real (((float_f64 *) SCM_UVEC_BASE (uvec))[idx]);
1960}
1961#undef FUNC_NAME
1962
1963
645f5e0e 1964SCM_DEFINE (scm_f64vector_set_x, "f64vector-set!", 3, 0, 0,
71ca65d9
MG		 1965 (SCM uvec, SCM index, SCM value),
1966 "Set the element at @var{index} in the homogeneous numeric\n"
1967 "vector @var{uvec} to @var{value}. The return value is not\n"
1968 "specified.")
1969#define FUNC_NAME s_scm_f64vector_ref
1970{
1971 int idx;
1972 float_f64 f;
1973
1974 SCM_VALIDATE_SMOB (1, uvec, uvec);
1975 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
1976 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
1977
1978 idx = scm_num2int (index, 2, FUNC_NAME);
1979 if (idx < 0 || idx >= SCM_UVEC_LENGTH (uvec))
93ccaef0 1980 scm_out_of_range_pos (FUNC_NAME, index, SCM_I_MAKINUM (2));
71ca65d9
MG		 1981
1982 f = scm_num2dbl (value, FUNC_NAME);
1983
1984 ((float_f64 *) SCM_UVEC_BASE (uvec))[idx] = f;
1985 return SCM_UNSPECIFIED;
1986}
1987#undef FUNC_NAME
1988
1989
645f5e0e 1990SCM_DEFINE (scm_f64vector_to_list, "f64vector->list", 1, 0, 0,
71ca65d9
MG		 1991 (SCM uvec),
1992 "Convert the homogeneous numeric vector @var{uvec} to a list.")
1993#define FUNC_NAME s_scm_f64vector_to_list
1994{
1995 int idx;
1996 float_f64 * p;
1997 SCM res = SCM_EOL;
1998
1999 SCM_VALIDATE_SMOB (1, uvec, uvec);
2000 if (SCM_UVEC_TYPE (uvec) != SCM_UVEC_F64)
2001 scm_wrong_type_arg (FUNC_NAME, 1, uvec);
2002
2003 idx = SCM_UVEC_LENGTH (uvec);
2004 p = (float_f64 *) SCM_UVEC_BASE (uvec) + idx;
2005 while (idx-- > 0)
2006 {
2007 p--;
2008 res = scm_cons (scm_make_real (*p), res);
2009 }
2010 return res;
2011}
2012#undef FUNC_NAME
2013
2014
2015SCM_DEFINE (scm_list_to_f64vector, "list->f64vector", 1, 0, 0,
2016 (SCM l),
2017 "Convert the list @var{l}, which must only contain signed\n"
2018 "8-bit values, to a numeric homogeneous vector.")
2019#define FUNC_NAME s_scm_list_to_f64vector
2020{
2021 SCM uvec;
2022 float_f64 * p;
2023 int n;
2024 int arg_pos = 1;
2025
2026 SCM_VALIDATE_LIST_COPYLEN (1, l, n);
2027
2028 uvec = make_uvec (FUNC_NAME, SCM_UVEC_F64, n);
2029 p = (float_f64 *) SCM_UVEC_BASE (uvec);
2030 while (SCM_CONSP (l))
2031 {
2032 float_f64 f = scm_num2dbl (SCM_CAR (l), FUNC_NAME);
2033 *p++ = f;
2034 l = SCM_CDR (l);
2035 arg_pos++;
2036 }
2037 return uvec;
2038}
2039#undef FUNC_NAME
2040
2041
2c4df451
MG		 2042/* Create the smob type for homogeneous numeric vectors and install
2043 the primitives. */
71ca65d9
MG		 2044void
2045scm_init_srfi_4 (void)
2046{
2047 scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
2048 scm_set_smob_free (scm_tc16_uvec, uvec_free);
2049 scm_set_smob_print (scm_tc16_uvec, uvec_print);
71ca65d9 2050#include "srfi/srfi-4.x"
71ca65d9 2051}
2c4df451
MG		 2052
2053/* End of srfi-4.c. */
Unnamed repository; edit this file 'description' to name the repository.