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