HCoop / bpt / guile.git / blob
? search:
summary | shortlog | log | commit | commitdiff | tree
blame | history | raw | HEAD
replace "scm_*_t" with "scm_t_*".
[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 (mapfunc, scm_reverse (inds), SCM_EOL);
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 (mapfunc, scm_reverse (inds), SCM_EOL);
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_VALIDATE_REST_ARGUMENT (args);
1271 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1272 if (SCM_ARRAYP (v))
1273 {
1274 pos = scm_aind (v, args, FUNC_NAME);
1275 v = SCM_ARRAY_V (v);
1276 }
1277 else
1278 {
1279 unsigned long int length;
1280 if (SCM_NIMP (args))
1281 {
1282 SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
1283 SCM_ARG3, FUNC_NAME);
1284 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1285 pos = SCM_INUM (SCM_CAR (args));
1286 }
1287 else
1288 {
1289 SCM_VALIDATE_INUM_COPY (3,args,pos);
1290 }
1291 length = SCM_INUM (scm_uniform_vector_length (v));
1292 SCM_ASRTGO (pos >= 0 && pos < length, outrng);
1293 }
1294 switch (SCM_TYP7 (v))
1295 {
1296 default: badarg1:
1297 SCM_WRONG_TYPE_ARG (1, v);
1298 /* not reached */
1299 outrng:
1300 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (pos));
1301 wna:
1302 SCM_WRONG_NUM_ARGS ();
1303 case scm_tc7_smob: /* enclosed */
1304 goto badarg1;
1305 case scm_tc7_bvect:
1306 if (SCM_FALSEP (obj))
1307 SCM_BITVEC_CLR(v,pos);
1308 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1309 SCM_BITVEC_SET(v,pos);
1310 else
1311 badobj:SCM_WRONG_TYPE_ARG (2, obj);
1312 break;
1313 case scm_tc7_string:
1314 SCM_ASRTGO (SCM_CHARP (obj), badobj);
1315 SCM_STRING_UCHARS (v)[pos] = SCM_CHAR (obj);
1316 break;
1317 case scm_tc7_byvect:
1318 if (SCM_CHARP (obj))
1319 obj = SCM_MAKINUM ((char) SCM_CHAR (obj));
1320 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1321 ((char *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1322 break;
1323 case scm_tc7_uvect:
1324 ((unsigned long *) SCM_UVECTOR_BASE (v))[pos]
1325 = scm_num2ulong (obj, SCM_ARG2, FUNC_NAME);
1326 break;
1327 case scm_tc7_ivect:
1328 ((long *) SCM_UVECTOR_BASE (v))[pos]
1329 = scm_num2long (obj, SCM_ARG2, FUNC_NAME);
1330 break;
1331 case scm_tc7_svect:
1332 SCM_ASRTGO (SCM_INUMP (obj), badobj);
1333 ((short *) SCM_UVECTOR_BASE (v))[pos] = SCM_INUM (obj);
1334 break;
1335 #ifdef HAVE_LONG_LONGS
1336 case scm_tc7_llvect:
1337 ((long long *) SCM_UVECTOR_BASE (v))[pos]
1338 = scm_num2long_long (obj, SCM_ARG2, FUNC_NAME);
1339 break;
1340 #endif
1341 case scm_tc7_fvect:
1342 ((float *) SCM_UVECTOR_BASE (v))[pos]
1343 = (float) scm_num2dbl (obj, FUNC_NAME);
1344 break;
1345 case scm_tc7_dvect:
1346 ((double *) SCM_UVECTOR_BASE (v))[pos]
1347 = scm_num2dbl (obj, FUNC_NAME);
1348 break;
1349 case scm_tc7_cvect:
1350 SCM_ASRTGO (SCM_INEXACTP (obj), badobj);
1351 if (SCM_REALP (obj)) {
1352 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_REAL_VALUE (obj);
1353 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = 0.0;
1354 } else {
1355 ((double *) SCM_UVECTOR_BASE (v))[2 * pos] = SCM_COMPLEX_REAL (obj);
1356 ((double *) SCM_UVECTOR_BASE (v))[2 * pos + 1] = SCM_COMPLEX_IMAG (obj);
1357 }
1358 break;
1359 case scm_tc7_vector:
1360 case scm_tc7_wvect:
1361 SCM_VELTS (v)[pos] = obj;
1362 break;
1363 }
1364 return SCM_UNSPECIFIED;
1365 }
1366 #undef FUNC_NAME
1367
1368 /* attempts to unroll an array into a one-dimensional array.
1369 returns the unrolled array or #f if it can't be done. */
1370 /* if strict is not SCM_UNDEFINED, return #f if returned array
1371 wouldn't have contiguous elements. */
1372 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
1373 (SCM ra, SCM strict),
1374 "@deffnx primitive array-contents array strict\n"
1375 "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
1376 "without changing their order (last subscript changing fastest), then\n"
1377 "@code{array-contents} returns that shared array, otherwise it returns\n"
1378 "@code{#f}. All arrays made by @var{make-array} and\n"
1379 "@var{make-uniform-array} may be unrolled, some arrays made by\n"
1380 "@var{make-shared-array} may not be.\n\n"
1381 "If the optional argument @var{strict} is provided, a shared array will\n"
1382 "be returned only if its elements are stored internally contiguous in\n"
1383 "memory.")
1384 #define FUNC_NAME s_scm_array_contents
1385 {
1386 SCM sra;
1387 if (SCM_IMP (ra))
1388 return SCM_BOOL_F;
1389 switch SCM_TYP7 (ra)
1390 {
1391 default:
1392 return SCM_BOOL_F;
1393 case scm_tc7_vector:
1394 case scm_tc7_wvect:
1395 case scm_tc7_string:
1396 case scm_tc7_bvect:
1397 case scm_tc7_byvect:
1398 case scm_tc7_uvect:
1399 case scm_tc7_ivect:
1400 case scm_tc7_fvect:
1401 case scm_tc7_dvect:
1402 case scm_tc7_cvect:
1403 case scm_tc7_svect:
1404 #ifdef HAVE_LONG_LONGS
1405 case scm_tc7_llvect:
1406 #endif
1407 return ra;
1408 case scm_tc7_smob:
1409 {
1410 size_t k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1411 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1412 return SCM_BOOL_F;
1413 for (k = 0; k < ndim; k++)
1414 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1415 if (!SCM_UNBNDP (strict))
1416 {
1417 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1418 return SCM_BOOL_F;
1419 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1420 {
1421 if (len != SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) ||
1422 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1423 len % SCM_LONG_BIT)
1424 return SCM_BOOL_F;
1425 }
1426 }
1427
1428 {
1429 SCM v = SCM_ARRAY_V (ra);
1430 unsigned long int length = SCM_INUM (scm_uniform_vector_length (v));
1431 if ((len == length) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1432 return v;
1433 }
1434
1435 sra = scm_make_ra (1);
1436 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1437 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1438 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1439 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1440 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1441 return sra;
1442 }
1443 }
1444 }
1445 #undef FUNC_NAME
1446
1447
1448 SCM
1449 scm_ra2contig (SCM ra, int copy)
1450 {
1451 SCM ret;
1452 long inc = 1;
1453 size_t k, len = 1;
1454 for (k = SCM_ARRAY_NDIM (ra); k--;)
1455 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1456 k = SCM_ARRAY_NDIM (ra);
1457 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1458 {
1459 if (scm_tc7_bvect != SCM_TYP7 (SCM_ARRAY_V (ra)))
1460 return ra;
1461 if ((len == SCM_BITVECTOR_LENGTH (SCM_ARRAY_V (ra)) &&
1462 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1463 0 == len % SCM_LONG_BIT))
1464 return ra;
1465 }
1466 ret = scm_make_ra (k);
1467 SCM_ARRAY_BASE (ret) = 0;
1468 while (k--)
1469 {
1470 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1471 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1472 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1473 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1474 }
1475 SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
1476 if (copy)
1477 scm_array_copy_x (ra, ret);
1478 return ret;
1479 }
1480
1481
1482
1483 SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
1484 (SCM ra, SCM port_or_fd, SCM start, SCM end),
1485 "@deffnx primitive uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
1486 "Attempts to read all elements of @var{ura}, in lexicographic order, as\n"
1487 "binary objects from @var{port-or-fdes}.\n"
1488 "If an end of file is encountered during\n"
1489 "uniform-array-read! the objects up to that point only are put into @var{ura}\n"
1490 "(starting at the beginning) and the remainder of the array is\n"
1491 "unchanged.\n\n"
1492 "The optional arguments @var{start} and @var{end} allow\n"
1493 "a specified region of a vector (or linearized array) to be read,\n"
1494 "leaving the remainder of the vector unchanged.\n\n"
1495 "@code{uniform-array-read!} returns the number of objects read.\n"
1496 "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
1497 "returned by @code{(current-input-port)}.")
1498 #define FUNC_NAME s_scm_uniform_array_read_x
1499 {
1500 SCM cra = SCM_UNDEFINED, v = ra;
1501 long sz, vlen, ans;
1502 long cstart = 0;
1503 long cend;
1504 long offset = 0;
1505 char *base;
1506
1507 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1508 if (SCM_UNBNDP (port_or_fd))
1509 port_or_fd = scm_cur_inp;
1510 else
1511 SCM_ASSERT (SCM_INUMP (port_or_fd)
1512 || (SCM_OPINPORTP (port_or_fd)),
1513 port_or_fd, SCM_ARG2, FUNC_NAME);
1514 vlen = SCM_INUM (scm_uniform_vector_length (v));
1515
1516 loop:
1517 switch SCM_TYP7 (v)
1518 {
1519 default:
1520 badarg1:SCM_WRONG_TYPE_ARG (SCM_ARG1, v);
1521 case scm_tc7_smob:
1522 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1523 cra = scm_ra2contig (ra, 0);
1524 cstart += SCM_ARRAY_BASE (cra);
1525 vlen = SCM_ARRAY_DIMS (cra)->inc *
1526 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1527 v = SCM_ARRAY_V (cra);
1528 goto loop;
1529 case scm_tc7_string:
1530 base = SCM_STRING_CHARS (v);
1531 sz = sizeof (char);
1532 break;
1533 case scm_tc7_bvect:
1534 base = (char *) SCM_BITVECTOR_BASE (v);
1535 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1536 cstart /= SCM_LONG_BIT;
1537 sz = sizeof (long);
1538 break;
1539 case scm_tc7_byvect:
1540 base = (char *) SCM_UVECTOR_BASE (v);
1541 sz = sizeof (char);
1542 break;
1543 case scm_tc7_uvect:
1544 case scm_tc7_ivect:
1545 base = (char *) SCM_UVECTOR_BASE (v);
1546 sz = sizeof (long);
1547 break;
1548 case scm_tc7_svect:
1549 base = (char *) SCM_UVECTOR_BASE (v);
1550 sz = sizeof (short);
1551 break;
1552 #ifdef HAVE_LONG_LONGS
1553 case scm_tc7_llvect:
1554 base = (char *) SCM_UVECTOR_BASE (v);
1555 sz = sizeof (long long);
1556 break;
1557 #endif
1558 case scm_tc7_fvect:
1559 base = (char *) SCM_UVECTOR_BASE (v);
1560 sz = sizeof (float);
1561 break;
1562 case scm_tc7_dvect:
1563 base = (char *) SCM_UVECTOR_BASE (v);
1564 sz = sizeof (double);
1565 break;
1566 case scm_tc7_cvect:
1567 base = (char *) SCM_UVECTOR_BASE (v);
1568 sz = 2 * sizeof (double);
1569 break;
1570 }
1571
1572 cend = vlen;
1573 if (!SCM_UNBNDP (start))
1574 {
1575 offset =
1576 SCM_NUM2LONG (3, start);
1577
1578 if (offset < 0 || offset >= cend)
1579 scm_out_of_range (FUNC_NAME, start);
1580
1581 if (!SCM_UNBNDP (end))
1582 {
1583 long tend =
1584 SCM_NUM2LONG (4, end);
1585
1586 if (tend <= offset || tend > cend)
1587 scm_out_of_range (FUNC_NAME, end);
1588 cend = tend;
1589 }
1590 }
1591
1592 if (SCM_NIMP (port_or_fd))
1593 {
1594 scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd);
1595 int remaining = (cend - offset) * sz;
1596 char *dest = base + (cstart + offset) * sz;
1597
1598 if (pt->rw_active == SCM_PORT_WRITE)
1599 scm_flush (port_or_fd);
1600
1601 ans = cend - offset;
1602 while (remaining > 0)
1603 {
1604 if (pt->read_pos < pt->read_end)
1605 {
1606 int to_copy = min (pt->read_end - pt->read_pos,
1607 remaining);
1608
1609 memcpy (dest, pt->read_pos, to_copy);
1610 pt->read_pos += to_copy;
1611 remaining -= to_copy;
1612 dest += to_copy;
1613 }
1614 else
1615 {
1616 if (scm_fill_input (port_or_fd) == EOF)
1617 {
1618 if (remaining % sz != 0)
1619 {
1620 SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
1621 }
1622 ans -= remaining / sz;
1623 break;
1624 }
1625 }
1626 }
1627
1628 if (pt->rw_random)
1629 pt->rw_active = SCM_PORT_READ;
1630 }
1631 else /* file descriptor. */
1632 {
1633 SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
1634 base + (cstart + offset) * sz,
1635 (sz * (cend - offset))));
1636 if (ans == -1)
1637 SCM_SYSERROR;
1638 }
1639 if (SCM_TYP7 (v) == scm_tc7_bvect)
1640 ans *= SCM_LONG_BIT;
1641
1642 if (!SCM_EQ_P (v, ra) && !SCM_EQ_P (cra, ra))
1643 scm_array_copy_x (cra, ra);
1644
1645 return SCM_MAKINUM (ans);
1646 }
1647 #undef FUNC_NAME
1648
1649 SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
1650 (SCM v, SCM port_or_fd, SCM start, SCM end),
1651 "@deffnx primitive uniform-vector-write uve [port-or-fdes] [start] [end]\n"
1652 "Writes all elements of @var{ura} as binary objects to\n"
1653 "@var{port-or-fdes}.\n\n"
1654 "The optional arguments @var{start}\n"
1655 "and @var{end} allow\n"
1656 "a specified region of a vector (or linearized array) to be written.\n\n"
1657 "The number of objects actually written is returned. \n"
1658 "@var{port-or-fdes} may be\n"
1659 "omitted, in which case it defaults to the value returned by\n"
1660 "@code{(current-output-port)}.")
1661 #define FUNC_NAME s_scm_uniform_array_write
1662 {
1663 long sz, vlen, ans;
1664 long offset = 0;
1665 long cstart = 0;
1666 long cend;
1667 char *base;
1668
1669 port_or_fd = SCM_COERCE_OUTPORT (port_or_fd);
1670
1671 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1672 if (SCM_UNBNDP (port_or_fd))
1673 port_or_fd = scm_cur_outp;
1674 else
1675 SCM_ASSERT (SCM_INUMP (port_or_fd)
1676 || (SCM_OPOUTPORTP (port_or_fd)),
1677 port_or_fd, SCM_ARG2, FUNC_NAME);
1678 vlen = SCM_INUM (scm_uniform_vector_length (v));
1679
1680 loop:
1681 switch SCM_TYP7 (v)
1682 {
1683 default:
1684 badarg1:SCM_WRONG_TYPE_ARG (1, v);
1685 case scm_tc7_smob:
1686 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1687 v = scm_ra2contig (v, 1);
1688 cstart = SCM_ARRAY_BASE (v);
1689 vlen = SCM_ARRAY_DIMS (v)->inc
1690 * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
1691 v = SCM_ARRAY_V (v);
1692 goto loop;
1693 case scm_tc7_string:
1694 base = SCM_STRING_CHARS (v);
1695 sz = sizeof (char);
1696 break;
1697 case scm_tc7_bvect:
1698 base = (char *) SCM_BITVECTOR_BASE (v);
1699 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1700 cstart /= SCM_LONG_BIT;
1701 sz = sizeof (long);
1702 break;
1703 case scm_tc7_byvect:
1704 base = (char *) SCM_UVECTOR_BASE (v);
1705 sz = sizeof (char);
1706 break;
1707 case scm_tc7_uvect:
1708 case scm_tc7_ivect:
1709 base = (char *) SCM_UVECTOR_BASE (v);
1710 sz = sizeof (long);
1711 break;
1712 case scm_tc7_svect:
1713 base = (char *) SCM_UVECTOR_BASE (v);
1714 sz = sizeof (short);
1715 break;
1716 #ifdef HAVE_LONG_LONGS
1717 case scm_tc7_llvect:
1718 base = (char *) SCM_UVECTOR_BASE (v);
1719 sz = sizeof (long long);
1720 break;
1721 #endif
1722 case scm_tc7_fvect:
1723 base = (char *) SCM_UVECTOR_BASE (v);
1724 sz = sizeof (float);
1725 break;
1726 case scm_tc7_dvect:
1727 base = (char *) SCM_UVECTOR_BASE (v);
1728 sz = sizeof (double);
1729 break;
1730 case scm_tc7_cvect:
1731 base = (char *) SCM_UVECTOR_BASE (v);
1732 sz = 2 * sizeof (double);
1733 break;
1734 }
1735
1736 cend = vlen;
1737 if (!SCM_UNBNDP (start))
1738 {
1739 offset =
1740 SCM_NUM2LONG (3, start);
1741
1742 if (offset < 0 || offset >= cend)
1743 scm_out_of_range (FUNC_NAME, start);
1744
1745 if (!SCM_UNBNDP (end))
1746 {
1747 long tend =
1748 SCM_NUM2LONG (4, end);
1749
1750 if (tend <= offset || tend > cend)
1751 scm_out_of_range (FUNC_NAME, end);
1752 cend = tend;
1753 }
1754 }
1755
1756 if (SCM_NIMP (port_or_fd))
1757 {
1758 char *source = base + (cstart + offset) * sz;
1759
1760 ans = cend - offset;
1761 scm_lfwrite (source, ans * sz, port_or_fd);
1762 }
1763 else /* file descriptor. */
1764 {
1765 SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
1766 base + (cstart + offset) * sz,
1767 (sz * (cend - offset))));
1768 if (ans == -1)
1769 SCM_SYSERROR;
1770 }
1771 if (SCM_TYP7 (v) == scm_tc7_bvect)
1772 ans *= SCM_LONG_BIT;
1773
1774 return SCM_MAKINUM (ans);
1775 }
1776 #undef FUNC_NAME
1777
1778
1779 static char cnt_tab[16] =
1780 {0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1781
1782 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
1783 (SCM b, SCM bitvector),
1784 "Return the number of occurrences of the boolean @var{b} in\n"
1785 "@var{bitvector}.")
1786 #define FUNC_NAME s_scm_bit_count
1787 {
1788 SCM_VALIDATE_BOOL (1, b);
1789 SCM_ASSERT (SCM_BITVECTOR_P (bitvector), bitvector, 2, FUNC_NAME);
1790 if (SCM_BITVECTOR_LENGTH (bitvector) == 0) {
1791 return SCM_INUM0;
1792 } else {
1793 unsigned long int count = 0;
1794 unsigned long int i = (SCM_BITVECTOR_LENGTH (bitvector) - 1) / SCM_LONG_BIT;
1795 unsigned long int w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1796 if (SCM_FALSEP (b)) {
1797 w = ~w;
1798 };
1799 w <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (bitvector) - 1) % SCM_LONG_BIT);
1800 while (1) {
1801 while (w) {
1802 count += cnt_tab[w & 0x0f];
1803 w >>= 4;
1804 }
1805 if (i == 0) {
1806 return SCM_MAKINUM (count);
1807 } else {
1808 --i;
1809 w = SCM_UNPACK (SCM_VELTS (bitvector)[i]);
1810 if (SCM_FALSEP (b)) {
1811 w = ~w;
1812 }
1813 }
1814 }
1815 }
1816 }
1817 #undef FUNC_NAME
1818
1819
1820 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
1821 (SCM item, SCM v, SCM k),
1822 "Return the minimum index of an occurrence of @var{bool} in\n"
1823 "@var{bv} which is at least @var{k}. If no @var{bool} occurs\n"
1824 "within the specified range @code{#f} is returned.")
1825 #define FUNC_NAME s_scm_bit_position
1826 {
1827 long i, lenw, xbits, pos;
1828 register unsigned long w;
1829
1830 SCM_VALIDATE_BOOL (1, item);
1831 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG2, FUNC_NAME);
1832 SCM_VALIDATE_INUM_COPY (3,k,pos);
1833 SCM_ASSERT_RANGE (3, k, (pos <= SCM_BITVECTOR_LENGTH (v)) && (pos >= 0));
1834
1835 if (pos == SCM_BITVECTOR_LENGTH (v))
1836 return SCM_BOOL_F;
1837
1838 lenw = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1839 i = pos / SCM_LONG_BIT;
1840 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1841 if (SCM_FALSEP (item))
1842 w = ~w;
1843 xbits = (pos % SCM_LONG_BIT);
1844 pos -= xbits;
1845 w = ((w >> xbits) << xbits);
1846 xbits = SCM_LONG_BIT - 1 - (SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT;
1847 while (!0)
1848 {
1849 if (w && (i == lenw))
1850 w = ((w << xbits) >> xbits);
1851 if (w)
1852 while (w)
1853 switch (w & 0x0f)
1854 {
1855 default:
1856 return SCM_MAKINUM (pos);
1857 case 2:
1858 case 6:
1859 case 10:
1860 case 14:
1861 return SCM_MAKINUM (pos + 1);
1862 case 4:
1863 case 12:
1864 return SCM_MAKINUM (pos + 2);
1865 case 8:
1866 return SCM_MAKINUM (pos + 3);
1867 case 0:
1868 pos += 4;
1869 w >>= 4;
1870 }
1871 if (++i > lenw)
1872 break;
1873 pos += SCM_LONG_BIT;
1874 w = SCM_UNPACK (SCM_VELTS (v)[i]);
1875 if (SCM_FALSEP (item))
1876 w = ~w;
1877 }
1878 return SCM_BOOL_F;
1879 }
1880 #undef FUNC_NAME
1881
1882
1883 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
1884 (SCM v, SCM kv, SCM obj),
1885 "If uve is a bit-vector @var{bv} and uve must be of the same\n"
1886 "length. If @var{bool} is @code{#t}, uve is OR'ed into\n"
1887 "@var{bv}; If @var{bool} is @code{#f}, the inversion of uve is\n"
1888 "AND'ed into @var{bv}.\n\n"
1889 "If uve is a unsigned integer vector all the elements of uve\n"
1890 "must be between 0 and the @code{length} of @var{bv}. The bits\n"
1891 "of @var{bv} corresponding to the indexes in uve are set to\n"
1892 "@var{bool}. The return value is unspecified.")
1893 #define FUNC_NAME s_scm_bit_set_star_x
1894 {
1895 register long i, k, vlen;
1896 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1897 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1898 switch SCM_TYP7 (kv)
1899 {
1900 default:
1901 badarg2:SCM_WRONG_TYPE_ARG (2, kv);
1902 case scm_tc7_uvect:
1903 vlen = SCM_BITVECTOR_LENGTH (v);
1904 if (SCM_FALSEP (obj))
1905 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1906 {
1907 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1908 if (k >= vlen)
1909 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1910 SCM_BITVEC_CLR(v,k);
1911 }
1912 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1913 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1914 {
1915 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1916 if (k >= vlen)
1917 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1918 SCM_BITVEC_SET(v,k);
1919 }
1920 else
1921 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1922 break;
1923 case scm_tc7_bvect:
1924 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1925 if (SCM_FALSEP (obj))
1926 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1927 SCM_BITVECTOR_BASE (v) [k] &= ~SCM_BITVECTOR_BASE (kv) [k];
1928 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1929 for (k = (SCM_BITVECTOR_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1930 SCM_BITVECTOR_BASE (v) [k] |= SCM_BITVECTOR_BASE (kv) [k];
1931 else
1932 goto badarg3;
1933 break;
1934 }
1935 return SCM_UNSPECIFIED;
1936 }
1937 #undef FUNC_NAME
1938
1939
1940 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
1941 (SCM v, SCM kv, SCM obj),
1942 "Return\n"
1943 "@lisp\n"
1944 "(bit-count (bit-set*! (if bool bv (bit-invert! bv)) uve #t) #t).\n"
1945 "@end lisp\n"
1946 "@var{bv} is not modified.")
1947 #define FUNC_NAME s_scm_bit_count_star
1948 {
1949 register long i, vlen, count = 0;
1950 register unsigned long k;
1951 int fObj = 0;
1952
1953 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
1954 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1955 switch SCM_TYP7 (kv)
1956 {
1957 default:
1958 badarg2:
1959 SCM_WRONG_TYPE_ARG (2, kv);
1960 case scm_tc7_uvect:
1961 vlen = SCM_BITVECTOR_LENGTH (v);
1962 if (SCM_FALSEP (obj))
1963 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1964 {
1965 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1966 if (k >= vlen)
1967 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1968 if (!SCM_BITVEC_REF(v,k))
1969 count++;
1970 }
1971 else if (SCM_EQ_P (obj, SCM_BOOL_T))
1972 for (i = SCM_UVECTOR_LENGTH (kv); i;)
1973 {
1974 k = SCM_UNPACK (SCM_VELTS (kv)[--i]);
1975 if (k >= vlen)
1976 scm_out_of_range (FUNC_NAME, SCM_MAKINUM (k));
1977 if (SCM_BITVEC_REF (v,k))
1978 count++;
1979 }
1980 else
1981 badarg3:SCM_WRONG_TYPE_ARG (3, obj);
1982 break;
1983 case scm_tc7_bvect:
1984 SCM_ASSERT (SCM_BITVECTOR_LENGTH (v) == SCM_BITVECTOR_LENGTH (kv), v, SCM_ARG1, FUNC_NAME);
1985 if (0 == SCM_BITVECTOR_LENGTH (v))
1986 return SCM_INUM0;
1987 SCM_ASRTGO (SCM_BOOLP (obj), badarg3);
1988 fObj = SCM_EQ_P (obj, SCM_BOOL_T);
1989 i = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT;
1990 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK (SCM_VELTS (v)[i]) : ~ SCM_UNPACK (SCM_VELTS (v)[i]));
1991 k <<= SCM_LONG_BIT - 1 - ((SCM_BITVECTOR_LENGTH (v) - 1) % SCM_LONG_BIT);
1992 while (1)
1993 {
1994 for (; k; k >>= 4)
1995 count += cnt_tab[k & 0x0f];
1996 if (0 == i--)
1997 return SCM_MAKINUM (count);
1998
1999 /* urg. repetitive (see above.) */
2000 k = SCM_UNPACK (SCM_VELTS (kv)[i]) & (fObj ? SCM_UNPACK(SCM_VELTS (v)[i]) : ~SCM_UNPACK (SCM_VELTS (v)[i]));
2001 }
2002 }
2003 return SCM_MAKINUM (count);
2004 }
2005 #undef FUNC_NAME
2006
2007
2008 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
2009 (SCM v),
2010 "Modifies @var{bv} by replacing each element with its negation.")
2011 #define FUNC_NAME s_scm_bit_invert_x
2012 {
2013 long int k;
2014
2015 SCM_ASSERT (SCM_BITVECTOR_P (v), v, SCM_ARG1, FUNC_NAME);
2016
2017 k = SCM_BITVECTOR_LENGTH (v);
2018 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
2019 SCM_BITVECTOR_BASE (v) [k] = ~SCM_BITVECTOR_BASE (v) [k];
2020
2021 return SCM_UNSPECIFIED;
2022 }
2023 #undef FUNC_NAME
2024
2025
2026 SCM
2027 scm_istr2bve (char *str, long len)
2028 {
2029 SCM v = scm_make_uve (len, SCM_BOOL_T);
2030 long *data = (long *) SCM_VELTS (v);
2031 register unsigned long mask;
2032 register long k;
2033 register long j;
2034 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
2035 {
2036 data[k] = 0L;
2037 j = len - k * SCM_LONG_BIT;
2038 if (j > SCM_LONG_BIT)
2039 j = SCM_LONG_BIT;
2040 for (mask = 1L; j--; mask <<= 1)
2041 switch (*str++)
2042 {
2043 case '0':
2044 break;
2045 case '1':
2046 data[k] |= mask;
2047 break;
2048 default:
2049 return SCM_BOOL_F;
2050 }
2051 }
2052 return v;
2053 }
2054
2055
2056
2057 static SCM
2058 ra2l (SCM ra,unsigned long base,unsigned long k)
2059 {
2060 register SCM res = SCM_EOL;
2061 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2062 register size_t i;
2063 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
2064 return SCM_EOL;
2065 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
2066 if (k < SCM_ARRAY_NDIM (ra) - 1)
2067 {
2068 do
2069 {
2070 i -= inc;
2071 res = scm_cons (ra2l (ra, i, k + 1), res);
2072 }
2073 while (i != base);
2074 }
2075 else
2076 do
2077 {
2078 i -= inc;
2079 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
2080 }
2081 while (i != base);
2082 return res;
2083 }
2084
2085
2086 SCM_DEFINE (scm_t_arrayo_list, "array->list", 1, 0, 0,
2087 (SCM v),
2088 "Return a list consisting of all the elements, in order, of\n"
2089 "@var{array}.")
2090 #define FUNC_NAME s_scm_t_arrayo_list
2091 {
2092 SCM res = SCM_EOL;
2093 register long k;
2094 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2095 switch SCM_TYP7 (v)
2096 {
2097 default:
2098 badarg1:SCM_WRONG_TYPE_ARG (1, v);
2099 case scm_tc7_smob:
2100 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2101 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2102 case scm_tc7_vector:
2103 case scm_tc7_wvect:
2104 return scm_vector_to_list (v);
2105 case scm_tc7_string:
2106 return scm_string_to_list (v);
2107 case scm_tc7_bvect:
2108 {
2109 long *data = (long *) SCM_VELTS (v);
2110 register unsigned long mask;
2111 for (k = (SCM_BITVECTOR_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
2112 for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
2113 res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
2114 for (mask = 1L << ((SCM_BITVECTOR_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2115 res = scm_cons (SCM_BOOL(((long *) data)[k] & mask), res);
2116 return res;
2117 }
2118 case scm_tc7_byvect:
2119 {
2120 signed char *data = (signed char *) SCM_VELTS (v);
2121 unsigned long k = SCM_UVECTOR_LENGTH (v);
2122 while (k != 0)
2123 res = scm_cons (SCM_MAKINUM (data[--k]), res);
2124 return res;
2125 }
2126 case scm_tc7_uvect:
2127 {
2128 long *data = (long *)SCM_VELTS(v);
2129 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2130 res = scm_cons(scm_ulong2num(data[k]), res);
2131 return res;
2132 }
2133 case scm_tc7_ivect:
2134 {
2135 long *data = (long *)SCM_VELTS(v);
2136 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2137 res = scm_cons(scm_long2num(data[k]), res);
2138 return res;
2139 }
2140 case scm_tc7_svect:
2141 {
2142 short *data = (short *)SCM_VELTS(v);
2143 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2144 res = scm_cons(scm_short2num (data[k]), res);
2145 return res;
2146 }
2147 #ifdef HAVE_LONG_LONGS
2148 case scm_tc7_llvect:
2149 {
2150 long long *data = (long long *)SCM_VELTS(v);
2151 for (k = SCM_UVECTOR_LENGTH(v) - 1; k >= 0; k--)
2152 res = scm_cons(scm_long_long2num(data[k]), res);
2153 return res;
2154 }
2155 #endif
2156 case scm_tc7_fvect:
2157 {
2158 float *data = (float *) SCM_VELTS (v);
2159 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2160 res = scm_cons (scm_make_real (data[k]), res);
2161 return res;
2162 }
2163 case scm_tc7_dvect:
2164 {
2165 double *data = (double *) SCM_VELTS (v);
2166 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2167 res = scm_cons (scm_make_real (data[k]), res);
2168 return res;
2169 }
2170 case scm_tc7_cvect:
2171 {
2172 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2173 for (k = SCM_UVECTOR_LENGTH (v) - 1; k >= 0; k--)
2174 res = scm_cons (scm_make_complex (data[k][0], data[k][1]), res);
2175 return res;
2176 }
2177 }
2178 }
2179 #undef FUNC_NAME
2180
2181
2182 static int l2ra(SCM lst, SCM ra, unsigned long base, unsigned long k);
2183
2184 SCM_DEFINE (scm_list_to_uniform_array, "list->uniform-array", 3, 0, 0,
2185 (SCM ndim, SCM prot, SCM lst),
2186 "@deffnx procedure list->uniform-vector prot lst\n"
2187 "Return a uniform array of the type indicated by prototype\n"
2188 "@var{prot} with elements the same as those of @var{lst}.\n"
2189 "Elements must be of the appropriate type, no coercions are\n"
2190 "done.")
2191 #define FUNC_NAME s_scm_list_to_uniform_array
2192 {
2193 SCM shp = SCM_EOL;
2194 SCM row = lst;
2195 SCM ra;
2196 unsigned long k;
2197 long n;
2198 SCM_VALIDATE_INUM_COPY (1,ndim,k);
2199 while (k--)
2200 {
2201 n = scm_ilength (row);
2202 SCM_ASSERT (n >= 0, lst, SCM_ARG3, FUNC_NAME);
2203 shp = scm_cons (SCM_MAKINUM (n), shp);
2204 if (SCM_NIMP (row))
2205 row = SCM_CAR (row);
2206 }
2207 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot,
2208 SCM_UNDEFINED);
2209 if (SCM_NULLP (shp))
2210 {
2211 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2212 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2213 return ra;
2214 }
2215 if (!SCM_ARRAYP (ra))
2216 {
2217 unsigned long int length = SCM_INUM (scm_uniform_vector_length (ra));
2218 for (k = 0; k < length; k++, lst = SCM_CDR (lst))
2219 scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
2220 return ra;
2221 }
2222 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2223 return ra;
2224 else
2225 badlst:SCM_MISC_ERROR ("Bad scm_array contents list: ~S", SCM_LIST1 (lst));
2226 }
2227 #undef FUNC_NAME
2228
2229 static int
2230 l2ra (SCM lst, SCM ra, unsigned long base, unsigned long k)
2231 {
2232 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2233 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2234 int ok = 1;
2235 if (n <= 0)
2236 return (SCM_NULLP (lst));
2237 if (k < SCM_ARRAY_NDIM (ra) - 1)
2238 {
2239 while (n--)
2240 {
2241 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2242 return 0;
2243 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2244 base += inc;
2245 lst = SCM_CDR (lst);
2246 }
2247 if (SCM_NNULLP (lst))
2248 return 0;
2249 }
2250 else
2251 {
2252 while (n--)
2253 {
2254 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2255 return 0;
2256 scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
2257 base += inc;
2258 lst = SCM_CDR (lst);
2259 }
2260 if (SCM_NNULLP (lst))
2261 return 0;
2262 }
2263 return ok;
2264 }
2265
2266
2267 static void
2268 rapr1 (SCM ra,unsigned long j,unsigned long k,SCM port,scm_print_state *pstate)
2269 {
2270 long inc = 1;
2271 long n = (SCM_TYP7 (ra) == scm_tc7_smob
2272 ? 0
2273 : SCM_INUM (scm_uniform_vector_length (ra)));
2274 int enclosed = 0;
2275 tail:
2276 switch SCM_TYP7 (ra)
2277 {
2278 case scm_tc7_smob:
2279 if (enclosed++)
2280 {
2281 SCM_ARRAY_BASE (ra) = j;
2282 if (n-- > 0)
2283 scm_iprin1 (ra, port, pstate);
2284 for (j += inc; n-- > 0; j += inc)
2285 {
2286 scm_putc (' ', port);
2287 SCM_ARRAY_BASE (ra) = j;
2288 scm_iprin1 (ra, port, pstate);
2289 }
2290 break;
2291 }
2292 if (k + 1 < SCM_ARRAY_NDIM (ra))
2293 {
2294 long i;
2295 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2296 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2297 {
2298 scm_putc ('(', port);
2299 rapr1 (ra, j, k + 1, port, pstate);
2300 scm_puts (") ", port);
2301 j += inc;
2302 }
2303 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2304 { /* could be zero size. */
2305 scm_putc ('(', port);
2306 rapr1 (ra, j, k + 1, port, pstate);
2307 scm_putc (')', port);
2308 }
2309 break;
2310 }
2311 if (SCM_ARRAY_NDIM (ra) > 0)
2312 { /* Could be zero-dimensional */
2313 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2314 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2315 }
2316 else
2317 n = 1;
2318 ra = SCM_ARRAY_V (ra);
2319 goto tail;
2320 default:
2321 /* scm_tc7_bvect and scm_tc7_llvect only? */
2322 if (n-- > 0)
2323 scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
2324 for (j += inc; n-- > 0; j += inc)
2325 {
2326 scm_putc (' ', port);
2327 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
2328 }
2329 break;
2330 case scm_tc7_string:
2331 if (n-- > 0)
2332 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2333 if (SCM_WRITINGP (pstate))
2334 for (j += inc; n-- > 0; j += inc)
2335 {
2336 scm_putc (' ', port);
2337 scm_iprin1 (SCM_MAKE_CHAR (SCM_STRING_UCHARS (ra)[j]), port, pstate);
2338 }
2339 else
2340 for (j += inc; n-- > 0; j += inc)
2341 scm_putc (SCM_STRING_CHARS (ra)[j], port);
2342 break;
2343 case scm_tc7_byvect:
2344 if (n-- > 0)
2345 scm_intprint (((char *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2346 for (j += inc; n-- > 0; j += inc)
2347 {
2348 scm_putc (' ', port);
2349 scm_intprint (((char *)SCM_CELL_WORD_1 (ra))[j], 10, port);
2350 }
2351 break;
2352
2353 case scm_tc7_uvect:
2354 {
2355 char str[11];
2356
2357 if (n-- > 0)
2358 {
2359 /* intprint can't handle >= 2^31. */
2360 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2361 scm_puts (str, port);
2362 }
2363 for (j += inc; n-- > 0; j += inc)
2364 {
2365 scm_putc (' ', port);
2366 sprintf (str, "%lu", ((unsigned long *) SCM_VELTS (ra))[j]);
2367 scm_puts (str, port);
2368 }
2369 }
2370 case scm_tc7_ivect:
2371 if (n-- > 0)
2372 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2373 for (j += inc; n-- > 0; j += inc)
2374 {
2375 scm_putc (' ', port);
2376 scm_intprint (((signed long *) SCM_VELTS (ra))[j], 10, port);
2377 }
2378 break;
2379
2380 case scm_tc7_svect:
2381 if (n-- > 0)
2382 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2383 for (j += inc; n-- > 0; j += inc)
2384 {
2385 scm_putc (' ', port);
2386 scm_intprint (((short *) SCM_CELL_WORD_1 (ra))[j], 10, port);
2387 }
2388 break;
2389
2390 case scm_tc7_fvect:
2391 if (n-- > 0)
2392 {
2393 SCM z = scm_make_real (1.0);
2394 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2395 scm_print_real (z, port, pstate);
2396 for (j += inc; n-- > 0; j += inc)
2397 {
2398 scm_putc (' ', port);
2399 SCM_REAL_VALUE (z) = ((float *) SCM_VELTS (ra))[j];
2400 scm_print_real (z, port, pstate);
2401 }
2402 }
2403 break;
2404 case scm_tc7_dvect:
2405 if (n-- > 0)
2406 {
2407 SCM z = scm_make_real (1.0 / 3.0);
2408 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2409 scm_print_real (z, port, pstate);
2410 for (j += inc; n-- > 0; j += inc)
2411 {
2412 scm_putc (' ', port);
2413 SCM_REAL_VALUE (z) = ((double *) SCM_VELTS (ra))[j];
2414 scm_print_real (z, port, pstate);
2415 }
2416 }
2417 break;
2418 case scm_tc7_cvect:
2419 if (n-- > 0)
2420 {
2421 SCM cz = scm_make_complex (0.0, 1.0), z = scm_make_real (1.0 / 3.0);
2422 SCM_REAL_VALUE (z) =
2423 SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2424 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2425 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2426 port, pstate);
2427 for (j += inc; n-- > 0; j += inc)
2428 {
2429 scm_putc (' ', port);
2430 SCM_REAL_VALUE (z)
2431 = SCM_COMPLEX_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2432 SCM_COMPLEX_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2433 scm_print_complex ((0.0 == SCM_COMPLEX_IMAG (cz) ? z : cz),
2434 port, pstate);
2435 }
2436 }
2437 break;
2438 }
2439 }
2440
2441
2442
2443 int
2444 scm_raprin1 (SCM exp, SCM port, scm_print_state *pstate)
2445 {
2446 SCM v = exp;
2447 unsigned long base = 0;
2448 scm_putc ('#', port);
2449 tail:
2450 switch SCM_TYP7 (v)
2451 {
2452 case scm_tc7_smob:
2453 {
2454 long ndim = SCM_ARRAY_NDIM (v);
2455 base = SCM_ARRAY_BASE (v);
2456 v = SCM_ARRAY_V (v);
2457 if (SCM_ARRAYP (v))
2458
2459 {
2460 scm_puts ("<enclosed-array ", port);
2461 rapr1 (exp, base, 0, port, pstate);
2462 scm_putc ('>', port);
2463 return 1;
2464 }
2465 else
2466 {
2467 scm_intprint (ndim, 10, port);
2468 goto tail;
2469 }
2470 }
2471 case scm_tc7_bvect:
2472 if (SCM_EQ_P (exp, v))
2473 { /* a uve, not an scm_array */
2474 register long i, j, w;
2475 scm_putc ('*', port);
2476 for (i = 0; i < (SCM_BITVECTOR_LENGTH (exp)) / SCM_LONG_BIT; i++)
2477 {
2478 scm_t_bits w = SCM_UNPACK (SCM_VELTS (exp)[i]);
2479 for (j = SCM_LONG_BIT; j; j--)
2480 {
2481 scm_putc (w & 1 ? '1' : '0', port);
2482 w >>= 1;
2483 }
2484 }
2485 j = SCM_BITVECTOR_LENGTH (exp) % SCM_LONG_BIT;
2486 if (j)
2487 {
2488 w = SCM_UNPACK (SCM_VELTS (exp)[SCM_BITVECTOR_LENGTH (exp) / SCM_LONG_BIT]);
2489 for (; j; j--)
2490 {
2491 scm_putc (w & 1 ? '1' : '0', port);
2492 w >>= 1;
2493 }
2494 }
2495 return 1;
2496 }
2497 else
2498 scm_putc ('b', port);
2499 break;
2500 case scm_tc7_string:
2501 scm_putc ('a', port);
2502 break;
2503 case scm_tc7_byvect:
2504 scm_putc ('y', port);
2505 break;
2506 case scm_tc7_uvect:
2507 scm_putc ('u', port);
2508 break;
2509 case scm_tc7_ivect:
2510 scm_putc ('e', port);
2511 break;
2512 case scm_tc7_svect:
2513 scm_putc ('h', port);
2514 break;
2515 #ifdef HAVE_LONG_LONGS
2516 case scm_tc7_llvect:
2517 scm_putc ('l', port);
2518 break;
2519 #endif
2520 case scm_tc7_fvect:
2521 scm_putc ('s', port);
2522 break;
2523 case scm_tc7_dvect:
2524 scm_putc ('i', port);
2525 break;
2526 case scm_tc7_cvect:
2527 scm_putc ('c', port);
2528 break;
2529 }
2530 scm_putc ('(', port);
2531 rapr1 (exp, base, 0, port, pstate);
2532 scm_putc (')', port);
2533 return 1;
2534 }
2535
2536 SCM_DEFINE (scm_array_prototype, "array-prototype", 1, 0, 0,
2537 (SCM ra),
2538 "Return an object that would produce an array of the same type\n"
2539 "as @var{array}, if used as the @var{prototype} for\n"
2540 "@code{make-uniform-array}.")
2541 #define FUNC_NAME s_scm_array_prototype
2542 {
2543 int enclosed = 0;
2544 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2545 loop:
2546 switch SCM_TYP7 (ra)
2547 {
2548 default:
2549 badarg:SCM_WRONG_TYPE_ARG (1, ra);
2550 case scm_tc7_smob:
2551 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2552 if (enclosed++)
2553 return SCM_UNSPECIFIED;
2554 ra = SCM_ARRAY_V (ra);
2555 goto loop;
2556 case scm_tc7_vector:
2557 case scm_tc7_wvect:
2558 return SCM_EOL;
2559 case scm_tc7_bvect:
2560 return SCM_BOOL_T;
2561 case scm_tc7_string:
2562 return SCM_MAKE_CHAR ('a');
2563 case scm_tc7_byvect:
2564 return SCM_MAKE_CHAR ('\0');
2565 case scm_tc7_uvect:
2566 return SCM_MAKINUM (1L);
2567 case scm_tc7_ivect:
2568 return SCM_MAKINUM (-1L);
2569 case scm_tc7_svect:
2570 return scm_str2symbol ("s");
2571 #ifdef HAVE_LONG_LONGS
2572 case scm_tc7_llvect:
2573 return scm_str2symbol ("l");
2574 #endif
2575 case scm_tc7_fvect:
2576 return scm_make_real (1.0);
2577 case scm_tc7_dvect:
2578 return scm_make_real (1.0 / 3.0);
2579 case scm_tc7_cvect:
2580 return scm_make_complex (0.0, 1.0);
2581 }
2582 }
2583 #undef FUNC_NAME
2584
2585
2586 static SCM
2587 array_mark (SCM ptr)
2588 {
2589 return SCM_ARRAY_V (ptr);
2590 }
2591
2592
2593 static size_t
2594 array_free (SCM ptr)
2595 {
2596 scm_must_free (SCM_ARRAY_MEM (ptr));
2597 return sizeof (scm_t_array) +
2598 SCM_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim);
2599 }
2600
2601 void
2602 scm_init_unif ()
2603 {
2604 scm_tc16_array = scm_make_smob_type ("array", 0);
2605 scm_set_smob_mark (scm_tc16_array, array_mark);
2606 scm_set_smob_free (scm_tc16_array, array_free);
2607 scm_set_smob_print (scm_tc16_array, scm_raprin1);
2608 scm_set_smob_equalp (scm_tc16_array, scm_array_equal_p);
2609 scm_add_feature ("array");
2610 #ifndef SCM_MAGIC_SNARFER
2611 #include "libguile/unif.x"
2612 #endif
2613 }
2614
2615 /*
2616 Local Variables:
2617 c-file-style: "gnu"
2618 End:
2619 */
Unnamed repository; edit this file 'description' to name the repository.