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