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