HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* errno.h: prototype for scm_strerror.
[bpt/guile.git] / libguile / unif.c
CommitLineData
3d8d56df 1/* Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
0f2d19dd
JB		 2 *
3 * This program is free software; you can redistribute it and/or modify
4 * it under the terms of the GNU General Public License as published by
5 * the Free Software Foundation; either version 2, or (at your option)
6 * any later version.
7 *
8 * This program is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 * GNU General Public License for more details.
12 *
13 * You should have received a copy of the GNU General Public License
14 * along with this software; see the file COPYING. If not, write to
82892bed
JB		 15 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
16 * Boston, MA 02111-1307 USA
0f2d19dd
JB		 17 *
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
20 *
21 * The exception is that, if you link the GUILE library with other files
22 * to produce an executable, this does not by itself cause the
23 * resulting executable to be covered by the GNU General Public License.
24 * Your use of that executable is in no way restricted on account of
25 * linking the GUILE library code into it.
26 *
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
29 *
30 * This exception applies only to the code released by the
31 * Free Software Foundation under the name GUILE. If you copy
32 * code from other Free Software Foundation releases into a copy of
33 * GUILE, as the General Public License permits, the exception does
34 * not apply to the code that you add in this way. To avoid misleading
35 * anyone as to the status of such modified files, you must delete
36 * this exception notice from them.
37 *
38 * If you write modifications of your own for GUILE, it is your choice
39 * whether to permit this exception to apply to your modifications.
82892bed 40 * If you do not wish that, delete this exception notice. */
0f2d19dd
JB		 41\f
42
43#include <stdio.h>
44#include "_scm.h"
20e6290e
JB		 45#include "chars.h"
46#include "eval.h"
47#include "genio.h"
48#include "smob.h"
49#include "sequences.h"
50#include "strop.h"
51#include "feature.h"
52
53#include "unif.h"
95b88819 54#include "ramap.h"
0f2d19dd 55
3d8d56df
GH		 56#ifdef HAVE_UNISTD_H
57#include <unistd.h>
58#endif
59
0f2d19dd
JB		 60\f
61/* The set of uniform scm_vector types is:
62 * Vector of: Called:
63 * unsigned char string
64 * char byvect
65 * boolean bvect
66 * signed int ivect
67 * unsigned int uvect
68 * float fvect
69 * double dvect
70 * complex double cvect
71 * short svect
72 * long_long llvect
73 */
74
75long scm_tc16_array;
76
77/*
78 * This complicates things too much if allowed on any array.
79 * C code can safely call it on arrays known to be used in a single
80 * threaded manner.
81 *
82 * SCM_PROC(s_vector_set_length_x, "vector-set-length!", 2, 0, 0, scm_vector_set_length_x);
83 */
84static char s_vector_set_length_x[] = "vector-set-length!";
85
1cc91f1b 86
0f2d19dd
JB		 87SCM
88scm_vector_set_length_x (vect, len)
89 SCM vect;
90 SCM len;
0f2d19dd
JB		 91{
92 long l;
93 scm_sizet siz;
94 scm_sizet sz;
95
96 l = SCM_INUM (len);
97 SCM_ASRTGO (SCM_NIMP (vect), badarg1);
98 switch (SCM_TYP7 (vect))
99 {
100 default:
101 badarg1: scm_wta (vect, (char *) SCM_ARG1, s_vector_set_length_x);
102 case scm_tc7_string:
103 case scm_tc7_mb_string:
104 SCM_ASRTGO (vect != scm_nullstr, badarg1);
105 sz = sizeof (char);
106 l++;
107 break;
108 case scm_tc7_vector:
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
0aa0871f
GH		 1233/* Note that args may be a list or an immediate object, depending which
1234 PROC is used (and it's called from C too). */
0f2d19dd
JB		 1235SCM
1236scm_array_set_x (v, obj, args)
1237 SCM v;
1238 SCM obj;
1239 SCM args;
0f2d19dd
JB		 1240{
1241 long pos;
1242 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1243 if (SCM_ARRAYP (v))
0f2d19dd
JB		 1244 {
1245 pos = scm_aind (v, args, s_array_set_x);
1246 v = SCM_ARRAY_V (v);
1247 }
1248 else
1249 {
1250 if (SCM_NIMP (args))
0f2d19dd 1251 {
0aa0871f
GH		 1252 SCM_ASSERT (SCM_CONSP(args) && SCM_INUMP (SCM_CAR (args)), args,
1253 SCM_ARG3, s_array_set_x);
0f2d19dd 1254 SCM_ASRTGO (SCM_NULLP (SCM_CDR (args)), wna);
0aa0871f 1255 pos = SCM_INUM (SCM_CAR (args));
0f2d19dd
JB		 1256 }
1257 else
1258 {
0aa0871f 1259 SCM_ASSERT (SCM_INUMP (args), args, SCM_ARG3, s_array_set_x);
0f2d19dd
JB		 1260 pos = SCM_INUM (args);
1261 }
1262 SCM_ASRTGO (pos >= 0 && pos < SCM_LENGTH (v), outrng);
1263 }
1264 switch (SCM_TYP7 (v))
1265 {
35de7ebe
JB		 1266 default: badarg1:
1267 scm_wta (v, (char *) SCM_ARG1, s_array_set_x);
1268 abort ();
52859adf 1269 outrng:scm_out_of_range (s_array_set_x, SCM_MAKINUM (pos));
f5bf2977 1270 wna: scm_wrong_num_args (scm_makfrom0str (s_array_set_x));
0f2d19dd
JB		 1271 case scm_tc7_smob: /* enclosed */
1272 goto badarg1;
1273 case scm_tc7_bvect:
1274 if (SCM_BOOL_F == obj)
1275 SCM_VELTS (v)[pos / SCM_LONG_BIT] &= ~(1L << (pos % SCM_LONG_BIT));
1276 else if (SCM_BOOL_T == obj)
1277 SCM_VELTS (v)[pos / SCM_LONG_BIT] |= (1L << (pos % SCM_LONG_BIT));
1278 else
0aa0871f 1279 badobj:scm_wta (obj, (char *) SCM_ARG2, s_array_set_x);
0f2d19dd
JB		 1280 break;
1281 case scm_tc7_string:
0aa0871f 1282 SCM_ASRTGO (SCM_ICHRP (obj), badobj);
0f2d19dd
JB		 1283 SCM_CHARS (v)[pos] = SCM_ICHR (obj);
1284 break;
1285 case scm_tc7_byvect:
1286 if (SCM_ICHRP (obj))
b1d24656 1287 obj = SCM_MAKINUM ((char) SCM_ICHR (obj));
0aa0871f 1288 SCM_ASRTGO (SCM_INUMP (obj), badobj);
0f2d19dd
JB		 1289 ((char *)SCM_CHARS (v))[pos] = SCM_INUM (obj);
1290 break;
1291# ifdef SCM_INUMS_ONLY
1292 case scm_tc7_uvect:
0aa0871f 1293 SCM_ASRTGO (SCM_INUM (obj) >= 0, badobj);
0f2d19dd 1294 case scm_tc7_ivect:
0aa0871f 1295 SCM_ASRTGO(SCM_INUMP(obj), badobj); SCM_VELTS(v)[pos] = SCM_INUM(obj); break;
0f2d19dd
JB		 1296# else
1297 case scm_tc7_uvect:
0aa0871f 1298 SCM_VELTS(v)[pos] = scm_num2ulong(obj, (char *)SCM_ARG2, s_array_set_x); break;
0f2d19dd 1299 case scm_tc7_ivect:
0aa0871f 1300 SCM_VELTS(v)[pos] = num2long(obj, (char *)SCM_ARG2, s_array_set_x); break;
0f2d19dd
JB		 1301# endif
1302 break;
1303
1304 case scm_tc7_svect:
0aa0871f 1305 SCM_ASRTGO (SCM_INUMP (obj), badobj);
0f2d19dd
JB		 1306 ((short *) SCM_CDR (v))[pos] = SCM_INUM (obj);
1307 break;
1308#ifdef LONGLONGS
1309 case scm_tc7_llvect:
0aa0871f 1310 ((long_long *) SCM_CDR (v))[pos] = scm_num2long_long (obj, (char *)SCM_ARG2, s_array_set_x);
0f2d19dd
JB		 1311 break;
1312#endif
1313
1314
1315#ifdef SCM_FLOATS
1316#ifdef SCM_SINGLES
1317 case scm_tc7_fvect:
0aa0871f 1318 SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
0f2d19dd
JB		 1319 ((float *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
1320 break;
1321#endif
1322 case scm_tc7_dvect:
0aa0871f 1323 SCM_ASRTGO (SCM_NIMP (obj) && SCM_REALP (obj), badobj);
0f2d19dd
JB		 1324 ((double *) SCM_CDR (v))[pos] = SCM_REALPART (obj);
1325 break;
1326 case scm_tc7_cvect:
0aa0871f 1327 SCM_ASRTGO (SCM_NIMP (obj) && SCM_INEXP (obj), badobj);
0f2d19dd
JB		 1328 ((double *) SCM_CDR (v))[2 * pos] = SCM_REALPART (obj);
1329 ((double *) SCM_CDR (v))[2 * pos + 1] = SCM_CPLXP (obj) ? SCM_IMAG (obj) : 0.0;
1330 break;
1331#endif
1332 case scm_tc7_vector:
1333 SCM_VELTS (v)[pos] = obj;
1334 break;
1335 }
1336 return SCM_UNSPECIFIED;
1337}
1338
1339SCM_PROC(s_array_contents, "array-contents", 1, 1, 0, scm_array_contents);
1cc91f1b 1340
0f2d19dd
JB		 1341SCM
1342scm_array_contents (ra, strict)
1343 SCM ra;
1344 SCM strict;
0f2d19dd
JB		 1345{
1346 SCM sra;
1347 if (SCM_IMP (ra))
1348 return SCM_BOOL_F;
1349 switch SCM_TYP7
1350 (ra)
1351 {
1352 default:
1353 return SCM_BOOL_F;
1354 case scm_tc7_vector:
1355 case scm_tc7_string:
1356 case scm_tc7_bvect:
1357 case scm_tc7_byvect:
1358 case scm_tc7_uvect:
1359 case scm_tc7_ivect:
1360 case scm_tc7_fvect:
1361 case scm_tc7_dvect:
1362 case scm_tc7_cvect:
1363 case scm_tc7_svect:
1364#ifdef LONGLONGS
1365 case scm_tc7_llvect:
1366#endif
1367 return ra;
1368 case scm_tc7_smob:
1369 {
1370 scm_sizet k, ndim = SCM_ARRAY_NDIM (ra), len = 1;
1371 if (!SCM_ARRAYP (ra) || !SCM_ARRAY_CONTP (ra))
1372 return SCM_BOOL_F;
1373 for (k = 0; k < ndim; k++)
1374 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1375 if (!SCM_UNBNDP (strict))
1376 {
1377 if SCM_ARRAY_BASE
1378 (ra) return SCM_BOOL_F;
1379 if (ndim && (1 != SCM_ARRAY_DIMS (ra)[ndim - 1].inc))
1380 return SCM_BOOL_F;
1381 if (scm_tc7_bvect == SCM_TYP7 (SCM_ARRAY_V (ra)))
1382 {
1383 if (len != SCM_LENGTH (SCM_ARRAY_V (ra)) ||
1384 SCM_ARRAY_BASE (ra) % SCM_LONG_BIT ||
1385 len % SCM_LONG_BIT)
1386 return SCM_BOOL_F;
1387 }
1388 }
1389 if ((len == SCM_LENGTH (SCM_ARRAY_V (ra))) && 0 == SCM_ARRAY_BASE (ra) && SCM_ARRAY_DIMS (ra)->inc)
1390 return SCM_ARRAY_V (ra);
1391 sra = scm_make_ra (1);
1392 SCM_ARRAY_DIMS (sra)->lbnd = 0;
1393 SCM_ARRAY_DIMS (sra)->ubnd = len - 1;
1394 SCM_ARRAY_V (sra) = SCM_ARRAY_V (ra);
1395 SCM_ARRAY_BASE (sra) = SCM_ARRAY_BASE (ra);
1396 SCM_ARRAY_DIMS (sra)->inc = (ndim ? SCM_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
1397 return sra;
1398 }
1399 }
1400}
1401
1cc91f1b 1402
0f2d19dd
JB		 1403SCM
1404scm_ra2contig (ra, copy)
1405 SCM ra;
1406 int copy;
0f2d19dd
JB		 1407{
1408 SCM ret;
1409 long inc = 1;
1410 scm_sizet k, len = 1;
1411 for (k = SCM_ARRAY_NDIM (ra); k--;)
1412 len *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1413 k = SCM_ARRAY_NDIM (ra);
1414 if (SCM_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_ARRAY_DIMS (ra)[k - 1].inc)))
1415 {
1416 if (scm_tc7_bvect != SCM_TYP7 (ra))
1417 return ra;
1418 if ((len == SCM_LENGTH (SCM_ARRAY_V (ra)) &&
1419 0 == SCM_ARRAY_BASE (ra) % SCM_LONG_BIT &&
1420 0 == len % SCM_LONG_BIT))
1421 return ra;
1422 }
1423 ret = scm_make_ra (k);
1424 SCM_ARRAY_BASE (ret) = 0;
1425 while (k--)
1426 {
1427 SCM_ARRAY_DIMS (ret)[k].lbnd = SCM_ARRAY_DIMS (ra)[k].lbnd;
1428 SCM_ARRAY_DIMS (ret)[k].ubnd = SCM_ARRAY_DIMS (ra)[k].ubnd;
1429 SCM_ARRAY_DIMS (ret)[k].inc = inc;
1430 inc *= SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1;
1431 }
1432 SCM_ARRAY_V (ret) = scm_make_uve ((inc - 1), scm_array_prototype (ra));
1433 if (copy)
1434 scm_array_copy_x (ra, ret);
1435 return ret;
1436}
1437
1438
1439
3d8d56df 1440SCM_PROC(s_uniform_array_read_x, "uniform-array-read!", 1, 3, 0, scm_uniform_array_read_x);
1cc91f1b 1441
0f2d19dd 1442SCM
1146b6cd 1443scm_uniform_array_read_x (ra, port_or_fd, start, end)
0f2d19dd 1444 SCM ra;
3d8d56df 1445 SCM port_or_fd;
1146b6cd
GH		 1446 SCM start;
1447 SCM end;
0f2d19dd 1448{
35de7ebe 1449 SCM cra = SCM_UNDEFINED, v = ra;
3d8d56df 1450 long sz, vlen, ans;
1146b6cd
GH		 1451 long cstart = 0;
1452 long cend;
1453 long offset = 0;
35de7ebe 1454
0f2d19dd 1455 SCM_ASRTGO (SCM_NIMP (v), badarg1);
3d8d56df
GH		 1456 if (SCM_UNBNDP (port_or_fd))
1457 port_or_fd = scm_cur_inp;
1458 else
1459 SCM_ASSERT (SCM_INUMP (port_or_fd)
1460 || (SCM_NIMP (port_or_fd) && SCM_OPINFPORTP (port_or_fd)),
1461 port_or_fd, SCM_ARG2, s_uniform_array_read_x);
1462 vlen = SCM_LENGTH (v);
35de7ebe 1463
0f2d19dd 1464loop:
35de7ebe 1465 switch SCM_TYP7 (v)
0f2d19dd
JB		 1466 {
1467 default:
1468 badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_read_x);
1469 case scm_tc7_smob:
1470 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1471 cra = scm_ra2contig (ra, 0);
1146b6cd 1472 cstart += SCM_ARRAY_BASE (cra);
3d8d56df 1473 vlen = SCM_ARRAY_DIMS (cra)->inc *
0f2d19dd
JB		 1474 (SCM_ARRAY_DIMS (cra)->ubnd - SCM_ARRAY_DIMS (cra)->lbnd + 1);
1475 v = SCM_ARRAY_V (cra);
1476 goto loop;
1477 case scm_tc7_string:
1478 case scm_tc7_byvect:
1479 sz = sizeof (char);
1480 break;
1481 case scm_tc7_bvect:
3d8d56df 1482 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1146b6cd 1483 cstart /= SCM_LONG_BIT;
0f2d19dd
JB		 1484 case scm_tc7_uvect:
1485 case scm_tc7_ivect:
1486 sz = sizeof (long);
1487 break;
1488 case scm_tc7_svect:
1489 sz = sizeof (short);
1490 break;
1491#ifdef LONGLONGS
1492 case scm_tc7_llvect:
1493 sz = sizeof (long_long);
1494 break;
1495#endif
1496#ifdef SCM_FLOATS
1497#ifdef SCM_SINGLES
1498 case scm_tc7_fvect:
1499 sz = sizeof (float);
1500 break;
1501#endif
1502 case scm_tc7_dvect:
1503 sz = sizeof (double);
1504 break;
1505 case scm_tc7_cvect:
1506 sz = 2 * sizeof (double);
1507 break;
1508#endif
1509 }
3d8d56df 1510
1146b6cd
GH		 1511 cend = vlen;
1512 if (!SCM_UNBNDP (start))
3d8d56df 1513 {
1146b6cd
GH		 1514 offset =
1515 scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_read_x);
35de7ebe 1516
1146b6cd
GH		 1517 if (offset < 0 || offset >= cend)
1518 scm_out_of_range (s_uniform_array_read_x, start);
1519
1520 if (!SCM_UNBNDP (end))
1521 {
1522 long tend =
1523 scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_read_x);
3d8d56df 1524
1146b6cd
GH		 1525 if (tend <= offset || tend > cend)
1526 scm_out_of_range (s_uniform_array_read_x, end);
1527 cend = tend;
1528 }
0f2d19dd 1529 }
35de7ebe 1530
3d8d56df
GH		 1531 if (SCM_NIMP (port_or_fd))
1532 {
1533 /* if we have stored a character from the port in our own buffer,
1534 push it back onto the stream. */
1535 /* An ungetc before an fread will not work on some systems if
1536 setbuf(0). do #define NOSETBUF in scmfig.h to fix this. */
1537 if (SCM_CRDYP (port_or_fd))
1538 {
1539 ungetc (SCM_CGETUN (port_or_fd), (FILE *)SCM_STREAM (port_or_fd));
1540 SCM_CLRDY (port_or_fd); /* Clear ungetted char */
1541 }
1146b6cd
GH		 1542 SCM_SYSCALL (ans = fread (SCM_CHARS (v) + (cstart + offset) * sz,
1543 (scm_sizet) sz, (scm_sizet) (cend - offset),
1544 (FILE *)SCM_STREAM (port_or_fd)));
3d8d56df
GH		 1545 }
1546 else /* file descriptor. */
1547 {
1548 SCM_SYSCALL (ans = read (SCM_INUM (port_or_fd),
1146b6cd
GH		 1549 SCM_CHARS (v) + (cstart + offset) * sz,
1550 (scm_sizet) (sz * (cend - offset))));
3d8d56df
GH		 1551 if (ans == -1)
1552 scm_syserror (s_uniform_array_read_x);
1553 }
0f2d19dd
JB		 1554 if (SCM_TYP7 (v) == scm_tc7_bvect)
1555 ans *= SCM_LONG_BIT;
35de7ebe 1556
0f2d19dd
JB		 1557 if (v != ra && cra != ra)
1558 scm_array_copy_x (cra, ra);
35de7ebe 1559
0f2d19dd
JB		 1560 return SCM_MAKINUM (ans);
1561}
1562
3d8d56df 1563SCM_PROC(s_uniform_array_write, "uniform-array-write", 1, 3, 0, scm_uniform_array_write);
1cc91f1b 1564
0f2d19dd 1565SCM
1146b6cd 1566scm_uniform_array_write (v, port_or_fd, start, end)
0f2d19dd 1567 SCM v;
3d8d56df 1568 SCM port_or_fd;
1146b6cd
GH		 1569 SCM start;
1570 SCM end;
0f2d19dd 1571{
3d8d56df 1572 long sz, vlen, ans;
1146b6cd
GH		 1573 long offset = 0;
1574 long cstart = 0;
1575 long cend;
3d8d56df 1576
0f2d19dd 1577 SCM_ASRTGO (SCM_NIMP (v), badarg1);
3d8d56df
GH		 1578 if (SCM_UNBNDP (port_or_fd))
1579 port_or_fd = scm_cur_outp;
1580 else
1581 SCM_ASSERT (SCM_INUMP (port_or_fd)
1582 || (SCM_NIMP (port_or_fd) && SCM_OPOUTFPORTP (port_or_fd)),
1583 port_or_fd, SCM_ARG2, s_uniform_array_write);
1584 vlen = SCM_LENGTH (v);
1585
0f2d19dd 1586loop:
3d8d56df 1587 switch SCM_TYP7 (v)
0f2d19dd
JB		 1588 {
1589 default:
1590 badarg1:scm_wta (v, (char *) SCM_ARG1, s_uniform_array_write);
1591 case scm_tc7_smob:
1592 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
1593 v = scm_ra2contig (v, 1);
1146b6cd 1594 cstart = SCM_ARRAY_BASE (v);
3d8d56df
GH		 1595 vlen = SCM_ARRAY_DIMS (v)->inc
1596 * (SCM_ARRAY_DIMS (v)->ubnd - SCM_ARRAY_DIMS (v)->lbnd + 1);
0f2d19dd
JB		 1597 v = SCM_ARRAY_V (v);
1598 goto loop;
0f2d19dd 1599 case scm_tc7_string:
3d8d56df 1600 case scm_tc7_byvect:
0f2d19dd
JB		 1601 sz = sizeof (char);
1602 break;
1603 case scm_tc7_bvect:
3d8d56df 1604 vlen = (vlen + SCM_LONG_BIT - 1) / SCM_LONG_BIT;
1146b6cd 1605 cstart /= SCM_LONG_BIT;
0f2d19dd
JB		 1606 case scm_tc7_uvect:
1607 case scm_tc7_ivect:
1608 sz = sizeof (long);
1609 break;
1610 case scm_tc7_svect:
1611 sz = sizeof (short);
1612 break;
1613#ifdef LONGLONGS
1614 case scm_tc7_llvect:
1615 sz = sizeof (long_long);
1616 break;
1617#endif
1618#ifdef SCM_FLOATS
1619#ifdef SCM_SINGLES
1620 case scm_tc7_fvect:
1621 sz = sizeof (float);
1622 break;
1623#endif
1624 case scm_tc7_dvect:
1625 sz = sizeof (double);
1626 break;
1627 case scm_tc7_cvect:
1628 sz = 2 * sizeof (double);
1629 break;
1630#endif
1631 }
3d8d56df 1632
1146b6cd
GH		 1633 cend = vlen;
1634 if (!SCM_UNBNDP (start))
3d8d56df 1635 {
1146b6cd
GH		 1636 offset =
1637 scm_num2long (start, (char *) SCM_ARG3, s_uniform_array_write);
3d8d56df 1638
1146b6cd
GH		 1639 if (offset < 0 || offset >= cend)
1640 scm_out_of_range (s_uniform_array_write, start);
1641
1642 if (!SCM_UNBNDP (end))
1643 {
1644 long tend =
1645 scm_num2long (end, (char *) SCM_ARG4, s_uniform_array_write);
3d8d56df 1646
1146b6cd
GH		 1647 if (tend <= offset || tend > cend)
1648 scm_out_of_range (s_uniform_array_write, end);
1649 cend = tend;
1650 }
3d8d56df
GH		 1651 }
1652
1653 if (SCM_NIMP (port_or_fd))
1654 {
1146b6cd
GH		 1655 SCM_SYSCALL (ans = fwrite (SCM_CHARS (v) + (cstart + offset) * sz,
1656 (scm_sizet) sz, (scm_sizet) (cend - offset),
3d8d56df
GH		 1657 (FILE *)SCM_STREAM (port_or_fd)));
1658 }
1659 else /* file descriptor. */
1660 {
1661 SCM_SYSCALL (ans = write (SCM_INUM (port_or_fd),
1146b6cd
GH		 1662 SCM_CHARS (v) + (cstart + offset) * sz,
1663 (scm_sizet) (sz * (cend - offset))));
3d8d56df
GH		 1664 if (ans == -1)
1665 scm_syserror (s_uniform_array_write);
1666 }
0f2d19dd
JB		 1667 if (SCM_TYP7 (v) == scm_tc7_bvect)
1668 ans *= SCM_LONG_BIT;
3d8d56df 1669
0f2d19dd
JB		 1670 return SCM_MAKINUM (ans);
1671}
1672
1673
1674static char cnt_tab[16] =
1675{0, 1, 1, 2, 1, 2, 2, 3, 1, 2, 2, 3, 2, 3, 3, 4};
1676
1677SCM_PROC(s_bit_count, "bit-count", 2, 0, 0, scm_bit_count);
1cc91f1b 1678
0f2d19dd
JB		 1679SCM
1680scm_bit_count (item, seq)
1681 SCM item;
1682 SCM seq;
0f2d19dd
JB		 1683{
1684 long i;
1685 register unsigned long cnt = 0, w;
1686 SCM_ASSERT (SCM_NIMP (seq), seq, SCM_ARG2, s_bit_count);
1687 switch SCM_TYP7
1688 (seq)
1689 {
1690 default:
1691 scm_wta (seq, (char *) SCM_ARG2, s_bit_count);
1692 case scm_tc7_bvect:
1693 if (0 == SCM_LENGTH (seq))
1694 return SCM_INUM0;
1695 i = (SCM_LENGTH (seq) - 1) / SCM_LONG_BIT;
1696 w = SCM_VELTS (seq)[i];
1697 if (SCM_FALSEP (item))
1698 w = ~w;
1699 w <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (seq) - 1) % SCM_LONG_BIT);
1700 while (!0)
1701 {
1702 for (; w; w >>= 4)
1703 cnt += cnt_tab[w & 0x0f];
1704 if (0 == i--)
1705 return SCM_MAKINUM (cnt);
1706 w = SCM_VELTS (seq)[i];
1707 if (SCM_FALSEP (item))
1708 w = ~w;
1709 }
1710 }
1711}
1712
1713
1714SCM_PROC(s_bit_position, "bit-position", 3, 0, 0, scm_bit_position);
1cc91f1b 1715
0f2d19dd
JB		 1716SCM
1717scm_bit_position (item, v, k)
1718 SCM item;
1719 SCM v;
1720 SCM k;
0f2d19dd
JB		 1721{
1722 long i, lenw, xbits, pos = SCM_INUM (k);
1723 register unsigned long w;
1724 SCM_ASSERT (SCM_NIMP (v), v, SCM_ARG2, s_bit_position);
1725 SCM_ASSERT (SCM_INUMP (k), k, SCM_ARG3, s_bit_position);
1726 SCM_ASSERT ((pos <= SCM_LENGTH (v)) && (pos >= 0),
1727 k, SCM_OUTOFRANGE, s_bit_position);
1728 if (pos == SCM_LENGTH (v))
1729 return SCM_BOOL_F;
1730 switch SCM_TYP7
1731 (v)
1732 {
1733 default:
1734 scm_wta (v, (char *) SCM_ARG2, s_bit_position);
1735 case scm_tc7_bvect:
1736 if (0 == SCM_LENGTH (v))
1737 return SCM_MAKINUM (-1L);
1738 lenw = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; /* watch for part words */
1739 i = pos / SCM_LONG_BIT;
1740 w = SCM_VELTS (v)[i];
1741 if (SCM_FALSEP (item))
1742 w = ~w;
1743 xbits = (pos % SCM_LONG_BIT);
1744 pos -= xbits;
1745 w = ((w >> xbits) << xbits);
1746 xbits = SCM_LONG_BIT - 1 - (SCM_LENGTH (v) - 1) % SCM_LONG_BIT;
1747 while (!0)
1748 {
1749 if (w && (i == lenw))
1750 w = ((w << xbits) >> xbits);
1751 if (w)
1752 while (w)
1753 switch (w & 0x0f)
1754 {
1755 default:
1756 return SCM_MAKINUM (pos);
1757 case 2:
1758 case 6:
1759 case 10:
1760 case 14:
1761 return SCM_MAKINUM (pos + 1);
1762 case 4:
1763 case 12:
1764 return SCM_MAKINUM (pos + 2);
1765 case 8:
1766 return SCM_MAKINUM (pos + 3);
1767 case 0:
1768 pos += 4;
1769 w >>= 4;
1770 }
1771 if (++i > lenw)
1772 break;
1773 pos += SCM_LONG_BIT;
1774 w = SCM_VELTS (v)[i];
1775 if (SCM_FALSEP (item))
1776 w = ~w;
1777 }
1778 return SCM_BOOL_F;
1779 }
1780}
1781
1782
1783SCM_PROC(s_bit_set_star_x, "bit-set*!", 3, 0, 0, scm_bit_set_star_x);
1cc91f1b 1784
0f2d19dd
JB		 1785SCM
1786scm_bit_set_star_x (v, kv, obj)
1787 SCM v;
1788 SCM kv;
1789 SCM obj;
0f2d19dd
JB		 1790{
1791 register long i, k, vlen;
1792 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1793 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1794 switch SCM_TYP7
1795 (kv)
1796 {
1797 default:
1798 badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_set_star_x);
1799 case scm_tc7_uvect:
1800 switch SCM_TYP7
1801 (v)
1802 {
1803 default:
1804 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_set_star_x);
1805 case scm_tc7_bvect:
1806 vlen = SCM_LENGTH (v);
1807 if (SCM_BOOL_F == obj)
1808 for (i = SCM_LENGTH (kv); i;)
1809 {
1810 k = SCM_VELTS (kv)[--i];
1811 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
1812 SCM_VELTS (v)[k / SCM_LONG_BIT] &= ~(1L << (k % SCM_LONG_BIT));
1813 }
1814 else if (SCM_BOOL_T == obj)
1815 for (i = SCM_LENGTH (kv); i;)
1816 {
1817 k = SCM_VELTS (kv)[--i];
1818 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_set_star_x);
1819 SCM_VELTS (v)[k / SCM_LONG_BIT] |= (1L << (k % SCM_LONG_BIT));
1820 }
1821 else
1822 badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_set_star_x);
1823 }
1824 break;
1825 case scm_tc7_bvect:
1826 SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
1827 if (SCM_BOOL_F == 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 if (SCM_BOOL_T == obj)
1831 for (k = (SCM_LENGTH (v) + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1832 SCM_VELTS (v)[k] |= SCM_VELTS (kv)[k];
1833 else
1834 goto badarg3;
1835 break;
1836 }
1837 return SCM_UNSPECIFIED;
1838}
1839
1840
1841SCM_PROC(s_bit_count_star, "bit-count*", 3, 0, 0, scm_bit_count_star);
1cc91f1b 1842
0f2d19dd
JB		 1843SCM
1844scm_bit_count_star (v, kv, obj)
1845 SCM v;
1846 SCM kv;
1847 SCM obj;
0f2d19dd
JB		 1848{
1849 register long i, vlen, count = 0;
1850 register unsigned long k;
1851 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1852 SCM_ASRTGO (SCM_NIMP (kv), badarg2);
1853 switch SCM_TYP7
1854 (kv)
1855 {
1856 default:
1857 badarg2:scm_wta (kv, (char *) SCM_ARG2, s_bit_count_star);
1858 case scm_tc7_uvect:
1859 switch SCM_TYP7
1860 (v)
1861 {
1862 default:
1863 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_count_star);
1864 case scm_tc7_bvect:
1865 vlen = SCM_LENGTH (v);
1866 if (SCM_BOOL_F == obj)
1867 for (i = SCM_LENGTH (kv); i;)
1868 {
1869 k = SCM_VELTS (kv)[--i];
1870 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
1871 if (!(SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT))))
1872 count++;
1873 }
1874 else if (SCM_BOOL_T == obj)
1875 for (i = SCM_LENGTH (kv); i;)
1876 {
1877 k = SCM_VELTS (kv)[--i];
1878 SCM_ASSERT ((k < vlen), SCM_MAKINUM (k), SCM_OUTOFRANGE, s_bit_count_star);
1879 if (SCM_VELTS (v)[k / SCM_LONG_BIT] & (1L << (k % SCM_LONG_BIT)))
1880 count++;
1881 }
1882 else
1883 badarg3:scm_wta (obj, (char *) SCM_ARG3, s_bit_count_star);
1884 }
1885 break;
1886 case scm_tc7_bvect:
1887 SCM_ASRTGO (SCM_TYP7 (v) == scm_tc7_bvect && SCM_LENGTH (v) == SCM_LENGTH (kv), badarg1);
1888 if (0 == SCM_LENGTH (v))
1889 return SCM_INUM0;
1890 SCM_ASRTGO (SCM_BOOL_T == obj || SCM_BOOL_F == obj, badarg3);
1891 obj = (SCM_BOOL_T == obj);
1892 i = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT;
1893 k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
1894 k <<= SCM_LONG_BIT - 1 - ((SCM_LENGTH (v) - 1) % SCM_LONG_BIT);
1895 while (!0)
1896 {
1897 for (; k; k >>= 4)
1898 count += cnt_tab[k & 0x0f];
1899 if (0 == i--)
1900 return SCM_MAKINUM (count);
1901 k = SCM_VELTS (kv)[i] & (obj ? SCM_VELTS (v)[i] : ~SCM_VELTS (v)[i]);
1902 }
1903 }
1904 return SCM_MAKINUM (count);
1905}
1906
1907
1908SCM_PROC(s_bit_invert_x, "bit-invert!", 1, 0, 0, scm_bit_invert_x);
1cc91f1b 1909
0f2d19dd
JB		 1910SCM
1911scm_bit_invert_x (v)
1912 SCM v;
0f2d19dd
JB		 1913{
1914 register long k;
1915 SCM_ASRTGO (SCM_NIMP (v), badarg1);
1916 k = SCM_LENGTH (v);
1917 switch SCM_TYP7
1918 (v)
1919 {
1920 case scm_tc7_bvect:
1921 for (k = (k + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k--;)
1922 SCM_VELTS (v)[k] = ~SCM_VELTS (v)[k];
1923 break;
1924 default:
1925 badarg1:scm_wta (v, (char *) SCM_ARG1, s_bit_invert_x);
1926 }
1927 return SCM_UNSPECIFIED;
1928}
1929
1930
0f2d19dd
JB		 1931SCM
1932scm_istr2bve (str, len)
1933 char *str;
1934 long len;
0f2d19dd
JB		 1935{
1936 SCM v = scm_make_uve (len, SCM_BOOL_T);
1937 long *data = (long *) SCM_VELTS (v);
1938 register unsigned long mask;
1939 register long k;
1940 register long j;
1941 for (k = 0; k < (len + SCM_LONG_BIT - 1) / SCM_LONG_BIT; k++)
1942 {
1943 data[k] = 0L;
1944 j = len - k * SCM_LONG_BIT;
1945 if (j > SCM_LONG_BIT)
1946 j = SCM_LONG_BIT;
1947 for (mask = 1L; j--; mask <<= 1)
1948 switch (*str++)
1949 {
1950 case '0':
1951 break;
1952 case '1':
1953 data[k] |= mask;
1954 break;
1955 default:
1956 return SCM_BOOL_F;
1957 }
1958 }
1959 return v;
1960}
1961
1962
1cc91f1b
JB		 1963
1964static SCM ra2l SCM_P ((SCM ra, scm_sizet base, scm_sizet k));
1965
0f2d19dd
JB		 1966static SCM
1967ra2l (ra, base, k)
1968 SCM ra;
1969 scm_sizet base;
1970 scm_sizet k;
0f2d19dd
JB		 1971{
1972 register SCM res = SCM_EOL;
1973 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
1974 register scm_sizet i;
1975 if (SCM_ARRAY_DIMS (ra)[k].ubnd < SCM_ARRAY_DIMS (ra)[k].lbnd)
1976 return SCM_EOL;
1977 i = base + (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd) * inc;
1978 if (k < SCM_ARRAY_NDIM (ra) - 1)
1979 {
1980 do
1981 {
1982 i -= inc;
1983 res = scm_cons (ra2l (ra, i, k + 1), res);
1984 }
1985 while (i != base);
1986 }
1987 else
1988 do
1989 {
1990 i -= inc;
1991 res = scm_cons (scm_uniform_vector_ref (SCM_ARRAY_V (ra), SCM_MAKINUM (i)), res);
1992 }
1993 while (i != base);
1994 return res;
1995}
1996
1997
1998SCM_PROC(s_array_to_list, "array->list", 1, 0, 0, scm_array_to_list);
1cc91f1b 1999
0f2d19dd
JB		 2000SCM
2001scm_array_to_list (v)
2002 SCM v;
0f2d19dd
JB		 2003{
2004 SCM res = SCM_EOL;
2005 register long k;
2006 SCM_ASRTGO (SCM_NIMP (v), badarg1);
2007 switch SCM_TYP7
2008 (v)
2009 {
2010 default:
2011 badarg1:scm_wta (v, (char *) SCM_ARG1, s_array_to_list);
2012 case scm_tc7_smob:
2013 SCM_ASRTGO (SCM_ARRAYP (v), badarg1);
2014 return ra2l (v, SCM_ARRAY_BASE (v), 0);
2015 case scm_tc7_vector:
2016 return scm_vector_to_list (v);
2017 case scm_tc7_string:
2018 return scm_string_to_list (v);
2019 case scm_tc7_bvect:
2020 {
2021 long *data = (long *) SCM_VELTS (v);
2022 register unsigned long mask;
2023 for (k = (SCM_LENGTH (v) - 1) / SCM_LONG_BIT; k > 0; k--)
cdbadcac 2024 for (mask = 1UL << (SCM_LONG_BIT - 1); mask; mask >>= 1)
0f2d19dd
JB		 2025 res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
2026 for (mask = 1L << ((SCM_LENGTH (v) % SCM_LONG_BIT) - 1); mask; mask >>= 1)
2027 res = scm_cons (((long *) data)[k] & mask ? SCM_BOOL_T : SCM_BOOL_F, res);
2028 return res;
2029 }
2030# ifdef SCM_INUMS_ONLY
2031 case scm_tc7_uvect:
2032 case scm_tc7_ivect:
2033 {
2034 long *data = (long *) SCM_VELTS (v);
2035 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2036 res = scm_cons (SCM_MAKINUM (data[k]), res);
2037 return res;
2038 }
2039# else
2040 case scm_tc7_uvect: {
2041 long *data = (long *)SCM_VELTS(v);
2042 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2043 res = scm_cons(scm_ulong2num(data[k]), res);
2044 return res;
2045 }
2046 case scm_tc7_ivect: {
2047 long *data = (long *)SCM_VELTS(v);
2048 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2049 res = scm_cons(scm_long2num(data[k]), res);
2050 return res;
2051 }
2052# endif
2053 case scm_tc7_svect: {
2054 short *data;
2055 data = (short *)SCM_VELTS(v);
2056 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2057 res = scm_cons(SCM_MAKINUM (data[k]), res);
2058 return res;
2059 }
2060#ifdef LONGLONGS
2061 case scm_tc7_llvect: {
2062 long_long *data;
2063 data = (long_long *)SCM_VELTS(v);
2064 for (k = SCM_LENGTH(v) - 1; k >= 0; k--)
2065 res = scm_cons(scm_long_long2num(data[k]), res);
2066 return res;
2067 }
2068#endif
2069
2070
2071#ifdef SCM_FLOATS
2072#ifdef SCM_SINGLES
2073 case scm_tc7_fvect:
2074 {
2075 float *data = (float *) SCM_VELTS (v);
2076 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2077 res = scm_cons (scm_makflo (data[k]), res);
2078 return res;
2079 }
2080#endif /*SCM_SINGLES*/
2081 case scm_tc7_dvect:
2082 {
2083 double *data = (double *) SCM_VELTS (v);
2084 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2085 res = scm_cons (scm_makdbl (data[k], 0.0), res);
2086 return res;
2087 }
2088 case scm_tc7_cvect:
2089 {
2090 double (*data)[2] = (double (*)[2]) SCM_VELTS (v);
2091 for (k = SCM_LENGTH (v) - 1; k >= 0; k--)
2092 res = scm_cons (scm_makdbl (data[k][0], data[k][1]), res);
2093 return res;
2094 }
2095#endif /*SCM_FLOATS*/
2096 }
2097}
2098
2099
2100static char s_bad_ralst[] = "Bad scm_array contents scm_list";
1cc91f1b
JB		 2101
2102static int l2ra SCM_P ((SCM lst, SCM ra, scm_sizet base, scm_sizet k));
0f2d19dd
JB		 2103
2104SCM_PROC(s_list_to_uniform_array, "list->uniform-array", 3, 0, 0, scm_list_to_uniform_array);
1cc91f1b 2105
0f2d19dd
JB		 2106SCM
2107scm_list_to_uniform_array (ndim, prot, lst)
2108 SCM ndim;
2109 SCM prot;
2110 SCM lst;
0f2d19dd
JB		 2111{
2112 SCM shp = SCM_EOL;
2113 SCM row = lst;
2114 SCM ra;
2115 scm_sizet k;
2116 long n;
2117 SCM_ASSERT (SCM_INUMP (ndim), ndim, SCM_ARG1, s_list_to_uniform_array);
2118 k = SCM_INUM (ndim);
2119 while (k--)
2120 {
2121 n = scm_ilength (row);
0aa0871f 2122 SCM_ASSERT (n >= 0, lst, SCM_ARG3, s_list_to_uniform_array);
0f2d19dd
JB		 2123 shp = scm_cons (SCM_MAKINUM (n), shp);
2124 if (SCM_NIMP (row))
2125 row = SCM_CAR (row);
2126 }
2127 ra = scm_dimensions_to_uniform_array (scm_reverse (shp), prot, SCM_EOL);
2128 if (SCM_NULLP (shp))
2129
2130 {
2131 SCM_ASRTGO (1 == scm_ilength (lst), badlst);
2132 scm_array_set_x (ra, SCM_CAR (lst), SCM_EOL);
2133 return ra;
2134 }
2135 if (!SCM_ARRAYP (ra))
2136 {
2137 for (k = 0; k < SCM_LENGTH (ra); k++, lst = SCM_CDR (lst))
2138 scm_array_set_x (ra, SCM_CAR (lst), SCM_MAKINUM (k));
2139 return ra;
2140 }
2141 if (l2ra (lst, ra, SCM_ARRAY_BASE (ra), 0))
2142 return ra;
2143 else
2144 badlst:scm_wta (lst, s_bad_ralst, s_list_to_uniform_array);
2145 return SCM_BOOL_F;
2146}
2147
0f2d19dd
JB		 2148static int
2149l2ra (lst, ra, base, k)
2150 SCM lst;
2151 SCM ra;
2152 scm_sizet base;
2153 scm_sizet k;
0f2d19dd
JB		 2154{
2155 register long inc = SCM_ARRAY_DIMS (ra)[k].inc;
2156 register long n = (1 + SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd);
2157 int ok = 1;
2158 if (n <= 0)
2159 return (SCM_EOL == lst);
2160 if (k < SCM_ARRAY_NDIM (ra) - 1)
2161 {
2162 while (n--)
2163 {
2164 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2165 return 0;
2166 ok = ok && l2ra (SCM_CAR (lst), ra, base, k + 1);
2167 base += inc;
2168 lst = SCM_CDR (lst);
2169 }
2170 if (SCM_NNULLP (lst))
2171 return 0;
2172 }
2173 else
2174 {
2175 while (n--)
2176 {
2177 if (SCM_IMP (lst) || SCM_NCONSP (lst))
2178 return 0;
2179 ok = ok && scm_array_set_x (SCM_ARRAY_V (ra), SCM_CAR (lst), SCM_MAKINUM (base));
2180 base += inc;
2181 lst = SCM_CDR (lst);
2182 }
2183 if (SCM_NNULLP (lst))
2184 return 0;
2185 }
2186 return ok;
2187}
2188
1cc91f1b
JB		 2189
2190static void rapr1 SCM_P ((SCM ra, scm_sizet j, scm_sizet k, SCM port, scm_print_state *pstate));
2191
0f2d19dd 2192static void
9882ea19 2193rapr1 (ra, j, k, port, pstate)
0f2d19dd
JB		 2194 SCM ra;
2195 scm_sizet j;
2196 scm_sizet k;
2197 SCM port;
9882ea19 2198 scm_print_state *pstate;
0f2d19dd
JB		 2199{
2200 long inc = 1;
2201 long n = SCM_LENGTH (ra);
2202 int enclosed = 0;
2203tail:
2204 switch SCM_TYP7
2205 (ra)
2206 {
2207 case scm_tc7_smob:
2208 if (enclosed++)
2209 {
2210 SCM_ARRAY_BASE (ra) = j;
2211 if (n-- > 0)
9882ea19 2212 scm_iprin1 (ra, port, pstate);
0f2d19dd
JB		 2213 for (j += inc; n-- > 0; j += inc)
2214 {
2215 scm_gen_putc (' ', port);
2216 SCM_ARRAY_BASE (ra) = j;
9882ea19 2217 scm_iprin1 (ra, port, pstate);
0f2d19dd
JB		 2218 }
2219 break;
2220 }
2221 if (k + 1 < SCM_ARRAY_NDIM (ra))
2222 {
2223 long i;
2224 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2225 for (i = SCM_ARRAY_DIMS (ra)[k].lbnd; i < SCM_ARRAY_DIMS (ra)[k].ubnd; i++)
2226 {
2227 scm_gen_putc ('(', port);
9882ea19 2228 rapr1 (ra, j, k + 1, port, pstate);
0f2d19dd
JB		 2229 scm_gen_puts (scm_regular_string, ") ", port);
2230 j += inc;
2231 }
2232 if (i == SCM_ARRAY_DIMS (ra)[k].ubnd)
2233 { /* could be zero size. */
2234 scm_gen_putc ('(', port);
9882ea19 2235 rapr1 (ra, j, k + 1, port, pstate);
0f2d19dd
JB		 2236 scm_gen_putc (')', port);
2237 }
2238 break;
2239 }
2240 if SCM_ARRAY_NDIM
2241 (ra)
2242 { /* Could be zero-dimensional */
2243 inc = SCM_ARRAY_DIMS (ra)[k].inc;
2244 n = (SCM_ARRAY_DIMS (ra)[k].ubnd - SCM_ARRAY_DIMS (ra)[k].lbnd + 1);
2245 }
2246 else
2247 n = 1;
2248 ra = SCM_ARRAY_V (ra);
2249 goto tail;
2250 default:
2251 if (n-- > 0)
9882ea19 2252 scm_iprin1 (scm_uniform_vector_ref (ra, SCM_MAKINUM (j)), port, pstate);
0f2d19dd
JB		 2253 for (j += inc; n-- > 0; j += inc)
2254 {
2255 scm_gen_putc (' ', port);
9882ea19 2256 scm_iprin1 (scm_cvref (ra, j, SCM_UNDEFINED), port, pstate);
0f2d19dd
JB		 2257 }
2258 break;
2259 case scm_tc7_string:
2260 if (n-- > 0)
9882ea19
MD		 2261 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
2262 if (SCM_WRITINGP (pstate))
0f2d19dd
JB		 2263 for (j += inc; n-- > 0; j += inc)
2264 {
2265 scm_gen_putc (' ', port);
9882ea19 2266 scm_iprin1 (SCM_MAKICHR (SCM_CHARS (ra)[j]), port, pstate);
0f2d19dd
JB		 2267 }
2268 else
2269 for (j += inc; n-- > 0; j += inc)
2270 scm_gen_putc (SCM_CHARS (ra)[j], port);
2271 break;
2272 case scm_tc7_byvect:
2273 if (n-- > 0)
2274 scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
2275 for (j += inc; n-- > 0; j += inc)
2276 {
2277 scm_gen_putc (' ', port);
2278 scm_intprint (((char *)SCM_CDR (ra))[j], 10, port);
2279 }
2280 break;
2281
2282 case scm_tc7_uvect:
2283 case scm_tc7_ivect:
2284 if (n-- > 0)
2285 scm_intprint (SCM_VELTS (ra)[j], 10, port);
2286 for (j += inc; n-- > 0; j += inc)
2287 {
2288 scm_gen_putc (' ', port);
2289 scm_intprint (SCM_VELTS (ra)[j], 10, port);
2290 }
2291 break;
2292
2293 case scm_tc7_svect:
2294 if (n-- > 0)
2295 scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
2296 for (j += inc; n-- > 0; j += inc)
2297 {
2298 scm_gen_putc (' ', port);
2299 scm_intprint (((short *)SCM_CDR (ra))[j], 10, port);
2300 }
2301 break;
2302
2303#ifdef SCM_FLOATS
2304#ifdef SCM_SINGLES
2305 case scm_tc7_fvect:
2306 if (n-- > 0)
2307 {
2308 SCM z = scm_makflo (1.0);
2309 SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
9882ea19 2310 scm_floprint (z, port, pstate);
0f2d19dd
JB		 2311 for (j += inc; n-- > 0; j += inc)
2312 {
2313 scm_gen_putc (' ', port);
2314 SCM_FLO (z) = ((float *) SCM_VELTS (ra))[j];
9882ea19 2315 scm_floprint (z, port, pstate);
0f2d19dd
JB		 2316 }
2317 }
2318 break;
2319#endif /*SCM_SINGLES*/
2320 case scm_tc7_dvect:
2321 if (n-- > 0)
2322 {
2323 SCM z = scm_makdbl (1.0 / 3.0, 0.0);
2324 SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
9882ea19 2325 scm_floprint (z, port, pstate);
0f2d19dd
JB		 2326 for (j += inc; n-- > 0; j += inc)
2327 {
2328 scm_gen_putc (' ', port);
2329 SCM_REAL (z) = ((double *) SCM_VELTS (ra))[j];
9882ea19 2330 scm_floprint (z, port, pstate);
0f2d19dd
JB		 2331 }
2332 }
2333 break;
2334 case scm_tc7_cvect:
2335 if (n-- > 0)
2336 {
2337 SCM cz = scm_makdbl (0.0, 1.0), z = scm_makdbl (1.0 / 3.0, 0.0);
2338 SCM_REAL (z) = SCM_REAL (cz) = (((double *) SCM_VELTS (ra))[2 * j]);
2339 SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
9882ea19 2340 scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
0f2d19dd
JB		 2341 for (j += inc; n-- > 0; j += inc)
2342 {
2343 scm_gen_putc (' ', port);
2344 SCM_REAL (z) = SCM_REAL (cz) = ((double *) SCM_VELTS (ra))[2 * j];
2345 SCM_IMAG (cz) = ((double *) SCM_VELTS (ra))[2 * j + 1];
9882ea19 2346 scm_floprint ((0.0 == SCM_IMAG (cz) ? z : cz), port, pstate);
0f2d19dd
JB		 2347 }
2348 }
2349 break;
2350#endif /*SCM_FLOATS*/
2351 }
2352}
2353
2354
1cc91f1b 2355
0f2d19dd 2356int
9882ea19 2357scm_raprin1 (exp, port, pstate)
0f2d19dd
JB		 2358 SCM exp;
2359 SCM port;
9882ea19 2360 scm_print_state *pstate;
0f2d19dd
JB		 2361{
2362 SCM v = exp;
2363 scm_sizet base = 0;
2364 scm_gen_putc ('#', port);
2365tail:
2366 switch SCM_TYP7
2367 (v)
2368 {
2369 case scm_tc7_smob:
2370 {
2371 long ndim = SCM_ARRAY_NDIM (v);
2372 base = SCM_ARRAY_BASE (v);
2373 v = SCM_ARRAY_V (v);
2374 if (SCM_ARRAYP (v))
2375
2376 {
2377 scm_gen_puts (scm_regular_string, "<enclosed-array ", port);
9882ea19 2378 rapr1 (exp, base, 0, port, pstate);
0f2d19dd
JB		 2379 scm_gen_putc ('>', port);
2380 return 1;
2381 }
2382 else
2383 {
2384 scm_intprint (ndim, 10, port);
2385 goto tail;
2386 }
2387 }
2388 case scm_tc7_bvect:
2389 if (exp == v)
2390 { /* a uve, not an scm_array */
2391 register long i, j, w;
2392 scm_gen_putc ('*', port);
2393 for (i = 0; i < (SCM_LENGTH (exp)) / SCM_LONG_BIT; i++)
2394 {
2395 w = SCM_VELTS (exp)[i];
2396 for (j = SCM_LONG_BIT; j; j--)
2397 {
2398 scm_gen_putc (w & 1 ? '1' : '0', port);
2399 w >>= 1;
2400 }
2401 }
2402 j = SCM_LENGTH (exp) % SCM_LONG_BIT;
2403 if (j)
2404 {
2405 w = SCM_VELTS (exp)[SCM_LENGTH (exp) / SCM_LONG_BIT];
2406 for (; j; j--)
2407 {
2408 scm_gen_putc (w & 1 ? '1' : '0', port);
2409 w >>= 1;
2410 }
2411 }
2412 return 1;
2413 }
2414 else
2415 scm_gen_putc ('b', port);
2416 break;
2417 case scm_tc7_string:
2418 scm_gen_putc ('a', port);
2419 break;
2420 case scm_tc7_byvect:
2421 scm_gen_puts (scm_regular_string, "bytes", port);
2422 break;
2423 case scm_tc7_uvect:
2424 scm_gen_putc ('u', port);
2425 break;
2426 case scm_tc7_ivect:
2427 scm_gen_putc ('e', port);
2428 break;
2429 case scm_tc7_svect:
2430 scm_gen_puts (scm_regular_string, "short", port);
2431 break;
2432#ifdef LONGLONGS
2433 case scm_tc7_llvect:
2434 scm_gen_puts (scm_regular_string, "long_long", port);
2435 break;
2436#endif
2437#ifdef SCM_FLOATS
2438#ifdef SCM_SINGLES
2439 case scm_tc7_fvect:
2440 scm_gen_putc ('s', port);
2441 break;
2442#endif /*SCM_SINGLES*/
2443 case scm_tc7_dvect:
2444 scm_gen_putc ('i', port);
2445 break;
2446 case scm_tc7_cvect:
2447 scm_gen_putc ('c', port);
2448 break;
2449#endif /*SCM_FLOATS*/
2450 }
2451 scm_gen_putc ('(', port);
9882ea19 2452 rapr1 (exp, base, 0, port, pstate);
0f2d19dd
JB		 2453 scm_gen_putc (')', port);
2454 return 1;
2455}
2456
2457SCM_PROC(s_array_prototype, "array-prototype", 1, 0, 0, scm_array_prototype);
1cc91f1b 2458
0f2d19dd
JB		 2459SCM
2460scm_array_prototype (ra)
2461 SCM ra;
0f2d19dd
JB		 2462{
2463 int enclosed = 0;
2464 SCM_ASRTGO (SCM_NIMP (ra), badarg);
2465loop:
2466 switch SCM_TYP7
2467 (ra)
2468 {
2469 default:
2470 badarg:scm_wta (ra, (char *) SCM_ARG1, s_array_prototype);
2471 case scm_tc7_smob:
2472 SCM_ASRTGO (SCM_ARRAYP (ra), badarg);
2473 if (enclosed++)
2474 return SCM_UNSPECIFIED;
2475 ra = SCM_ARRAY_V (ra);
2476 goto loop;
2477 case scm_tc7_vector:
2478 return SCM_EOL;
2479 case scm_tc7_bvect:
2480 return SCM_BOOL_T;
2481 case scm_tc7_string:
2482 return SCM_MAKICHR ('a');
2483 case scm_tc7_byvect:
2484 return SCM_MAKICHR ('\0');
2485 case scm_tc7_uvect:
2486 return SCM_MAKINUM (1L);
2487 case scm_tc7_ivect:
2488 return SCM_MAKINUM (-1L);
2489 case scm_tc7_svect:
2490 return SCM_CDR (scm_intern ("s", 1));
2491#ifdef LONGLONGS
2492 case scm_tc7_llvect:
2493 return SCM_CDR (scm_intern ("l", 1));
2494#endif
2495#ifdef SCM_FLOATS
2496#ifdef SCM_SINGLES
2497 case scm_tc7_fvect:
2498 return scm_makflo (1.0);
2499#endif
2500 case scm_tc7_dvect:
2501 return scm_makdbl (1.0 / 3.0, 0.0);
2502 case scm_tc7_cvect:
2503 return scm_makdbl (0.0, 1.0);
2504#endif
2505 }
2506}
2507
1cc91f1b
JB		 2508
2509static SCM markra SCM_P ((SCM ptr));
2510
0f2d19dd
JB		 2511static SCM
2512markra (ptr)
2513 SCM ptr;
0f2d19dd
JB		 2514{
2515 if SCM_GC8MARKP
2516 (ptr) return SCM_BOOL_F;
2517 SCM_SETGC8MARK (ptr);
2518 return SCM_ARRAY_V (ptr);
2519}
2520
1cc91f1b
JB		 2521
2522static scm_sizet freera SCM_P ((SCM ptr));
2523
0f2d19dd
JB		 2524static scm_sizet
2525freera (ptr)
2526 SCM ptr;
0f2d19dd
JB		 2527{
2528 scm_must_free (SCM_CHARS (ptr));
2529 return sizeof (scm_array) + SCM_ARRAY_NDIM (ptr) * sizeof (scm_array_dim);
2530}
2531
2532static scm_smobfuns rasmob =
2533{markra, freera, scm_raprin1, scm_array_equal_p};
2534
2535
2536/* This must be done after scm_init_scl() */
1cc91f1b 2537
0f2d19dd
JB		 2538void
2539scm_init_unif ()
0f2d19dd
JB		 2540{
2541#include "unif.x"
2542 scm_tc16_array = scm_newsmob (&rasmob);
2543 scm_add_feature ("array");
2544}
2545
2546#else /* ARRAYS */
2547
1cc91f1b 2548
0f2d19dd 2549int
9882ea19 2550scm_raprin1 (exp, port, pstate)
0f2d19dd
JB		 2551 SCM exp;
2552 SCM port;
9882ea19 2553 scm_print_state *pstate;
0f2d19dd
JB		 2554{
2555 return 0;
2556}
2557
1cc91f1b 2558
0f2d19dd
JB		 2559SCM
2560scm_istr2bve (str, len)
2561 char *str;
2562 long len;
0f2d19dd
JB		 2563{
2564 return SCM_BOOL_F;
2565}
2566
0f2d19dd
JB		 2567void
2568scm_init_unif ()
2569{
175475a8 2570#include "unif.x"
0f2d19dd
JB		 2571 scm_make_subr (s_resizuve, scm_tc7_subr_2, scm_vector_set_length_x);
2572}
2573
2574#endif /* ARRAYS */
Unnamed repository; edit this file 'description' to name the repository.