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