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