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