HCoop / bpt / guile.git / blob
? search:


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