HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* boot-9.scm (%%handle-system-error key): set args and rest to
[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 {
506 SCM_ASSERT (1 == k, SCM_UNDEFINED, SCM_WNA, what);
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 }
520 SCM_ASSERT (0 == k && SCM_NULLP (args), SCM_UNDEFINED, SCM_WNA, what);
521 return pos;
522}
523
524
525#ifdef __STDC__
526SCM
527scm_make_ra (int ndim)
528#else
529SCM
530scm_make_ra (ndim)
531 int ndim;
532#endif
533{
534 SCM ra;
535 SCM_NEWCELL (ra);
536 SCM_DEFER_INTS;
537 SCM_SETCDR (ra, scm_must_malloc ((long) (sizeof (scm_array) + ndim * sizeof (scm_array_dim)),
538 "array"));
539 SCM_CAR (ra) = ((long) ndim << 17) + scm_tc16_array;
540 SCM_ARRAY_V (ra) = scm_nullvect;
541 SCM_ALLOW_INTS;
542 return ra;
543}
544
545static char s_bad_spec[] = "Bad scm_array dimension";
546/* Increments will still need to be set. */
547
548#ifdef __STDC__
549SCM
550scm_shap2ra (SCM args, char *what)
551#else
552SCM
553scm_shap2ra (args, what)
554 SCM args;
555 char *what;
556#endif
557{
558 scm_array_dim *s;
559 SCM ra, spec, sp;
560 int ndim = scm_ilength (args);
561 SCM_ASSERT (0 <= ndim, args, s_bad_spec, what);
562 ra = scm_make_ra (ndim);
563 SCM_ARRAY_BASE (ra) = 0;
564 s = SCM_ARRAY_DIMS (ra);
565 for (; SCM_NIMP (args); s++, args = SCM_CDR (args))
566 {
567 spec = SCM_CAR (args);
568 if (SCM_IMP (spec))
569
570 {
571 SCM_ASSERT (SCM_INUMP (spec) && SCM_INUM (spec) >= 0, spec, s_bad_spec, what);
572 s->lbnd = 0;
573 s->ubnd = SCM_INUM (spec) - 1;
574 s->inc = 1;
575 }
576 else
577 {
578 SCM_ASSERT (SCM_CONSP (spec) && SCM_INUMP (SCM_CAR (spec)), spec, s_bad_spec, what);
579 s->lbnd = SCM_INUM (SCM_CAR (spec));
580 sp = SCM_CDR (spec);
581 SCM_ASSERT (SCM_INUMP (SCM_CAR (sp)) && SCM_NULLP (SCM_CDR (sp)),
582 spec, s_bad_spec, what);
583 s->ubnd = SCM_INUM (SCM_CAR (sp));
584 s->inc = 1;
585 }
586 }
587 return ra;
588}
589
590SCM_PROC(s_dimensions_to_uniform_array, "dimensions->uniform-array", 2, 0, 1, scm_dimensions_to_uniform_array);
591#ifdef __STDC__
592SCM
593scm_dimensions_to_uniform_array (SCM dims, SCM prot, SCM fill)
594#else
595SCM
596scm_dimensions_to_uniform_array (dims, prot, fill)
597 SCM dims;
598 SCM prot;
599 SCM fill;
600#endif
601{
602 scm_sizet k, vlen = 1;
603 long rlen = 1;
604 scm_array_dim *s;
605 SCM ra;
606 if (SCM_INUMP (dims))
607 if (SCM_INUM (dims) < SCM_LENGTH_MAX)
608 {
609 SCM answer;
610 answer = scm_make_uve (SCM_INUM (dims), prot);
611 if (SCM_NNULLP (fill))
612 {
613 SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
614 scm_array_fill_x (answer, SCM_CAR (fill));
615 }
616 else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
617 scm_array_fill_x (answer, SCM_MAKINUM (0));
618 else
619 scm_array_fill_x (answer, prot);
620 return answer;
621 }
622 else
623 dims = scm_cons (dims, SCM_EOL);
624 SCM_ASSERT (SCM_NULLP (dims) || (SCM_NIMP (dims) && SCM_CONSP (dims)),
625 dims, SCM_ARG1, s_dimensions_to_uniform_array);
626 ra = scm_shap2ra (dims, s_dimensions_to_uniform_array);
627 SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
628 s = SCM_ARRAY_DIMS (ra);
629 k = SCM_ARRAY_NDIM (ra);
630 while (k--)
631 {
632 s[k].inc = (rlen > 0 ? rlen : 0);
633 rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
634 vlen *= (s[k].ubnd - s[k].lbnd + 1);
635 }
636 if (rlen < SCM_LENGTH_MAX)
637 SCM_ARRAY_V (ra) = scm_make_uve ((rlen > 0 ? rlen : 0L), prot);
638 else
639 {
640 scm_sizet bit;
641 switch (SCM_TYP7 (scm_make_uve (0L, prot)))
642 {
643 default:
644 bit = SCM_LONG_BIT;
645 break;
646 case scm_tc7_bvect:
647 bit = 1;
648 break;
649 case scm_tc7_string:
650 bit = SCM_CHAR_BIT;
651 break;
652 case scm_tc7_fvect:
653 bit = sizeof (float) * SCM_CHAR_BIT / sizeof (char);
654 break;
655 case scm_tc7_dvect:
656 bit = sizeof (double) * SCM_CHAR_BIT / sizeof (char);
657 break;
658 case scm_tc7_cvect:
659 bit = 2 * sizeof (double) * SCM_CHAR_BIT / sizeof (char);
660 break;
661 }
662 SCM_ARRAY_BASE (ra) = (SCM_LONG_BIT + bit - 1) / bit;
663 rlen += SCM_ARRAY_BASE (ra);
664 SCM_ARRAY_V (ra) = scm_make_uve (rlen, prot);
665 *((long *) SCM_VELTS (SCM_ARRAY_V (ra))) = rlen;
666 }
667 if (SCM_NNULLP (fill))
668 {
669 SCM_ASSERT (1 == scm_ilength (fill), fill, SCM_WNA, s_dimensions_to_uniform_array);
670 scm_array_fill_x (ra, SCM_CAR (fill));
671 }
672 else if (SCM_NIMP (prot) && SCM_SYMBOLP (prot))
673 scm_array_fill_x (ra, SCM_MAKINUM (0));
674 else
675 scm_array_fill_x (ra, prot);
676 if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
677 if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
678 return SCM_ARRAY_V (ra);
679 return ra;
680}
681
682#ifdef __STDC__
683void
684scm_ra_set_contp (SCM ra)
685#else
686void
687scm_ra_set_contp (ra)
688 SCM ra;
689#endif
690{
691 scm_sizet k = SCM_ARRAY_NDIM (ra);
692 long inc;
693 if (k)
694 inc = SCM_ARRAY_DIMS (ra)[k - 1].inc;
695 while (k--)
696 {
697 if (inc != SCM_ARRAY_DIMS (ra)[k].inc)
698 {
699 SCM_CAR (ra) &= ~SCM_ARRAY_CONTIGUOUS;
700 return;
701 }
702 inc *= (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
703 }
704 SCM_CAR (ra) |= SCM_ARRAY_CONTIGUOUS;
705}
706
707
708SCM_PROC(s_make_shared_array, "make-shared-array", 2, 0, 1, scm_make_shared_array);
709#ifdef __STDC__
710SCM
711scm_make_shared_array (SCM oldra, SCM mapfunc, SCM dims)
712#else
713SCM
714scm_make_shared_array (oldra, mapfunc, dims)
715 SCM oldra;
716 SCM mapfunc;
717 SCM dims;
718#endif
719{
720 SCM ra;
721 SCM inds, indptr;
722 SCM imap;
723 scm_sizet i, k;
724 long old_min, new_min, old_max, new_max;
725 scm_array_dim *s;
726 SCM_ASSERT (SCM_BOOL_T == scm_procedure_p (mapfunc), mapfunc, SCM_ARG2, s_make_shared_array);
727 SCM_ASSERT (SCM_NIMP (oldra) && (SCM_BOOL_F != scm_array_p (oldra, SCM_UNDEFINED)), oldra, SCM_ARG1, s_make_shared_array);
728 ra = scm_shap2ra (dims, s_make_shared_array);
729 if (SCM_ARRAYP (oldra))
730 {
731 SCM_ARRAY_V (ra) = SCM_ARRAY_V (oldra);
732 old_min = old_max = SCM_ARRAY_BASE (oldra);
733 s = SCM_ARRAY_DIMS (oldra);
734 k = SCM_ARRAY_NDIM (oldra);
735 while (k--)
736 {
737 if (s[k].inc > 0)
738 old_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
739 else
740 old_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
741 }
742 }
743 else
744 {
745 SCM_ARRAY_V (ra) = oldra;
746 old_min = 0;
747 old_max = (long) SCM_LENGTH (oldra) - 1;
748 }
749 inds = SCM_EOL;
750 s = SCM_ARRAY_DIMS (ra);
751 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
752 {
753 inds = scm_cons (SCM_MAKINUM (s[k].lbnd), inds);
754 if (s[k].ubnd < s[k].lbnd)
755 {
756 if (1 == SCM_ARRAY_NDIM (ra))
757 ra = scm_make_uve (0L, scm_array_prototype (ra));
758 else
759 SCM_ARRAY_V (ra) = scm_make_uve (0L, scm_array_prototype (ra));
760 return ra;
761 }
762 }
763 imap = scm_apply (mapfunc, scm_list_reverse (inds), SCM_EOL);
764 if (SCM_ARRAYP (oldra))
765 i = (scm_sizet) scm_aind (oldra, imap, s_make_shared_array);
766 else
767 {
768 if (SCM_NINUMP (imap))
769
770 {
771 SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
772 imap, s_bad_ind, s_make_shared_array);
773 imap = SCM_CAR (imap);
774 }
775 i = SCM_INUM (imap);
776 }
777 SCM_ARRAY_BASE (ra) = new_min = new_max = i;
778 indptr = inds;
779 k = SCM_ARRAY_NDIM (ra);
780 while (k--)
781 {
782 if (s[k].ubnd > s[k].lbnd)
783 {
784 SCM_CAR (indptr) = SCM_MAKINUM (SCM_INUM (SCM_CAR (indptr)) + 1);
785 imap = scm_apply (mapfunc, scm_reverse (inds), SCM_EOL);
786 if (SCM_ARRAYP (oldra))
787
788 s[k].inc = scm_aind (oldra, imap, s_make_shared_array) - i;
789 else
790 {
791 if (SCM_NINUMP (imap))
792
793 {
794 SCM_ASSERT (1 == scm_ilength (imap) && SCM_INUMP (SCM_CAR (imap)),
795 imap, s_bad_ind, s_make_shared_array);
796 imap = SCM_CAR (imap);
797 }
798 s[k].inc = (long) SCM_INUM (imap) - i;
799 }
800 i += s[k].inc;
801 if (s[k].inc > 0)
802 new_max += (s[k].ubnd - s[k].lbnd) * s[k].inc;
803 else
804 new_min += (s[k].ubnd - s[k].lbnd) * s[k].inc;
805 }
806 else
807 s[k].inc = new_max - new_min + 1; /* contiguous by default */
808 indptr = SCM_CDR (indptr);
809 }
810 SCM_ASSERT (old_min <= new_min && old_max >= new_max, SCM_UNDEFINED,
811 "mapping out of range", s_make_shared_array);
812 if (1 == SCM_ARRAY_NDIM (ra) && 0 == SCM_ARRAY_BASE (ra))
813 {
814 if (1 == s->inc && 0 == s->lbnd
815 && SCM_LENGTH (SCM_ARRAY_V (ra)) == 1 + s->ubnd)
816 return SCM_ARRAY_V (ra);
817 if (s->ubnd < s->lbnd)
818 return scm_make_uve (0L, scm_array_prototype (ra));
819 }
820 scm_ra_set_contp (ra);
821 return ra;
822}
823
824
825/* args are RA . DIMS */
826SCM_PROC(s_transpose_array, "transpose-array", 0, 0, 1, scm_transpose_array);
827#ifdef __STDC__
828SCM
829scm_transpose_array (SCM args)
830#else
831SCM
832scm_transpose_array (args)
833 SCM args;
834#endif
835{
836 SCM ra, res, vargs, *ve = &vargs;
837 scm_array_dim *s, *r;
838 int ndim, i, k;
839 SCM_ASSERT (SCM_NIMP (args), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
840 ra = SCM_CAR (args);
841 args = SCM_CDR (args);
842 switch SCM_TYP7
843 (ra)
844 {
845 default:
846 badarg:scm_wta (ra, (char *) SCM_ARG1, s_transpose_array);
847 case scm_tc7_bvect:
848 case scm_tc7_string:
849 case scm_tc7_byvect:
850 case scm_tc7_uvect:
851 case scm_tc7_ivect:
852 case scm_tc7_fvect:
853 case scm_tc7_dvect:
854 case scm_tc7_cvect:
855 case scm_tc7_svect:
856#ifdef LONGLONGS
857 case scm_tc7_llvect:
858#endif
859 SCM_ASSERT (SCM_NIMP (args) && SCM_NULLP (SCM_CDR (args)), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
860 SCM_ASSERT (SCM_INUM0 == SCM_CAR (args), SCM_CAR (args), SCM_ARG1, s_transpose_array);
861 return ra;
862 case scm_tc7_smob:
863 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
864 vargs = scm_vector (args);
865 SCM_ASSERT (SCM_LENGTH (vargs) == SCM_ARRAY_NDIM (ra), SCM_UNDEFINED, SCM_WNA, s_transpose_array);
866 ve = SCM_VELTS (vargs);
867 ndim = 0;
868 for (k = 0; k < SCM_ARRAY_NDIM (ra); k++)
869 {
870 i = SCM_INUM (ve[k]);
871 SCM_ASSERT (SCM_INUMP (ve[k]) && i >= 0 && i < SCM_ARRAY_NDIM (ra),
872 ve[k], SCM_ARG2, s_transpose_array);
873 if (ndim < i)
874 ndim = i;
875 }
876 ndim++;
877 res = scm_make_ra (ndim);
878 SCM_ARRAY_V (res) = SCM_ARRAY_V (ra);
879 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra);
880 for (k = ndim; k--;)
881 {
882 SCM_ARRAY_DIMS (res)[k].lbnd = 0;
883 SCM_ARRAY_DIMS (res)[k].ubnd = -1;
884 }
885 for (k = SCM_ARRAY_NDIM (ra); k--;)
886 {
887 i = SCM_INUM (ve[k]);
888 s = &(SCM_ARRAY_DIMS (ra)[k]);
889 r = &(SCM_ARRAY_DIMS (res)[i]);
890 if (r->ubnd < r->lbnd)
891 {
892 r->lbnd = s->lbnd;
893 r->ubnd = s->ubnd;
894 r->inc = s->inc;
895 ndim--;
896 }
897 else
898 {
899 if (r->ubnd > s->ubnd)
900 r->ubnd = s->ubnd;
901 if (r->lbnd < s->lbnd)
902 {
903 SCM_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
904 r->lbnd = s->lbnd;
905 }
906 r->inc += s->inc;
907 }
908 }
909 SCM_ASSERT (ndim <= 0, args, "bad argument scm_list", s_transpose_array);
910 scm_ra_set_contp (res);
911 return res;
912 }
913}
914
915/* args are RA . AXES */
916SCM_PROC(s_enclose_array, "enclose-array", 0, 0, 1, scm_enclose_array);
917#ifdef __STDC__
918SCM
919scm_enclose_array (SCM axes)
920#else
921SCM
922scm_enclose_array (axes)
923 SCM axes;
924#endif
925{
926 SCM axv, ra, res, ra_inr;
927 scm_array_dim vdim, *s = &vdim;
928 int ndim, j, k, ninr, noutr;
929 SCM_ASSERT (SCM_NIMP (axes), SCM_UNDEFINED, SCM_WNA, s_enclose_array);
930 ra = SCM_CAR (axes);
931 axes = SCM_CDR (axes);
932 if (SCM_NULLP (axes))
933
934 axes = scm_cons ((SCM_ARRAYP (ra) ? SCM_MAKINUM (SCM_ARRAY_NDIM (ra) - 1) : SCM_INUM0), SCM_EOL);
935 ninr = scm_ilength (axes);
936 ra_inr = scm_make_ra (ninr);
937 SCM_ASRTGO (SCM_NIMP (ra), badarg1);
938 switch SCM_TYP7
939 (ra)
940 {
941 default:
942 badarg1:scm_wta (ra, (char *) SCM_ARG1, s_enclose_array);
943 case scm_tc7_string:
944 case scm_tc7_bvect:
945 case scm_tc7_byvect:
946 case scm_tc7_uvect:
947 case scm_tc7_ivect:
948 case scm_tc7_fvect:
949 case scm_tc7_dvect:
950 case scm_tc7_cvect:
951 case scm_tc7_vector:
952 case scm_tc7_svect:
953#ifdef LONGLONGS
954 case scm_tc7_llvect:
955#endif
956 s->lbnd = 0;
957 s->ubnd = SCM_LENGTH (ra) - 1;
958 s->inc = 1;
959 SCM_ARRAY_V (ra_inr) = ra;
960 SCM_ARRAY_BASE (ra_inr) = 0;
961 ndim = 1;
962 break;
963 case scm_tc7_smob:
964 SCM_ASRTGO (SCM_ARRAYP (ra), badarg1);
965 s = SCM_ARRAY_DIMS (ra);
966 SCM_ARRAY_V (ra_inr) = SCM_ARRAY_V (ra);
967 SCM_ARRAY_BASE (ra_inr) = SCM_ARRAY_BASE (ra);
968 ndim = SCM_ARRAY_NDIM (ra);
969 break;
970 }
971 noutr = ndim - ninr;
972 axv = scm_make_string (SCM_MAKINUM (ndim), SCM_MAKICHR (0));
973 SCM_ASSERT (0 <= noutr && 0 <= ninr, SCM_UNDEFINED, SCM_WNA, s_enclose_array);
974 res = scm_make_ra (noutr);
975 SCM_ARRAY_BASE (res) = SCM_ARRAY_BASE (ra_inr);
976 SCM_ARRAY_V (res) = ra_inr;
977 for (k = 0; k < ninr; k++, axes = SCM_CDR (axes))
978 {
979 SCM_ASSERT (SCM_INUMP (SCM_CAR (axes)), SCM_CAR (axes), "bad axis", s_enclose_array);
980 j = SCM_INUM (SCM_CAR (axes));
981 SCM_ARRAY_DIMS (ra_inr)[k].lbnd = s[j].lbnd;
982 SCM_ARRAY_DIMS (ra_inr)[k].ubnd = s[j].ubnd;
983 SCM_ARRAY_DIMS (ra_inr)[k].inc = s[j].inc;
984 SCM_CHARS (axv)[j] = 1;
985 }
986 for (j = 0, k = 0; k < noutr; k++, j++)
987 {
988 while (SCM_CHARS (axv)[j])
989 j++;
990 SCM_ARRAY_DIMS (res)[k].lbnd = s[j].lbnd;
991 SCM_ARRAY_DIMS (res)[k].ubnd = s[j].ubnd;
992 SCM_ARRAY_DIMS (res)[k].inc = s[j].inc;
993 }
994 scm_ra_set_contp (ra_inr);
995 scm_ra_set_contp (res);
996 return res;
997}
998
999
1000
1001SCM_PROC(s_array_in_bounds_p, "array-in-bounds?", 0, 0, 1, scm_array_in_bounds_p);
1002#ifdef __STDC__
1003SCM
1004scm_array_in_bounds_p (SCM args)
1005#else
1006SCM
1007scm_array_in_bounds_p (args)
1008 SCM args;
1009#endif
1010{
1011 SCM v, ind = SCM_EOL;
1012 long pos = 0;
1013 register scm_sizet k;
1014 register long j;
1015 scm_array_dim *s;
1016 SCM_ASSERT (SCM_NIMP (args), args, SCM_WNA, s_array_in_bounds_p);
1017 v = SCM_CAR (args);
1018 args = SCM_CDR (args);
1019 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1020 if (SCM_NIMP (args))
1021
1022 {
1023 ind = SCM_CAR (args);
1024 args = SCM_CDR (args);
1025 SCM_ASSERT (SCM_INUMP (ind), ind, SCM_ARG2, s_array_in_bounds_p);
1026 pos = SCM_INUM (ind);
1027 }
1028tail:
1029 switch SCM_TYP7
1030 (v)
1031 {
1032 default:
1033 badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_in_bounds_p);
1034 wna:scm_wta (args, (char *) SCM_WNA, s_array_in_bounds_p);
1035 case scm_tc7_smob:
1036 k = SCM_ARRAY_NDIM (v);
1037 s = SCM_ARRAY_DIMS (v);
1038 pos = SCM_ARRAY_BASE (v);
1039 if (!k)
1040 {
1041 SCM_ASRTGO (SCM_NULLP (ind), wna);
1042 ind = SCM_INUM0;
1043 }
1044 else
1045 while (!0)
1046 {
1047 j = SCM_INUM (ind);
1048 if (!(j >= (s->lbnd) && j <= (s->ubnd)))
1049 {
1050 SCM_ASRTGO (--k == scm_ilength (args), wna);
1051 return SCM_BOOL_F;
1052 }
1053 pos += (j - s->lbnd) * (s->inc);
1054 if (!(--k && SCM_NIMP (args)))
1055 break;
1056 ind = SCM_CAR (args);
1057 args = SCM_CDR (args);
1058 s++;
1059 SCM_ASSERT (SCM_INUMP (ind), ind, s_bad_ind, s_array_in_bounds_p);
1060 }
1061 SCM_ASRTGO (0 == k, wna);
1062 v = SCM_ARRAY_V (v);
1063 goto tail;
1064 case scm_tc7_bvect:
1065 case scm_tc7_string:
1066 case scm_tc7_byvect:
1067 case scm_tc7_uvect:
1068 case scm_tc7_ivect:
1069 case scm_tc7_fvect:
1070 case scm_tc7_dvect:
1071 case scm_tc7_cvect:
1072 case scm_tc7_svect:
1073#ifdef LONGLONGS
1074 case scm_tc7_llvect:
1075#endif
1076 case scm_tc7_vector:
1077 SCM_ASRTGO (SCM_NULLP (args) && SCM_INUMP (ind), wna);
1078 return pos >= 0 && pos < SCM_LENGTH (v) ? SCM_BOOL_T : SCM_BOOL_F;
1079 }
1080}
1081
1082
1083SCM_PROC(s_array_ref, "array-ref", 1, 0, 1, scm_uniform_vector_ref);
1084SCM_PROC(s_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0, scm_uniform_vector_ref);
1085#ifdef __STDC__
1086SCM
1087scm_uniform_vector_ref (SCM v, SCM args)
1088#else
1089SCM
1090scm_uniform_vector_ref (v, args)
1091 SCM v;
1092 SCM args;
1093#endif
1094{
1095 long pos;
1096 if (SCM_IMP (v))
1097
1098 {
1099 SCM_ASRTGO (SCM_NULLP (args), badarg);
1100 return v;
1101 }
1102 else if (SCM_ARRAYP (v))
1103
1104 {
1105 pos = scm_aind (v, args, s_uniform_vector_ref);
1106 v = SCM_ARRAY_V (v);
1107 }
1108 else
1109 {
1110 if (SCM_NIMP (args))
1111
1112 {
1113 SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_uniform_vector_ref);
1114 pos = SCM_INUM (SCM_CAR (args));
1115 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1116 }
1117 else
1118 {
1119 SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_uniform_vector_ref);
1120 pos = SCM_INUM (args);
1121 }
1122 SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
1123 }
1124 switch SCM_TYP7
1125 (v)
1126 {
1127 default:
1128 if (SCM_NULLP (args))
1129 return v;
1130 badarg:scm_wta (v, (char *) SCM_ARG1, s_uniform_vector_ref);
1131 outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_uniform_vector_ref);
1132 wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_uniform_vector_ref);
1133 case scm_tc7_smob:
1134 { /* enclosed */
1135 int k = SCM_ARRAY_NDIM (v);
1136 SCM res = scm_make_ra (k);
1137 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1138 SCM_ARRAY_BASE (res) = pos;
1139 while (k--)
1140 {
1141 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1142 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1143 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1144 }
1145 return res;
1146 }
1147 case scm_tc7_bvect:
1148 if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
1149 return SCM_BOOL_T;
1150 else
1151 return SCM_BOOL_F;
1152 case scm_tc7_string:
1153 return SCM_MAKICHR (SCM_CHARS (v)[pos]);
1154 case scm_tc7_byvect:
1155 return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
1156# ifdef SCM_INUMS_ONLY
1157 case scm_tc7_uvect:
1158 case scm_tc7_ivect:
1159 return SCM_MAKINUM (SCM_VELTS (v)[pos]);
1160# else
1161 case scm_tc7_uvect:
1162 return scm_ulong2num(SCM_VELTS(v)[pos]);
1163 case scm_tc7_ivect:
1164 return scm_long2num(SCM_VELTS(v)[pos]);
1165# endif
1166
1167 case scm_tc7_svect:
1168 return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
1169#ifdef LONGLONGS
1170 case scm_tc7_llvect:
1171 return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
1172#endif
1173
1174#ifdef SCM_FLOATS
1175#ifdef SCM_SINGLES
1176 case scm_tc7_fvect:
1177 return scm_makflo (((float *) SCM_CDR (v))[pos]);
1178#endif
1179 case scm_tc7_dvect:
1180 return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
1181 case scm_tc7_cvect:
1182 return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
1183 ((double *) SCM_CDR (v))[2 * pos + 1]);
1184#endif
1185 case scm_tc7_vector:
1186 return SCM_VELTS (v)[pos];
1187 }
1188}
1189
1190/* Internal version of scm_uniform_vector_ref for uves that does no error checking and
1191 tries to recycle conses. (Make *sure* you want them recycled.) */
1192#ifdef __STDC__
1193SCM
1194scm_cvref (SCM v, scm_sizet pos, SCM last)
1195#else
1196SCM
1197scm_cvref (v, pos, last)
1198 SCM v;
1199 scm_sizet pos;
1200 SCM last;
1201#endif
1202{
1203 switch SCM_TYP7
1204 (v)
1205 {
1206 default:
1207 scm_wta (v, (char *) SCM_ARG1, "PROGRAMMING ERROR: scm_cvref");
1208 case scm_tc7_bvect:
1209 if (SCM_VELTS (v)[pos / SCM_LONG_BIT] & (1L << (pos % SCM_LONG_BIT)))
1210 return SCM_BOOL_T;
1211 else
1212 return SCM_BOOL_F;
1213 case scm_tc7_string:
1214 return SCM_MAKICHR (SCM_CHARS (v)[pos]);
1215 case scm_tc7_byvect:
1216 return SCM_MAKINUM (((char *)SCM_CHARS (v))[pos]);
1217# ifdef SCM_INUMS_ONLY
1218 case scm_tc7_uvect:
1219 case scm_tc7_ivect:
1220 return SCM_MAKINUM (SCM_VELTS (v)[pos]);
1221# else
1222 case scm_tc7_uvect:
1223 return scm_ulong2num(SCM_VELTS(v)[pos]);
1224 case scm_tc7_ivect:
1225 return scm_long2num(SCM_VELTS(v)[pos]);
1226# endif
1227 case scm_tc7_svect:
1228 return SCM_MAKINUM (((short *) SCM_CDR (v))[pos]);
1229#ifdef LONGLONGS
1230 case scm_tc7_llvect:
1231 return scm_long_long2num (((long_long *) SCM_CDR (v))[pos]);
1232#endif
1233#ifdef SCM_FLOATS
1234#ifdef SCM_SINGLES
1235 case scm_tc7_fvect:
1236 if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_flo == SCM_CAR (last)))
1237 {
1238 SCM_FLO (last) = ((float *) SCM_CDR (v))[pos];
1239 return last;
1240 }
1241 return scm_makflo (((float *) SCM_CDR (v))[pos]);
1242#endif
1243 case scm_tc7_dvect:
1244#ifdef SCM_SINGLES
1245 if (SCM_NIMP (last) && scm_tc_dblr == SCM_CAR (last))
1246#else
1247 if (SCM_NIMP (last) && (last != scm_flo0) && (scm_tc_dblr == SCM_CAR (last)))
1248#endif
1249 {
1250 SCM_REAL (last) = ((double *) SCM_CDR (v))[pos];
1251 return last;
1252 }
1253 return scm_makdbl (((double *) SCM_CDR (v))[pos], 0.0);
1254 case scm_tc7_cvect:
1255 if (SCM_NIMP (last) && scm_tc_dblc == SCM_CAR (last))
1256 {
1257 SCM_REAL (last) = ((double *) SCM_CDR (v))[2 * pos];
1258 SCM_IMAG (last) = ((double *) SCM_CDR (v))[2 * pos + 1];
1259 return last;
1260 }
1261 return scm_makdbl (((double *) SCM_CDR (v))[2 * pos],
1262 ((double *) SCM_CDR (v))[2 * pos + 1]);
1263#endif
1264 case scm_tc7_vector:
1265 return SCM_VELTS (v)[pos];
1266 case scm_tc7_smob:
1267 { /* enclosed scm_array */
1268 int k = SCM_ARRAY_NDIM (v);
1269 SCM res = scm_make_ra (k);
1270 SCM_ARRAY_V (res) = SCM_ARRAY_V (v);
1271 SCM_ARRAY_BASE (res) = pos;
1272 while (k--)
1273 {
1274 SCM_ARRAY_DIMS (res)[k].ubnd = SCM_ARRAY_DIMS (v)[k].ubnd;
1275 SCM_ARRAY_DIMS (res)[k].lbnd = SCM_ARRAY_DIMS (v)[k].lbnd;
1276 SCM_ARRAY_DIMS (res)[k].inc = SCM_ARRAY_DIMS (v)[k].inc;
1277 }
1278 return res;
1279 }
1280 }
1281}
1282
1283SCM_PROC(s_uniform_array_set1_x, "uniform-array-set1!", 3, 0, 0, scm_array_set_x);
1284SCM_PROC(s_array_set_x, "array-set!", 2, 0, 1, scm_array_set_x);
1285#ifdef __STDC__
1286SCM
1287scm_array_set_x (SCM v, SCM obj, SCM args)
1288#else
1289SCM
1290scm_array_set_x (v, obj, args)
1291 SCM v;
1292 SCM obj;
1293 SCM args;
1294#endif
1295{
1296 long pos;
1297 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1298 if (SCM_ARRAYP (v))
1299
1300 {
1301 pos = scm_aind (v, args, s_array_set_x);
1302 v = SCM_ARRAY_V (v);
1303 }
1304 else
1305 {
1306 if (SCM_NIMP (args))
1307
1308 {
1309 SCM_ASSERT (SCM_CONSP (args) && SCM_INUMP (SCM_CAR (args)), args, SCM_ARG2, s_array_set_x);
1310 pos = SCM_INUM (SCM_CAR (args));
1311 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
1312 }
1313 else
1314 {
1315 SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG2, s_array_set_x);
1316 pos = SCM_INUM (args);
1317 }
1318 SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
1319 }
1320 switch (SCM_TYP7 (v))
1321 {
1322 default:
1323 badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
1324 outrng:scm_wta (SCM_MAKINUM (pos), (char *) SCM_OUTOFRANGE, s_array_set_x);
1325 wna:scm_wta (SCM_UNDEFINED, (char *) SCM_WNA, s_array_set_x);
1326 case scm_tc7_smob: /* enclosed */
1327 goto badarg1;
1328 case scm_tc7_bvect:
1329 if (SCM_BOOL_F == obj)
1330 SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT));
1331 else if (SCM_BOOL_T == obj)
1332 SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
1333 else
1334 badarg3:scm_wta (obj, (char *) SCM_ARG3, s_array_set_x);
1335 break;
1336 case scm_tc7_string:
1337 SCM_ASRTGO (SCM_ICHRP (obj), badarg3);
1338 SCM_CHARS (v)[pos] = SCM_ICHR (obj);
1339 break;
1340 case scm_tc7_byvect:
1341 if (SCM_ICHRP (obj))
1342 obj = SCM_MAKINUM (SCM_ICHR (obj));
1343 SCM_ASRTGO (SCM_INUMP (obj), badarg3);
1344 ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
1345 break;
1346# ifdef SCM_INUMS_ONLY
1347 case scm_tc7_uvect:
1348 SCM_ASRTGO (SCM_INUM (obj) >= 0, badarg3);
1349 case scm_tc7_ivect:
1350 SCM_ASRTGO(SCM_INUMP(obj), badarg3); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
1351# else
1352 case scm_tc7_uvect:
1353 SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG3, s_array_set_x); break;
1354 case scm_tc7_ivect:
1355 SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG3, s_array_set_x); break;
1356# endif
1357 break;
1358
1359 case scm_tc7_svect:
1360 SCM_ASRTGO (SCM_INUMP (obj), badarg3);
1361 ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
1362 break;
1363#ifdef LONGLONGS
1364 case scm_tc7_llvect:
1365 ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG3, s_array_set_x);
1366 break;
1367#endif
1368
1369
1370#ifdef SCM_FLOATS
1371#ifdef SCM_SINGLES
1372 case scm_tc7_fvect:
1373 SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
1374 ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
1375 break;
1376#endif
1377 case scm_tc7_dvect:
1378 SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badarg3);
1379 ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
1380 break;
1381 case scm_tc7_cvect:
1382 SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badarg3);
1383 ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
1384 ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
1385 break;
1386#endif
1387 case scm_tc7_vector:
1388 SCM_VELTS (v)[pos] = obj;
1389 break;
1390 }
1391 return SCM_UNSPECIFIED;
1392}
1393
1394SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
1395#ifdef __STDC__
1396SCM
1397scm_array_contents (SCM ra, SCM strict)
1398#else
1399SCM
1400scm_array_contents (ra, strict)
1401 SCM ra;
1402 SCM strict;
1403#endif
1404{
1405 SCM sra;
1406 if (SCM_IMP (ra))
1407 return SCM_BOOL_F;
1408 switch SCM_TYP7
1409 (ra)
1410 {
1411 default:
1412 return SCM_BOOL_F;
1413 case scm_tc7_vector:
1414 case scm_tc7_string:
1415 case scm_tc7_bvect:
1416 case scm_tc7_byvect:
1417 case scm_tc7_uvect:
1418 case scm_tc7_ivect:
1419 case scm_tc7_fvect:
1420 case scm_tc7_dvect:
1421 case scm_tc7_cvect:
1422 case scm_tc7_svect:
1423#ifdef LONGLONGS
1424 case scm_tc7_llvect:
1425#endif
1426 return ra;
1427 case scm_tc7_smob:
1428 {
1429 scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1430 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1431 return SCM_BOOL_F;
1432 for (k = 0; k < ndim; k++)
1433 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1434 if (!SCM_UNBNDP (strict))
1435 {
1436 if SCM_ARRAY_BASE
1437 (ra) return SCM_BOOL_F;
1438 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1439 return SCM_BOOL_F;
1440 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1441 {
1442 if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) ||
1443 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1444 len % SCM_LONG_BIT)
1445 return SCM_BOOL_F;
1446 }
1447 }
1448 if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1449 return SCM_ARRAY_V (ra);
1450 sra = scm_make_ra (1);
1451 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1452 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1453 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1454 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1455 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1456 return sra;
1457 }
1458 }
1459}
1460
1461#ifdef __STDC__
1462SCM
1463scm_ra2contig (SCM ra, int copy)
1464#else
1465SCM
1466scm_ra2contig (ra, copy)
1467 SCM ra;
1468 int copy;
1469#endif
1470{
1471 SCM ret;
1472 long inc = 1;
1473 scm_sizet k, len = 1;
1474 for (k = SCM_ARRAY_NDIM (ra); k--;)
1475 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1476 k = SCM_ARRAY_NDIM (ra);
1477 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1478 {
1479 if (scm_tc7_bvect != SCM_TYP7 (ra))
1480 return ra;
1481 if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) &&
1482 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1483 0 == len % SCM_LONG_BIT))
1484 return ra;
1485 }
1486 ret = scm_make_ra (k);
1487 SCM_ARRAY_BASE (ret) = 0;
1488 while (k--)
1489 {
1490 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1491 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1492 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1493 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1494 }
1495 SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
1496 if (copy)
1497 scm_array_copy_x (ra, ret);
1498 return ret;
1499}
1500
1501
1502
1503SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 1, 0, scm_uniform_array_read_x);
1504#ifdef __STDC__
1505SCM
1506scm_uniform_array_read_x (SCM ra, SCM port)
1507#else
1508SCM
1509scm_uniform_array_read_x (ra, port)
1510 SCM ra;
1511 SCM port;
1512#endif
1513{
1514 SCM cra, v = ra;
1515 long sz, len, ans;
1516 long start = 0;
1517 if (SCM_UNBNDP (port))
1518 port = scm_cur_inp;
1519 else
1520 SCM_ASSERT (SCM_NIMP (port) && SCM_OPINFPORTP (port), port, SCM_ARG2, s_uniform_array_read_x);
1521 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1522 len = SCM_LENGTH (v);
1523loop:
1524 switch SCM_TYP7
1525 (v)
1526 {
1527 default:
1528 badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
1529 case scm_tc7_smob:
1530 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1531 cra = scm_ra2contig (ra, 0);
1532 start = SCM_ARRAY_BASE (cra);
1533 len = SCM_ARRAY_DIMS (cra)->inc *
1534 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1535 v = SCM_ARRAY_V (cra);
1536 goto loop;
1537 case scm_tc7_string:
1538 case scm_tc7_byvect:
1539 sz = sizeof (char);
1540 break;
1541 case scm_tc7_bvect:
1542 len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1543 start /= SCM_LONG_BIT;
1544 case scm_tc7_uvect:
1545 case scm_tc7_ivect:
1546 sz = sizeof (long);
1547 break;
1548 case scm_tc7_svect:
1549 sz = sizeof (short);
1550 break;
1551#ifdef LONGLONGS
1552 case scm_tc7_llvect:
1553 sz = sizeof (long_long);
1554 break;
1555#endif
1556#ifdef SCM_FLOATS
1557#ifdef SCM_SINGLES
1558 case scm_tc7_fvect:
1559 sz = sizeof (float);
1560 break;
1561#endif
1562 case scm_tc7_dvect:
1563 sz = sizeof (double);
1564 break;
1565 case scm_tc7_cvect:
1566 sz = 2 * sizeof (double);
1567 break;
1568#endif
1569 }
1570 /* An ungetc before an fread will not work on some systems if setbuf(0).
1571 do #define NOSETBUF in scmfig.h to fix this. */
1572 if (SCM_CRDYP (port))
1573
1574 { /* UGGH!!! */
1575 ungetc (SCM_CGETUN (port), (FILE *)SCM_STREAM (port));
1576 SCM_CLRDY (port); /* Clear ungetted char */
1577 }
1578 SCM_SYSCALL (ans = fread (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
1579 if (SCM_TYP7 (v) == scm_tc7_bvect)
1580 ans *= SCM_LONG_BIT;
1581 if (v != ra && cra != ra)
1582 scm_array_copy_x (cra, ra);
1583 return SCM_MAKINUM (ans);
1584}
1585
1586SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 1, 0, scm_uniform_array_write);
1587#ifdef __STDC__
1588SCM
1589scm_uniform_array_write (SCM v, SCM port)
1590#else
1591SCM
1592scm_uniform_array_write (v, port)
1593 SCM v;
1594 SCM port;
1595#endif
1596{
1597 long sz, len, ans;
1598 long start = 0;
1599 if (SCM_UNBNDP (port))
1600 port = scm_cur_outp;
1601 else
1602 SCM_ASSERT (SCM_NIMP (port) && SCM_OPOUTFPORTP (port), port, SCM_ARG2, s_uniform_array_write);
1603 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1604 len = SCM_LENGTH (v);
1605loop:
1606 switch SCM_TYP7
1607 (v)
1608 {
1609 default:
1610 badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
1611 case scm_tc7_smob:
1612 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1613 v = scm_ra2contig (v, 1);
1614 start = SCM_ARRAY_BASE (v);
1615 len = SCM_ARRAY_DIMS (v)->inc * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
1616 v = SCM_ARRAY_V (v);
1617 goto loop;
1618 case scm_tc7_byvect:
1619 case scm_tc7_string:
1620 sz = sizeof (char);
1621 break;
1622 case scm_tc7_bvect:
1623 len = (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1624 start /= SCM_LONG_BIT;
1625 case scm_tc7_uvect:
1626 case scm_tc7_ivect:
1627 sz = sizeof (long);
1628 break;
1629 case scm_tc7_svect:
1630 sz = sizeof (short);
1631 break;
1632#ifdef LONGLONGS
1633 case scm_tc7_llvect:
1634 sz = sizeof (long_long);
1635 break;
1636#endif
1637#ifdef SCM_FLOATS
1638#ifdef SCM_SINGLES
1639 case scm_tc7_fvect:
1640 sz = sizeof (float);
1641 break;
1642#endif
1643 case scm_tc7_dvect:
1644 sz = sizeof (double);
1645 break;
1646 case scm_tc7_cvect:
1647 sz = 2 * sizeof (double);
1648 break;
1649#endif
1650 }
1651 SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + start * sz, (scm_sizet) sz, (scm_sizet) len, (FILE *)SCM_STREAM (port)));
1652 if (SCM_TYP7 (v) == scm_tc7_bvect)
1653 ans *= SCM_LONG_BIT;
1654 return SCM_MAKINUM (ans);
1655}
1656
1657
1658static char cnt_tab[16] =
1659{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1660
1661SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);
1662#ifdef __STDC__
1663SCM
1664scm_bit_count (SCM item, SCM seq)
1665#else
1666SCM
1667scm_bit_count (item, seq)
1668 SCM item;
1669 SCM seq;
1670#endif
1671{
1672 long i;
1673 register unsigned long cnt = 0, w;
1674 SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
1675 switch SCM_TYP7
1676 (seq)
1677 {
1678 default:
1679 scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
1680 case scm_tc7_bvect:
1681 if (0 == SCM_LENGTH (seq))
1682 return SCM_INUM0;
1683 i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
1684 w = SCM_VELTS (seq)[i];
1685 if (SCM_FALSEP (item))
1686 w = ~w;
1687 w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
1688 while (!0)
1689 {
1690 for (; w; w >>= 4)
1691 cnt += cnt_tab[w & 0x0f];
1692 if (0 == i--)
1693 return SCM_MAKINUM (cnt);
1694 w = SCM_VELTS (seq)[i];
1695 if (SCM_FALSEP (item))
1696 w = ~w;
1697 }
1698 }
1699}
1700
1701
1702SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);
1703#ifdef __STDC__
1704SCM
1705scm_bit_position (SCM item, SCM v, SCM k)
1706#else
1707SCM
1708scm_bit_position (item, v, k)
1709 SCM item;
1710 SCM v;
1711 SCM k;
1712#endif
1713{
1714 long i, lenw, xbits, pos = SCM_INUM (k);
1715 register unsigned long w;
1716 SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position);
1717 SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position);
1718 SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0),
1719 k, SCM_OUTOFRANGE, s_bit_position);
1720 if (pos == SCM_LENGTH (v))
1721 return SCM_BOOL_F;
1722 switch SCM_TYP7
1723 (v)
1724 {
1725 default:
1726 scm_wta (v, (char *) SCM_ARG2, s_bit_position);
1727 case scm_tc7_bvect:
1728 if (0 == SCM_LENGTH (v))
1729 return SCM_MAKINUM (-1L);
1730 lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1731 i = pos / SCM_LONG_BIT;
1732 w = SCM_VELTS (v)[i];
1733 if (SCM_FALSEP (item))
1734 w = ~w;
1735 xbits = (pos % SCM_LONG_BIT);
1736 pos -= xbits;
1737 w = ((w >> xbits) << xbits);
1738 xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT;
1739 while (!0)
1740 {
1741 if (w && (i == lenw))
1742 w = ((w << xbits) >> xbits);
1743 if (w)
1744 while (w)
1745 switch (w & 0x0f)
1746 {
1747 default:
1748 return SCM_MAKINUM (pos);
1749 case 2:
1750 case 6:
1751 case 10:
1752 case 14:
1753 return SCM_MAKINUM (pos + 1);
1754 case 4:
1755 case 12:
1756 return SCM_MAKINUM (pos + 2);
1757 case 8:
1758 return SCM_MAKINUM (pos + 3);
1759 case 0:
1760 pos += 4;
1761 w >>= 4;
1762 }
1763 if (++i > lenw)
1764 break;
1765 pos += SCM_LONG_BIT;
1766 w = SCM_VELTS (v)[i];
1767 if (SCM_FALSEP (item))
1768 w = ~w;
1769 }
1770 return SCM_BOOL_F;
1771 }
1772}
1773
1774
1775SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);
1776#ifdef __STDC__
1777SCM
1778scm_bit_set_star_x (SCM v, SCM kv, SCM obj)
1779#else
1780SCM
1781scm_bit_set_star_x (v, kv, obj)
1782 SCM v;
1783 SCM kv;
1784 SCM obj;
1785#endif
1786{
1787 register long i, k, vlen;
1788 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1789 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1790 switch SCM_TYP7
1791 (kv)
1792 {
1793 default:
1794 badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
1795 case scm_tc7_uvect:
1796 switch SCM_TYP7
1797 (v)
1798 {
1799 default:
1800 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
1801 case scm_tc7_bvect:
1802 vlen = SCM_LENGTH (v);
1803 if (SCM_BOOL_F == obj)
1804 for (i = SCM_LENGTH (kv); i;)
1805 {
1806 k = SCM_VELTS (kv)[--i];
1807 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
1808 SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
1809 }
1810 else if (SCM_BOOL_T == obj)
1811 for (i = SCM_LENGTH (kv); i;)
1812 {
1813 k = SCM_VELTS (kv)[--i];
1814 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
1815 SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
1816 }
1817 else
1818 badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x);
1819 }
1820 break;
1821 case scm_tc7_bvect:
1822 SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
1823 if (SCM_BOOL_F == obj)
1824 for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1825 SCM_VELTS (v)[k] &= ~(SCM_VELTS (kv)[k]);
1826 else if (SCM_BOOL_T == obj)
1827 for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1828 SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k];
1829 else
1830 goto badarg3;
1831 break;
1832 }
1833 return SCM_UNSPECIFIED;
1834}
1835
1836
1837SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);
1838#ifdef __STDC__
1839SCM
1840scm_bit_count_star (SCM v, SCM kv, SCM obj)
1841#else
1842SCM
1843scm_bit_count_star (v, kv, obj)
1844 SCM v;
1845 SCM kv;
1846 SCM obj;
1847#endif
1848{
1849 register long i, vlen, count = 0;
1850 register unsigned long k;
1851 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1852 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1853 switch SCM_TYP7
1854 (kv)
1855 {
1856 default:
1857 badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
1858 case scm_tc7_uvect:
1859 switch SCM_TYP7
1860 (v)
1861 {
1862 default:
1863 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star);
1864 case scm_tc7_bvect:
1865 vlen = SCM_LENGTH (v);
1866 if (SCM_BOOL_F == obj)
1867 for (i = SCM_LENGTH (kv); i;)
1868 {
1869 k = SCM_VELTS (kv)[--i];
1870 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
1871 if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
1872 count++;
1873 }
1874 else if (SCM_BOOL_T == obj)
1875 for (i = SCM_LENGTH (kv); i;)
1876 {
1877 k = SCM_VELTS (kv)[--i];
1878 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
1879 if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
1880 count++;
1881 }
1882 else
1883 badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star);
1884 }
1885 break;
1886 case scm_tc7_bvect:
1887 SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
1888 if (0 == SCM_LENGTH (v))
1889 return SCM_INUM0;
1890 SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
1891 obj = (SCM_BOOL_T == obj);
1892 i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
1893 k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
1894 k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
1895 while (!0)
1896 {
1897 for (; k; k >>= 4)
1898 count += cnt_tab[k & 0x0f];
1899 if (0 == i--)
1900 return SCM_MAKINUM (count);
1901 k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
1902 }
1903 }
1904 return SCM_MAKINUM (count);
1905}
1906
1907
1908SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);
1909#ifdef __STDC__
1910SCM
1911scm_bit_invert_x (SCM v)
1912#else
1913SCM
1914scm_bit_invert_x (v)
1915 SCM v;
1916#endif
1917{
1918 register long k;
1919 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1920 k = SCM_LENGTH (v);
1921 switch SCM_TYP7
1922 (v)
1923 {
1924 case scm_tc7_bvect:
1925 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1926 SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
1927 break;
1928 default:
1929 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x);
1930 }
1931 return SCM_UNSPECIFIED;
1932}
1933
1934
1935SCM_PROC(s_string_upcase_x, "string-upcase!", 1, 0, 0, scm_string_upcase_x);
1936#ifdef __STDC__
1937SCM
1938scm_string_upcase_x (SCM v)
1939#else
1940SCM
1941scm_string_upcase_x (v)
1942 SCM v;
1943#endif
1944{
1945 register long k;
1946 register unsigned char *cs;
1947 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1948 k = SCM_LENGTH (v);
1949 switch SCM_TYP7
1950 (v)
1951 {
1952 case scm_tc7_string:
1953 cs = SCM_UCHARS (v);
1954 while (k--)
1955 cs[k] = scm_upcase(cs[k]);
1956 break;
1957 default:
1958 badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_upcase_x);
1959 }
1960 return v;
1961}
1962
1963SCM_PROC(s_string_downcase_x, "string-downcase!", 1, 0, 0, scm_string_downcase_x);
1964#ifdef __STDC__
1965SCM
1966scm_string_downcase_x (SCM v)
1967#else
1968SCM
1969scm_string_downcase_x (v)
1970 SCM v;
1971#endif
1972{
1973 register long k;
1974 register unsigned char *cs;
1975 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1976 k = SCM_LENGTH (v);
1977 switch SCM_TYP7
1978 (v)
1979 {
1980 case scm_tc7_string:
1981 cs = SCM_UCHARS (v);
1982 while (k--)
1983 cs[k] = scm_downcase(cs[k]);
1984 break;
1985 default:
1986 badarg1:scm_wta (v, (char *) SCM_ARG1, s_string_downcase_x);
1987 }
1988 return v;
1989}
1990
1991
1992#ifdef __STDC__
1993SCM
1994scm_istr2bve (char *str, long len)
1995#else
1996SCM
1997scm_istr2bve (str, len)
1998 char *str;
1999 long len;
2000#endif
2001{
2002 SCM v = scm_make_uve (len, SCM_BOOL_T);
2003 long *data = (long *) SCM_VELTS (v);
2004 register unsigned long mask;
2005 register long k;
2006 register long j;
2007 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
2008 {
2009 data[k] = 0L;
2010 j = len - k * SCM_LONG_BIT;
2011 if (j > SCM_LONG_BIT)
2012 j = SCM_LONG_BIT;
2013 for (mask = 1L; j--; mask <<= 1)
2014 switch (*str++)
2015 {
2016 case '0':
2017 break;
2018 case '1':
2019 data[k] |= mask;
2020 break;
2021 default:
2022 return SCM_BOOL_F;
2023 }
2024 }
2025 return v;
2026}
2027
2028
2029#ifdef __STDC__
2030static SCM
2031ra2l (SCM ra, scm_sizet base, scm_sizet k)
2032#else
2033static SCM
2034ra2l (ra, base, k)
2035 SCM ra;
2036 scm_sizet base;
2037 scm_sizet k;
2038#endif
2039{
2040 register SCM res = SCM_EOL;
2041 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2042 register scm_sizet i;
2043 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
2044 return SCM_EOL;
2045 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
2046 if (k < SCM_ARRAY_NDIM (ra) - 1)
2047 {
2048 do
2049 {
2050 i -= inc;
2051 res = scm_cons (ra2l (ra, i, k + 1), res);
2052 }
2053 while (i != base);
2054 }
2055 else
2056 do
2057 {
2058 i -= inc;
2059 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
2060 }
2061 while (i != base);
2062 return res;
2063}
2064
2065
2066SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);
2067#ifdef __STDC__
2068SCM
2069scm_array_to_list (SCM v)
2070#else
2071SCM
2072scm_array_to_list (v)
2073 SCM v;
2074#endif
2075{
2076 SCM res = SCM_EOL;
2077 register long k;
2078 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2079 switch SCM_TYP7
2080 (v)
2081 {
2082 default:
2083 badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list);
2084 case scm_tc7_smob:
2085 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2086 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2087 case scm_tc7_vector:
2088 return scm_vector_to_list (v);
2089 case scm_tc7_string:
2090 return scm_string_to_list (v);
2091 case scm_tc7_bvect:
2092 {
2093 long *data = (long *) SCM_VELTS (v);
2094 register unsigned long mask;
2095 for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
2096 for (mask = 1L << (SCM_LONG_BIT - 1); mask; mask >>= 1)
2097 res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
2098 for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2099 res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
2100 return res;
2101 }
2102# ifdef SCM_INUMS_ONLY
2103 case scm_tc7_uvect:
2104 case scm_tc7_ivect:
2105 {
2106 long *data = (long *) SCM_VELTS (v);
2107 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2108 res = scm_cons (SCM_MAKINUM (data[k]), res);
2109 return res;
2110 }
2111# else
2112 case scm_tc7_uvect: {
2113 long *data = (long *)SCM_VELTS(v);
2114 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2115 res = scm_cons(scm_ulong2num(data[k]), res);
2116 return res;
2117 }
2118 case scm_tc7_ivect: {
2119 long *data = (long *)SCM_VELTS(v);
2120 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2121 res = scm_cons(scm_long2num(data[k]), res);
2122 return res;
2123 }
2124# endif
2125 case scm_tc7_svect: {
2126 short *data;
2127 data = (short *)SCM_VELTS(v);
2128 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2129 res = scm_cons(SCM_MAKINUM (data[k]), res);
2130 return res;
2131 }
2132#ifdef LONGLONGS
2133 case scm_tc7_llvect: {
2134 long_long *data;
2135 data = (long_long *)SCM_VELTS(v);
2136 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2137 res = scm_cons(scm_long_long2num(data[k]), res);
2138 return res;
2139 }
2140#endif
2141
2142
2143#ifdef SCM_FLOATS
2144#ifdef SCM_SINGLES
2145 case scm_tc7_fvect:
2146 {
2147 float *data = (float *) SCM_VELTS (v);
2148 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2149 res = scm_cons (scm_makflo (data[k]), res);
2150 return res;
2151 }
2152#endif /*SCM_SINGLES*/
2153 case scm_tc7_dvect:
2154 {
2155 double *data = (double *) SCM_VELTS (v);
2156 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2157 res = scm_cons (scm_makdbl (data[k], 0.0), res);
2158 return res;
2159 }
2160 case scm_tc7_cvect:
2161 {
2162 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2163 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2164 res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
2165 return res;
2166 }
2167#endif /*SCM_FLOATS*/
2168 }
2169}
2170
2171
2172static char s_bad_ralst[] = "Bad scm_array contents scm_list";
5e840c2e
JB		 2173#ifdef __STDC__
2174static int l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k);
2175#else
0f2d19dd 2176static int l2ra ();
5e840c2e 2177#endif
0f2d19dd
JB		 2178
2179SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
2180#ifdef __STDC__
2181SCM
2182scm_list_to_uniform_array (SCM ndim, SCM prot, SCM lst)
2183#else
2184SCM
2185scm_list_to_uniform_array (ndim, prot, lst)
2186 SCM ndim;
2187 SCM prot;
2188 SCM lst;
2189#endif
2190{
2191 SCM shp = SCM_EOL;
2192 SCM row = lst;
2193 SCM ra;
2194 scm_sizet k;
2195 long n;
2196 SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array);
2197 k = SCM_INUM (ndim);
2198 while (k--)
2199 {
2200 n = scm_ilength (row);
2201 SCM_ASSERT (n >= 0, lst, SCM_ARG2, s_list_to_uniform_array);
2202 shp = scm_cons (SCM_MAKINUM (n), shp);
2203 if (SCM_NIMP (row))
2204 row = SCM_CAR (row);
2205 }
2206 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL);
2207 if (SCM_NULLP (shp))
2208
2209 {
2210 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2211 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2212 return ra;
2213 }
2214 if (!SCM_ARRAYP (ra))
2215 {
2216 for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst))
2217 scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
2218 return ra;
2219 }
2220 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2221 return ra;
2222 else
2223 badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array);
2224 return SCM_BOOL_F;
2225}
2226
2227
2228#ifdef __STDC__
2229static int
2230l2ra (SCM lst, SCM ra, scm_sizet base, scm_sizet k)
2231#else
2232static int
2233l2ra (lst, ra, base, k)
2234 SCM lst;
2235 SCM ra;
2236 scm_sizet base;
2237 scm_sizet k;
2238#endif
2239{
2240 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2241 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2242 int ok = 1;
2243 if (n <= 0)
2244 return (SCM_EOL == lst);
2245 if (k < SCM_ARRAY_NDIM (ra) - 1)
2246 {
2247 while (n--)
2248 {
2249 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2250 return 0;
2251 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2252 base += inc;
2253 lst = SCM_CDR (lst);
2254 }
2255 if (SCM_NNULLP (lst))
2256 return 0;
2257 }
2258 else
2259 {
2260 while (n--)
2261 {
2262 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2263 return 0;
2264 ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
2265 base += inc;
2266 lst = SCM_CDR (lst);
2267 }
2268 if (SCM_NNULLP (lst))
2269 return 0;
2270 }
2271 return ok;
2272}
2273
2274#ifdef __STDC__
2275static void
2276rapr1 (SCM ra, scm_sizet j, scm_sizet k, SCM port, int writing)
2277#else
2278static void
2279rapr1 (ra, j, k, port, writing)
2280 SCM ra;
2281 scm_sizet j;
2282 scm_sizet k;
2283 SCM port;
2284 int writing;
2285#endif
2286{
2287 long inc = 1;
2288 long n = SCM_LENGTH (ra);
2289 int enclosed = 0;
2290tail:
2291 switch SCM_TYP7
2292 (ra)
2293 {
2294 case scm_tc7_smob:
2295 if (enclosed++)
2296 {
2297 SCM_ARRAY_BASE (ra) = j;
2298 if (n-- > 0)
2299 scm_iprin1 (ra, port, writing);
2300 for (j += inc; n-- > 0; j += inc)
2301 {
2302 scm_gen_putc (' ', port);
2303 SCM_ARRAY_BASE (ra) = j;
2304 scm_iprin1 (ra, port, writing);
2305 }
2306 break;
2307 }
2308 if (k + 1 < SCM_ARRAY_NDIM (ra))
2309 {
2310 long i;
2311 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2312 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2313 {
2314 scm_gen_putc ('(', port);
2315 rapr1 (ra, j, k + 1, port, writing);
2316 scm_gen_puts (scm_regular_string, ") ", port);
2317 j += inc;
2318 }
2319 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2320 { /* could be zero size. */
2321 scm_gen_putc ('(', port);
2322 rapr1 (ra, j, k + 1, port, writing);
2323 scm_gen_putc (')', port);
2324 }
2325 break;
2326 }
2327 if SCM_ARRAY_NDIM
2328 (ra)
2329 { /* Could be zero-dimensional */
2330 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2331 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2332 }
2333 else
2334 n = 1;
2335 ra = SCM_ARRAY_V (ra);
2336 goto tail;
2337 default:
2338 if (n-- > 0)
2339 scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, writing);
2340 for (j += inc; n-- > 0; j += inc)
2341 {
2342 scm_gen_putc (' ', port);
2343 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, writing);
2344 }
2345 break;
2346 case scm_tc7_string:
2347 if (n-- > 0)
2348 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
2349 if (writing)
2350 for (j += inc; n-- > 0; j += inc)
2351 {
2352 scm_gen_putc (' ', port);
2353 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, writing);
2354 }
2355 else
2356 for (j += inc; n-- > 0; j += inc)
2357 scm_gen_putc (SCM_CHARS (ra)[j], port);
2358 break;
2359 case scm_tc7_byvect:
2360 if (n-- > 0)
2361 scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
2362 for (j += inc; n-- > 0; j += inc)
2363 {
2364 scm_gen_putc (' ', port);
2365 scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
2366 }
2367 break;
2368
2369 case scm_tc7_uvect:
2370 case scm_tc7_ivect:
2371 if (n-- > 0)
2372 scm_intprint (SCM_VELTS (ra)[j], 10, port);
2373 for (j += inc; n-- > 0; j += inc)
2374 {
2375 scm_gen_putc (' ', port);
2376 scm_intprint (SCM_VELTS (ra)[j], 10, port);
2377 }
2378 break;
2379
2380 case scm_tc7_svect:
2381 if (n-- > 0)
2382 scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
2383 for (j += inc; n-- > 0; j += inc)
2384 {
2385 scm_gen_putc (' ', port);
2386 scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
2387 }
2388 break;
2389
2390#ifdef SCM_FLOATS
2391#ifdef SCM_SINGLES
2392 case scm_tc7_fvect:
2393 if (n-- > 0)
2394 {
2395 SCM z = scm_makflo (1.0);
2396 SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
2397 scm_floprint (z, port, writing);
2398 for (j += inc; n-- > 0; j += inc)
2399 {
2400 scm_gen_putc (' ', port);
2401 SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
2402 scm_floprint (z, port, writing);
2403 }
2404 }
2405 break;
2406#endif /*SCM_SINGLES*/
2407 case scm_tc7_dvect:
2408 if (n-- > 0)
2409 {
2410 SCM z = scm_makdbl (1.0 / 3.0, 0.0);
2411 SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
2412 scm_floprint (z, port, writing);
2413 for (j += inc; n-- > 0; j += inc)
2414 {
2415 scm_gen_putc (' ', port);
2416 SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
2417 scm_floprint (z, port, writing);
2418 }
2419 }
2420 break;
2421 case scm_tc7_cvect:
2422 if (n-- > 0)
2423 {
2424 SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
2425 SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
2426 SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2427 scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing);
2428 for (j += inc; n-- > 0; j += inc)
2429 {
2430 scm_gen_putc (' ', port);
2431 SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2432 SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
2433 scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, writing);
2434 }
2435 }
2436 break;
2437#endif /*SCM_FLOATS*/
2438 }
2439}
2440
2441
2442#ifdef __STDC__
2443int
2444scm_raprin1 (SCM exp, SCM port, int writing)
2445#else
2446int
2447scm_raprin1 (exp, port, writing)
2448 SCM exp;
2449 SCM port;
2450 int writing;
2451#endif
2452{
2453 SCM v = exp;
2454 scm_sizet base = 0;
2455 scm_gen_putc ('#', port);
2456tail:
2457 switch SCM_TYP7
2458 (v)
2459 {
2460 case scm_tc7_smob:
2461 {
2462 long ndim = SCM_ARRAY_NDIM (v);
2463 base = SCM_ARRAY_BASE (v);
2464 v = SCM_ARRAY_V (v);
2465 if (SCM_ARRAYP (v))
2466
2467 {
2468 scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
2469 rapr1 (exp, base, 0, port, writing);
2470 scm_gen_putc ('>', port);
2471 return 1;
2472 }
2473 else
2474 {
2475 scm_intprint (ndim, 10, port);
2476 goto tail;
2477 }
2478 }
2479 case scm_tc7_bvect:
2480 if (exp == v)
2481 { /* a uve, not an scm_array */
2482 register long i, j, w;
2483 scm_gen_putc ('*', port);
2484 for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
2485 {
2486 w = SCM_VELTS (exp)[i];
2487 for (j = SCM_LONG_BIT; j; j--)
2488 {
2489 scm_gen_putc (w & 1 ? '1' : '0', port);
2490 w >>= 1;
2491 }
2492 }
2493 j = SCM_LENGTH (exp) % SCM_LONG_BIT;
2494 if (j)
2495 {
2496 w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
2497 for (; j; j--)
2498 {
2499 scm_gen_putc (w & 1 ? '1' : '0', port);
2500 w >>= 1;
2501 }
2502 }
2503 return 1;
2504 }
2505 else
2506 scm_gen_putc ('b', port);
2507 break;
2508 case scm_tc7_string:
2509 scm_gen_putc ('a', port);
2510 break;
2511 case scm_tc7_byvect:
2512 scm_gen_puts (scm_regular_string, "bytes", port);
2513 break;
2514 case scm_tc7_uvect:
2515 scm_gen_putc ('u', port);
2516 break;
2517 case scm_tc7_ivect:
2518 scm_gen_putc ('e', port);
2519 break;
2520 case scm_tc7_svect:
2521 scm_gen_puts (scm_regular_string, "short", port);
2522 break;
2523#ifdef LONGLONGS
2524 case scm_tc7_llvect:
2525 scm_gen_puts (scm_regular_string, "long_long", port);
2526 break;
2527#endif
2528#ifdef SCM_FLOATS
2529#ifdef SCM_SINGLES
2530 case scm_tc7_fvect:
2531 scm_gen_putc ('s', port);
2532 break;
2533#endif /*SCM_SINGLES*/
2534 case scm_tc7_dvect:
2535 scm_gen_putc ('i', port);
2536 break;
2537 case scm_tc7_cvect:
2538 scm_gen_putc ('c', port);
2539 break;
2540#endif /*SCM_FLOATS*/
2541 }
2542 scm_gen_putc ('(', port);
2543 rapr1 (exp, base, 0, port, writing);
2544 scm_gen_putc (')', port);
2545 return 1;
2546}
2547
2548SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);
2549#ifdef __STDC__
2550SCM
2551scm_array_prototype (SCM ra)
2552#else
2553SCM
2554scm_array_prototype (ra)
2555 SCM ra;
2556#endif
2557{
2558 int enclosed = 0;
2559 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2560loop:
2561 switch SCM_TYP7
2562 (ra)
2563 {
2564 default:
2565 badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype);
2566 case scm_tc7_smob:
2567 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2568 if (enclosed++)
2569 return SCM_UNSPECIFIED;
2570 ra = SCM_ARRAY_V (ra);
2571 goto loop;
2572 case scm_tc7_vector:
2573 return SCM_EOL;
2574 case scm_tc7_bvect:
2575 return SCM_BOOL_T;
2576 case scm_tc7_string:
2577 return SCM_MAKICHR ('a');
2578 case scm_tc7_byvect:
2579 return SCM_MAKICHR ('\0');
2580 case scm_tc7_uvect:
2581 return SCM_MAKINUM (1L);
2582 case scm_tc7_ivect:
2583 return SCM_MAKINUM (-1L);
2584 case scm_tc7_svect:
2585 return SCM_CDR (scm_intern ("s", 1));
2586#ifdef LONGLONGS
2587 case scm_tc7_llvect:
2588 return SCM_CDR (scm_intern ("l", 1));
2589#endif
2590#ifdef SCM_FLOATS
2591#ifdef SCM_SINGLES
2592 case scm_tc7_fvect:
2593 return scm_makflo (1.0);
2594#endif
2595 case scm_tc7_dvect:
2596 return scm_makdbl (1.0 / 3.0, 0.0);
2597 case scm_tc7_cvect:
2598 return scm_makdbl (0.0, 1.0);
2599#endif
2600 }
2601}
2602
2603#ifdef __STDC__
2604static SCM
2605markra (SCM ptr)
2606#else
2607static SCM
2608markra (ptr)
2609 SCM ptr;
2610#endif
2611{
2612 if SCM_GC8MARKP
2613 (ptr) return SCM_BOOL_F;
2614 SCM_SETGC8MARK (ptr);
2615 return SCM_ARRAY_V (ptr);
2616}
2617
2618#ifdef __STDC__
2619static scm_sizet
2620freera (SCM ptr)
2621#else
2622static scm_sizet
2623freera (ptr)
2624 SCM ptr;
2625#endif
2626{
2627 scm_must_free (SCM_CHARS (ptr));
2628 return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
2629}
2630
2631static scm_smobfuns rasmob =
2632{markra, freera, scm_raprin1, scm_array_equal_p};
2633
2634
2635/* This must be done after scm_init_scl() */
2636#ifdef __STDC__
2637void
2638scm_init_unif (void)
2639#else
2640void
2641scm_init_unif ()
2642#endif
2643{
2644#include "unif.x"
2645 scm_tc16_array = scm_newsmob (&rasmob);
2646 scm_add_feature ("array");
2647}
2648
2649#else /* ARRAYS */
2650
2651#ifdef __STDC__
2652int
2653scm_raprin1 (SCM exp, SCM port, int writing)
2654#else
2655int
2656scm_raprin1 (exp, port, writing)
2657 SCM exp;
2658 SCM port;
2659 int writing;
2660#endif
2661{
2662 return 0;
2663}
2664
2665#ifdef __STDC__
2666SCM
2667scm_istr2bve (char *str, long len)
2668#else
2669SCM
2670scm_istr2bve (str, len)
2671 char *str;
2672 long len;
2673#endif
2674{
2675 return SCM_BOOL_F;
2676}
2677
0f2d19dd
JB		 2678void
2679scm_init_unif ()
2680{
2681 scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
2682}
2683
2684#endif /* ARRAYS */
2685
2686
2687
2688
Unnamed repository; edit this file 'description' to name the repository.