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