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