HCoop / bpt / guile.git / blob
? search:


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