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