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