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