HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
* validate.h, deprecated.h (SCM_VALIDATE_INUM, SCM_VALIDATE_INUM_COPY,
[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_I_MAKINUM (SCM_VECTOR_LENGTH (v));
222 case scm_tc7_string:
223 return SCM_I_MAKINUM (SCM_STRING_LENGTH (v));
224 case scm_tc7_bvect:
225 return SCM_I_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_I_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_I_MAKINUM (1L);
351 case scm_tc7_smob:
352 if (SCM_ARRAYP (ra))
353 return SCM_I_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_I_MAKINUM (s[k].lbnd),
401 SCM_I_MAKINUM (s[k].ubnd),
402 SCM_EOL)
403 : SCM_I_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_I_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_I_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_I_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_I_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_I_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_I_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_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
804 SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
805 return ra;
806 case scm_tc7_smob:
807 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
808 vargs = scm_vector (args);
809 if (SCM_VECTOR_LENGTH (vargs) != SCM_ARRAY_NDIM (ra))
810 SCM_WRONG_NUM_ARGS ();
811 ve = SCM_VELTS (vargs);
812 ndim = 0;
813 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
814 {
815 SCM_ASSERT (SCM_INUMP (ve[k]), ve[k], (SCM_ARG2 + k),
816 FUNC_NAME);
817 i = SCM_INUM (ve[k]);
818 if (i < 0 || i >= SCM_ARRAY_NDIM (ra))
819 scm_out_of_range (FUNC_NAME, ve[k]);
820 if (ndim < i)
821 ndim = i;
822 }
823 ndim++;
824 res = scm_make_ra (ndim);
825 SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
826 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
827 for (k = ndim; k--;)
828 {
829 SCM_ARRAY_DIMS (res)[k].lbnd = 0;
830 SCM_ARRAY_DIMS (res)[k].ubnd = -1;
831 }
832 for (k = SCM_ARRAY_NDIM (ra); k--;)
833 {
834 i = SCM_INUM (ve[k]);
835 s = &(SCM_ARRAY_DIMS (ra)[k]);
836 r = &(SCM_ARRAY_DIMS (res)[i]);
837 if (r->ubnd < r->lbnd)
838 {
839 r->lbnd = s->lbnd;
840 r->ubnd = s->ubnd;
841 r->inc = s->inc;
842 ndim--;
843 }
844 else
845 {
846 if (r->ubnd > s->ubnd)
847 r->ubnd = s->ubnd;
848 if (r->lbnd < s->lbnd)
849 {
850 SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
851 r->lbnd = s->lbnd;
852 }
853 r->inc += s->inc;
854 }
855 }
856 if (ndim > 0)
857 SCM_MISC_ERROR ("bad argument list", SCM_EOL);
858 scm_ra_set_contp (res);
859 return res;
860 }
861 }
862 #undef FUNC_NAME
863
864 /* args are RA . AXES */
865 SCM_DEFINE (scm_enclose_array, "enclose-array", 1, 0, 1,
866 (SCM ra, SCM axes),
867 "@var{dim0}, @var{dim1} @dots{} should be nonnegative integers less than\n"
868 "the rank of @var{array}. @var{enclose-array} returns an array\n"
869 "resembling an array of shared arrays. The dimensions of each shared\n"
870 "array are the same as the @var{dim}th dimensions of the original array,\n"
871 "the dimensions of the outer array are the same as those of the original\n"
872 "array that did not match a @var{dim}.\n\n"
873 "An enclosed array is not a general Scheme array. Its elements may not\n"
874 "be set using @code{array-set!}. Two references to the same element of\n"
875 "an enclosed array will be @code{equal?} but will not in general be\n"
876 "@code{eq?}. The value returned by @var{array-prototype} when given an\n"
877 "enclosed array is unspecified.\n\n"
878 "examples:\n"
879 "@lisp\n"
880 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1) @result{}\n"
881 " #<enclosed-array (#1(a d) #1(b e) #1(c f)) (#1(1 4) #1(2 5) #1(3 6))>\n\n"
882 "(enclose-array '#3(((a b c) (d e f)) ((1 2 3) (4 5 6))) 1 0) @result{}\n"
883 " #<enclosed-array #2((a 1) (d 4)) #2((b 2) (e 5)) #2((c 3) (f 6))>\n"
884 "@end lisp")
885 #define FUNC_NAME s_scm_enclose_array
886 {
887 SCM axv, res, ra_inr;
888 scm_t_array_dim vdim, *s = &vdim;
889 int ndim, j, k, ninr, noutr;
890
891 SCM_VALIDATE_REST_ARGUMENT (axes);
892 if (SCM_NULLP (axes))
893 axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_I_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
894 ninr = scm_ilength (axes);
895 if (ninr < 0)
896 SCM_WRONG_NUM_ARGS ();
897 ra_inr = scm_make_ra (ninr);
898 SCM_ASRTGO (SCM_NIMP (ra), badarg1);
899 switch SCM_TYP7 (ra)
900 {
901 default:
902 badarg1:SCM_WRONG_TYPE_ARG (1, ra);
903 case scm_tc7_string:
904 case scm_tc7_bvect:
905 case scm_tc7_byvect:
906 case scm_tc7_uvect:
907 case scm_tc7_ivect:
908 case scm_tc7_fvect:
909 case scm_tc7_dvect:
910 case scm_tc7_cvect:
911 case scm_tc7_vector:
912 case scm_tc7_wvect:
913 case scm_tc7_svect:
914 #if SCM_SIZEOF_LONG_LONG != 0
915 case scm_tc7_llvect:
916 #endif
917 s->lbnd = 0;
918 s->ubnd = SCM_INUM (scm_uniform_vector_length (ra)) - 1;
919 s->inc = 1;
920 SCM_ARRAY_V (ra_inr) = ra;
921 SCM_ARRAY_BASE (ra_inr) = 0;
922 ndim = 1;
923 break;
924 case scm_tc7_smob:
925 SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
926 s = SCM_ARRAY_DIMS (ra);
927 SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
928 SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
929 ndim = SCM_ARRAY_NDIM (ra);
930 break;
931 }
932 noutr = ndim - ninr;
933 if (noutr < 0)
934 SCM_WRONG_NUM_ARGS ();
935 axv = scm_make_string (SCM_I_MAKINUM (ndim), SCM_MAKE_CHAR (0));
936 res = scm_make_ra (noutr);
937 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
938 SCM_ARRAY_V (res) = ra_inr;
939 for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
940 {
941 if (!SCM_INUMP (SCM_CAR (axes)))
942 SCM_MISC_ERROR ("bad axis", SCM_EOL);
943 j = SCM_INUM (SCM_CAR (axes));
944 SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
945 SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
946 SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
947 SCM_STRING_CHARS (axv)[j] = 1;
948 }
949 for (j = 0, k = 0; k < noutr; k++, j++)
950 {
951 while (SCM_STRING_CHARS (axv)[j])
952 j++;
953 SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
954 SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
955 SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
956 }
957 scm_ra_set_contp (ra_inr);
958 scm_ra_set_contp (res);
959 return res;
960 }
961 #undef FUNC_NAME
962
963
964
965 SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
966 (SCM v, SCM args),
967 "Return @code{#t} if its arguments would be acceptable to\n"
968 "@code{array-ref}.")
969 #define FUNC_NAME s_scm_array_in_bounds_p
970 {
971 SCM ind = SCM_EOL;
972 long pos = 0;
973 register size_t k;
974 register long j;
975 scm_t_array_dim *s;
976
977 SCM_VALIDATE_REST_ARGUMENT (args);
978 SCM_ASRTGO (SCM_NIMP (v), badarg1);
979 if (SCM_NIMP (args))
980
981 {
982 ind = SCM_CAR (args);
983 args = SCM_CDR (args);
984 SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, FUNC_NAME);
985 pos = SCM_INUM (ind);
986 }
987 tail:
988 switch SCM_TYP7 (v)
989 {
990 default:
991 badarg1:SCM_WRONG_TYPE_ARG (1, v);
992 wna: SCM_WRONG_NUM_ARGS ();
993 case scm_tc7_smob:
994 k = SCM_ARRAY_NDIM (v);
995 s = SCM_ARRAY_DIMS (v);
996 pos = SCM_ARRAY_BASE (v);
997 if (!k)
998 {
999 SCM_ASRTGO (SCM_NULLP (ind), wna);
1000 ind = SCM_INUM0;
1001 }
1002 else
1003 while (!0)
1004 {
1005 j = SCM_INUM (ind);
1006 if (!(j >= (s->lbnd) && j <= (s->ubnd)))
1007 {
1008 SCM_ASRTGO (--k == scm_ilength (args), wna);
1009 return SCM_BOOL_F;
1010 }
1011 pos += (j - s->lbnd) * (s->inc);
1012 if (!(--k && SCM_NIMP (args)))
1013 break;
1014 ind = SCM_CAR (args);
1015 args = SCM_CDR (args);
1016 s++;
1017 if (!SCM_INUMP (ind))
1018 SCM_MISC_ERROR (s_bad_ind, SCM_EOL);
1019 }
1020 SCM_ASRTGO (0 == k, wna);
1021 v = SCM_ARRAY_V (v);
1022 goto tail;
1023 case scm_tc7_bvect:
1024 case scm_tc7_string:
1025 case scm_tc7_byvect:
1026 case scm_tc7_uvect:
1027 case scm_tc7_ivect:
1028 case scm_tc7_fvect:
1029 case scm_tc7_dvect:
1030 case scm_tc7_cvect:
1031 case scm_tc7_svect:
1032 #if SCM_SIZEOF_LONG_LONG != 0
1033 case scm_tc7_llvect:
1034 #endif
1035 case scm_tc7_vector:
1036 case scm_tc7_wvect:
1037 {
1038 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
1039 SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
1040 return scm_from_bool(pos >= 0 && pos < length);
1041 }
1042 }
1043 }
1044 #undef FUNC_NAME
1045
1046
1047 SCM_REGISTER_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
1048
1049
1050 SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
1051 (SCM v, SCM args),
1052 "@deffnx {Scheme Procedure} array-ref v . args\n"
1053 "Return the element at the @code{(index1, index2)} element in\n"
1054 "@var{array}.")
1055 #define FUNC_NAME s_scm_uniform_vector_ref
1056 {
1057 long pos;
1058
1059 if (SCM_IMP (v))
1060 {
1061 SCM_ASRTGO (SCM_NULLP (args), badarg);
1062 return v;
1063 }
1064 else if (SCM_ARRAYP (v))
1065 {
1066 pos = scm_aind (v, args, FUNC_NAME);
1067 v = SCM_ARRAY_V (v);
1068 }
1069 else
1070 {
1071 unsigned long int length;
1072 if (SCM_NIMP (args))
1073 {
1074 SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, FUNC_NAME);
1075 pos = SCM_INUM (SCM_CAR (args));
1076 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1077 }
1078 else
1079 {
1080 pos = scm_to_long (args);
1081 }
1082 length = SCM_INUM (scm_uniform_vector_length (v));
1083 SCM_ASRTGO (pos >= 0 && pos < length, outrng);
1084 }
1085 switch SCM_TYP7 (v)
1086 {
1087 default:
1088 if (SCM_NULLP (args))
1089 return v;
1090 badarg:
1091 SCM_WRONG_TYPE_ARG (1, v);
1092 /* not reached */
1093
1094 outrng:
1095 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (pos));
1096 wna:
1097 SCM_WRONG_NUM_ARGS ();
1098 case scm_tc7_smob:
1099 { /* enclosed */
1100 int k = SCM_ARRAY_NDIM (v);
1101 SCM res = scm_make_ra (k);
1102 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1103 SCM_ARRAY_BASE (res) = pos;
1104 while (k--)
1105 {
1106 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1107 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1108 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1109 }
1110 return res;
1111 }
1112 case scm_tc7_bvect:
1113 if (SCM_BITVEC_REF (v, pos))
1114 return SCM_BOOL_T;
1115 else
1116 return SCM_BOOL_F;
1117 case scm_tc7_string:
1118 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
1119 case scm_tc7_byvect:
1120 return SCM_I_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
1121 case scm_tc7_uvect:
1122 return scm_ulong2num (((unsigned long *) SCM_VELTS (v))[pos]);
1123 case scm_tc7_ivect:
1124 return scm_long2num (((signed long *) SCM_VELTS (v))[pos]);
1125
1126 case scm_tc7_svect:
1127 return SCM_I_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
1128 #if SCM_SIZEOF_LONG_LONG != 0
1129 case scm_tc7_llvect:
1130 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
1131 #endif
1132
1133 case scm_tc7_fvect:
1134 return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
1135 case scm_tc7_dvect:
1136 return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
1137 case scm_tc7_cvect:
1138 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
1139 ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
1140 case scm_tc7_vector:
1141 case scm_tc7_wvect:
1142 return SCM_VELTS (v)[pos];
1143 }
1144 }
1145 #undef FUNC_NAME
1146
1147 /* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1148 tries to recycle conses. (Make *sure* you want them recycled.) */
1149
1150 SCM
1151 scm_cvref (SCM v, unsigned long pos, SCM last)
1152 #define FUNC_NAME "scm_cvref"
1153 {
1154 switch SCM_TYP7 (v)
1155 {
1156 default:
1157 SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1158 case scm_tc7_bvect:
1159 if (SCM_BITVEC_REF(v, pos))
1160 return SCM_BOOL_T;
1161 else
1162 return SCM_BOOL_F;
1163 case scm_tc7_string:
1164 return SCM_MAKE_CHAR (SCM_STRING_UCHARS (v)[pos]);
1165 case scm_tc7_byvect:
1166 return SCM_I_MAKINUM (((char *) SCM_UVECTOR_BASE (v))[pos]);
1167 case scm_tc7_uvect:
1168 return scm_ulong2num(((unsigned long *) SCM_VELTS (v))[pos]);
1169 case scm_tc7_ivect:
1170 return scm_long2num(((signed long *) SCM_VELTS (v))[pos]);
1171 case scm_tc7_svect:
1172 return SCM_I_MAKINUM (((short *) SCM_CELL_WORD_1 (v))[pos]);
1173 #if SCM_SIZEOF_LONG_LONG != 0
1174 case scm_tc7_llvect:
1175 return scm_long_long2num (((long long *) SCM_CELL_WORD_1 (v))[pos]);
1176 #endif
1177 case scm_tc7_fvect:
1178 if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
1179 {
1180 SCM_REAL_VALUE (last) = ((float *) SCM_CELL_WORD_1 (v))[pos];
1181 return last;
1182 }
1183 return scm_make_real (((float *) SCM_CELL_WORD_1 (v))[pos]);
1184 case scm_tc7_dvect:
1185 if (SCM_REALP (last) && !SCM_EQ_P (last, scm_flo0))
1186 {
1187 SCM_REAL_VALUE (last) = ((double *) SCM_CELL_WORD_1 (v))[pos];
1188 return last;
1189 }
1190 return scm_make_real (((double *) SCM_CELL_WORD_1 (v))[pos]);
1191 case scm_tc7_cvect:
1192 if (SCM_COMPLEXP (last))
1193 {
1194 SCM_COMPLEX_REAL (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos];
1195 SCM_COMPLEX_IMAG (last) = ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1];
1196 return last;
1197 }
1198 return scm_make_complex (((double *) SCM_CELL_WORD_1 (v))[2 * pos],
1199 ((double *) SCM_CELL_WORD_1 (v))[2 * pos + 1]);
1200 case scm_tc7_vector:
1201 case scm_tc7_wvect:
1202 return SCM_VELTS (v)[pos];
1203 case scm_tc7_smob:
1204 { /* enclosed scm_array */
1205 int k = SCM_ARRAY_NDIM (v);
1206 SCM res = scm_make_ra (k);
1207 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1208 SCM_ARRAY_BASE (res) = pos;
1209 while (k--)
1210 {
1211 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1212 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1213 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1214 }
1215 return res;
1216 }
1217 }
1218 }
1219 #undef FUNC_NAME
1220
1221
1222 SCM_REGISTER_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
1223
1224
1225 /* Note that args may be a list or an immediate object, depending which
1226 PROC is used (and it's called from C too). */
1227 SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
1228 (SCM v, SCM obj, SCM args),
1229 "@deffnx {Scheme Procedure} uniform-array-set1! v obj args\n"
1230 "Set the element at the @code{(index1, index2)} element in @var{array} to\n"
1231 "@var{new-value}. The value returned by array-set! is unspecified.")
1232 #define FUNC_NAME s_scm_array_set_x
1233 {
1234 long pos = 0;
1235
1236 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1237 if (SCM_ARRAYP (v))
1238 {
1239 pos = scm_aind (v, args, FUNC_NAME);
1240 v = SCM_ARRAY_V (v);
1241 }
1242 else
1243 {
1244 unsigned long int length;
1245 if (SCM_CONSP (args))
1246 {
1247 SCM_ASSERT (SCM_INUMP (SCM_CAR (args)), args, SCM_ARG3, FUNC_NAME);
1248 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1249 pos = SCM_INUM (SCM_CAR (args));
1250 }
1251 else
1252 {
1253 pos = scm_to_long (args);
1254 }
1255 length = SCM_INUM (scm_uniform_vector_length (v));
1256 SCM_ASRTGO (pos >= 0 && pos < length, outrng);
1257 }
1258 switch (SCM_TYP7 (v))
1259 {
1260 default: badarg1:
1261 SCM_WRONG_TYPE_ARG (1, v);
1262 /* not reached */
1263 outrng:
1264 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (pos));
1265 wna:
1266 SCM_WRONG_NUM_ARGS ();
1267 case scm_tc7_smob: /* enclosed */
1268 goto badarg1;
1269 case scm_tc7_bvect:
1270 if (scm_is_false (obj))
1271 SCM_BITVEC_CLR(v, pos);
1272 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1273 SCM_BITVEC_SET(v, pos);
1274 else
1275 badobj:SCM_WRONG_TYPE_ARG (2, obj);
1276 break;
1277 case scm_tc7_string:
1278 SCM_ASRTGO (SCM_CHARP (obj), badobj);
1279 SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj);
1280 break;
1281 case scm_tc7_byvect:
1282 if (SCM_CHARP (obj))
1283 obj = SCM_I_MAKINUM ((char) SCM_CHAR (obj));
1284 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1285 ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1286 break;
1287 case scm_tc7_uvect:
1288 ((unsigned long *) SCM_UVECTOR_BASE (v))[pos]
1289 = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME);
1290 break;
1291 case scm_tc7_ivect:
1292 ((long *) SCM_UVECTOR_BASE (v))[pos]
1293 = scm_num2long (obj, SCM_ARG2, FUNC_NAME);
1294 break;
1295 case scm_tc7_svect:
1296 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1297 ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1298 break;
1299 #if SCM_SIZEOF_LONG_LONG != 0
1300 case scm_tc7_llvect:
1301 ((long long *) SCM_UVECTOR_BASE (v))[pos]
1302 = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
1303 break;
1304 #endif
1305 case scm_tc7_fvect:
1306 ((float *) SCM_UVECTOR_BASE (v))[pos]
1307 = (float) scm_num2dbl (obj, FUNC_NAME);
1308 break;
1309 case scm_tc7_dvect:
1310 ((double *) SCM_UVECTOR_BASE (v))[pos]
1311 = scm_num2dbl (obj, FUNC_NAME);
1312 break;
1313 case scm_tc7_cvect:
1314 SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
1315 if (SCM_REALP (obj)) {
1316 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
1317 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
1318 } else {
1319 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
1320 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
1321 }
1322 break;
1323 case scm_tc7_vector:
1324 case scm_tc7_wvect:
1325 SCM_VECTOR_SET (v, pos, obj);
1326 break;
1327 }
1328 return SCM_UNSPECIFIED;
1329 }
1330 #undef FUNC_NAME
1331
1332 /* attempts to unroll an array into a one-dimensional array.
1333 returns the unrolled array or #f if it can't be done. */
1334 /* if strict is not SCM_UNDEFINED, return #f if returned array
1335 wouldn't have contiguous elements. */
1336 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1337 (SCM ra, SCM strict),
1338 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1339 "without changing their order (last subscript changing fastest), then\n"
1340 "@code{array-contents} returns that shared array, otherwise it returns\n"
1341 "@code{#f}. All arrays made by @var{make-array} and\n"
1342 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1343 "@var{make-shared-array} may not be.\n\n"
1344 "If the optional argument @var{strict} is provided, a shared array will\n"
1345 "be returned only if its elements are stored internally contiguous in\n"
1346 "memory.")
1347 #define FUNC_NAME s_scm_array_contents
1348 {
1349 SCM sra;
1350 if (SCM_IMP (ra))
1351 return SCM_BOOL_F;
1352 switch SCM_TYP7 (ra)
1353 {
1354 default:
1355 return SCM_BOOL_F;
1356 case scm_tc7_vector:
1357 case scm_tc7_wvect:
1358 case scm_tc7_string:
1359 case scm_tc7_bvect:
1360 case scm_tc7_byvect:
1361 case scm_tc7_uvect:
1362 case scm_tc7_ivect:
1363 case scm_tc7_fvect:
1364 case scm_tc7_dvect:
1365 case scm_tc7_cvect:
1366 case scm_tc7_svect:
1367 #if SCM_SIZEOF_LONG_LONG != 0
1368 case scm_tc7_llvect:
1369 #endif
1370 return ra;
1371 case scm_tc7_smob:
1372 {
1373 size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1374 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1375 return SCM_BOOL_F;
1376 for (k = 0; k < ndim; k++)
1377 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1378 if (!SCM_UNBNDP (strict))
1379 {
1380 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1381 return SCM_BOOL_F;
1382 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1383 {
1384 if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
1385 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1386 len % SCM_LONG_BIT)
1387 return SCM_BOOL_F;
1388 }
1389 }
1390
1391 {
1392 SCM v = SCM_ARRAY_V (ra);
1393 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
1394 if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1395 return v;
1396 }
1397
1398 sra = scm_make_ra (1);
1399 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1400 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1401 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1402 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1403 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1404 return sra;
1405 }
1406 }
1407 }
1408 #undef FUNC_NAME
1409
1410
1411 SCM
1412 scm_ra2contig (SCM ra, int copy)
1413 {
1414 SCM ret;
1415 long inc = 1;
1416 size_t k, len = 1;
1417 for (k = SCM_ARRAY_NDIM (ra); k--;)
1418 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1419 k = SCM_ARRAY_NDIM (ra);
1420 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1421 {
1422 if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
1423 return ra;
1424 if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
1425 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1426 0 == len % SCM_LONG_BIT))
1427 return ra;
1428 }
1429 ret = scm_make_ra (k);
1430 SCM_ARRAY_BASE (ret) = 0;
1431 while (k--)
1432 {
1433 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1434 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1435 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1436 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1437 }
1438 SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra));
1439 if (copy)
1440 scm_array_copy_x (ra, ret);
1441 return ret;
1442 }
1443
1444
1445
1446 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1447 (SCM ra, SCM port_or_fd, SCM start, SCM end),
1448 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1449 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1450 "binary objects from @var{port-or-fdes}.\n"
1451 "If an end of file is encountered,\n"
1452 "the objects up to that point are put into @var{ura}\n"
1453 "(starting at the beginning) and the remainder of the array is\n"
1454 "unchanged.\n\n"
1455 "The optional arguments @var{start} and @var{end} allow\n"
1456 "a specified region of a vector (or linearized array) to be read,\n"
1457 "leaving the remainder of the vector unchanged.\n\n"
1458 "@code{uniform-array-read!} returns the number of objects read.\n"
1459 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1460 "returned by @code{(current-input-port)}.")
1461 #define FUNC_NAME s_scm_uniform_array_read_x
1462 {
1463 SCM cra = SCM_UNDEFINED, v = ra;
1464 long sz, vlen, ans;
1465 long cstart = 0;
1466 long cend;
1467 long offset = 0;
1468 char *base;
1469
1470 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1471 if (SCM_UNBNDP (port_or_fd))
1472 port_or_fd = scm_cur_inp;
1473 else
1474 SCM_ASSERT (SCM_INUMP (port_or_fd)
1475 || (SCM_OPINPORTP (port_or_fd)),
1476 port_or_fd, SCM_ARG2, FUNC_NAME);
1477 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1478 ? 0
1479 : SCM_INUM (scm_uniform_vector_length (v)));
1480
1481 loop:
1482 switch SCM_TYP7 (v)
1483 {
1484 default:
1485 badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1486 case scm_tc7_smob:
1487 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1488 cra = scm_ra2contig (ra, 0);
1489 cstart += SCM_ARRAY_BASE (cra);
1490 vlen = SCM_ARRAY_DIMS (cra)->inc *
1491 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1492 v = SCM_ARRAY_V (cra);
1493 goto loop;
1494 case scm_tc7_string:
1495 base = SCM_STRING_CHARS (v);
1496 sz = sizeof (char);
1497 break;
1498 case scm_tc7_bvect:
1499 base = (char *) SCM_BITVECTOR_BASE (v);
1500 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1501 cstart /= SCM_LONG_BIT;
1502 sz = sizeof (long);
1503 break;
1504 case scm_tc7_byvect:
1505 base = (char *) SCM_UVECTOR_BASE (v);
1506 sz = sizeof (char);
1507 break;
1508 case scm_tc7_uvect:
1509 case scm_tc7_ivect:
1510 base = (char *) SCM_UVECTOR_BASE (v);
1511 sz = sizeof (long);
1512 break;
1513 case scm_tc7_svect:
1514 base = (char *) SCM_UVECTOR_BASE (v);
1515 sz = sizeof (short);
1516 break;
1517 #if SCM_SIZEOF_LONG_LONG != 0
1518 case scm_tc7_llvect:
1519 base = (char *) SCM_UVECTOR_BASE (v);
1520 sz = sizeof (long long);
1521 break;
1522 #endif
1523 case scm_tc7_fvect:
1524 base = (char *) SCM_UVECTOR_BASE (v);
1525 sz = sizeof (float);
1526 break;
1527 case scm_tc7_dvect:
1528 base = (char *) SCM_UVECTOR_BASE (v);
1529 sz = sizeof (double);
1530 break;
1531 case scm_tc7_cvect:
1532 base = (char *) SCM_UVECTOR_BASE (v);
1533 sz = 2 * sizeof (double);
1534 break;
1535 }
1536
1537 cend = vlen;
1538 if (!SCM_UNBNDP (start))
1539 {
1540 offset =
1541 SCM_NUM2LONG (3, start);
1542
1543 if (offset < 0 || offset >= cend)
1544 scm_out_of_range (FUNC_NAME, start);
1545
1546 if (!SCM_UNBNDP (end))
1547 {
1548 long tend =
1549 SCM_NUM2LONG (4, end);
1550
1551 if (tend <= offset || tend > cend)
1552 scm_out_of_range (FUNC_NAME, end);
1553 cend = tend;
1554 }
1555 }
1556
1557 if (SCM_NIMP (port_or_fd))
1558 {
1559 scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
1560 int remaining = (cend - offset) * sz;
1561 char *dest = base + (cstart + offset) * sz;
1562
1563 if (pt->rw_active == SCM_PORT_WRITE)
1564 scm_flush (port_or_fd);
1565
1566 ans = cend - offset;
1567 while (remaining > 0)
1568 {
1569 if (pt->read_pos < pt->read_end)
1570 {
1571 int to_copy = min (pt->read_end - pt->read_pos,
1572 remaining);
1573
1574 memcpy (dest, pt->read_pos, to_copy);
1575 pt->read_pos += to_copy;
1576 remaining -= to_copy;
1577 dest += to_copy;
1578 }
1579 else
1580 {
1581 if (scm_fill_input (port_or_fd) == EOF)
1582 {
1583 if (remaining % sz != 0)
1584 {
1585 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
1586 }
1587 ans -= remaining / sz;
1588 break;
1589 }
1590 }
1591 }
1592
1593 if (pt->rw_random)
1594 pt->rw_active = SCM_PORT_READ;
1595 }
1596 else /* file descriptor. */
1597 {
1598 SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
1599 base + (cstart + offset) * sz,
1600 (sz * (cend - offset))));
1601 if (ans == -1)
1602 SCM_SYSERROR;
1603 }
1604 if (SCM_TYP7 (v) == scm_tc7_bvect)
1605 ans *= SCM_LONG_BIT;
1606
1607 if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
1608 scm_array_copy_x (cra, ra);
1609
1610 return SCM_I_MAKINUM (ans);
1611 }
1612 #undef FUNC_NAME
1613
1614 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1615 (SCM v, SCM port_or_fd, SCM start, SCM end),
1616 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1617 "Writes all elements of @var{ura} as binary objects to\n"
1618 "@var{port-or-fdes}.\n\n"
1619 "The optional arguments @var{start}\n"
1620 "and @var{end} allow\n"
1621 "a specified region of a vector (or linearized array) to be written.\n\n"
1622 "The number of objects actually written is returned.\n"
1623 "@var{port-or-fdes} may be\n"
1624 "omitted, in which case it defaults to the value returned by\n"
1625 "@code{(current-output-port)}.")
1626 #define FUNC_NAME s_scm_uniform_array_write
1627 {
1628 long sz, vlen, ans;
1629 long offset = 0;
1630 long cstart = 0;
1631 long cend;
1632 char *base;
1633
1634 port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
1635
1636 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1637 if (SCM_UNBNDP (port_or_fd))
1638 port_or_fd = scm_cur_outp;
1639 else
1640 SCM_ASSERT (SCM_INUMP (port_or_fd)
1641 || (SCM_OPOUTPORTP (port_or_fd)),
1642 port_or_fd, SCM_ARG2, FUNC_NAME);
1643 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1644 ? 0
1645 : SCM_INUM (scm_uniform_vector_length (v)));
1646
1647 loop:
1648 switch SCM_TYP7 (v)
1649 {
1650 default:
1651 badarg1:SCM_WRONG_TYPE_ARG (1, v);
1652 case scm_tc7_smob:
1653 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1654 v = scm_ra2contig (v, 1);
1655 cstart = SCM_ARRAY_BASE (v);
1656 vlen = (SCM_ARRAY_DIMS (v)->inc
1657 * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1));
1658 v = SCM_ARRAY_V (v);
1659 goto loop;
1660 case scm_tc7_string:
1661 base = SCM_STRING_CHARS (v);
1662 sz = sizeof (char);
1663 break;
1664 case scm_tc7_bvect:
1665 base = (char *) SCM_BITVECTOR_BASE (v);
1666 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1667 cstart /= SCM_LONG_BIT;
1668 sz = sizeof (long);
1669 break;
1670 case scm_tc7_byvect:
1671 base = (char *) SCM_UVECTOR_BASE (v);
1672 sz = sizeof (char);
1673 break;
1674 case scm_tc7_uvect:
1675 case scm_tc7_ivect:
1676 base = (char *) SCM_UVECTOR_BASE (v);
1677 sz = sizeof (long);
1678 break;
1679 case scm_tc7_svect:
1680 base = (char *) SCM_UVECTOR_BASE (v);
1681 sz = sizeof (short);
1682 break;
1683 #if SCM_SIZEOF_LONG_LONG != 0
1684 case scm_tc7_llvect:
1685 base = (char *) SCM_UVECTOR_BASE (v);
1686 sz = sizeof (long long);
1687 break;
1688 #endif
1689 case scm_tc7_fvect:
1690 base = (char *) SCM_UVECTOR_BASE (v);
1691 sz = sizeof (float);
1692 break;
1693 case scm_tc7_dvect:
1694 base = (char *) SCM_UVECTOR_BASE (v);
1695 sz = sizeof (double);
1696 break;
1697 case scm_tc7_cvect:
1698 base = (char *) SCM_UVECTOR_BASE (v);
1699 sz = 2 * sizeof (double);
1700 break;
1701 }
1702
1703 cend = vlen;
1704 if (!SCM_UNBNDP (start))
1705 {
1706 offset =
1707 SCM_NUM2LONG (3, start);
1708
1709 if (offset < 0 || offset >= cend)
1710 scm_out_of_range (FUNC_NAME, start);
1711
1712 if (!SCM_UNBNDP (end))
1713 {
1714 long tend =
1715 SCM_NUM2LONG (4, end);
1716
1717 if (tend <= offset || tend > cend)
1718 scm_out_of_range (FUNC_NAME, end);
1719 cend = tend;
1720 }
1721 }
1722
1723 if (SCM_NIMP (port_or_fd))
1724 {
1725 char *source = base + (cstart + offset) * sz;
1726
1727 ans = cend - offset;
1728 scm_lfwrite (source, ans * sz, port_or_fd);
1729 }
1730 else /* file descriptor. */
1731 {
1732 SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
1733 base + (cstart + offset) * sz,
1734 (sz * (cend - offset))));
1735 if (ans == -1)
1736 SCM_SYSERROR;
1737 }
1738 if (SCM_TYP7 (v) == scm_tc7_bvect)
1739 ans *= SCM_LONG_BIT;
1740
1741 return SCM_I_MAKINUM (ans);
1742 }
1743 #undef FUNC_NAME
1744
1745
1746 static char cnt_tab[16] =
1747 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1748
1749 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1750 (SCM b, SCM bitvector),
1751 "Return the number of occurrences of the boolean @var{b} in\n"
1752 "@var{bitvector}.")
1753 #define FUNC_NAME s_scm_bit_count
1754 {
1755 SCM_VALIDATE_BOOL (1, b);
1756 SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
1757 if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
1758 return SCM_INUM0;
1759 } else {
1760 unsigned long int count = 0;
1761 unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
1762 unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1763 if (scm_is_false (b)) {
1764 w = ~w;
1765 };
1766 w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
1767 while (1) {
1768 while (w) {
1769 count += cnt_tab[w & 0x0f];
1770 w >>= 4;
1771 }
1772 if (i == 0) {
1773 return SCM_I_MAKINUM (count);
1774 } else {
1775 --i;
1776 w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1777 if (scm_is_false (b)) {
1778 w = ~w;
1779 }
1780 }
1781 }
1782 }
1783 }
1784 #undef FUNC_NAME
1785
1786
1787 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1788 (SCM item, SCM v, SCM k),
1789 "Return the index of the first occurrance of @var{item} in bit\n"
1790 "vector @var{v}, starting from @var{k}. If there is no\n"
1791 "@var{item} entry between @var{k} and the end of\n"
1792 "@var{bitvector}, then return @code{#f}. For example,\n"
1793 "\n"
1794 "@example\n"
1795 "(bit-position #t #*000101 0) @result{} 3\n"
1796 "(bit-position #f #*0001111 3) @result{} #f\n"
1797 "@end example")
1798 #define FUNC_NAME s_scm_bit_position
1799 {
1800 long i, lenw, xbits, pos;
1801 register unsigned long w;
1802
1803 SCM_VALIDATE_BOOL (1, item);
1804 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
1805 pos = scm_to_long (k);
1806 SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
1807
1808 if (pos == SCM_BITVECTOR_LENGTH (v))
1809 return SCM_BOOL_F;
1810
1811 lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1812 i = pos / SCM_LONG_BIT;
1813 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1814 if (scm_is_false (item))
1815 w = ~w;
1816 xbits = (pos % SCM_LONG_BIT);
1817 pos -= xbits;
1818 w = ((w >> xbits) << xbits);
1819 xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
1820 while (!0)
1821 {
1822 if (w && (i == lenw))
1823 w = ((w << xbits) >> xbits);
1824 if (w)
1825 while (w)
1826 switch (w & 0x0f)
1827 {
1828 default:
1829 return SCM_I_MAKINUM (pos);
1830 case 2:
1831 case 6:
1832 case 10:
1833 case 14:
1834 return SCM_I_MAKINUM (pos + 1);
1835 case 4:
1836 case 12:
1837 return SCM_I_MAKINUM (pos + 2);
1838 case 8:
1839 return SCM_I_MAKINUM (pos + 3);
1840 case 0:
1841 pos += 4;
1842 w >>= 4;
1843 }
1844 if (++i > lenw)
1845 break;
1846 pos += SCM_LONG_BIT;
1847 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1848 if (scm_is_false (item))
1849 w = ~w;
1850 }
1851 return SCM_BOOL_F;
1852 }
1853 #undef FUNC_NAME
1854
1855
1856 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1857 (SCM v, SCM kv, SCM obj),
1858 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1859 "selecting the entries to change. The return value is\n"
1860 "unspecified.\n"
1861 "\n"
1862 "If @var{kv} is a bit vector, then those entries where it has\n"
1863 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1864 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1865 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1866 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1867 "\n"
1868 "@example\n"
1869 "(define bv #*01000010)\n"
1870 "(bit-set*! bv #*10010001 #t)\n"
1871 "bv\n"
1872 "@result{} #*11010011\n"
1873 "@end example\n"
1874 "\n"
1875 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1876 "they're indexes into @var{v} which are set to @var{obj}.\n"
1877 "\n"
1878 "@example\n"
1879 "(define bv #*01000010)\n"
1880 "(bit-set*! bv #u(5 2 7) #t)\n"
1881 "bv\n"
1882 "@result{} #*01100111\n"
1883 "@end example")
1884 #define FUNC_NAME s_scm_bit_set_star_x
1885 {
1886 register long i, k, vlen;
1887 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1888 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1889 switch SCM_TYP7 (kv)
1890 {
1891 default:
1892 badarg2:SCM_WRONG_TYPE_ARG (2, kv);
1893 case scm_tc7_uvect:
1894 vlen = SCM_BITVECTOR_LENGTH (v);
1895 if (scm_is_false (obj))
1896 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1897 {
1898 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1899 if (k >= vlen)
1900 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k));
1901 SCM_BITVEC_CLR(v, k);
1902 }
1903 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1904 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1905 {
1906 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1907 if (k >= vlen)
1908 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k));
1909 SCM_BITVEC_SET(v, k);
1910 }
1911 else
1912 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1913 break;
1914 case scm_tc7_bvect:
1915 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1916 if (scm_is_false (obj))
1917 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1918 SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
1919 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1920 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1921 SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
1922 else
1923 goto badarg3;
1924 break;
1925 }
1926 return SCM_UNSPECIFIED;
1927 }
1928 #undef FUNC_NAME
1929
1930
1931 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
1932 (SCM v, SCM kv, SCM obj),
1933 "Return a count of how many entries in bit vector @var{v} are\n"
1934 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1935 "consider.\n"
1936 "\n"
1937 "If @var{kv} is a bit vector, then those entries where it has\n"
1938 "@code{#t} are the ones in @var{v} which are considered.\n"
1939 "@var{kv} and @var{v} must be the same length.\n"
1940 "\n"
1941 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1942 "it's the indexes in @var{v} to consider.\n"
1943 "\n"
1944 "For example,\n"
1945 "\n"
1946 "@example\n"
1947 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1948 "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n"
1949 "@end example")
1950 #define FUNC_NAME s_scm_bit_count_star
1951 {
1952 register long i, vlen, count = 0;
1953 register unsigned long k;
1954 int fObj = 0;
1955
1956 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1957 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1958 switch SCM_TYP7 (kv)
1959 {
1960 default:
1961 badarg2:
1962 SCM_WRONG_TYPE_ARG (2, kv);
1963 case scm_tc7_uvect:
1964 vlen = SCM_BITVECTOR_LENGTH (v);
1965 if (scm_is_false (obj))
1966 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1967 {
1968 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1969 if (k >= vlen)
1970 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k));
1971 if (!SCM_BITVEC_REF(v, k))
1972 count++;
1973 }
1974 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1975 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1976 {
1977 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1978 if (k >= vlen)
1979 scm_out_of_range (FUNC_NAME, SCM_I_MAKINUM (k));
1980 if (SCM_BITVEC_REF (v, k))
1981 count++;
1982 }
1983 else
1984 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1985 break;
1986 case scm_tc7_bvect:
1987 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1988 if (0 == SCM_BITVECTOR_LENGTH (v))
1989 return SCM_INUM0;
1990 SCM_ASRTGO (scm_is_bool (obj), badarg3);
1991 fObj = SCM_EQ_P (obj, SCM_BOOL_T);
1992 i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
1993 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
1994 k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
1995 while (1)
1996 {
1997 for (; k; k >>= 4)
1998 count += cnt_tab[k & 0x0f];
1999 if (0 == i--)
2000 return SCM_I_MAKINUM (count);
2001
2002 /* urg. repetitive (see above.) */
2003 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
2004 }
2005 }
2006 return SCM_I_MAKINUM (count);
2007 }
2008 #undef FUNC_NAME
2009
2010
2011 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
2012 (SCM v),
2013 "Modify the bit vector @var{v} by replacing each element with\n"
2014 "its negation.")
2015 #define FUNC_NAME s_scm_bit_invert_x
2016 {
2017 long int k;
2018
2019 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
2020
2021 k = SCM_BITVECTOR_LENGTH (v);
2022 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
2023 SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
2024
2025 return SCM_UNSPECIFIED;
2026 }
2027 #undef FUNC_NAME
2028
2029
2030 SCM
2031 scm_istr2bve (char *str, long len)
2032 {
2033 SCM v = scm_make_uve (len, SCM_BOOL_T);
2034 long *data = (long *) SCM_VELTS (v);
2035 register unsigned long mask;
2036 register long k;
2037 register long j;
2038 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
2039 {
2040 data[k] = 0L;
2041 j = len - k * SCM_LONG_BIT;
2042 if (j > SCM_LONG_BIT)
2043 j = SCM_LONG_BIT;
2044 for (mask = 1L; j--; mask <<= 1)
2045 switch (*str++)
2046 {
2047 case '0':
2048 break;
2049 case '1':
2050 data[k] |= mask;
2051 break;
2052 default:
2053 return SCM_BOOL_F;
2054 }
2055 }
2056 return v;
2057 }
2058
2059
2060
2061 static SCM
2062 ra2l (SCM ra, unsigned long base, unsigned long k)
2063 {
2064 register SCM res = SCM_EOL;
2065 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2066 register size_t i;
2067 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
2068 return SCM_EOL;
2069 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
2070 if (k < SCM_ARRAY_NDIM (ra) - 1)
2071 {
2072 do
2073 {
2074 i -= inc;
2075 res = scm_cons (ra2l (ra, i, k + 1), res);
2076 }
2077 while (i != base);
2078 }
2079 else
2080 do
2081 {
2082 i -= inc;
2083 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_I_MAKINUM (i)), res);
2084 }
2085 while (i != base);
2086 return res;
2087 }
2088
2089
2090 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
2091 (SCM v),
2092 "Return a list consisting of all the elements, in order, of\n"
2093 "@var{array}.")
2094 #define FUNC_NAME s_scm_array_to_list
2095 {
2096 SCM res = SCM_EOL;
2097 register long k;
2098 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2099 switch SCM_TYP7 (v)
2100 {
2101 default:
2102 badarg1:SCM_WRONG_TYPE_ARG (1, v);
2103 case scm_tc7_smob:
2104 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2105 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2106 case scm_tc7_vector:
2107 case scm_tc7_wvect:
2108 return scm_vector_to_list (v);
2109 case scm_tc7_string:
2110 return scm_string_to_list (v);
2111 case scm_tc7_bvect:
2112 {
2113 long *data = (long *) SCM_VELTS (v);
2114 register unsigned long mask;
2115 for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
2116 for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
2117 res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
2118 for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2119 res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
2120 return res;
2121 }
2122 case scm_tc7_byvect:
2123 {
2124 signed char *data = (signed char *) SCM_VELTS (v);
2125 unsigned long k = SCM_UVECTOR_LENGTH (v);
2126 while (k != 0)
2127 res = scm_cons (SCM_I_MAKINUM (data[--k]), res);
2128 return res;
2129 }
2130 case scm_tc7_uvect:
2131 {
2132 long *data = (long *)SCM_VELTS(v);
2133 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2134 res = scm_cons(scm_ulong2num(data[k]), res);
2135 return res;
2136 }
2137 case scm_tc7_ivect:
2138 {
2139 long *data = (long *)SCM_VELTS(v);
2140 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2141 res = scm_cons(scm_long2num(data[k]), res);
2142 return res;
2143 }
2144 case scm_tc7_svect:
2145 {
2146 short *data = (short *)SCM_VELTS(v);
2147 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2148 res = scm_cons(scm_short2num (data[k]), res);
2149 return res;
2150 }
2151 #if SCM_SIZEOF_LONG_LONG != 0
2152 case scm_tc7_llvect:
2153 {
2154 long long *data = (long long *)SCM_VELTS(v);
2155 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2156 res = scm_cons(scm_long_long2num(data[k]), res);
2157 return res;
2158 }
2159 #endif
2160 case scm_tc7_fvect:
2161 {
2162 float *data = (float *) SCM_VELTS (v);
2163 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2164 res = scm_cons (scm_make_real (data[k]), res);
2165 return res;
2166 }
2167 case scm_tc7_dvect:
2168 {
2169 double *data = (double *) SCM_VELTS (v);
2170 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2171 res = scm_cons (scm_make_real (data[k]), res);
2172 return res;
2173 }
2174 case scm_tc7_cvect:
2175 {
2176 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2177 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2178 res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
2179 return res;
2180 }
2181 }
2182 }
2183 #undef FUNC_NAME
2184
2185
2186 static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
2187
2188 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2189 (SCM ndim, SCM prot, SCM lst),
2190 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2191 "Return a uniform array of the type indicated by prototype\n"
2192 "@var{prot} with elements the same as those of @var{lst}.\n"
2193 "Elements must be of the appropriate type, no coercions are\n"
2194 "done.")
2195 #define FUNC_NAME s_scm_list_to_uniform_array
2196 {
2197 SCM shp = SCM_EOL;
2198 SCM row = lst;
2199 SCM ra;
2200 unsigned long k;
2201 long n;
2202 k = scm_to_ulong (ndim);
2203 while (k--)
2204 {
2205 n = scm_ilength (row);
2206 SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
2207 shp = scm_cons (SCM_I_MAKINUM (n), shp);
2208 if (SCM_NIMP (row))
2209 row = SCM_CAR (row);
2210 }
2211 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
2212 SCM_UNDEFINED);
2213 if (SCM_NULLP (shp))
2214 {
2215 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2216 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2217 return ra;
2218 }
2219 if (!SCM_ARRAYP (ra))
2220 {
2221 unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
2222 for (k = 0; k < length; k++, lst = SCM_CDR (lst))
2223 scm_array_set_x (ra, SCM_CAR (lst), SCM_I_MAKINUM (k));
2224 return ra;
2225 }
2226 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2227 return ra;
2228 else
2229 badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2230 scm_list_1 (lst));
2231 }
2232 #undef FUNC_NAME
2233
2234 static int
2235 l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
2236 {
2237 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2238 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2239 int ok = 1;
2240 if (n <= 0)
2241 return (SCM_NULLP (lst));
2242 if (k < SCM_ARRAY_NDIM (ra) - 1)
2243 {
2244 while (n--)
2245 {
2246 if (!SCM_CONSP (lst))
2247 return 0;
2248 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2249 base += inc;
2250 lst = SCM_CDR (lst);
2251 }
2252 if (!SCM_NULLP (lst))
2253 return 0;
2254 }
2255 else
2256 {
2257 while (n--)
2258 {
2259 if (!SCM_CONSP (lst))
2260 return 0;
2261 scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_I_MAKINUM (base));
2262 base += inc;
2263 lst = SCM_CDR (lst);
2264 }
2265 if (!SCM_NULLP (lst))
2266 return 0;
2267 }
2268 return ok;
2269 }
2270
2271
2272 static void
2273 rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
2274 {
2275 long inc = 1;
2276 long n = (SCM_TYP7 (ra) == scm_tc7_smob
2277 ? 0
2278 : SCM_INUM (scm_uniform_vector_length (ra)));
2279 int enclosed = 0;
2280 tail:
2281 switch SCM_TYP7 (ra)
2282 {
2283 case scm_tc7_smob:
2284 if (enclosed++)
2285 {
2286 SCM_ARRAY_BASE (ra) = j;
2287 if (n-- > 0)
2288 scm_iprin1 (ra, port, pstate);
2289 for (j += inc; n-- > 0; j += inc)
2290 {
2291 scm_putc (' ', port);
2292 SCM_ARRAY_BASE (ra) = j;
2293 scm_iprin1 (ra, port, pstate);
2294 }
2295 break;
2296 }
2297 if (k + 1 < SCM_ARRAY_NDIM (ra))
2298 {
2299 long i;
2300 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2301 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2302 {
2303 scm_putc ('(', port);
2304 rapr1 (ra, j, k + 1, port, pstate);
2305 scm_puts (") ", port);
2306 j += inc;
2307 }
2308 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2309 { /* could be zero size. */
2310 scm_putc ('(', port);
2311 rapr1 (ra, j, k + 1, port, pstate);
2312 scm_putc (')', port);
2313 }
2314 break;
2315 }
2316 if (SCM_ARRAY_NDIM (ra) > 0)
2317 { /* Could be zero-dimensional */
2318 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2319 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2320 }
2321 else
2322 n = 1;
2323 ra = SCM_ARRAY_V (ra);
2324 goto tail;
2325 default:
2326 /* scm_tc7_bvect and scm_tc7_llvect only? */
2327 if (n-- > 0)
2328 scm_iprin1 (scm_uniform_vector_ref (ra, SCM_I_MAKINUM (j)), port, pstate);
2329 for (j += inc; n-- > 0; j += inc)
2330 {
2331 scm_putc (' ', port);
2332 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
2333 }
2334 break;
2335 case scm_tc7_string:
2336 if (n-- > 0)
2337 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2338 if (SCM_WRITINGP (pstate))
2339 for (j += inc; n-- > 0; j += inc)
2340 {
2341 scm_putc (' ', port);
2342 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2343 }
2344 else
2345 for (j += inc; n-- > 0; j += inc)
2346 scm_putc (SCM_STRING_CHARS (ra)[j], port);
2347 break;
2348 case scm_tc7_byvect:
2349 if (n-- > 0)
2350 scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2351 for (j += inc; n-- > 0; j += inc)
2352 {
2353 scm_putc (' ', port);
2354 scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
2355 }
2356 break;
2357
2358 case scm_tc7_uvect:
2359 {
2360 char str[11];
2361
2362 if (n-- > 0)
2363 {
2364 /* intprint can't handle >= 2^31. */
2365 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2366 scm_puts (str, port);
2367 }
2368 for (j += inc; n-- > 0; j += inc)
2369 {
2370 scm_putc (' ', port);
2371 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2372 scm_puts (str, port);
2373 }
2374 }
2375 case scm_tc7_ivect:
2376 if (n-- > 0)
2377 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2378 for (j += inc; n-- > 0; j += inc)
2379 {
2380 scm_putc (' ', port);
2381 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2382 }
2383 break;
2384
2385 case scm_tc7_svect:
2386 if (n-- > 0)
2387 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2388 for (j += inc; n-- > 0; j += inc)
2389 {
2390 scm_putc (' ', port);
2391 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2392 }
2393 break;
2394
2395 case scm_tc7_fvect:
2396 if (n-- > 0)
2397 {
2398 SCM z = scm_make_real (1.0);
2399 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2400 scm_print_real (z, port, pstate);
2401 for (j += inc; n-- > 0; j += inc)
2402 {
2403 scm_putc (' ', port);
2404 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2405 scm_print_real (z, port, pstate);
2406 }
2407 }
2408 break;
2409 case scm_tc7_dvect:
2410 if (n-- > 0)
2411 {
2412 SCM z = scm_make_real (1.0 / 3.0);
2413 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2414 scm_print_real (z, port, pstate);
2415 for (j += inc; n-- > 0; j += inc)
2416 {
2417 scm_putc (' ', port);
2418 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2419 scm_print_real (z, port, pstate);
2420 }
2421 }
2422 break;
2423 case scm_tc7_cvect:
2424 if (n-- > 0)
2425 {
2426 SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0);
2427 SCM_REAL_VALUE (z) =
2428 SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2429 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2430 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2431 port, pstate);
2432 for (j += inc; n-- > 0; j += inc)
2433 {
2434 scm_putc (' ', port);
2435 SCM_REAL_VALUE (z)
2436 = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2437 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2438 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2439 port, pstate);
2440 }
2441 }
2442 break;
2443 }
2444 }
2445
2446
2447
2448 int
2449 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2450 {
2451 SCM v = exp;
2452 unsigned long base = 0;
2453 scm_putc ('#', port);
2454 tail:
2455 switch SCM_TYP7 (v)
2456 {
2457 case scm_tc7_smob:
2458 {
2459 long ndim = SCM_ARRAY_NDIM (v);
2460 base = SCM_ARRAY_BASE (v);
2461 v = SCM_ARRAY_V (v);
2462 if (SCM_ARRAYP (v))
2463
2464 {
2465 scm_puts ("<enclosed-array ", port);
2466 rapr1 (exp, base, 0, port, pstate);
2467 scm_putc ('>', port);
2468 return 1;
2469 }
2470 else
2471 {
2472 scm_intprint (ndim, 10, port);
2473 goto tail;
2474 }
2475 }
2476 case scm_tc7_bvect:
2477 if (SCM_EQ_P (exp, v))
2478 { /* a uve, not an scm_array */
2479 register long i, j, w;
2480 scm_putc ('*', port);
2481 for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
2482 {
2483 scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
2484 for (j = SCM_LONG_BIT; j; j--)
2485 {
2486 scm_putc (w & 1 ? '1' : '0', port);
2487 w >>= 1;
2488 }
2489 }
2490 j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
2491 if (j)
2492 {
2493 w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
2494 for (; j; j--)
2495 {
2496 scm_putc (w & 1 ? '1' : '0', port);
2497 w >>= 1;
2498 }
2499 }
2500 return 1;
2501 }
2502 else
2503 scm_putc ('b', port);
2504 break;
2505 case scm_tc7_string:
2506 scm_putc ('a', port);
2507 break;
2508 case scm_tc7_byvect:
2509 scm_putc ('y', port);
2510 break;
2511 case scm_tc7_uvect:
2512 scm_putc ('u', port);
2513 break;
2514 case scm_tc7_ivect:
2515 scm_putc ('e', port);
2516 break;
2517 case scm_tc7_svect:
2518 scm_putc ('h', port);
2519 break;
2520 #if SCM_SIZEOF_LONG_LONG != 0
2521 case scm_tc7_llvect:
2522 scm_putc ('l', port);
2523 break;
2524 #endif
2525 case scm_tc7_fvect:
2526 scm_putc ('s', port);
2527 break;
2528 case scm_tc7_dvect:
2529 scm_putc ('i', port);
2530 break;
2531 case scm_tc7_cvect:
2532 scm_putc ('c', port);
2533 break;
2534 }
2535 scm_putc ('(', port);
2536 rapr1 (exp, base, 0, port, pstate);
2537 scm_putc (')', port);
2538 return 1;
2539 }
2540
2541 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2542 (SCM ra),
2543 "Return an object that would produce an array of the same type\n"
2544 "as @var{array}, if used as the @var{prototype} for\n"
2545 "@code{make-uniform-array}.")
2546 #define FUNC_NAME s_scm_array_prototype
2547 {
2548 int enclosed = 0;
2549 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2550 loop:
2551 switch SCM_TYP7 (ra)
2552 {
2553 default:
2554 badarg:SCM_WRONG_TYPE_ARG (1, ra);
2555 case scm_tc7_smob:
2556 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2557 if (enclosed++)
2558 return SCM_UNSPECIFIED;
2559 ra = SCM_ARRAY_V (ra);
2560 goto loop;
2561 case scm_tc7_vector:
2562 case scm_tc7_wvect:
2563 return SCM_EOL;
2564 case scm_tc7_bvect:
2565 return SCM_BOOL_T;
2566 case scm_tc7_string:
2567 return SCM_MAKE_CHAR ('a');
2568 case scm_tc7_byvect:
2569 return SCM_MAKE_CHAR ('\0');
2570 case scm_tc7_uvect:
2571 return SCM_I_MAKINUM (1L);
2572 case scm_tc7_ivect:
2573 return SCM_I_MAKINUM (-1L);
2574 case scm_tc7_svect:
2575 return scm_str2symbol ("s");
2576 #if SCM_SIZEOF_LONG_LONG != 0
2577 case scm_tc7_llvect:
2578 return scm_str2symbol ("l");
2579 #endif
2580 case scm_tc7_fvect:
2581 return scm_make_real (1.0);
2582 case scm_tc7_dvect:
2583 return exactly_one_third;
2584 case scm_tc7_cvect:
2585 return scm_make_complex (0.0, 1.0);
2586 }
2587 }
2588 #undef FUNC_NAME
2589
2590
2591 static SCM
2592 array_mark (SCM ptr)
2593 {
2594 return SCM_ARRAY_V (ptr);
2595 }
2596
2597
2598 static size_t
2599 array_free (SCM ptr)
2600 {
2601 scm_gc_free (SCM_ARRAY_MEM (ptr),
2602 (sizeof (scm_t_array)
2603 + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
2604 "array");
2605 return 0;
2606 }
2607
2608 void
2609 scm_init_unif ()
2610 {
2611 scm_tc16_array = scm_make_smob_type ("array", 0);
2612 scm_set_smob_mark (scm_tc16_array, array_mark);
2613 scm_set_smob_free (scm_tc16_array, array_free);
2614 scm_set_smob_print (scm_tc16_array, scm_raprin1);
2615 scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
2616 exactly_one_third = scm_permanent_object (scm_make_ratio (SCM_I_MAKINUM (1),
2617 SCM_I_MAKINUM (3)));
2618 scm_add_feature ("array");
2619 #include "libguile/unif.x"
2620 }
2621
2622 /*
2623 Local Variables:
2624 c-file-style: "gnu"
2625 End:
2626 */
Unnamed repository; edit this file 'description' to name the repository.