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