HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
Add copyright years.
[bpt/guile.git] / libguile / unif.c
1 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004 Free Software Foundation, Inc.
2 *
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
7 *
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
12 *
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
16 */
17
18
19 /*
20 This file has code for arrays in lots of variants (double, integer,
21 unsigned etc. ). It suffers from hugely repetitive code because
22 there is similar (but different) code for every variant included. (urg.)
23
24 --hwn
25 */
26 \f
27
28 #if HAVE_CONFIG_H
29 # include <config.h>
30 #endif
31
32 #include <stdio.h>
33 #include <errno.h>
34 #include <string.h>
35
36 #include "libguile/_scm.h"
37 #include "libguile/chars.h"
38 #include "libguile/eval.h"
39 #include "libguile/fports.h"
40 #include "libguile/smob.h"
41 #include "libguile/strop.h"
42 #include "libguile/feature.h"
43 #include "libguile/root.h"
44 #include "libguile/strings.h"
45 #include "libguile/vectors.h"
46
47 #include "libguile/validate.h"
48 #include "libguile/unif.h"
49 #include "libguile/ramap.h"
50
51 #ifdef HAVE_UNISTD_H
52 #include <unistd.h>
53 #endif
54
55 #ifdef HAVE_IO_H
56 #include <io.h>
57 #endif
58
59 \f
60 /* The set of uniform scm_vector types is:
61 * Vector of: Called:
62 * unsigned char string
63 * char byvect
64 * boolean bvect
65 * signed long ivect
66 * unsigned long uvect
67 * float fvect
68 * double dvect
69 * complex double cvect
70 * short svect
71 * long long llvect
72 */
73
74 scm_t_bits scm_tc16_array;
75
76 /* return the size of an element in a uniform array or 0 if type not
77 found. */
78 size_t
79 scm_uniform_element_size (SCM obj)
80 {
81 size_t result;
82
83 switch (SCM_TYP7 (obj))
84 {
85 case scm_tc7_bvect:
86 case scm_tc7_uvect:
87 case scm_tc7_ivect:
88 result = sizeof (long);
89 break;
90
91 case scm_tc7_byvect:
92 result = sizeof (char);
93 break;
94
95 case scm_tc7_svect:
96 result = sizeof (short);
97 break;
98
99 #if SCM_SIZEOF_LONG_LONG != 0
100 case scm_tc7_llvect:
101 result = sizeof (long long);
102 break;
103 #endif
104
105 case scm_tc7_fvect:
106 result = sizeof (float);
107 break;
108
109 case scm_tc7_dvect:
110 result = sizeof (double);
111 break;
112
113 case scm_tc7_cvect:
114 result = 2 * sizeof (double);
115 break;
116
117 default:
118 result = 0;
119 }
120 return result;
121 }
122
123 /* Silly function used not to modify the semantics of the silly
124 * prototype system in order to be backward compatible.
125 */
126 static int
127 singp (SCM obj)
128 {
129 if (!SCM_REALP (obj))
130 return 0;
131 else
132 {
133 double x = SCM_REAL_VALUE (obj);
134 float fx = x;
135 return (- SCM_FLTMAX < x) && (x < SCM_FLTMAX) && (fx == x);
136 }
137 }
138
139 SCM
140 scm_make_uve (long k, SCM prot)
141 #define FUNC_NAME "scm_make_uve"
142 {
143 SCM v;
144 long i, type;
145
146 if (SCM_EQ_P (prot, SCM_BOOL_T))
147 {
148 if (k > 0)
149 {
150 SCM_ASSERT_RANGE (1,
151 scm_long2num (k), k <= SCM_BITVECTOR_MAX_LENGTH);
152 i = sizeof (long) * ((k + SCM_LONG_BIT - 1) / SCM_LONG_BIT);
153 v = scm_cell (SCM_MAKE_BITVECTOR_TAG (k),
154 (scm_t_bits) scm_gc_malloc (i, "vector"));
155 }
156 else
157 v = scm_cell (SCM_MAKE_BITVECTOR_TAG (0), 0);
158 return v;
159 }
160 else if (SCM_CHARP (prot) && (SCM_CHAR (prot) == '\0'))
161 {
162 i = sizeof (char) * k;
163 type = scm_tc7_byvect;
164 }
165 else if (SCM_CHARP (prot))
166 {
167 i = sizeof (char) * k;
168 return scm_allocate_string (i);
169 }
170 else if (SCM_INUMP (prot))
171 {
172 i = sizeof (long) * k;
173 if (SCM_INUM (prot) > 0)
174 type = scm_tc7_uvect;
175 else
176 type = scm_tc7_ivect;
177 }
178 else if (SCM_SYMBOLP (prot) && (1 == SCM_SYMBOL_LENGTH (prot)))
179 {
180 char s;
181
182 s = SCM_SYMBOL_CHARS (prot)[0];
183 if (s == 's')
184 {
185 i = sizeof (short) * k;
186 type = scm_tc7_svect;
187 }
188 #if SCM_SIZEOF_LONG_LONG != 0
189 else if (s == 'l')
190 {
191 i = sizeof (long long) * k;
192 type = scm_tc7_llvect;
193 }
194 #endif
195 else
196 {
197 return scm_c_make_vector (k, SCM_UNDEFINED);
198 }
199 }
200 else if (!SCM_INEXACTP (prot))
201 /* Huge non-unif vectors are NOT supported. */
202 /* no special scm_vector */
203 return scm_c_make_vector (k, SCM_UNDEFINED);
204 else if (singp (prot))
205 {
206 i = sizeof (float) * k;
207 type = scm_tc7_fvect;
208 }
209 else if (SCM_COMPLEXP (prot))
210 {
211 i = 2 * sizeof (double) * k;
212 type = scm_tc7_cvect;
213 }
214 else
215 {
216 i = sizeof (double) * k;
217 type = scm_tc7_dvect;
218 }
219
220 SCM_ASSERT_RANGE (1, scm_long2num (k), k <= SCM_UVECTOR_MAX_LENGTH);
221
222 return scm_cell (SCM_MAKE_UVECTOR_TAG (k, type),
223 (scm_t_bits) scm_gc_malloc (i, "vector"));
224 }
225 #undef FUNC_NAME
226
227
228 SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
229 (SCM v),
230 "Return the number of elements in @var{uve}.")
231 #define FUNC_NAME s_scm_uniform_vector_length
232 {
233 SCM_ASRTGO (SCM_NIMP (v), badarg1);
234 switch SCM_TYP7 (v)
235 {
236 default:
237 badarg1:SCM_WRONG_TYPE_ARG (1, v);
238 case scm_tc7_vector:
239 case scm_tc7_wvect:
240 return SCM_MAKINUM (SCM_VECTOR_LENGTH (v));
241 case scm_tc7_string:
242 return SCM_MAKINUM (SCM_STRING_LENGTH (v));
243 case scm_tc7_bvect:
244 return SCM_MAKINUM (SCM_BITVECTOR_LENGTH (v));
245 case scm_tc7_byvect:
246 case scm_tc7_uvect:
247 case scm_tc7_ivect:
248 case scm_tc7_fvect:
249 case scm_tc7_dvect:
250 case scm_tc7_cvect:
251 case scm_tc7_svect:
252 #if SCM_SIZEOF_LONG_LONG != 0
253 case scm_tc7_llvect:
254 #endif
255 return SCM_MAKINUM (SCM_UVECTOR_LENGTH (v));
256 }
257 }
258 #undef FUNC_NAME
259
260 SCM_DEFINE (scm_array_p, "array?", 1, 1, 0,
261 (SCM v, SCM prot),
262 "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
263 "not. The @var{prototype} argument is used with uniform arrays\n"
264 "and is described elsewhere.")
265 #define FUNC_NAME s_scm_array_p
266 {
267 int nprot;
268 int enclosed;
269 nprot = SCM_UNBNDP (prot);
270 enclosed = 0;
271 if (SCM_IMP (v))
272 return SCM_BOOL_F;
273
274 while (SCM_TYP7 (v) == scm_tc7_smob)
275 {
276 if (!SCM_ARRAYP (v))
277 return SCM_BOOL_F;
278 if (nprot)
279 return SCM_BOOL_T;
280 if (enclosed++)
281 return SCM_BOOL_F;
282 v = SCM_ARRAY_V (v);
283 }
284 if (nprot)
285 return SCM_BOOL(nprot);
286 else
287 {
288 int protp = 0;
289
290 switch (SCM_TYP7 (v))
291 {
292 case scm_tc7_bvect:
293 protp = (SCM_EQ_P (prot, SCM_BOOL_T));
294 case scm_tc7_string:
295 protp = SCM_CHARP(prot) && (SCM_CHAR (prot) != '\0');
296 case scm_tc7_byvect:
297 protp = SCM_EQ_P (prot, SCM_MAKE_CHAR ('\0'));
298 case scm_tc7_uvect:
299 protp = SCM_INUMP(prot) && SCM_INUM(prot)>0;
300 case scm_tc7_ivect:
301 protp = SCM_INUMP(prot) && SCM_INUM(prot)<=0;
302
303 case scm_tc7_svect:
304 protp = SCM_SYMBOLP (prot)
305 && (1 == SCM_SYMBOL_LENGTH (prot))
306 && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
307 #if SCM_SIZEOF_LONG_LONG != 0
308 case scm_tc7_llvect:
309 protp = SCM_SYMBOLP (prot)
310 && (1 == SCM_SYMBOL_LENGTH (prot))
311 && ('s' == SCM_SYMBOL_CHARS (prot)[0]);
312 #endif
313 case scm_tc7_fvect:
314 protp = singp (prot);
315 case scm_tc7_dvect:
316 protp = SCM_REALP(prot);
317 case scm_tc7_cvect:
318 protp = SCM_COMPLEXP(prot);
319 case scm_tc7_vector:
320 case scm_tc7_wvect:
321 protp = SCM_NULLP(prot);
322 default:
323 /* no default */
324 ;
325 }
326 return SCM_BOOL(protp);
327 }
328 }
329 #undef FUNC_NAME
330
331
332 SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
333 (SCM ra),
334 "Return the number of dimensions of @var{obj}. If @var{obj} is\n"
335 "not an array, @code{0} is returned.")
336 #define FUNC_NAME s_scm_array_rank
337 {
338 if (SCM_IMP (ra))
339 return SCM_INUM0;
340 switch (SCM_TYP7 (ra))
341 {
342 default:
343 return SCM_INUM0;
344 case scm_tc7_string:
345 case scm_tc7_vector:
346 case scm_tc7_wvect:
347 case scm_tc7_byvect:
348 case scm_tc7_uvect:
349 case scm_tc7_ivect:
350 case scm_tc7_fvect:
351 case scm_tc7_cvect:
352 case scm_tc7_dvect:
353 #if SCM_SIZEOF_LONG_LONG != 0
354 case scm_tc7_llvect:
355 #endif
356 case scm_tc7_svect:
357 return SCM_MAKINUM (1L);
358 case scm_tc7_smob:
359 if (SCM_ARRAYP (ra))
360 return SCM_MAKINUM (SCM_ARRAY_NDIM (ra));
361 return SCM_INUM0;
362 }
363 }
364 #undef FUNC_NAME
365
366
367 SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
368 (SCM ra),
369 "@code{Array-dimensions} is similar to @code{array-shape} but replaces\n"
370 "elements with a @code{0} minimum with one greater than the maximum. So:\n"
371 "@lisp\n"
372 "(array-dimensions (make-array 'foo '(-1 3) 5)) @result{} ((-1 3) 5)\n"
373 "@end lisp")
374 #define FUNC_NAME s_scm_array_dimensions
375 {
376 SCM res = SCM_EOL;
377 size_t k;
378 scm_t_array_dim *s;
379 if (SCM_IMP (ra))
380 return SCM_BOOL_F;
381 switch (SCM_TYP7 (ra))
382 {
383 default:
384 return SCM_BOOL_F;
385 case scm_tc7_string:
386 case scm_tc7_vector:
387 case scm_tc7_wvect:
388 case scm_tc7_bvect:
389 case scm_tc7_byvect:
390 case scm_tc7_uvect:
391 case scm_tc7_ivect:
392 case scm_tc7_fvect:
393 case scm_tc7_cvect:
394 case scm_tc7_dvect:
395 case scm_tc7_svect:
396 #if SCM_SIZEOF_LONG_LONG != 0
397 case scm_tc7_llvect:
398 #endif
399 return scm_cons (scm_uniform_vector_length (ra), SCM_EOL);
400 case scm_tc7_smob:
401 if (!SCM_ARRAYP (ra))
402 return SCM_BOOL_F;
403 k = SCM_ARRAY_NDIM (ra);
404 s = SCM_ARRAY_DIMS (ra);
405 while (k--)
406 res = scm_cons (s[k].lbnd
407 ? scm_cons2 (SCM_MAKINUM (s[k].lbnd),
408 SCM_MAKINUM (s[k].ubnd),
409 SCM_EOL)
410 : SCM_MAKINUM (1 + s[k].ubnd),
411 res);
412 return res;
413 }
414 }
415 #undef FUNC_NAME
416
417
418 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
419 (SCM ra),
420 "Return the root vector of a shared array.")
421 #define FUNC_NAME s_scm_shared_array_root
422 {
423 SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
424 return SCM_ARRAY_V (ra);
425 }
426 #undef FUNC_NAME
427
428
429 SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
430 (SCM ra),
431 "Return the root vector index of the first element in the array.")
432 #define FUNC_NAME s_scm_shared_array_offset
433 {
434 SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
435 return SCM_MAKINUM (SCM_ARRAY_BASE (ra));
436 }
437 #undef FUNC_NAME
438
439
440 SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
441 (SCM ra),
442 "For each dimension, return the distance between elements in the root vector.")
443 #define FUNC_NAME s_scm_shared_array_increments
444 {
445 SCM res = SCM_EOL;
446 size_t k;
447 scm_t_array_dim *s;
448 SCM_ASSERT (SCM_ARRAYP (ra), ra, SCM_ARG1, FUNC_NAME);
449 k = SCM_ARRAY_NDIM (ra);
450 s = SCM_ARRAY_DIMS (ra);
451 while (k--)
452 res = scm_cons (SCM_MAKINUM (s[k].inc), res);
453 return res;
454 }
455 #undef FUNC_NAME
456
457
458 static char s_bad_ind[] = "Bad scm_array index";
459
460
461 long
462 scm_aind (SCM ra, SCM args, const char *what)
463 #define FUNC_NAME what
464 {
465 SCM ind;
466 register long j;
467 register unsigned long pos = SCM_ARRAY_BASE (ra);
468 register unsigned long k = SCM_ARRAY_NDIM (ra);
469 scm_t_array_dim *s = SCM_ARRAY_DIMS (ra);
470 if (SCM_INUMP (args))
471 {
472 if (k != 1)
473 scm_error_num_args_subr (what);
474 return pos + (SCM_INUM (args) - s->lbnd) * (s->inc);
475 }
476 while (k && SCM_CONSP (args))
477 {
478 ind = SCM_CAR (args);
479 args = SCM_CDR (args);
480 if (!SCM_INUMP (ind))
481 scm_misc_error (what, s_bad_ind, SCM_EOL);
482 j = SCM_INUM (ind);
483 if (j < s->lbnd || j > s->ubnd)
484 scm_out_of_range (what, ind);
485 pos += (j - s->lbnd) * (s->inc);
486 k--;
487 s++;
488 }
489 if (k != 0 || !SCM_NULLP (args))
490 scm_error_num_args_subr (what);
491
492 return pos;
493 }
494 #undef FUNC_NAME
495
496
497 SCM
498 scm_make_ra (int ndim)
499 {
500 SCM ra;
501 SCM_DEFER_INTS;
502 SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_tc16_array,
503 scm_gc_malloc ((sizeof (scm_t_array) +
504 ndim * sizeof (scm_t_array_dim)),
505 "array"));
506 SCM_ARRAY_V (ra) = scm_nullvect;
507 SCM_ALLOW_INTS;
508 return ra;
509 }
510
511 static char s_bad_spec[] = "Bad scm_array dimension";
512 /* Increments will still need to be set. */
513
514
515 SCM
516 scm_shap2ra (SCM args, const char *what)
517 {
518 scm_t_array_dim *s;
519 SCM ra, spec, sp;
520 int ndim = scm_ilength (args);
521 if (ndim < 0)
522 scm_misc_error (what, s_bad_spec, SCM_EOL);
523
524 ra = scm_make_ra (ndim);
525 SCM_ARRAY_BASE (ra) = 0;
526 s = SCM_ARRAY_DIMS (ra);
527 for (; !SCM_NULLP (args); s++, args = SCM_CDR (args))
528 {
529 spec = SCM_CAR (args);
530 if (SCM_INUMP (spec))
531 {
532 if (SCM_INUM (spec) < 0)
533 scm_misc_error (what, s_bad_spec, SCM_EOL);
534 s->lbnd = 0;
535 s->ubnd = SCM_INUM (spec) - 1;
536 s->inc = 1;
537 }
538 else
539 {
540 if (!SCM_CONSP (spec) || !SCM_INUMP (SCM_CAR (spec)))
541 scm_misc_error (what, s_bad_spec, SCM_EOL);
542 s->lbnd = SCM_INUM (SCM_CAR (spec));
543 sp = SCM_CDR (spec);
544 if (!SCM_CONSP (sp)
545 || !SCM_INUMP (SCM_CAR (sp))
546 || !SCM_NULLP (SCM_CDR (sp)))
547 scm_misc_error (what, s_bad_spec, SCM_EOL);
548 s->ubnd = SCM_INUM (SCM_CAR (sp));
549 s->inc = 1;
550 }
551 }
552 return ra;
553 }
554
555 SCM_DEFINE (scm_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 1, 0,
556 (SCM dims, SCM prot, SCM fill),
557 "@deffnx {Scheme Procedure} make-uniform-vector length prototype [fill]\n"
558 "Create and return a uniform array or vector of type\n"
559 "corresponding to @var{prototype} with dimensions @var{dims} or\n"
560 "length @var{length}. If @var{fill} is supplied, it's used to\n"
561 "fill the array, otherwise @var{prototype} is used.")
562 #define FUNC_NAME s_scm_dimensions_to_uniform_array
563 {
564 size_t k;
565 unsigned long rlen = 1;
566 scm_t_array_dim *s;
567 SCM ra;
568
569 if (SCM_INUMP (dims))
570 {
571 SCM answer = scm_make_uve (SCM_INUM (dims), prot);
572 if (!SCM_UNBNDP (fill))
573 scm_array_fill_x (answer, fill);
574 else if (SCM_SYMBOLP (prot))
575 scm_array_fill_x (answer, SCM_MAKINUM (0));
576 else
577 scm_array_fill_x (answer, prot);
578 return answer;
579 }
580
581 SCM_ASSERT (SCM_NULLP (dims) || SCM_CONSP (dims),
582 dims, SCM_ARG1, FUNC_NAME);
583 ra = scm_shap2ra (dims, FUNC_NAME);
584 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
585 s = SCM_ARRAY_DIMS (ra);
586 k = SCM_ARRAY_NDIM (ra);
587
588 while (k--)
589 {
590 s[k].inc = rlen;
591 SCM_ASSERT_RANGE (1, dims, s[k].lbnd <= s[k].ubnd);
592 rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
593 }
594
595 SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
596
597 if (!SCM_UNBNDP (fill))
598 scm_array_fill_x (ra, fill);
599 else if (SCM_SYMBOLP (prot))
600 scm_array_fill_x (ra, SCM_MAKINUM (0));
601 else
602 scm_array_fill_x (ra, prot);
603
604 if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
605 if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
606 return SCM_ARRAY_V (ra);
607 return ra;
608 }
609 #undef FUNC_NAME
610
611
612 void
613 scm_ra_set_contp (SCM ra)
614 {
615 size_t k = SCM_ARRAY_NDIM (ra);
616 if (k)
617 {
618 long inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
619 while (k--)
620 {
621 if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
622 {
623 SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
624 return;
625 }
626 inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd
627 - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
628 }
629 }
630 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
631 }
632
633
634 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
635 (SCM oldra, SCM mapfunc, SCM dims),
636 "@code{make-shared-array} can be used to create shared subarrays of other\n"
637 "arrays. The @var{mapper} is a function that translates coordinates in\n"
638 "the new array into coordinates in the old array. A @var{mapper} must be\n"
639 "linear, and its range must stay within the bounds of the old array, but\n"
640 "it can be otherwise arbitrary. A simple example:\n"
641 "@lisp\n"
642 "(define fred (make-array #f 8 8))\n"
643 "(define freds-diagonal\n"
644 " (make-shared-array fred (lambda (i) (list i i)) 8))\n"
645 "(array-set! freds-diagonal 'foo 3)\n"
646 "(array-ref fred 3 3) @result{} foo\n"
647 "(define freds-center\n"
648 " (make-shared-array fred (lambda (i j) (list (+ 3 i) (+ 3 j))) 2 2))\n"
649 "(array-ref freds-center 0 0) @result{} foo\n"
650 "@end lisp")
651 #define FUNC_NAME s_scm_make_shared_array
652 {
653 SCM ra;
654 SCM inds, indptr;
655 SCM imap;
656 size_t k, i;
657 long old_min, new_min, old_max, new_max;
658 scm_t_array_dim *s;
659
660 SCM_VALIDATE_REST_ARGUMENT (dims);
661 SCM_VALIDATE_ARRAY (1, oldra);
662 SCM_VALIDATE_PROC (2, mapfunc);
663 ra = scm_shap2ra (dims, FUNC_NAME);
664 if (SCM_ARRAYP (oldra))
665 {
666 SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
667 old_min = old_max = SCM_ARRAY_BASE (oldra);
668 s = SCM_ARRAY_DIMS (oldra);
669 k = SCM_ARRAY_NDIM (oldra);
670 while (k--)
671 {
672 if (s[k].inc > 0)
673 old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
674 else
675 old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
676 }
677 }
678 else
679 {
680 SCM_ARRAY_V (ra) = oldra;
681 old_min = 0;
682 old_max = SCM_INUM (scm_uniform_vector_length (oldra)) - 1;
683 }
684 inds = SCM_EOL;
685 s = SCM_ARRAY_DIMS (ra);
686 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
687 {
688 inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds);
689 if (s[k].ubnd < s[k].lbnd)
690 {
691 if (1 == SCM_ARRAY_NDIM (ra))
692 ra = scm_make_uve (0L, scm_array_prototype (ra));
693 else
694 SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra));
695 return ra;
696 }
697 }
698 imap = scm_apply_0 (mapfunc, scm_reverse (inds));
699 if (SCM_ARRAYP (oldra))
700 i = (size_t) scm_aind (oldra, imap, FUNC_NAME);
701 else
702 {
703 if (SCM_NINUMP (imap))
704
705 {
706 if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap)))
707 SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
708 imap = SCM_CAR (imap);
709 }
710 i = SCM_INUM (imap);
711 }
712 SCM_ARRAY_BASE (ra) = new_min = new_max = i;
713 indptr = inds;
714 k = SCM_ARRAY_NDIM (ra);
715 while (k--)
716 {
717 if (s[k].ubnd > s[k].lbnd)
718 {
719 SCM_SETCAR (indptr, SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1));
720 imap = scm_apply_0 (mapfunc, scm_reverse (inds));
721 if (SCM_ARRAYP (oldra))
722
723 s[k].inc = scm_aind (oldra, imap, FUNC_NAME) - i;
724 else
725 {
726 if (SCM_NINUMP (imap))
727 {
728 if (scm_ilength (imap) != 1 || !SCM_INUMP (SCM_CAR (imap)))
729 SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
730 imap = SCM_CAR (imap);
731 }
732 s[k].inc = (long) SCM_INUM (imap) - i;
733 }
734 i += s[k].inc;
735 if (s[k].inc > 0)
736 new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
737 else
738 new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
739 }
740 else
741 s[k].inc = new_max - new_min + 1; /* contiguous by default */
742 indptr = SCM_CDR (indptr);
743 }
744 if (old_min > new_min || old_max < new_max)
745 SCM_MISC_ERROR ("mapping out of range", SCM_EOL);
746 if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
747 {
748 SCM v = SCM_ARRAY_V (ra);
749 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
750 if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
751 return v;
752 if (s->ubnd < s->lbnd)
753 return scm_make_uve (0L, scm_array_prototype (ra));
754 }
755 scm_ra_set_contp (ra);
756 return ra;
757 }
758 #undef FUNC_NAME
759
760
761 /* args are RA . DIMS */
762 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
763 (SCM ra, SCM args),
764 "Return an array sharing contents with @var{array}, but with\n"
765 "dimensions arranged in a different order. There must be one\n"
766 "@var{dim} argument for each dimension of @var{array}.\n"
767 "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
768 "and the rank of the array to be returned. Each integer in that\n"
769 "range must appear at least once in the argument list.\n"
770 "\n"
771 "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
772 "dimensions in the array to be returned, their positions in the\n"
773 "argument list to dimensions of @var{array}. Several @var{dim}s\n"
774 "may have the same value, in which case the returned array will\n"
775 "have smaller rank than @var{array}.\n"
776 "\n"
777 "@lisp\n"
778 "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
779 "(transpose-array '#2((a b) (c d)) 0 0) @result{} #1(a d)\n"
780 "(transpose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 1 0) @result{}\n"
781 " #2((a 4) (b 5) (c 6))\n"
782 "@end lisp")
783 #define FUNC_NAME s_scm_transpose_array
784 {
785 SCM res, vargs;
786 SCM const *ve = &vargs;
787 scm_t_array_dim *s, *r;
788 int ndim, i, k;
789
790 SCM_VALIDATE_REST_ARGUMENT (args);
791 SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
792 switch (SCM_TYP7 (ra))
793 {
794 default:
795 badarg:SCM_WRONG_TYPE_ARG (1, ra);
796 case scm_tc7_bvect:
797 case scm_tc7_string:
798 case scm_tc7_byvect:
799 case scm_tc7_uvect:
800 case scm_tc7_ivect:
801 case scm_tc7_fvect:
802 case scm_tc7_dvect:
803 case scm_tc7_cvect:
804 case scm_tc7_svect:
805 #if SCM_SIZEOF_LONG_LONG != 0
806 case scm_tc7_llvect:
807 #endif
808 if (SCM_NULLP (args) || !SCM_NULLP (SCM_CDR (args)))
809 SCM_WRONG_NUM_ARGS ();
810 SCM_VALIDATE_INUM (SCM_ARG2, SCM_CAR (args));
811 SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args),
812 SCM_EQ_P (SCM_INUM0, SCM_CAR (args)));
813 return ra;
814 case scm_tc7_smob:
815 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
816 vargs = scm_vector (args);
817 if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
818 SCM_WRONG_NUM_ARGS ();
819 ve = SCM_VELTS (vargs);
820 ndim = 0;
821 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
822 {
823 SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
824 FUNC_NAME);
825 i = SCM_INUM (ve[k]);
826 if (i < 0 || i >= SCM_ARRAY_NDIM (ra))
827 scm_out_of_range (FUNC_NAME, ve[k]);
828 if (ndim < i)
829 ndim = i;
830 }
831 ndim++;
832 res = scm_make_ra (ndim);
833 SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
834 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
835 for (k = ndim; k--;)
836 {
837 SCM_ARRAY_DIMS (res)[k].lbnd = 0;
838 SCM_ARRAY_DIMS (res)[k].ubnd = -1;
839 }
840 for (k = SCM_ARRAY_NDIM (ra); k--;)
841 {
842 i = SCM_INUM (ve[k]);
843 s = &(SCM_ARRAY_DIMS (ra)[k]);
844 r = &(SCM_ARRAY_DIMS (res)[i]);
845 if (r->ubnd < r->lbnd)
846 {
847 r->lbnd = s->lbnd;
848 r->ubnd = s->ubnd;
849 r->inc = s->inc;
850 ndim--;
851 }
852 else
853 {
854 if (r->ubnd > s->ubnd)
855 r->ubnd = s->ubnd;
856 if (r->lbnd < s->lbnd)
857 {
858 SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
859 r->lbnd = s->lbnd;
860 }
861 r->inc += s->inc;
862 }
863 }
864 if (ndim > 0)
865 SCM_MISC_ERROR ("bad argument list", SCM_EOL);
866 scm_ra_set_contp (res);
867 return res;
868 }
869 }
870 #undef FUNC_NAME
871
872 /* args are RA . AXES */
873 SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
874 (SCM ra, SCM axes),
875 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
876 "the rank of @var{array}. @var{enclose-array} returns an array\n"
877 "resembling an array of shared arrays. The dimensions of each shared\n"
878 "array are the same as the @var{dim}th dimensions of the original array,\n"
879 "the dimensions of the outer array are the same as those of the original\n"
880 "array that did not match a @var{dim}.\n\n"
881 "An enclosed array is not a general Scheme array. Its elements may not\n"
882 "be set using @code{array-set!}. Two references to the same element of\n"
883 "an enclosed array will be @code{equal?} but will not in general be\n"
884 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
885 "enclosed array is unspecified.\n\n"
886 "examples:\n"
887 "@lisp\n"
888 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
889 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
890 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
891 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
892 "@end lisp")
893 #define FUNC_NAME s_scm_enclose_array
894 {
895 SCM axv, res, ra_inr;
896 scm_t_array_dim vdim, *s = &vdim;
897 int ndim, j, k, ninr, noutr;
898
899 SCM_VALIDATE_REST_ARGUMENT (axes);
900 if (SCM_NULLP (axes))
901 axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
902 ninr = scm_ilength (axes);
903 if (ninr < 0)
904 SCM_WRONG_NUM_ARGS ();
905 ra_inr = scm_make_ra (ninr);
906 SCM_ASRTGO (SCM_NIMP (ra), badarg1);
907 switch SCM_TYP7 (ra)
908 {
909 default:
910 badarg1:SCM_WRONG_TYPE_ARG (1, ra);
911 case scm_tc7_string:
912 case scm_tc7_bvect:
913 case scm_tc7_byvect:
914 case scm_tc7_uvect:
915 case scm_tc7_ivect:
916 case scm_tc7_fvect:
917 case scm_tc7_dvect:
918 case scm_tc7_cvect:
919 case scm_tc7_vector:
920 case scm_tc7_wvect:
921 case scm_tc7_svect:
922 #if SCM_SIZEOF_LONG_LONG != 0
923 case scm_tc7_llvect:
924 #endif
925 s->lbnd = 0;
926 s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1;
927 s->inc = 1;
928 SCM_ARRAY_V (ra_inr) = ra;
929 SCM_ARRAY_BASE (ra_inr) = 0;
930 ndim = 1;
931 break;
932 case scm_tc7_smob:
933 SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
934 s = SCM_ARRAY_DIMS (ra);
935 SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
936 SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
937 ndim = SCM_ARRAY_NDIM (ra);
938 break;
939 }
940 noutr = ndim - ninr;
941 if (noutr < 0)
942 SCM_WRONG_NUM_ARGS ();
943 axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKE_CHAR (0));
944 res = scm_make_ra (noutr);
945 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
946 SCM_ARRAY_V (res) = ra_inr;
947 for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
948 {
949 if (!SCM_INUMP (SCM_CAR (axes)))
950 SCM_MISC_ERROR ("bad axis", SCM_EOL);
951 j = SCM_INUM (SCM_CAR (axes));
952 SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
953 SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
954 SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
955 SCM_STRING_CHARS (axv)[j] = 1;
956 }
957 for (j = 0, k = 0; k < noutr; k++, j++)
958 {
959 while (SCM_STRING_CHARS (axv)[j])
960 j++;
961 SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
962 SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
963 SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
964 }
965 scm_ra_set_contp (ra_inr);
966 scm_ra_set_contp (res);
967 return res;
968 }
969 #undef FUNC_NAME
970
971
972
973 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
974 (SCM v, SCM args),
975 "Return @code{#t} if its arguments would be acceptable to\n"
976 "@code{array-ref}.")
977 #define FUNC_NAME s_scm_array_in_bounds_p
978 {
979 SCM ind = SCM_EOL;
980 long pos = 0;
981 register size_t k;
982 register long j;
983 scm_t_array_dim *s;
984
985 SCM_VALIDATE_REST_ARGUMENT (args);
986 SCM_ASRTGO (SCM_NIMP (v), badarg1);
987 if (SCM_NIMP (args))
988
989 {
990 ind = SCM_CAR (args);
991 args = SCM_CDR (args);
992 SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME);
993 pos = SCM_INUM (ind);
994 }
995 tail:
996 switch SCM_TYP7 (v)
997 {
998 default:
999 badarg1:SCM_WRONG_TYPE_ARG (1, v);
1000 wna: SCM_WRONG_NUM_ARGS ();
1001 case scm_tc7_smob:
1002 k = SCM_ARRAY_NDIM (v);
1003 s = SCM_ARRAY_DIMS (v);
1004 pos = SCM_ARRAY_BASE (v);
1005 if (!k)
1006 {
1007 SCM_ASRTGO (SCM_NULLP (ind), wna);
1008 ind = SCM_INUM0;
1009 }
1010 else
1011 while (!0)
1012 {
1013 j = SCM_INUM (ind);
1014 if (!(j >= (s->lbnd) && j <= (s->ubnd)))
1015 {
1016 SCM_ASRTGO (--k == scm_ilength (args), wna);
1017 return SCM_BOOL_F;
1018 }
1019 pos += (j - s->lbnd) * (s->inc);
1020 if (!(--k && SCM_NIMP (args)))
1021 break;
1022 ind = SCM_CAR (args);
1023 args = SCM_CDR (args);
1024 s++;
1025 if (!SCM_INUMP (ind))
1026 SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
1027 }
1028 SCM_ASRTGO (0 == k, wna);
1029 v = SCM_ARRAY_V (v);
1030 goto tail;
1031 case scm_tc7_bvect:
1032 case scm_tc7_string:
1033 case scm_tc7_byvect:
1034 case scm_tc7_uvect:
1035 case scm_tc7_ivect:
1036 case scm_tc7_fvect:
1037 case scm_tc7_dvect:
1038 case scm_tc7_cvect:
1039 case scm_tc7_svect:
1040 #if SCM_SIZEOF_LONG_LONG != 0
1041 case scm_tc7_llvect:
1042 #endif
1043 case scm_tc7_vector:
1044 case scm_tc7_wvect:
1045 {
1046 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
1047 SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
1048 return SCM_BOOL(pos >= 0 && pos < length);
1049 }
1050 }
1051 }
1052 #undef FUNC_NAME
1053
1054
1055 SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
1056
1057
1058 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
1059 (SCM v, SCM args),
1060 "@deffnx {Scheme Procedure} array-ref v . args\n"
1061 "Return the element at the @code{(index1, index2)} element in\n"
1062 "@var{array}.")
1063 #define FUNC_NAME s_scm_uniform_vector_ref
1064 {
1065 long pos;
1066
1067 if (SCM_IMP (v))
1068 {
1069 SCM_ASRTGO (SCM_NULLP (args), badarg);
1070 return v;
1071 }
1072 else if (SCM_ARRAYP (v))
1073 {
1074 pos = scm_aind (v, args, FUNC_NAME);
1075 v = SCM_ARRAY_V (v);
1076 }
1077 else
1078 {
1079 unsigned long int length;
1080 if (SCM_NIMP (args))
1081 {
1082 SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
1083 pos = SCM_INUM (SCM_CAR (args));
1084 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1085 }
1086 else
1087 {
1088 SCM_VALIDATE_INUM (2, args);
1089 pos = SCM_INUM (args);
1090 }
1091 length = SCM_INUM (scm_uniform_vector_length (v));
1092 SCM_ASRTGO (pos >= 0 && pos < length, outrng);
1093 }
1094 switch SCM_TYP7 (v)
1095 {
1096 default:
1097 if (SCM_NULLP (args))
1098 return v;
1099 badarg:
1100 SCM_WRONG_TYPE_ARG (1, v);
1101 /* not reached */
1102
1103 outrng:
1104 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
1105 wna:
1106 SCM_WRONG_NUM_ARGS ();
1107 case scm_tc7_smob:
1108 { /* enclosed */
1109 int k = SCM_ARRAY_NDIM (v);
1110 SCM res = scm_make_ra (k);
1111 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1112 SCM_ARRAY_BASE (res) = pos;
1113 while (k--)
1114 {
1115 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1116 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1117 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1118 }
1119 return res;
1120 }
1121 case scm_tc7_bvect:
1122 if (SCM_BITVEC_REF (v, pos))
1123 return SCM_BOOL_T;
1124 else
1125 return SCM_BOOL_F;
1126 case scm_tc7_string:
1127 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
1128 case scm_tc7_byvect:
1129 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
1130 case scm_tc7_uvect:
1131 return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]);
1132 case scm_tc7_ivect:
1133 return scm_long2num (((signed long *) SCM_VELTS (v))[pos]);
1134
1135 case scm_tc7_svect:
1136 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
1137 #if SCM_SIZEOF_LONG_LONG != 0
1138 case scm_tc7_llvect:
1139 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
1140 #endif
1141
1142 case scm_tc7_fvect:
1143 return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
1144 case scm_tc7_dvect:
1145 return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
1146 case scm_tc7_cvect:
1147 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
1148 ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
1149 case scm_tc7_vector:
1150 case scm_tc7_wvect:
1151 return SCM_VELTS (v)[pos];
1152 }
1153 }
1154 #undef FUNC_NAME
1155
1156 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1157 tries to recycle conses. (Make *sure* you want them recycled.) */
1158
1159 SCM
1160 scm_cvref (SCM v, unsigned long pos, SCM last)
1161 #define FUNC_NAME "scm_cvref"
1162 {
1163 switch SCM_TYP7 (v)
1164 {
1165 default:
1166 SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1167 case scm_tc7_bvect:
1168 if (SCM_BITVEC_REF(v, pos))
1169 return SCM_BOOL_T;
1170 else
1171 return SCM_BOOL_F;
1172 case scm_tc7_string:
1173 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
1174 case scm_tc7_byvect:
1175 return SCM_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
1176 case scm_tc7_uvect:
1177 return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]);
1178 case scm_tc7_ivect:
1179 return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
1180 case scm_tc7_svect:
1181 return SCM_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
1182 #if SCM_SIZEOF_LONG_LONG != 0
1183 case scm_tc7_llvect:
1184 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
1185 #endif
1186 case scm_tc7_fvect:
1187 if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
1188 {
1189 SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
1190 return last;
1191 }
1192 return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
1193 case scm_tc7_dvect:
1194 if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
1195 {
1196 SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
1197 return last;
1198 }
1199 return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
1200 case scm_tc7_cvect:
1201 if (SCM_COMPLEXP (last))
1202 {
1203 SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
1204 SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
1205 return last;
1206 }
1207 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
1208 ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
1209 case scm_tc7_vector:
1210 case scm_tc7_wvect:
1211 return SCM_VELTS (v)[pos];
1212 case scm_tc7_smob:
1213 { /* enclosed scm_array */
1214 int k = SCM_ARRAY_NDIM (v);
1215 SCM res = scm_make_ra (k);
1216 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1217 SCM_ARRAY_BASE (res) = pos;
1218 while (k--)
1219 {
1220 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1221 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1222 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1223 }
1224 return res;
1225 }
1226 }
1227 }
1228 #undef FUNC_NAME
1229
1230
1231 SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
1232
1233
1234 /* Note that args may be a list or an immediate object, depending which
1235 PROC is used (and it's called from C too). */
1236 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
1237 (SCM v, SCM obj, SCM args),
1238 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1239 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1240 "@var{new-value}. The value returned by array-set! is unspecified.")
1241 #define FUNC_NAME s_scm_array_set_x
1242 {
1243 long pos = 0;
1244
1245 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1246 if (SCM_ARRAYP (v))
1247 {
1248 pos = scm_aind (v, args, FUNC_NAME);
1249 v = SCM_ARRAY_V (v);
1250 }
1251 else
1252 {
1253 unsigned long int length;
1254 if (SCM_CONSP (args))
1255 {
1256 SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG3, FUNC_NAME);
1257 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1258 pos = SCM_INUM (SCM_CAR (args));
1259 }
1260 else
1261 {
1262 SCM_VALIDATE_INUM_COPY (3, args, pos);
1263 }
1264 length = SCM_INUM (scm_uniform_vector_length (v));
1265 SCM_ASRTGO (pos >= 0 && pos < length, outrng);
1266 }
1267 switch (SCM_TYP7 (v))
1268 {
1269 default: badarg1:
1270 SCM_WRONG_TYPE_ARG (1, v);
1271 /* not reached */
1272 outrng:
1273 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
1274 wna:
1275 SCM_WRONG_NUM_ARGS ();
1276 case scm_tc7_smob: /* enclosed */
1277 goto badarg1;
1278 case scm_tc7_bvect:
1279 if (SCM_FALSEP (obj))
1280 SCM_BITVEC_CLR(v, pos);
1281 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1282 SCM_BITVEC_SET(v, pos);
1283 else
1284 badobj:SCM_WRONG_TYPE_ARG (2, obj);
1285 break;
1286 case scm_tc7_string:
1287 SCM_ASRTGO (SCM_CHARP (obj), badobj);
1288 SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj);
1289 break;
1290 case scm_tc7_byvect:
1291 if (SCM_CHARP (obj))
1292 obj = SCM_MAKINUM ((char) SCM_CHAR (obj));
1293 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1294 ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1295 break;
1296 case scm_tc7_uvect:
1297 ((unsigned long *) SCM_UVECTOR_BASE (v))[pos]
1298 = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME);
1299 break;
1300 case scm_tc7_ivect:
1301 ((long *) SCM_UVECTOR_BASE (v))[pos]
1302 = scm_num2long (obj, SCM_ARG2, FUNC_NAME);
1303 break;
1304 case scm_tc7_svect:
1305 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1306 ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1307 break;
1308 #if SCM_SIZEOF_LONG_LONG != 0
1309 case scm_tc7_llvect:
1310 ((long long *) SCM_UVECTOR_BASE (v))[pos]
1311 = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
1312 break;
1313 #endif
1314 case scm_tc7_fvect:
1315 ((float *) SCM_UVECTOR_BASE (v))[pos]
1316 = (float) scm_num2dbl (obj, FUNC_NAME);
1317 break;
1318 case scm_tc7_dvect:
1319 ((double *) SCM_UVECTOR_BASE (v))[pos]
1320 = scm_num2dbl (obj, FUNC_NAME);
1321 break;
1322 case scm_tc7_cvect:
1323 SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
1324 if (SCM_REALP (obj)) {
1325 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
1326 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
1327 } else {
1328 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
1329 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
1330 }
1331 break;
1332 case scm_tc7_vector:
1333 case scm_tc7_wvect:
1334 SCM_VECTOR_SET (v, pos, obj);
1335 break;
1336 }
1337 return SCM_UNSPECIFIED;
1338 }
1339 #undef FUNC_NAME
1340
1341 /* attempts to unroll an array into a one-dimensional array.
1342 returns the unrolled array or #f if it can't be done. */
1343 /* if strict is not SCM_UNDEFINED, return #f if returned array
1344 wouldn't have contiguous elements. */
1345 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1346 (SCM ra, SCM strict),
1347 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1348 "without changing their order (last subscript changing fastest), then\n"
1349 "@code{array-contents} returns that shared array, otherwise it returns\n"
1350 "@code{#f}. All arrays made by @var{make-array} and\n"
1351 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1352 "@var{make-shared-array} may not be.\n\n"
1353 "If the optional argument @var{strict} is provided, a shared array will\n"
1354 "be returned only if its elements are stored internally contiguous in\n"
1355 "memory.")
1356 #define FUNC_NAME s_scm_array_contents
1357 {
1358 SCM sra;
1359 if (SCM_IMP (ra))
1360 return SCM_BOOL_F;
1361 switch SCM_TYP7 (ra)
1362 {
1363 default:
1364 return SCM_BOOL_F;
1365 case scm_tc7_vector:
1366 case scm_tc7_wvect:
1367 case scm_tc7_string:
1368 case scm_tc7_bvect:
1369 case scm_tc7_byvect:
1370 case scm_tc7_uvect:
1371 case scm_tc7_ivect:
1372 case scm_tc7_fvect:
1373 case scm_tc7_dvect:
1374 case scm_tc7_cvect:
1375 case scm_tc7_svect:
1376 #if SCM_SIZEOF_LONG_LONG != 0
1377 case scm_tc7_llvect:
1378 #endif
1379 return ra;
1380 case scm_tc7_smob:
1381 {
1382 size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1383 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1384 return SCM_BOOL_F;
1385 for (k = 0; k < ndim; k++)
1386 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1387 if (!SCM_UNBNDP (strict))
1388 {
1389 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1390 return SCM_BOOL_F;
1391 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1392 {
1393 if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
1394 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1395 len % SCM_LONG_BIT)
1396 return SCM_BOOL_F;
1397 }
1398 }
1399
1400 {
1401 SCM v = SCM_ARRAY_V (ra);
1402 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
1403 if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1404 return v;
1405 }
1406
1407 sra = scm_make_ra (1);
1408 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1409 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1410 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1411 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1412 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1413 return sra;
1414 }
1415 }
1416 }
1417 #undef FUNC_NAME
1418
1419
1420 SCM
1421 scm_ra2contig (SCM ra, int copy)
1422 {
1423 SCM ret;
1424 long inc = 1;
1425 size_t k, len = 1;
1426 for (k = SCM_ARRAY_NDIM (ra); k--;)
1427 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1428 k = SCM_ARRAY_NDIM (ra);
1429 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1430 {
1431 if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
1432 return ra;
1433 if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
1434 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1435 0 == len % SCM_LONG_BIT))
1436 return ra;
1437 }
1438 ret = scm_make_ra (k);
1439 SCM_ARRAY_BASE (ret) = 0;
1440 while (k--)
1441 {
1442 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1443 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1444 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1445 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1446 }
1447 SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra));
1448 if (copy)
1449 scm_array_copy_x (ra, ret);
1450 return ret;
1451 }
1452
1453
1454
1455 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1456 (SCM ra, SCM port_or_fd, SCM start, SCM end),
1457 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1458 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1459 "binary objects from @var{port-or-fdes}.\n"
1460 "If an end of file is encountered,\n"
1461 "the objects up to that point are put into @var{ura}\n"
1462 "(starting at the beginning) and the remainder of the array is\n"
1463 "unchanged.\n\n"
1464 "The optional arguments @var{start} and @var{end} allow\n"
1465 "a specified region of a vector (or linearized array) to be read,\n"
1466 "leaving the remainder of the vector unchanged.\n\n"
1467 "@code{uniform-array-read!} returns the number of objects read.\n"
1468 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1469 "returned by @code{(current-input-port)}.")
1470 #define FUNC_NAME s_scm_uniform_array_read_x
1471 {
1472 SCM cra = SCM_UNDEFINED, v = ra;
1473 long sz, vlen, ans;
1474 long cstart = 0;
1475 long cend;
1476 long offset = 0;
1477 char *base;
1478
1479 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1480 if (SCM_UNBNDP (port_or_fd))
1481 port_or_fd = scm_cur_inp;
1482 else
1483 SCM_ASSERT (SCM_INUMP (port_or_fd)
1484 || (SCM_OPINPORTP (port_or_fd)),
1485 port_or_fd, SCM_ARG2, FUNC_NAME);
1486 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1487 ? 0
1488 : SCM_INUM (scm_uniform_vector_length (v)));
1489
1490 loop:
1491 switch SCM_TYP7 (v)
1492 {
1493 default:
1494 badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1495 case scm_tc7_smob:
1496 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1497 cra = scm_ra2contig (ra, 0);
1498 cstart += SCM_ARRAY_BASE (cra);
1499 vlen = SCM_ARRAY_DIMS (cra)->inc *
1500 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1501 v = SCM_ARRAY_V (cra);
1502 goto loop;
1503 case scm_tc7_string:
1504 base = SCM_STRING_CHARS (v);
1505 sz = sizeof (char);
1506 break;
1507 case scm_tc7_bvect:
1508 base = (char *) SCM_BITVECTOR_BASE (v);
1509 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1510 cstart /= SCM_LONG_BIT;
1511 sz = sizeof (long);
1512 break;
1513 case scm_tc7_byvect:
1514 base = (char *) SCM_UVECTOR_BASE (v);
1515 sz = sizeof (char);
1516 break;
1517 case scm_tc7_uvect:
1518 case scm_tc7_ivect:
1519 base = (char *) SCM_UVECTOR_BASE (v);
1520 sz = sizeof (long);
1521 break;
1522 case scm_tc7_svect:
1523 base = (char *) SCM_UVECTOR_BASE (v);
1524 sz = sizeof (short);
1525 break;
1526 #if SCM_SIZEOF_LONG_LONG != 0
1527 case scm_tc7_llvect:
1528 base = (char *) SCM_UVECTOR_BASE (v);
1529 sz = sizeof (long long);
1530 break;
1531 #endif
1532 case scm_tc7_fvect:
1533 base = (char *) SCM_UVECTOR_BASE (v);
1534 sz = sizeof (float);
1535 break;
1536 case scm_tc7_dvect:
1537 base = (char *) SCM_UVECTOR_BASE (v);
1538 sz = sizeof (double);
1539 break;
1540 case scm_tc7_cvect:
1541 base = (char *) SCM_UVECTOR_BASE (v);
1542 sz = 2 * sizeof (double);
1543 break;
1544 }
1545
1546 cend = vlen;
1547 if (!SCM_UNBNDP (start))
1548 {
1549 offset =
1550 SCM_NUM2LONG (3, start);
1551
1552 if (offset < 0 || offset >= cend)
1553 scm_out_of_range (FUNC_NAME, start);
1554
1555 if (!SCM_UNBNDP (end))
1556 {
1557 long tend =
1558 SCM_NUM2LONG (4, end);
1559
1560 if (tend <= offset || tend > cend)
1561 scm_out_of_range (FUNC_NAME, end);
1562 cend = tend;
1563 }
1564 }
1565
1566 if (SCM_NIMP (port_or_fd))
1567 {
1568 scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
1569 int remaining = (cend - offset) * sz;
1570 char *dest = base + (cstart + offset) * sz;
1571
1572 if (pt->rw_active == SCM_PORT_WRITE)
1573 scm_flush (port_or_fd);
1574
1575 ans = cend - offset;
1576 while (remaining > 0)
1577 {
1578 if (pt->read_pos < pt->read_end)
1579 {
1580 int to_copy = min (pt->read_end - pt->read_pos,
1581 remaining);
1582
1583 memcpy (dest, pt->read_pos, to_copy);
1584 pt->read_pos += to_copy;
1585 remaining -= to_copy;
1586 dest += to_copy;
1587 }
1588 else
1589 {
1590 if (scm_fill_input (port_or_fd) == EOF)
1591 {
1592 if (remaining % sz != 0)
1593 {
1594 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
1595 }
1596 ans -= remaining / sz;
1597 break;
1598 }
1599 }
1600 }
1601
1602 if (pt->rw_random)
1603 pt->rw_active = SCM_PORT_READ;
1604 }
1605 else /* file descriptor. */
1606 {
1607 SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
1608 base + (cstart + offset) * sz,
1609 (sz * (cend - offset))));
1610 if (ans == -1)
1611 SCM_SYSERROR;
1612 }
1613 if (SCM_TYP7 (v) == scm_tc7_bvect)
1614 ans *= SCM_LONG_BIT;
1615
1616 if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
1617 scm_array_copy_x (cra, ra);
1618
1619 return SCM_MAKINUM (ans);
1620 }
1621 #undef FUNC_NAME
1622
1623 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1624 (SCM v, SCM port_or_fd, SCM start, SCM end),
1625 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1626 "Writes all elements of @var{ura} as binary objects to\n"
1627 "@var{port-or-fdes}.\n\n"
1628 "The optional arguments @var{start}\n"
1629 "and @var{end} allow\n"
1630 "a specified region of a vector (or linearized array) to be written.\n\n"
1631 "The number of objects actually written is returned.\n"
1632 "@var{port-or-fdes} may be\n"
1633 "omitted, in which case it defaults to the value returned by\n"
1634 "@code{(current-output-port)}.")
1635 #define FUNC_NAME s_scm_uniform_array_write
1636 {
1637 long sz, vlen, ans;
1638 long offset = 0;
1639 long cstart = 0;
1640 long cend;
1641 char *base;
1642
1643 port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
1644
1645 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1646 if (SCM_UNBNDP (port_or_fd))
1647 port_or_fd = scm_cur_outp;
1648 else
1649 SCM_ASSERT (SCM_INUMP (port_or_fd)
1650 || (SCM_OPOUTPORTP (port_or_fd)),
1651 port_or_fd, SCM_ARG2, FUNC_NAME);
1652 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1653 ? 0
1654 : SCM_INUM (scm_uniform_vector_length (v)));
1655
1656 loop:
1657 switch SCM_TYP7 (v)
1658 {
1659 default:
1660 badarg1:SCM_WRONG_TYPE_ARG (1, v);
1661 case scm_tc7_smob:
1662 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1663 v = scm_ra2contig (v, 1);
1664 cstart = SCM_ARRAY_BASE (v);
1665 vlen = (SCM_ARRAY_DIMS (v)->inc
1666 * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1));
1667 v = SCM_ARRAY_V (v);
1668 goto loop;
1669 case scm_tc7_string:
1670 base = SCM_STRING_CHARS (v);
1671 sz = sizeof (char);
1672 break;
1673 case scm_tc7_bvect:
1674 base = (char *) SCM_BITVECTOR_BASE (v);
1675 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1676 cstart /= SCM_LONG_BIT;
1677 sz = sizeof (long);
1678 break;
1679 case scm_tc7_byvect:
1680 base = (char *) SCM_UVECTOR_BASE (v);
1681 sz = sizeof (char);
1682 break;
1683 case scm_tc7_uvect:
1684 case scm_tc7_ivect:
1685 base = (char *) SCM_UVECTOR_BASE (v);
1686 sz = sizeof (long);
1687 break;
1688 case scm_tc7_svect:
1689 base = (char *) SCM_UVECTOR_BASE (v);
1690 sz = sizeof (short);
1691 break;
1692 #if SCM_SIZEOF_LONG_LONG != 0
1693 case scm_tc7_llvect:
1694 base = (char *) SCM_UVECTOR_BASE (v);
1695 sz = sizeof (long long);
1696 break;
1697 #endif
1698 case scm_tc7_fvect:
1699 base = (char *) SCM_UVECTOR_BASE (v);
1700 sz = sizeof (float);
1701 break;
1702 case scm_tc7_dvect:
1703 base = (char *) SCM_UVECTOR_BASE (v);
1704 sz = sizeof (double);
1705 break;
1706 case scm_tc7_cvect:
1707 base = (char *) SCM_UVECTOR_BASE (v);
1708 sz = 2 * sizeof (double);
1709 break;
1710 }
1711
1712 cend = vlen;
1713 if (!SCM_UNBNDP (start))
1714 {
1715 offset =
1716 SCM_NUM2LONG (3, start);
1717
1718 if (offset < 0 || offset >= cend)
1719 scm_out_of_range (FUNC_NAME, start);
1720
1721 if (!SCM_UNBNDP (end))
1722 {
1723 long tend =
1724 SCM_NUM2LONG (4, end);
1725
1726 if (tend <= offset || tend > cend)
1727 scm_out_of_range (FUNC_NAME, end);
1728 cend = tend;
1729 }
1730 }
1731
1732 if (SCM_NIMP (port_or_fd))
1733 {
1734 char *source = base + (cstart + offset) * sz;
1735
1736 ans = cend - offset;
1737 scm_lfwrite (source, ans * sz, port_or_fd);
1738 }
1739 else /* file descriptor. */
1740 {
1741 SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
1742 base + (cstart + offset) * sz,
1743 (sz * (cend - offset))));
1744 if (ans == -1)
1745 SCM_SYSERROR;
1746 }
1747 if (SCM_TYP7 (v) == scm_tc7_bvect)
1748 ans *= SCM_LONG_BIT;
1749
1750 return SCM_MAKINUM (ans);
1751 }
1752 #undef FUNC_NAME
1753
1754
1755 static char cnt_tab[16] =
1756 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1757
1758 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1759 (SCM b, SCM bitvector),
1760 "Return the number of occurrences of the boolean @var{b} in\n"
1761 "@var{bitvector}.")
1762 #define FUNC_NAME s_scm_bit_count
1763 {
1764 SCM_VALIDATE_BOOL (1, b);
1765 SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
1766 if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
1767 return SCM_INUM0;
1768 } else {
1769 unsigned long int count = 0;
1770 unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
1771 unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1772 if (SCM_FALSEP (b)) {
1773 w = ~w;
1774 };
1775 w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
1776 while (1) {
1777 while (w) {
1778 count += cnt_tab[w & 0x0f];
1779 w >>= 4;
1780 }
1781 if (i == 0) {
1782 return SCM_MAKINUM (count);
1783 } else {
1784 --i;
1785 w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1786 if (SCM_FALSEP (b)) {
1787 w = ~w;
1788 }
1789 }
1790 }
1791 }
1792 }
1793 #undef FUNC_NAME
1794
1795
1796 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1797 (SCM item, SCM v, SCM k),
1798 "Return the minimum index of an occurrence of @var{bool} in\n"
1799 "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
1800 "within the specified range @code{#f} is returned.")
1801 #define FUNC_NAME s_scm_bit_position
1802 {
1803 long i, lenw, xbits, pos;
1804 register unsigned long w;
1805
1806 SCM_VALIDATE_BOOL (1, item);
1807 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
1808 SCM_VALIDATE_INUM_COPY (3, k, pos);
1809 SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
1810
1811 if (pos == SCM_BITVECTOR_LENGTH (v))
1812 return SCM_BOOL_F;
1813
1814 lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1815 i = pos / SCM_LONG_BIT;
1816 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1817 if (SCM_FALSEP (item))
1818 w = ~w;
1819 xbits = (pos % SCM_LONG_BIT);
1820 pos -= xbits;
1821 w = ((w >> xbits) << xbits);
1822 xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
1823 while (!0)
1824 {
1825 if (w && (i == lenw))
1826 w = ((w << xbits) >> xbits);
1827 if (w)
1828 while (w)
1829 switch (w & 0x0f)
1830 {
1831 default:
1832 return SCM_MAKINUM (pos);
1833 case 2:
1834 case 6:
1835 case 10:
1836 case 14:
1837 return SCM_MAKINUM (pos + 1);
1838 case 4:
1839 case 12:
1840 return SCM_MAKINUM (pos + 2);
1841 case 8:
1842 return SCM_MAKINUM (pos + 3);
1843 case 0:
1844 pos += 4;
1845 w >>= 4;
1846 }
1847 if (++i > lenw)
1848 break;
1849 pos += SCM_LONG_BIT;
1850 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1851 if (SCM_FALSEP (item))
1852 w = ~w;
1853 }
1854 return SCM_BOOL_F;
1855 }
1856 #undef FUNC_NAME
1857
1858
1859 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1860 (SCM v, SCM kv, SCM obj),
1861 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1862 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1863 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1864 "AND'ed into @var{bv}.\n\n"
1865 "If uve is a unsigned long integer vector all the elements of uve\n"
1866 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1867 "of @var{bv} corresponding to the indexes in uve are set to\n"
1868 "@var{bool}. The return value is unspecified.")
1869 #define FUNC_NAME s_scm_bit_set_star_x
1870 {
1871 register long i, k, vlen;
1872 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1873 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1874 switch SCM_TYP7 (kv)
1875 {
1876 default:
1877 badarg2:SCM_WRONG_TYPE_ARG (2, kv);
1878 case scm_tc7_uvect:
1879 vlen = SCM_BITVECTOR_LENGTH (v);
1880 if (SCM_FALSEP (obj))
1881 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1882 {
1883 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1884 if (k >= vlen)
1885 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1886 SCM_BITVEC_CLR(v, k);
1887 }
1888 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1889 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1890 {
1891 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1892 if (k >= vlen)
1893 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1894 SCM_BITVEC_SET(v, k);
1895 }
1896 else
1897 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1898 break;
1899 case scm_tc7_bvect:
1900 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1901 if (SCM_FALSEP (obj))
1902 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1903 SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
1904 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1905 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1906 SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
1907 else
1908 goto badarg3;
1909 break;
1910 }
1911 return SCM_UNSPECIFIED;
1912 }
1913 #undef FUNC_NAME
1914
1915
1916 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
1917 (SCM v, SCM kv, SCM obj),
1918 "Return\n"
1919 "@lisp\n"
1920 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1921 "@end lisp\n"
1922 "@var{bv} is not modified.")
1923 #define FUNC_NAME s_scm_bit_count_star
1924 {
1925 register long i, vlen, count = 0;
1926 register unsigned long k;
1927 int fObj = 0;
1928
1929 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1930 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1931 switch SCM_TYP7 (kv)
1932 {
1933 default:
1934 badarg2:
1935 SCM_WRONG_TYPE_ARG (2, kv);
1936 case scm_tc7_uvect:
1937 vlen = SCM_BITVECTOR_LENGTH (v);
1938 if (SCM_FALSEP (obj))
1939 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1940 {
1941 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1942 if (k >= vlen)
1943 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1944 if (!SCM_BITVEC_REF(v, k))
1945 count++;
1946 }
1947 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1948 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1949 {
1950 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1951 if (k >= vlen)
1952 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1953 if (SCM_BITVEC_REF (v, k))
1954 count++;
1955 }
1956 else
1957 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1958 break;
1959 case scm_tc7_bvect:
1960 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1961 if (0 == SCM_BITVECTOR_LENGTH (v))
1962 return SCM_INUM0;
1963 SCM_ASRTGO (SCM_BOOLP (obj), badarg3);
1964 fObj = SCM_EQ_P (obj, SCM_BOOL_T);
1965 i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
1966 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
1967 k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
1968 while (1)
1969 {
1970 for (; k; k >>= 4)
1971 count += cnt_tab[k & 0x0f];
1972 if (0 == i--)
1973 return SCM_MAKINUM (count);
1974
1975 /* urg. repetitive (see above.) */
1976 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
1977 }
1978 }
1979 return SCM_MAKINUM (count);
1980 }
1981 #undef FUNC_NAME
1982
1983
1984 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
1985 (SCM v),
1986 "Modify @var{bv} by replacing each element with its negation.")
1987 #define FUNC_NAME s_scm_bit_invert_x
1988 {
1989 long int k;
1990
1991 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1992
1993 k = SCM_BITVECTOR_LENGTH (v);
1994 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1995 SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
1996
1997 return SCM_UNSPECIFIED;
1998 }
1999 #undef FUNC_NAME
2000
2001
2002 SCM
2003 scm_istr2bve (char *str, long len)
2004 {
2005 SCM v = scm_make_uve (len, SCM_BOOL_T);
2006 long *data = (long *) SCM_VELTS (v);
2007 register unsigned long mask;
2008 register long k;
2009 register long j;
2010 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
2011 {
2012 data[k] = 0L;
2013 j = len - k * SCM_LONG_BIT;
2014 if (j > SCM_LONG_BIT)
2015 j = SCM_LONG_BIT;
2016 for (mask = 1L; j--; mask <<= 1)
2017 switch (*str++)
2018 {
2019 case '0':
2020 break;
2021 case '1':
2022 data[k] |= mask;
2023 break;
2024 default:
2025 return SCM_BOOL_F;
2026 }
2027 }
2028 return v;
2029 }
2030
2031
2032
2033 static SCM
2034 ra2l (SCM ra, unsigned long base, unsigned long k)
2035 {
2036 register SCM res = SCM_EOL;
2037 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2038 register size_t i;
2039 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
2040 return SCM_EOL;
2041 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
2042 if (k < SCM_ARRAY_NDIM (ra) - 1)
2043 {
2044 do
2045 {
2046 i -= inc;
2047 res = scm_cons (ra2l (ra, i, k + 1), res);
2048 }
2049 while (i != base);
2050 }
2051 else
2052 do
2053 {
2054 i -= inc;
2055 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
2056 }
2057 while (i != base);
2058 return res;
2059 }
2060
2061
2062 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
2063 (SCM v),
2064 "Return a list consisting of all the elements, in order, of\n"
2065 "@var{array}.")
2066 #define FUNC_NAME s_scm_array_to_list
2067 {
2068 SCM res = SCM_EOL;
2069 register long k;
2070 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2071 switch SCM_TYP7 (v)
2072 {
2073 default:
2074 badarg1:SCM_WRONG_TYPE_ARG (1, v);
2075 case scm_tc7_smob:
2076 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2077 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2078 case scm_tc7_vector:
2079 case scm_tc7_wvect:
2080 return scm_vector_to_list (v);
2081 case scm_tc7_string:
2082 return scm_string_to_list (v);
2083 case scm_tc7_bvect:
2084 {
2085 long *data = (long *) SCM_VELTS (v);
2086 register unsigned long mask;
2087 for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
2088 for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
2089 res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
2090 for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2091 res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
2092 return res;
2093 }
2094 case scm_tc7_byvect:
2095 {
2096 signed char *data = (signed char *) SCM_VELTS (v);
2097 unsigned long k = SCM_UVECTOR_LENGTH (v);
2098 while (k != 0)
2099 res = scm_cons (SCM_MAKINUM (data[--k]), res);
2100 return res;
2101 }
2102 case scm_tc7_uvect:
2103 {
2104 long *data = (long *)SCM_VELTS(v);
2105 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2106 res = scm_cons(scm_ulong2num(data[k]), res);
2107 return res;
2108 }
2109 case scm_tc7_ivect:
2110 {
2111 long *data = (long *)SCM_VELTS(v);
2112 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2113 res = scm_cons(scm_long2num(data[k]), res);
2114 return res;
2115 }
2116 case scm_tc7_svect:
2117 {
2118 short *data = (short *)SCM_VELTS(v);
2119 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2120 res = scm_cons(scm_short2num (data[k]), res);
2121 return res;
2122 }
2123 #if SCM_SIZEOF_LONG_LONG != 0
2124 case scm_tc7_llvect:
2125 {
2126 long long *data = (long long *)SCM_VELTS(v);
2127 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2128 res = scm_cons(scm_long_long2num(data[k]), res);
2129 return res;
2130 }
2131 #endif
2132 case scm_tc7_fvect:
2133 {
2134 float *data = (float *) SCM_VELTS (v);
2135 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2136 res = scm_cons (scm_make_real (data[k]), res);
2137 return res;
2138 }
2139 case scm_tc7_dvect:
2140 {
2141 double *data = (double *) SCM_VELTS (v);
2142 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2143 res = scm_cons (scm_make_real (data[k]), res);
2144 return res;
2145 }
2146 case scm_tc7_cvect:
2147 {
2148 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2149 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2150 res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
2151 return res;
2152 }
2153 }
2154 }
2155 #undef FUNC_NAME
2156
2157
2158 static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
2159
2160 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2161 (SCM ndim, SCM prot, SCM lst),
2162 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2163 "Return a uniform array of the type indicated by prototype\n"
2164 "@var{prot} with elements the same as those of @var{lst}.\n"
2165 "Elements must be of the appropriate type, no coercions are\n"
2166 "done.")
2167 #define FUNC_NAME s_scm_list_to_uniform_array
2168 {
2169 SCM shp = SCM_EOL;
2170 SCM row = lst;
2171 SCM ra;
2172 unsigned long k;
2173 long n;
2174 SCM_VALIDATE_INUM_COPY (1, ndim, k);
2175 while (k--)
2176 {
2177 n = scm_ilength (row);
2178 SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
2179 shp = scm_cons (SCM_MAKINUM (n), shp);
2180 if (SCM_NIMP (row))
2181 row = SCM_CAR (row);
2182 }
2183 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
2184 SCM_UNDEFINED);
2185 if (SCM_NULLP (shp))
2186 {
2187 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2188 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2189 return ra;
2190 }
2191 if (!SCM_ARRAYP (ra))
2192 {
2193 unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
2194 for (k = 0; k < length; k++, lst = SCM_CDR (lst))
2195 scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
2196 return ra;
2197 }
2198 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2199 return ra;
2200 else
2201 badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2202 scm_list_1 (lst));
2203 }
2204 #undef FUNC_NAME
2205
2206 static int
2207 l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
2208 {
2209 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2210 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2211 int ok = 1;
2212 if (n <= 0)
2213 return (SCM_NULLP (lst));
2214 if (k < SCM_ARRAY_NDIM (ra) - 1)
2215 {
2216 while (n--)
2217 {
2218 if (!SCM_CONSP (lst))
2219 return 0;
2220 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2221 base += inc;
2222 lst = SCM_CDR (lst);
2223 }
2224 if (!SCM_NULLP (lst))
2225 return 0;
2226 }
2227 else
2228 {
2229 while (n--)
2230 {
2231 if (!SCM_CONSP (lst))
2232 return 0;
2233 scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
2234 base += inc;
2235 lst = SCM_CDR (lst);
2236 }
2237 if (!SCM_NULLP (lst))
2238 return 0;
2239 }
2240 return ok;
2241 }
2242
2243
2244 static void
2245 rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
2246 {
2247 long inc = 1;
2248 long n = (SCM_TYP7 (ra) == scm_tc7_smob
2249 ? 0
2250 : SCM_INUM (scm_uniform_vector_length (ra)));
2251 int enclosed = 0;
2252 tail:
2253 switch SCM_TYP7 (ra)
2254 {
2255 case scm_tc7_smob:
2256 if (enclosed++)
2257 {
2258 SCM_ARRAY_BASE (ra) = j;
2259 if (n-- > 0)
2260 scm_iprin1 (ra, port, pstate);
2261 for (j += inc; n-- > 0; j += inc)
2262 {
2263 scm_putc (' ', port);
2264 SCM_ARRAY_BASE (ra) = j;
2265 scm_iprin1 (ra, port, pstate);
2266 }
2267 break;
2268 }
2269 if (k + 1 < SCM_ARRAY_NDIM (ra))
2270 {
2271 long i;
2272 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2273 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2274 {
2275 scm_putc ('(', port);
2276 rapr1 (ra, j, k + 1, port, pstate);
2277 scm_puts (") ", port);
2278 j += inc;
2279 }
2280 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2281 { /* could be zero size. */
2282 scm_putc ('(', port);
2283 rapr1 (ra, j, k + 1, port, pstate);
2284 scm_putc (')', port);
2285 }
2286 break;
2287 }
2288 if (SCM_ARRAY_NDIM (ra) > 0)
2289 { /* Could be zero-dimensional */
2290 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2291 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2292 }
2293 else
2294 n = 1;
2295 ra = SCM_ARRAY_V (ra);
2296 goto tail;
2297 default:
2298 /* scm_tc7_bvect and scm_tc7_llvect only? */
2299 if (n-- > 0)
2300 scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
2301 for (j += inc; n-- > 0; j += inc)
2302 {
2303 scm_putc (' ', port);
2304 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
2305 }
2306 break;
2307 case scm_tc7_string:
2308 if (n-- > 0)
2309 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2310 if (SCM_WRITINGP (pstate))
2311 for (j += inc; n-- > 0; j += inc)
2312 {
2313 scm_putc (' ', port);
2314 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2315 }
2316 else
2317 for (j += inc; n-- > 0; j += inc)
2318 scm_putc (SCM_STRING_CHARS (ra)[j], port);
2319 break;
2320 case scm_tc7_byvect:
2321 if (n-- > 0)
2322 scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2323 for (j += inc; n-- > 0; j += inc)
2324 {
2325 scm_putc (' ', port);
2326 scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
2327 }
2328 break;
2329
2330 case scm_tc7_uvect:
2331 {
2332 char str[11];
2333
2334 if (n-- > 0)
2335 {
2336 /* intprint can't handle >= 2^31. */
2337 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2338 scm_puts (str, port);
2339 }
2340 for (j += inc; n-- > 0; j += inc)
2341 {
2342 scm_putc (' ', port);
2343 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2344 scm_puts (str, port);
2345 }
2346 }
2347 case scm_tc7_ivect:
2348 if (n-- > 0)
2349 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2350 for (j += inc; n-- > 0; j += inc)
2351 {
2352 scm_putc (' ', port);
2353 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2354 }
2355 break;
2356
2357 case scm_tc7_svect:
2358 if (n-- > 0)
2359 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2360 for (j += inc; n-- > 0; j += inc)
2361 {
2362 scm_putc (' ', port);
2363 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2364 }
2365 break;
2366
2367 case scm_tc7_fvect:
2368 if (n-- > 0)
2369 {
2370 SCM z = scm_make_real (1.0);
2371 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2372 scm_print_real (z, port, pstate);
2373 for (j += inc; n-- > 0; j += inc)
2374 {
2375 scm_putc (' ', port);
2376 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2377 scm_print_real (z, port, pstate);
2378 }
2379 }
2380 break;
2381 case scm_tc7_dvect:
2382 if (n-- > 0)
2383 {
2384 SCM z = scm_make_real (1.0 / 3.0);
2385 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2386 scm_print_real (z, port, pstate);
2387 for (j += inc; n-- > 0; j += inc)
2388 {
2389 scm_putc (' ', port);
2390 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2391 scm_print_real (z, port, pstate);
2392 }
2393 }
2394 break;
2395 case scm_tc7_cvect:
2396 if (n-- > 0)
2397 {
2398 SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0);
2399 SCM_REAL_VALUE (z) =
2400 SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2401 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2402 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2403 port, pstate);
2404 for (j += inc; n-- > 0; j += inc)
2405 {
2406 scm_putc (' ', port);
2407 SCM_REAL_VALUE (z)
2408 = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2409 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2410 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2411 port, pstate);
2412 }
2413 }
2414 break;
2415 }
2416 }
2417
2418
2419
2420 int
2421 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2422 {
2423 SCM v = exp;
2424 unsigned long base = 0;
2425 scm_putc ('#', port);
2426 tail:
2427 switch SCM_TYP7 (v)
2428 {
2429 case scm_tc7_smob:
2430 {
2431 long ndim = SCM_ARRAY_NDIM (v);
2432 base = SCM_ARRAY_BASE (v);
2433 v = SCM_ARRAY_V (v);
2434 if (SCM_ARRAYP (v))
2435
2436 {
2437 scm_puts ("<enclosed-array ", port);
2438 rapr1 (exp, base, 0, port, pstate);
2439 scm_putc ('>', port);
2440 return 1;
2441 }
2442 else
2443 {
2444 scm_intprint (ndim, 10, port);
2445 goto tail;
2446 }
2447 }
2448 case scm_tc7_bvect:
2449 if (SCM_EQ_P (exp, v))
2450 { /* a uve, not an scm_array */
2451 register long i, j, w;
2452 scm_putc ('*', port);
2453 for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
2454 {
2455 scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
2456 for (j = SCM_LONG_BIT; j; j--)
2457 {
2458 scm_putc (w & 1 ? '1' : '0', port);
2459 w >>= 1;
2460 }
2461 }
2462 j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
2463 if (j)
2464 {
2465 w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
2466 for (; j; j--)
2467 {
2468 scm_putc (w & 1 ? '1' : '0', port);
2469 w >>= 1;
2470 }
2471 }
2472 return 1;
2473 }
2474 else
2475 scm_putc ('b', port);
2476 break;
2477 case scm_tc7_string:
2478 scm_putc ('a', port);
2479 break;
2480 case scm_tc7_byvect:
2481 scm_putc ('y', port);
2482 break;
2483 case scm_tc7_uvect:
2484 scm_putc ('u', port);
2485 break;
2486 case scm_tc7_ivect:
2487 scm_putc ('e', port);
2488 break;
2489 case scm_tc7_svect:
2490 scm_putc ('h', port);
2491 break;
2492 #if SCM_SIZEOF_LONG_LONG != 0
2493 case scm_tc7_llvect:
2494 scm_putc ('l', port);
2495 break;
2496 #endif
2497 case scm_tc7_fvect:
2498 scm_putc ('s', port);
2499 break;
2500 case scm_tc7_dvect:
2501 scm_putc ('i', port);
2502 break;
2503 case scm_tc7_cvect:
2504 scm_putc ('c', port);
2505 break;
2506 }
2507 scm_putc ('(', port);
2508 rapr1 (exp, base, 0, port, pstate);
2509 scm_putc (')', port);
2510 return 1;
2511 }
2512
2513 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2514 (SCM ra),
2515 "Return an object that would produce an array of the same type\n"
2516 "as @var{array}, if used as the @var{prototype} for\n"
2517 "@code{make-uniform-array}.")
2518 #define FUNC_NAME s_scm_array_prototype
2519 {
2520 int enclosed = 0;
2521 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2522 loop:
2523 switch SCM_TYP7 (ra)
2524 {
2525 default:
2526 badarg:SCM_WRONG_TYPE_ARG (1, ra);
2527 case scm_tc7_smob:
2528 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2529 if (enclosed++)
2530 return SCM_UNSPECIFIED;
2531 ra = SCM_ARRAY_V (ra);
2532 goto loop;
2533 case scm_tc7_vector:
2534 case scm_tc7_wvect:
2535 return SCM_EOL;
2536 case scm_tc7_bvect:
2537 return SCM_BOOL_T;
2538 case scm_tc7_string:
2539 return SCM_MAKE_CHAR ('a');
2540 case scm_tc7_byvect:
2541 return SCM_MAKE_CHAR ('\0');
2542 case scm_tc7_uvect:
2543 return SCM_MAKINUM (1L);
2544 case scm_tc7_ivect:
2545 return SCM_MAKINUM (-1L);
2546 case scm_tc7_svect:
2547 return scm_str2symbol ("s");
2548 #if SCM_SIZEOF_LONG_LONG != 0
2549 case scm_tc7_llvect:
2550 return scm_str2symbol ("l");
2551 #endif
2552 case scm_tc7_fvect:
2553 return scm_make_real (1.0);
2554 case scm_tc7_dvect:
2555 return scm_make_real (1.0 / 3.0);
2556 case scm_tc7_cvect:
2557 return scm_make_complex (0.0, 1.0);
2558 }
2559 }
2560 #undef FUNC_NAME
2561
2562
2563 static SCM
2564 array_mark (SCM ptr)
2565 {
2566 return SCM_ARRAY_V (ptr);
2567 }
2568
2569
2570 static size_t
2571 array_free (SCM ptr)
2572 {
2573 scm_gc_free (SCM_ARRAY_MEM (ptr),
2574 (sizeof (scm_t_array)
2575 + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
2576 "array");
2577 return 0;
2578 }
2579
2580 void
2581 scm_init_unif ()
2582 {
2583 scm_tc16_array = scm_make_smob_type ("array", 0);
2584 scm_set_smob_mark (scm_tc16_array, array_mark);
2585 scm_set_smob_free (scm_tc16_array, array_free);
2586 scm_set_smob_print (scm_tc16_array, scm_raprin1);
2587 scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
2588 scm_add_feature ("array");
2589 #include "libguile/unif.x"
2590 }
2591
2592 /*
2593 Local Variables:
2594 c-file-style: "gnu"
2595 End:
2596 */
Unnamed repository; edit this file 'description' to name the repository.