HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
(scm_make_complex): Discouraged by moving to discouraged.h and
[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_from_long (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, scm_from_long (k),
161 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_from_double (((float *) SCM_CELL_WORD_1 (v))[pos]);
1129 case scm_tc7_dvect:
1130 return scm_from_double (((double *) SCM_CELL_WORD_1 (v))[pos]);
1131 case scm_tc7_cvect:
1132 return scm_c_make_rectangular (((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_from_double (((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_from_double (((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_c_make_rectangular (((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] = scm_to_ulong (obj);
1281 break;
1282 case scm_tc7_ivect:
1283 ((long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_long (obj);
1284 break;
1285 case scm_tc7_svect:
1286 ((short *) SCM_UVECTOR_BASE (v))[pos] = scm_to_short (obj);
1287 break;
1288 #if SCM_SIZEOF_LONG_LONG != 0
1289 case scm_tc7_llvect:
1290 ((long long *) SCM_UVECTOR_BASE (v))[pos] = scm_to_long_long (obj);
1291 break;
1292 #endif
1293 case scm_tc7_fvect:
1294 ((float *) SCM_UVECTOR_BASE (v))[pos] = scm_to_double (obj);
1295 break;
1296 case scm_tc7_dvect:
1297 ((double *) SCM_UVECTOR_BASE (v))[pos] = scm_to_double (obj);
1298 break;
1299 case scm_tc7_cvect:
1300 SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
1301 if (SCM_REALP (obj)) {
1302 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
1303 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
1304 } else {
1305 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
1306 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
1307 }
1308 break;
1309 case scm_tc7_vector:
1310 case scm_tc7_wvect:
1311 SCM_VECTOR_SET (v, pos, obj);
1312 break;
1313 }
1314 return SCM_UNSPECIFIED;
1315 }
1316 #undef FUNC_NAME
1317
1318 /* attempts to unroll an array into a one-dimensional array.
1319 returns the unrolled array or #f if it can't be done. */
1320 /* if strict is not SCM_UNDEFINED, return #f if returned array
1321 wouldn't have contiguous elements. */
1322 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1323 (SCM ra, SCM strict),
1324 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1325 "without changing their order (last subscript changing fastest), then\n"
1326 "@code{array-contents} returns that shared array, otherwise it returns\n"
1327 "@code{#f}. All arrays made by @var{make-array} and\n"
1328 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1329 "@var{make-shared-array} may not be.\n\n"
1330 "If the optional argument @var{strict} is provided, a shared array will\n"
1331 "be returned only if its elements are stored internally contiguous in\n"
1332 "memory.")
1333 #define FUNC_NAME s_scm_array_contents
1334 {
1335 SCM sra;
1336 if (SCM_IMP (ra))
1337 return SCM_BOOL_F;
1338 switch SCM_TYP7 (ra)
1339 {
1340 default:
1341 return SCM_BOOL_F;
1342 case scm_tc7_vector:
1343 case scm_tc7_wvect:
1344 case scm_tc7_string:
1345 case scm_tc7_bvect:
1346 case scm_tc7_byvect:
1347 case scm_tc7_uvect:
1348 case scm_tc7_ivect:
1349 case scm_tc7_fvect:
1350 case scm_tc7_dvect:
1351 case scm_tc7_cvect:
1352 case scm_tc7_svect:
1353 #if SCM_SIZEOF_LONG_LONG != 0
1354 case scm_tc7_llvect:
1355 #endif
1356 return ra;
1357 case scm_tc7_smob:
1358 {
1359 size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1360 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1361 return SCM_BOOL_F;
1362 for (k = 0; k < ndim; k++)
1363 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1364 if (!SCM_UNBNDP (strict))
1365 {
1366 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1367 return SCM_BOOL_F;
1368 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1369 {
1370 if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
1371 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1372 len % SCM_LONG_BIT)
1373 return SCM_BOOL_F;
1374 }
1375 }
1376
1377 {
1378 SCM v = SCM_ARRAY_V (ra);
1379 unsigned long length = scm_to_ulong (scm_uniform_vector_length (v));
1380 if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1381 return v;
1382 }
1383
1384 sra = scm_make_ra (1);
1385 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1386 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1387 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1388 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1389 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1390 return sra;
1391 }
1392 }
1393 }
1394 #undef FUNC_NAME
1395
1396
1397 SCM
1398 scm_ra2contig (SCM ra, int copy)
1399 {
1400 SCM ret;
1401 long inc = 1;
1402 size_t k, len = 1;
1403 for (k = SCM_ARRAY_NDIM (ra); k--;)
1404 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1405 k = SCM_ARRAY_NDIM (ra);
1406 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1407 {
1408 if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
1409 return ra;
1410 if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
1411 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1412 0 == len % SCM_LONG_BIT))
1413 return ra;
1414 }
1415 ret = scm_make_ra (k);
1416 SCM_ARRAY_BASE (ret) = 0;
1417 while (k--)
1418 {
1419 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1420 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1421 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1422 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1423 }
1424 SCM_ARRAY_V (ret) = scm_make_uve (inc, scm_array_prototype (ra));
1425 if (copy)
1426 scm_array_copy_x (ra, ret);
1427 return ret;
1428 }
1429
1430
1431
1432 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1433 (SCM ra, SCM port_or_fd, SCM start, SCM end),
1434 "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1435 "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
1436 "binary objects from @var{port-or-fdes}.\n"
1437 "If an end of file is encountered,\n"
1438 "the objects up to that point are put into @var{ura}\n"
1439 "(starting at the beginning) and the remainder of the array is\n"
1440 "unchanged.\n\n"
1441 "The optional arguments @var{start} and @var{end} allow\n"
1442 "a specified region of a vector (or linearized array) to be read,\n"
1443 "leaving the remainder of the vector unchanged.\n\n"
1444 "@code{uniform-array-read!} returns the number of objects read.\n"
1445 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1446 "returned by @code{(current-input-port)}.")
1447 #define FUNC_NAME s_scm_uniform_array_read_x
1448 {
1449 SCM cra = SCM_UNDEFINED, v = ra;
1450 long sz, vlen, ans;
1451 long cstart = 0;
1452 long cend;
1453 long offset = 0;
1454 char *base;
1455
1456 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1457 if (SCM_UNBNDP (port_or_fd))
1458 port_or_fd = scm_cur_inp;
1459 else
1460 SCM_ASSERT (scm_is_integer (port_or_fd)
1461 || (SCM_OPINPORTP (port_or_fd)),
1462 port_or_fd, SCM_ARG2, FUNC_NAME);
1463 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1464 ? 0
1465 : scm_to_long (scm_uniform_vector_length (v)));
1466
1467 loop:
1468 switch SCM_TYP7 (v)
1469 {
1470 default:
1471 badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1472 case scm_tc7_smob:
1473 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1474 cra = scm_ra2contig (ra, 0);
1475 cstart += SCM_ARRAY_BASE (cra);
1476 vlen = SCM_ARRAY_DIMS (cra)->inc *
1477 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1478 v = SCM_ARRAY_V (cra);
1479 goto loop;
1480 case scm_tc7_string:
1481 base = SCM_STRING_CHARS (v);
1482 sz = sizeof (char);
1483 break;
1484 case scm_tc7_bvect:
1485 base = (char *) SCM_BITVECTOR_BASE (v);
1486 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1487 cstart /= SCM_LONG_BIT;
1488 sz = sizeof (long);
1489 break;
1490 case scm_tc7_byvect:
1491 base = (char *) SCM_UVECTOR_BASE (v);
1492 sz = sizeof (char);
1493 break;
1494 case scm_tc7_uvect:
1495 case scm_tc7_ivect:
1496 base = (char *) SCM_UVECTOR_BASE (v);
1497 sz = sizeof (long);
1498 break;
1499 case scm_tc7_svect:
1500 base = (char *) SCM_UVECTOR_BASE (v);
1501 sz = sizeof (short);
1502 break;
1503 #if SCM_SIZEOF_LONG_LONG != 0
1504 case scm_tc7_llvect:
1505 base = (char *) SCM_UVECTOR_BASE (v);
1506 sz = sizeof (long long);
1507 break;
1508 #endif
1509 case scm_tc7_fvect:
1510 base = (char *) SCM_UVECTOR_BASE (v);
1511 sz = sizeof (float);
1512 break;
1513 case scm_tc7_dvect:
1514 base = (char *) SCM_UVECTOR_BASE (v);
1515 sz = sizeof (double);
1516 break;
1517 case scm_tc7_cvect:
1518 base = (char *) SCM_UVECTOR_BASE (v);
1519 sz = 2 * sizeof (double);
1520 break;
1521 }
1522
1523 cend = vlen;
1524 if (!SCM_UNBNDP (start))
1525 {
1526 offset =
1527 SCM_NUM2LONG (3, start);
1528
1529 if (offset < 0 || offset >= cend)
1530 scm_out_of_range (FUNC_NAME, start);
1531
1532 if (!SCM_UNBNDP (end))
1533 {
1534 long tend =
1535 SCM_NUM2LONG (4, end);
1536
1537 if (tend <= offset || tend > cend)
1538 scm_out_of_range (FUNC_NAME, end);
1539 cend = tend;
1540 }
1541 }
1542
1543 if (SCM_NIMP (port_or_fd))
1544 {
1545 scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
1546 int remaining = (cend - offset) * sz;
1547 char *dest = base + (cstart + offset) * sz;
1548
1549 if (pt->rw_active == SCM_PORT_WRITE)
1550 scm_flush (port_or_fd);
1551
1552 ans = cend - offset;
1553 while (remaining > 0)
1554 {
1555 if (pt->read_pos < pt->read_end)
1556 {
1557 int to_copy = min (pt->read_end - pt->read_pos,
1558 remaining);
1559
1560 memcpy (dest, pt->read_pos, to_copy);
1561 pt->read_pos += to_copy;
1562 remaining -= to_copy;
1563 dest += to_copy;
1564 }
1565 else
1566 {
1567 if (scm_fill_input (port_or_fd) == EOF)
1568 {
1569 if (remaining % sz != 0)
1570 {
1571 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
1572 }
1573 ans -= remaining / sz;
1574 break;
1575 }
1576 }
1577 }
1578
1579 if (pt->rw_random)
1580 pt->rw_active = SCM_PORT_READ;
1581 }
1582 else /* file descriptor. */
1583 {
1584 SCM_SYSCALL (ans = read (scm_to_int (port_or_fd),
1585 base + (cstart + offset) * sz,
1586 (sz * (cend - offset))));
1587 if (ans == -1)
1588 SCM_SYSERROR;
1589 }
1590 if (SCM_TYP7 (v) == scm_tc7_bvect)
1591 ans *= SCM_LONG_BIT;
1592
1593 if (!scm_is_eq (v, ra) && !scm_is_eq (cra, ra))
1594 scm_array_copy_x (cra, ra);
1595
1596 return scm_from_long (ans);
1597 }
1598 #undef FUNC_NAME
1599
1600 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1601 (SCM v, SCM port_or_fd, SCM start, SCM end),
1602 "@deffnx {Scheme Procedure} uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1603 "Writes all elements of @var{ura} as binary objects to\n"
1604 "@var{port-or-fdes}.\n\n"
1605 "The optional arguments @var{start}\n"
1606 "and @var{end} allow\n"
1607 "a specified region of a vector (or linearized array) to be written.\n\n"
1608 "The number of objects actually written is returned.\n"
1609 "@var{port-or-fdes} may be\n"
1610 "omitted, in which case it defaults to the value returned by\n"
1611 "@code{(current-output-port)}.")
1612 #define FUNC_NAME s_scm_uniform_array_write
1613 {
1614 long sz, vlen, ans;
1615 long offset = 0;
1616 long cstart = 0;
1617 long cend;
1618 char *base;
1619
1620 port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
1621
1622 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1623 if (SCM_UNBNDP (port_or_fd))
1624 port_or_fd = scm_cur_outp;
1625 else
1626 SCM_ASSERT (scm_is_integer (port_or_fd)
1627 || (SCM_OPOUTPORTP (port_or_fd)),
1628 port_or_fd, SCM_ARG2, FUNC_NAME);
1629 vlen = (SCM_TYP7 (v) == scm_tc7_smob
1630 ? 0
1631 : scm_to_long (scm_uniform_vector_length (v)));
1632
1633 loop:
1634 switch SCM_TYP7 (v)
1635 {
1636 default:
1637 badarg1:SCM_WRONG_TYPE_ARG (1, v);
1638 case scm_tc7_smob:
1639 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1640 v = scm_ra2contig (v, 1);
1641 cstart = SCM_ARRAY_BASE (v);
1642 vlen = (SCM_ARRAY_DIMS (v)->inc
1643 * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1));
1644 v = SCM_ARRAY_V (v);
1645 goto loop;
1646 case scm_tc7_string:
1647 base = SCM_STRING_CHARS (v);
1648 sz = sizeof (char);
1649 break;
1650 case scm_tc7_bvect:
1651 base = (char *) SCM_BITVECTOR_BASE (v);
1652 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1653 cstart /= SCM_LONG_BIT;
1654 sz = sizeof (long);
1655 break;
1656 case scm_tc7_byvect:
1657 base = (char *) SCM_UVECTOR_BASE (v);
1658 sz = sizeof (char);
1659 break;
1660 case scm_tc7_uvect:
1661 case scm_tc7_ivect:
1662 base = (char *) SCM_UVECTOR_BASE (v);
1663 sz = sizeof (long);
1664 break;
1665 case scm_tc7_svect:
1666 base = (char *) SCM_UVECTOR_BASE (v);
1667 sz = sizeof (short);
1668 break;
1669 #if SCM_SIZEOF_LONG_LONG != 0
1670 case scm_tc7_llvect:
1671 base = (char *) SCM_UVECTOR_BASE (v);
1672 sz = sizeof (long long);
1673 break;
1674 #endif
1675 case scm_tc7_fvect:
1676 base = (char *) SCM_UVECTOR_BASE (v);
1677 sz = sizeof (float);
1678 break;
1679 case scm_tc7_dvect:
1680 base = (char *) SCM_UVECTOR_BASE (v);
1681 sz = sizeof (double);
1682 break;
1683 case scm_tc7_cvect:
1684 base = (char *) SCM_UVECTOR_BASE (v);
1685 sz = 2 * sizeof (double);
1686 break;
1687 }
1688
1689 cend = vlen;
1690 if (!SCM_UNBNDP (start))
1691 {
1692 offset =
1693 SCM_NUM2LONG (3, start);
1694
1695 if (offset < 0 || offset >= cend)
1696 scm_out_of_range (FUNC_NAME, start);
1697
1698 if (!SCM_UNBNDP (end))
1699 {
1700 long tend =
1701 SCM_NUM2LONG (4, end);
1702
1703 if (tend <= offset || tend > cend)
1704 scm_out_of_range (FUNC_NAME, end);
1705 cend = tend;
1706 }
1707 }
1708
1709 if (SCM_NIMP (port_or_fd))
1710 {
1711 char *source = base + (cstart + offset) * sz;
1712
1713 ans = cend - offset;
1714 scm_lfwrite (source, ans * sz, port_or_fd);
1715 }
1716 else /* file descriptor. */
1717 {
1718 SCM_SYSCALL (ans = write (scm_to_int (port_or_fd),
1719 base + (cstart + offset) * sz,
1720 (sz * (cend - offset))));
1721 if (ans == -1)
1722 SCM_SYSERROR;
1723 }
1724 if (SCM_TYP7 (v) == scm_tc7_bvect)
1725 ans *= SCM_LONG_BIT;
1726
1727 return scm_from_long (ans);
1728 }
1729 #undef FUNC_NAME
1730
1731
1732 static char cnt_tab[16] =
1733 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1734
1735 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1736 (SCM b, SCM bitvector),
1737 "Return the number of occurrences of the boolean @var{b} in\n"
1738 "@var{bitvector}.")
1739 #define FUNC_NAME s_scm_bit_count
1740 {
1741 SCM_VALIDATE_BOOL (1, b);
1742 SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
1743 if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
1744 return SCM_INUM0;
1745 } else {
1746 unsigned long int count = 0;
1747 unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
1748 unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1749 if (scm_is_false (b)) {
1750 w = ~w;
1751 };
1752 w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
1753 while (1) {
1754 while (w) {
1755 count += cnt_tab[w & 0x0f];
1756 w >>= 4;
1757 }
1758 if (i == 0) {
1759 return scm_from_ulong (count);
1760 } else {
1761 --i;
1762 w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1763 if (scm_is_false (b)) {
1764 w = ~w;
1765 }
1766 }
1767 }
1768 }
1769 }
1770 #undef FUNC_NAME
1771
1772
1773 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1774 (SCM item, SCM v, SCM k),
1775 "Return the index of the first occurrance of @var{item} in bit\n"
1776 "vector @var{v}, starting from @var{k}. If there is no\n"
1777 "@var{item} entry between @var{k} and the end of\n"
1778 "@var{bitvector}, then return @code{#f}. For example,\n"
1779 "\n"
1780 "@example\n"
1781 "(bit-position #t #*000101 0) @result{} 3\n"
1782 "(bit-position #f #*0001111 3) @result{} #f\n"
1783 "@end example")
1784 #define FUNC_NAME s_scm_bit_position
1785 {
1786 long i, lenw, xbits, pos;
1787 register unsigned long w;
1788
1789 SCM_VALIDATE_BOOL (1, item);
1790 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
1791 pos = scm_to_long (k);
1792 SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
1793
1794 if (pos == SCM_BITVECTOR_LENGTH (v))
1795 return SCM_BOOL_F;
1796
1797 lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1798 i = pos / SCM_LONG_BIT;
1799 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1800 if (scm_is_false (item))
1801 w = ~w;
1802 xbits = (pos % SCM_LONG_BIT);
1803 pos -= xbits;
1804 w = ((w >> xbits) << xbits);
1805 xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
1806 while (!0)
1807 {
1808 if (w && (i == lenw))
1809 w = ((w << xbits) >> xbits);
1810 if (w)
1811 while (w)
1812 switch (w & 0x0f)
1813 {
1814 default:
1815 return scm_from_long (pos);
1816 case 2:
1817 case 6:
1818 case 10:
1819 case 14:
1820 return scm_from_long (pos + 1);
1821 case 4:
1822 case 12:
1823 return scm_from_long (pos + 2);
1824 case 8:
1825 return scm_from_long (pos + 3);
1826 case 0:
1827 pos += 4;
1828 w >>= 4;
1829 }
1830 if (++i > lenw)
1831 break;
1832 pos += SCM_LONG_BIT;
1833 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1834 if (scm_is_false (item))
1835 w = ~w;
1836 }
1837 return SCM_BOOL_F;
1838 }
1839 #undef FUNC_NAME
1840
1841
1842 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1843 (SCM v, SCM kv, SCM obj),
1844 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
1845 "selecting the entries to change. The return value is\n"
1846 "unspecified.\n"
1847 "\n"
1848 "If @var{kv} is a bit vector, then those entries where it has\n"
1849 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
1850 "@var{kv} and @var{v} must be the same length. When @var{obj}\n"
1851 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
1852 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
1853 "\n"
1854 "@example\n"
1855 "(define bv #*01000010)\n"
1856 "(bit-set*! bv #*10010001 #t)\n"
1857 "bv\n"
1858 "@result{} #*11010011\n"
1859 "@end example\n"
1860 "\n"
1861 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1862 "they're indexes into @var{v} which are set to @var{obj}.\n"
1863 "\n"
1864 "@example\n"
1865 "(define bv #*01000010)\n"
1866 "(bit-set*! bv #u(5 2 7) #t)\n"
1867 "bv\n"
1868 "@result{} #*01100111\n"
1869 "@end example")
1870 #define FUNC_NAME s_scm_bit_set_star_x
1871 {
1872 register long i, k, vlen;
1873 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1874 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1875 switch SCM_TYP7 (kv)
1876 {
1877 default:
1878 badarg2:SCM_WRONG_TYPE_ARG (2, kv);
1879 case scm_tc7_uvect:
1880 vlen = SCM_BITVECTOR_LENGTH (v);
1881 if (scm_is_false (obj))
1882 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1883 {
1884 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1885 if (k >= vlen)
1886 scm_out_of_range (FUNC_NAME, scm_from_long (k));
1887 SCM_BITVEC_CLR(v, k);
1888 }
1889 else if (scm_is_eq (obj, SCM_BOOL_T))
1890 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1891 {
1892 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1893 if (k >= vlen)
1894 scm_out_of_range (FUNC_NAME, scm_from_long (k));
1895 SCM_BITVEC_SET(v, k);
1896 }
1897 else
1898 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1899 break;
1900 case scm_tc7_bvect:
1901 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1902 if (scm_is_false (obj))
1903 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1904 SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
1905 else if (scm_is_eq (obj, SCM_BOOL_T))
1906 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1907 SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
1908 else
1909 goto badarg3;
1910 break;
1911 }
1912 return SCM_UNSPECIFIED;
1913 }
1914 #undef FUNC_NAME
1915
1916
1917 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
1918 (SCM v, SCM kv, SCM obj),
1919 "Return a count of how many entries in bit vector @var{v} are\n"
1920 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
1921 "consider.\n"
1922 "\n"
1923 "If @var{kv} is a bit vector, then those entries where it has\n"
1924 "@code{#t} are the ones in @var{v} which are considered.\n"
1925 "@var{kv} and @var{v} must be the same length.\n"
1926 "\n"
1927 "If @var{kv} is a uniform vector of unsigned long integers, then\n"
1928 "it's the indexes in @var{v} to consider.\n"
1929 "\n"
1930 "For example,\n"
1931 "\n"
1932 "@example\n"
1933 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
1934 "(bit-count* #*01110111 #u(7 0 4) #f) @result{} 2\n"
1935 "@end example")
1936 #define FUNC_NAME s_scm_bit_count_star
1937 {
1938 register long i, vlen, count = 0;
1939 register unsigned long k;
1940 int fObj = 0;
1941
1942 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1943 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1944 switch SCM_TYP7 (kv)
1945 {
1946 default:
1947 badarg2:
1948 SCM_WRONG_TYPE_ARG (2, kv);
1949 case scm_tc7_uvect:
1950 vlen = SCM_BITVECTOR_LENGTH (v);
1951 if (scm_is_false (obj))
1952 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1953 {
1954 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1955 if (k >= vlen)
1956 scm_out_of_range (FUNC_NAME, scm_from_long (k));
1957 if (!SCM_BITVEC_REF(v, k))
1958 count++;
1959 }
1960 else if (scm_is_eq (obj, SCM_BOOL_T))
1961 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1962 {
1963 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1964 if (k >= vlen)
1965 scm_out_of_range (FUNC_NAME, scm_from_long (k));
1966 if (SCM_BITVEC_REF (v, k))
1967 count++;
1968 }
1969 else
1970 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1971 break;
1972 case scm_tc7_bvect:
1973 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1974 if (0 == SCM_BITVECTOR_LENGTH (v))
1975 return SCM_INUM0;
1976 SCM_ASRTGO (scm_is_bool (obj), badarg3);
1977 fObj = scm_is_eq (obj, SCM_BOOL_T);
1978 i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
1979 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
1980 k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
1981 while (1)
1982 {
1983 for (; k; k >>= 4)
1984 count += cnt_tab[k & 0x0f];
1985 if (0 == i--)
1986 return scm_from_long (count);
1987
1988 /* urg. repetitive (see above.) */
1989 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
1990 }
1991 }
1992 return scm_from_long (count);
1993 }
1994 #undef FUNC_NAME
1995
1996
1997 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
1998 (SCM v),
1999 "Modify the bit vector @var{v} by replacing each element with\n"
2000 "its negation.")
2001 #define FUNC_NAME s_scm_bit_invert_x
2002 {
2003 long int k;
2004
2005 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
2006
2007 k = SCM_BITVECTOR_LENGTH (v);
2008 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
2009 SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
2010
2011 return SCM_UNSPECIFIED;
2012 }
2013 #undef FUNC_NAME
2014
2015
2016 SCM
2017 scm_istr2bve (char *str, long len)
2018 {
2019 SCM v = scm_make_uve (len, SCM_BOOL_T);
2020 long *data = (long *) SCM_VELTS (v);
2021 register unsigned long mask;
2022 register long k;
2023 register long j;
2024 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
2025 {
2026 data[k] = 0L;
2027 j = len - k * SCM_LONG_BIT;
2028 if (j > SCM_LONG_BIT)
2029 j = SCM_LONG_BIT;
2030 for (mask = 1L; j--; mask <<= 1)
2031 switch (*str++)
2032 {
2033 case '0':
2034 break;
2035 case '1':
2036 data[k] |= mask;
2037 break;
2038 default:
2039 return SCM_BOOL_F;
2040 }
2041 }
2042 return v;
2043 }
2044
2045
2046
2047 static SCM
2048 ra2l (SCM ra, unsigned long base, unsigned long k)
2049 {
2050 register SCM res = SCM_EOL;
2051 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2052 register size_t i;
2053 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
2054 return SCM_EOL;
2055 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
2056 if (k < SCM_ARRAY_NDIM (ra) - 1)
2057 {
2058 do
2059 {
2060 i -= inc;
2061 res = scm_cons (ra2l (ra, i, k + 1), res);
2062 }
2063 while (i != base);
2064 }
2065 else
2066 do
2067 {
2068 i -= inc;
2069 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), scm_from_size_t (i)), res);
2070 }
2071 while (i != base);
2072 return res;
2073 }
2074
2075
2076 SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
2077 (SCM v),
2078 "Return a list consisting of all the elements, in order, of\n"
2079 "@var{array}.")
2080 #define FUNC_NAME s_scm_array_to_list
2081 {
2082 SCM res = SCM_EOL;
2083 register long k;
2084 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2085 switch SCM_TYP7 (v)
2086 {
2087 default:
2088 badarg1:SCM_WRONG_TYPE_ARG (1, v);
2089 case scm_tc7_smob:
2090 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2091 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2092 case scm_tc7_vector:
2093 case scm_tc7_wvect:
2094 return scm_vector_to_list (v);
2095 case scm_tc7_string:
2096 return scm_string_to_list (v);
2097 case scm_tc7_bvect:
2098 {
2099 long *data = (long *) SCM_VELTS (v);
2100 register unsigned long mask;
2101 for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
2102 for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
2103 res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
2104 for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2105 res = scm_cons (scm_from_bool(((long *) data)[k] & mask), res);
2106 return res;
2107 }
2108 case scm_tc7_byvect:
2109 {
2110 signed char *data = (signed char *) SCM_VELTS (v);
2111 unsigned long k = SCM_UVECTOR_LENGTH (v);
2112 while (k != 0)
2113 res = scm_cons (scm_from_schar (data[--k]), res);
2114 return res;
2115 }
2116 case scm_tc7_uvect:
2117 {
2118 unsigned long *data = (unsigned long *)SCM_VELTS(v);
2119 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2120 res = scm_cons(scm_from_ulong (data[k]), res);
2121 return res;
2122 }
2123 case scm_tc7_ivect:
2124 {
2125 long *data = (long *)SCM_VELTS(v);
2126 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2127 res = scm_cons(scm_from_long (data[k]), res);
2128 return res;
2129 }
2130 case scm_tc7_svect:
2131 {
2132 short *data = (short *)SCM_VELTS(v);
2133 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2134 res = scm_cons (scm_from_short (data[k]), res);
2135 return res;
2136 }
2137 #if SCM_SIZEOF_LONG_LONG != 0
2138 case scm_tc7_llvect:
2139 {
2140 long long *data = (long long *)SCM_VELTS(v);
2141 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2142 res = scm_cons(scm_from_long_long (data[k]), res);
2143 return res;
2144 }
2145 #endif
2146 case scm_tc7_fvect:
2147 {
2148 float *data = (float *) SCM_VELTS (v);
2149 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2150 res = scm_cons (scm_from_double (data[k]), res);
2151 return res;
2152 }
2153 case scm_tc7_dvect:
2154 {
2155 double *data = (double *) SCM_VELTS (v);
2156 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2157 res = scm_cons (scm_from_double (data[k]), res);
2158 return res;
2159 }
2160 case scm_tc7_cvect:
2161 {
2162 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2163 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2164 res = scm_cons (scm_c_make_rectangular (data[k][0], data[k][1]),
2165 res);
2166 return res;
2167 }
2168 }
2169 }
2170 #undef FUNC_NAME
2171
2172
2173 static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
2174
2175 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2176 (SCM ndim, SCM prot, SCM lst),
2177 "@deffnx {Scheme Procedure} list->uniform-vector prot lst\n"
2178 "Return a uniform array of the type indicated by prototype\n"
2179 "@var{prot} with elements the same as those of @var{lst}.\n"
2180 "Elements must be of the appropriate type, no coercions are\n"
2181 "done.")
2182 #define FUNC_NAME s_scm_list_to_uniform_array
2183 {
2184 SCM shp = SCM_EOL;
2185 SCM row = lst;
2186 SCM ra;
2187 unsigned long k;
2188 long n;
2189 k = scm_to_ulong (ndim);
2190 while (k--)
2191 {
2192 n = scm_ilength (row);
2193 SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
2194 shp = scm_cons (scm_from_long (n), shp);
2195 if (SCM_NIMP (row))
2196 row = SCM_CAR (row);
2197 }
2198 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
2199 SCM_UNDEFINED);
2200 if (SCM_NULLP (shp))
2201 {
2202 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2203 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2204 return ra;
2205 }
2206 if (!SCM_ARRAYP (ra))
2207 {
2208 unsigned long length = scm_to_ulong (scm_uniform_vector_length (ra));
2209 for (k = 0; k < length; k++, lst = SCM_CDR (lst))
2210 scm_array_set_x (ra, SCM_CAR (lst), scm_from_ulong (k));
2211 return ra;
2212 }
2213 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2214 return ra;
2215 else
2216 badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S",
2217 scm_list_1 (lst));
2218 }
2219 #undef FUNC_NAME
2220
2221 static int
2222 l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
2223 {
2224 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2225 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2226 int ok = 1;
2227 if (n <= 0)
2228 return (SCM_NULLP (lst));
2229 if (k < SCM_ARRAY_NDIM (ra) - 1)
2230 {
2231 while (n--)
2232 {
2233 if (!SCM_CONSP (lst))
2234 return 0;
2235 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2236 base += inc;
2237 lst = SCM_CDR (lst);
2238 }
2239 if (!SCM_NULLP (lst))
2240 return 0;
2241 }
2242 else
2243 {
2244 while (n--)
2245 {
2246 if (!SCM_CONSP (lst))
2247 return 0;
2248 scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), scm_from_ulong (base));
2249 base += inc;
2250 lst = SCM_CDR (lst);
2251 }
2252 if (!SCM_NULLP (lst))
2253 return 0;
2254 }
2255 return ok;
2256 }
2257
2258
2259 static void
2260 rapr1 (SCM ra, unsigned long j, unsigned long k, SCM port, scm_print_state *pstate)
2261 {
2262 long inc = 1;
2263 long n = (SCM_TYP7 (ra) == scm_tc7_smob
2264 ? 0
2265 : scm_to_long (scm_uniform_vector_length (ra)));
2266 int enclosed = 0;
2267 tail:
2268 switch SCM_TYP7 (ra)
2269 {
2270 case scm_tc7_smob:
2271 if (enclosed++)
2272 {
2273 SCM_ARRAY_BASE (ra) = j;
2274 if (n-- > 0)
2275 scm_iprin1 (ra, port, pstate);
2276 for (j += inc; n-- > 0; j += inc)
2277 {
2278 scm_putc (' ', port);
2279 SCM_ARRAY_BASE (ra) = j;
2280 scm_iprin1 (ra, port, pstate);
2281 }
2282 break;
2283 }
2284 if (k + 1 < SCM_ARRAY_NDIM (ra))
2285 {
2286 long i;
2287 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2288 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2289 {
2290 scm_putc ('(', port);
2291 rapr1 (ra, j, k + 1, port, pstate);
2292 scm_puts (") ", port);
2293 j += inc;
2294 }
2295 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2296 { /* could be zero size. */
2297 scm_putc ('(', port);
2298 rapr1 (ra, j, k + 1, port, pstate);
2299 scm_putc (')', port);
2300 }
2301 break;
2302 }
2303 if (SCM_ARRAY_NDIM (ra) > 0)
2304 { /* Could be zero-dimensional */
2305 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2306 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2307 }
2308 else
2309 n = 1;
2310 ra = SCM_ARRAY_V (ra);
2311 goto tail;
2312 default:
2313 /* scm_tc7_bvect and scm_tc7_llvect only? */
2314 if (n-- > 0)
2315 scm_iprin1 (scm_uniform_vector_ref (ra, scm_from_ulong (j)), port, pstate);
2316 for (j += inc; n-- > 0; j += inc)
2317 {
2318 scm_putc (' ', port);
2319 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
2320 }
2321 break;
2322 case scm_tc7_string:
2323 if (n-- > 0)
2324 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2325 if (SCM_WRITINGP (pstate))
2326 for (j += inc; n-- > 0; j += inc)
2327 {
2328 scm_putc (' ', port);
2329 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2330 }
2331 else
2332 for (j += inc; n-- > 0; j += inc)
2333 scm_putc (SCM_STRING_CHARS (ra)[j], port);
2334 break;
2335 case scm_tc7_byvect:
2336 if (n-- > 0)
2337 scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2338 for (j += inc; n-- > 0; j += inc)
2339 {
2340 scm_putc (' ', port);
2341 scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
2342 }
2343 break;
2344
2345 case scm_tc7_uvect:
2346 {
2347 char str[11];
2348
2349 if (n-- > 0)
2350 {
2351 /* intprint can't handle >= 2^31. */
2352 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2353 scm_puts (str, port);
2354 }
2355 for (j += inc; n-- > 0; j += inc)
2356 {
2357 scm_putc (' ', port);
2358 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2359 scm_puts (str, port);
2360 }
2361 }
2362 case scm_tc7_ivect:
2363 if (n-- > 0)
2364 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2365 for (j += inc; n-- > 0; j += inc)
2366 {
2367 scm_putc (' ', port);
2368 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2369 }
2370 break;
2371
2372 case scm_tc7_svect:
2373 if (n-- > 0)
2374 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2375 for (j += inc; n-- > 0; j += inc)
2376 {
2377 scm_putc (' ', port);
2378 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2379 }
2380 break;
2381
2382 case scm_tc7_fvect:
2383 if (n-- > 0)
2384 {
2385 SCM z = scm_from_double (1.0);
2386 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2387 scm_print_real (z, port, pstate);
2388 for (j += inc; n-- > 0; j += inc)
2389 {
2390 scm_putc (' ', port);
2391 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2392 scm_print_real (z, port, pstate);
2393 }
2394 }
2395 break;
2396 case scm_tc7_dvect:
2397 if (n-- > 0)
2398 {
2399 SCM z = scm_from_double (1.0 / 3.0);
2400 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2401 scm_print_real (z, port, pstate);
2402 for (j += inc; n-- > 0; j += inc)
2403 {
2404 scm_putc (' ', port);
2405 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2406 scm_print_real (z, port, pstate);
2407 }
2408 }
2409 break;
2410 case scm_tc7_cvect:
2411 if (n-- > 0)
2412 {
2413 SCM cz = scm_c_make_rectangular (0.0, 1.0);
2414 SCM z = scm_from_double (1.0/3.0);
2415 SCM_REAL_VALUE (z) =
2416 SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2417 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2418 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2419 port, pstate);
2420 for (j += inc; n-- > 0; j += inc)
2421 {
2422 scm_putc (' ', port);
2423 SCM_REAL_VALUE (z)
2424 = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2425 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2426 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2427 port, pstate);
2428 }
2429 }
2430 break;
2431 }
2432 }
2433
2434
2435
2436 int
2437 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2438 {
2439 SCM v = exp;
2440 unsigned long base = 0;
2441 scm_putc ('#', port);
2442 tail:
2443 switch SCM_TYP7 (v)
2444 {
2445 case scm_tc7_smob:
2446 {
2447 long ndim = SCM_ARRAY_NDIM (v);
2448 base = SCM_ARRAY_BASE (v);
2449 v = SCM_ARRAY_V (v);
2450 if (SCM_ARRAYP (v))
2451
2452 {
2453 scm_puts ("<enclosed-array ", port);
2454 rapr1 (exp, base, 0, port, pstate);
2455 scm_putc ('>', port);
2456 return 1;
2457 }
2458 else
2459 {
2460 scm_intprint (ndim, 10, port);
2461 goto tail;
2462 }
2463 }
2464 case scm_tc7_bvect:
2465 if (scm_is_eq (exp, v))
2466 { /* a uve, not an scm_array */
2467 register long i, j, w;
2468 scm_putc ('*', port);
2469 for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
2470 {
2471 scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
2472 for (j = SCM_LONG_BIT; j; j--)
2473 {
2474 scm_putc (w & 1 ? '1' : '0', port);
2475 w >>= 1;
2476 }
2477 }
2478 j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
2479 if (j)
2480 {
2481 w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
2482 for (; j; j--)
2483 {
2484 scm_putc (w & 1 ? '1' : '0', port);
2485 w >>= 1;
2486 }
2487 }
2488 return 1;
2489 }
2490 else
2491 scm_putc ('b', port);
2492 break;
2493 case scm_tc7_string:
2494 scm_putc ('a', port);
2495 break;
2496 case scm_tc7_byvect:
2497 scm_putc ('y', port);
2498 break;
2499 case scm_tc7_uvect:
2500 scm_putc ('u', port);
2501 break;
2502 case scm_tc7_ivect:
2503 scm_putc ('e', port);
2504 break;
2505 case scm_tc7_svect:
2506 scm_putc ('h', port);
2507 break;
2508 #if SCM_SIZEOF_LONG_LONG != 0
2509 case scm_tc7_llvect:
2510 scm_putc ('l', port);
2511 break;
2512 #endif
2513 case scm_tc7_fvect:
2514 scm_putc ('s', port);
2515 break;
2516 case scm_tc7_dvect:
2517 scm_putc ('i', port);
2518 break;
2519 case scm_tc7_cvect:
2520 scm_putc ('c', port);
2521 break;
2522 }
2523 scm_putc ('(', port);
2524 rapr1 (exp, base, 0, port, pstate);
2525 scm_putc (')', port);
2526 return 1;
2527 }
2528
2529 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2530 (SCM ra),
2531 "Return an object that would produce an array of the same type\n"
2532 "as @var{array}, if used as the @var{prototype} for\n"
2533 "@code{make-uniform-array}.")
2534 #define FUNC_NAME s_scm_array_prototype
2535 {
2536 int enclosed = 0;
2537 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2538 loop:
2539 switch SCM_TYP7 (ra)
2540 {
2541 default:
2542 badarg:SCM_WRONG_TYPE_ARG (1, ra);
2543 case scm_tc7_smob:
2544 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2545 if (enclosed++)
2546 return SCM_UNSPECIFIED;
2547 ra = SCM_ARRAY_V (ra);
2548 goto loop;
2549 case scm_tc7_vector:
2550 case scm_tc7_wvect:
2551 return SCM_EOL;
2552 case scm_tc7_bvect:
2553 return SCM_BOOL_T;
2554 case scm_tc7_string:
2555 return SCM_MAKE_CHAR ('a');
2556 case scm_tc7_byvect:
2557 return SCM_MAKE_CHAR ('\0');
2558 case scm_tc7_uvect:
2559 return scm_from_int (1);
2560 case scm_tc7_ivect:
2561 return scm_from_int (-1);
2562 case scm_tc7_svect:
2563 return scm_str2symbol ("s");
2564 #if SCM_SIZEOF_LONG_LONG != 0
2565 case scm_tc7_llvect:
2566 return scm_str2symbol ("l");
2567 #endif
2568 case scm_tc7_fvect:
2569 return scm_from_double (1.0);
2570 case scm_tc7_dvect:
2571 return exactly_one_third;
2572 case scm_tc7_cvect:
2573 return scm_c_make_rectangular (0.0, 1.0);
2574 }
2575 }
2576 #undef FUNC_NAME
2577
2578
2579 static SCM
2580 array_mark (SCM ptr)
2581 {
2582 return SCM_ARRAY_V (ptr);
2583 }
2584
2585
2586 static size_t
2587 array_free (SCM ptr)
2588 {
2589 scm_gc_free (SCM_ARRAY_MEM (ptr),
2590 (sizeof (scm_t_array)
2591 + SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
2592 "array");
2593 return 0;
2594 }
2595
2596 void
2597 scm_init_unif ()
2598 {
2599 scm_tc16_array = scm_make_smob_type ("array", 0);
2600 scm_set_smob_mark (scm_tc16_array, array_mark);
2601 scm_set_smob_free (scm_tc16_array, array_free);
2602 scm_set_smob_print (scm_tc16_array, scm_raprin1);
2603 scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
2604 exactly_one_third = scm_permanent_object (scm_divide (scm_from_int (1),
2605 scm_from_int (3)));
2606 scm_add_feature ("array");
2607 #include "libguile/unif.x"
2608 }
2609
2610 /*
2611 Local Variables:
2612 c-file-style: "gnu"
2613 End:
2614 */
Unnamed repository; edit this file 'description' to name the repository.