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