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