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