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