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