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