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