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