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