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