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