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