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