~ chicken-core (master) /srfi-4.scm

  1;;;; srfi-4.scm - Homogeneous numeric vectors
  2;
  3; Copyright (c) 2008-2022, The CHICKEN Team
  4; Copyright (c) 2000-2007, Felix L. Winkelmann
  5; All rights reserved.
  6;
  7; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
  8; conditions are met:
  9;
 10;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
 11;     disclaimer.
 12;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
 13;     disclaimer in the documentation and/or other materials provided with the distribution.
 14;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
 15;     products derived from this software without specific prior written permission.
 16;
 17; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
 18; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
 19; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
 20; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 21; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
 22; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
 23; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
 24; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
 25; POSSIBILITY OF SUCH DAMAGE.
 26
 27
 28(declare
 29  (unit srfi-4)
 30  (uses expand extras)
 31  (disable-interrupts)
 32  (not inline ##sys#user-print-hook)
 33  (foreign-declare #<<EOF
 34#define C_copy_subvector(to, from, start_to, start_from, bytes)   \
 35  (C_memcpy((C_char *)C_data_pointer(to) + C_unfix(start_to), (C_char *)C_data_pointer(from) + C_unfix(start_from), C_unfix(bytes)), \
 36    C_SCHEME_UNDEFINED)
 37EOF
 38) )
 39
 40(module chicken.number-vector
 41  (bytevector->f32vector bytevector->f32vector/shared
 42   bytevector->f64vector bytevector->f64vector/shared
 43   bytevector->s16vector bytevector->s16vector/shared
 44   bytevector->s32vector bytevector->s32vector/shared
 45   bytevector->s64vector bytevector->s64vector/shared
 46   bytevector->s8vector bytevector->s8vector/shared
 47   bytevector->u16vector bytevector->u16vector/shared
 48   bytevector->u32vector bytevector->u32vector/shared
 49   bytevector->u64vector bytevector->u64vector/shared
 50   bytevector->c64vector bytevector->c64vector/shared
 51   bytevector->c128vector bytevector->c128vector/shared
 52   f32vector f32vector->bytevector f32vector->bytevector/shared f32vector->list
 53   f32vector-length f32vector-ref f32vector-set! f32vector?
 54   f64vector f64vector->bytevector f64vector->bytevector/shared f64vector->list
 55   f64vector-length f64vector-ref f64vector-set! f64vector?
 56   s8vector s8vector->bytevector s8vector->bytevector/shared s8vector->list
 57   s8vector-length s8vector-ref s8vector-set! s8vector?
 58   s16vector s16vector->bytevector s16vector->bytevector/shared s16vector->list
 59   s16vector-length s16vector-ref s16vector-set! s16vector?
 60   s32vector s32vector->bytevector s32vector->bytevector/shared s32vector->list
 61   s32vector-length s32vector-ref s32vector-set! s32vector?
 62   s64vector s64vector->bytevector s64vector->bytevector/shared s64vector->list
 63   s64vector-length s64vector-ref s64vector-set! s64vector?
 64   u8vector u8vector->list
 65   u8vector-length u8vector-ref u8vector-set! u8vector?
 66   u16vector u16vector->bytevector u16vector->bytevector/shared u16vector->list
 67   u16vector-length u16vector-ref u16vector-set! u16vector?
 68   u32vector u32vector->bytevector u32vector->bytevector/shared u32vector->list
 69   u32vector-length u32vector-ref u32vector-set! u32vector?
 70   u64vector u64vector->bytevector u64vector->bytevector/shared u64vector->list
 71   u64vector-length u64vector-ref u64vector-set! u64vector?
 72   c64vector c64vector->bytevector c64vector->bytevector/shared c64vector->list
 73   c64vector-length c64vector-ref c64vector-set! c64vector?
 74   c128vector c128vector->bytevector c128vector->bytevector/shared c128vector->list
 75   c128vector-length c128vector-ref c128vector-set! c128vector?
 76   list->f32vector list->f64vector list->s16vector list->s32vector
 77   list->s64vector list->s8vector list->u16vector list->u32vector
 78   list->u8vector list->u64vector list->c64vector list->c128vector
 79   make-f32vector make-f64vector make-s16vector make-s32vector
 80   make-s64vector make-s8vector make-u16vector make-u32vector
 81   make-u64vector make-u8vector make-c64vector make-c128vector
 82   number-vector? release-number-vector
 83   subf32vector subf64vector subs16vector subs32vector subs64vector
 84   subs8vector subu16vector subu8vector subu32vector subu64vector
 85   subc64vector subc128vector)
 86
 87(import scheme
 88	chicken.base
 89	chicken.bitwise
 90        chicken.bytevector
 91	chicken.fixnum
 92	chicken.foreign
 93	chicken.gc
 94	chicken.platform
 95	chicken.syntax)
 96
 97(include "common-declarations.scm")
 98
 99
100;;; Helper routines:
101
102(define-inline (check-int/flonum x loc)
103  (unless (or (##core#inline "C_i_exact_integerp" x)
104	      (##core#inline "C_i_flonump" x))
105    (##sys#error-hook (foreign-value "C_BAD_ARGUMENT_TYPE_NO_FLONUM_ERROR" int) loc x) ) )
106
107(define-inline (check-uint-length obj len loc)
108  (##sys#check-exact-uinteger obj loc)
109  (when (fx> (integer-length obj) len)
110    (##sys#error-hook
111     (foreign-value "C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR" int) loc obj)))
112
113(define-inline (check-int-length obj len loc)
114  (##sys#check-exact-integer obj loc)
115  (when (fx> (integer-length obj) (fx- len 1))
116    (##sys#error-hook
117     (foreign-value "C_BAD_ARGUMENT_TYPE_NUMERIC_RANGE_ERROR" int)
118     loc obj)))
119
120(define-syntax ->f
121  (syntax-rules ()
122    ((_ x)
123     (let ((tmp x))
124       (if (##core#inline "C_i_flonump" tmp)
125           tmp
126           (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) tmp))))))
127
128;;; Get vector length:
129
130(define (u8vector-length x)
131  (##core#inline "C_i_bytevector_length" x))
132
133(define (s8vector-length x)
134  (##core#inline "C_i_s8vector_length" x))
135
136(define (u16vector-length x)
137  (##core#inline "C_i_u16vector_length" x))
138
139(define (s16vector-length x)
140  (##core#inline "C_i_s16vector_length" x))
141
142(define (u32vector-length x)
143  (##core#inline "C_i_u32vector_length" x))
144
145(define (s32vector-length x)
146  (##core#inline "C_i_s32vector_length" x))
147
148(define (u64vector-length x)
149  (##core#inline "C_i_u64vector_length" x))
150
151(define (s64vector-length x)
152  (##core#inline "C_i_s64vector_length" x))
153
154(define (f32vector-length x)
155  (##core#inline "C_i_f32vector_length" x))
156
157(define (f64vector-length x)
158  (##core#inline "C_i_f64vector_length" x))
159
160(define (c64vector-length x)
161  (##sys#check-structure x 'c64vector 'c64vector-length)
162  (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1)) 8))
163
164(define (c128vector-length x)
165  (##sys#check-structure x 'c128vector 'c128vector-length)
166  (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1)) 16))
167
168
169;;; Safe accessors:
170
171(define u8vector-set! bytevector-u8-set!)
172
173(define (s8vector-set! x i y)
174  (##core#inline "C_i_s8vector_set" x i y))
175
176(define (u16vector-set! x i y)
177  (##core#inline "C_i_u16vector_set" x i y))
178
179(define (s16vector-set! x i y)
180  (##core#inline "C_i_s16vector_set" x i y))
181
182(define (u32vector-set! x i y)
183  (##core#inline "C_i_u32vector_set" x i y))
184
185(define (s32vector-set! x i y)
186  (##core#inline "C_i_s32vector_set" x i y))
187
188(define (u64vector-set! x i y)
189  (##core#inline "C_i_u64vector_set" x i y))
190
191(define (s64vector-set! x i y)
192  (##core#inline "C_i_s64vector_set" x i y))
193
194(define (f32vector-set! x i y)
195  (##core#inline "C_i_f32vector_set" x i y))
196
197(define (f64vector-set! x i y)
198  (##core#inline "C_i_f64vector_set" x i y))
199
200(define (c64vector-set! x i y)
201  (##sys#check-structure x 'c64vector 'c64vector-set!)
202  (let* ((bv (##sys#slot x 1))
203         (len (fx/ (##core#inline "C_i_bytevector_length" bv) 8)))
204    (##sys#check-range i 0 len 'c64vector-set!)
205    (##sys#check-number y 'c64vector-set!)
206    (##core#inline "C_u_i_f32vector_set" x (fx/ i 2) (->f (real-part y)))
207    (##core#inline "C_u_i_f32vector_set" x (fx+ (fx/ i 2) 1) (->f (imag-part y)))))
208
209(define (c128vector-set! x i y)
210  (##sys#check-structure x 'c128vector 'c128vector-set!)
211  (let* ((bv (##sys#slot x 1))
212         (len (fx/ (##core#inline "C_i_bytevector_length" bv) 16)))
213    (##sys#check-range i 0 len 'c128vector-set!)
214    (##sys#check-number y 'c128vector-set!)
215    (##core#inline "C_u_i_f64vector_set" x (fx/ i 2) (->f (real-part y)))
216    (##core#inline "C_u_i_f64vector_set" x (fx+ (fx/ i 2) 1) (->f (imag-part y)))))
217
218(define u8vector-ref bytevector-u8-ref)
219
220(define s8vector-ref
221  (getter-with-setter
222   (lambda (x i) (##core#inline "C_i_s8vector_ref" x i))
223   s8vector-set!
224   "(chicken.number-vector#s8vector-ref v i)"))
225
226(define u16vector-ref
227  (getter-with-setter
228   (lambda (x i) (##core#inline "C_i_u16vector_ref" x i))
229   u16vector-set!
230   "(chicken.number-vector#u16vector-ref v i)"))
231
232(define s16vector-ref
233  (getter-with-setter
234   (lambda (x i) (##core#inline "C_i_s16vector_ref" x i))
235   s16vector-set!
236   "(chicken.number-vector#s16vector-ref v i)"))
237   
238(define u32vector-ref
239  (getter-with-setter
240   (lambda (x i) (##core#inline_allocate ("C_a_i_u32vector_ref" 5) x i))
241   u32vector-set!
242   "(chicken.number-vector#u32vector-ref v i)"))
243
244(define s32vector-ref
245  (getter-with-setter
246   (lambda (x i) (##core#inline_allocate ("C_a_i_s32vector_ref" 5) x i))
247   s32vector-set!
248   "(chicken.number-vector#s32vector-ref v i)"))
249
250(define u64vector-ref
251  (getter-with-setter
252   (lambda (x i) (##core#inline_allocate ("C_a_i_u64vector_ref" 7) x i))
253   u64vector-set!
254   "(chicken.number-vector#u64vector-ref v i)"))
255
256(define s64vector-ref
257  (getter-with-setter
258   (lambda (x i) (##core#inline_allocate ("C_a_i_s64vector_ref" 7) x i))
259   s64vector-set!
260   "(chicken.number-vector#s64vector-ref v i)"))
261
262(define f32vector-ref
263  (getter-with-setter
264   (lambda (x i) (##core#inline_allocate ("C_a_i_f32vector_ref" 4) x i))
265   f32vector-set!
266   "(chicken.number-vector#f32vector-ref v i)"))
267
268(define f64vector-ref
269  (getter-with-setter
270   (lambda (x i) (##core#inline_allocate ("C_a_i_f64vector_ref" 4) x i))
271   f64vector-set!
272   "(chicken.number-vector#f64vector-ref v i)"))
273
274(define c64vector-ref
275  (getter-with-setter
276   (lambda (x i)
277     (##sys#check-structure x 'c64vector 'c64vector-ref)
278     (##sys#check-range i 0 (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
279                                 8) 'c64vector-ref)
280     (let ((p (fx/ i 2)))
281       (make-rectangular (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x p)
282                         (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x (fx+ p 1)))))
283   c64vector-set!
284   "(chicken.number-vector#c64vector-ref v i)"))
285
286(define c128vector-ref
287  (getter-with-setter
288   (lambda (x i)
289     (##sys#check-structure x 'c128vector 'c128vector-ref)
290     (##sys#check-range i 0 (fx/ (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
291                                 16) 'c128vector-ref)
292     (let ((p (fx/ i 2)))
293       (make-rectangular (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x p)
294                         (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x (fx+ p 1)))))
295   c128vector-set!
296   "(chicken.number-vector#c128vector-ref v i)"))
297
298
299;;; Basic constructors:
300
301(define make-f32vector)
302(define make-f64vector)
303(define make-s16vector)
304(define make-s32vector)
305(define make-s64vector)
306(define make-s8vector)
307(define make-u8vector)
308(define make-u16vector)
309(define make-u32vector)
310(define make-u64vector)
311(define make-c64vector)
312(define make-c128vector)
313(define release-number-vector)
314
315(let* ((ext-alloc
316	(foreign-lambda* scheme-object ((size_t bytes))
317	  "if (bytes > C_HEADER_SIZE_MASK) C_return(C_SCHEME_FALSE);"
318	  "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
319	  "if(buf == NULL) C_return(C_SCHEME_FALSE);"
320	  "C_block_header_init(buf, C_make_header(C_BYTEVECTOR_TYPE, bytes));"
321	  "C_return(buf);") )
322       (ext-free
323	(foreign-lambda* void ((scheme-object bv))
324	  "C_free((void *)C_block_item(bv, 1));") )
325       (alloc
326	(lambda (loc elem-size elems ext?)
327	  (##sys#check-fixnum elems loc)
328	  (when (fx< elems 0) (##sys#error loc "size is negative" elems))
329	  (let ((len (fx*? elems elem-size)))
330	    (unless len (##sys#error "overflow - cannot allocate the required number of elements" elems))
331	    (if ext?
332		(let ((bv (ext-alloc len)))
333		  (or bv
334		      (##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
335		(##sys#allocate-bytevector len #f))))))
336
337  (set! release-number-vector
338    (lambda (v)
339      (if (number-vector? v)
340	  (ext-free v)
341	  (##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )
342
343  (set! make-u8vector
344    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
345      (let ((v (alloc 'make-u8vector 1 len ext?)))
346	(when (and ext? fin?) (set-finalizer! v ext-free))
347	(if (not init)
348	    v
349	    (begin
350	      (check-uint-length init 8 'make-u8vector)
351	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
352		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
353		(##core#inline "C_setsubbyte" v i init) ) ) ) ) ) )
354
355  (set! make-s8vector
356    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
357      (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector 1 len ext?))))
358	(when (and ext? fin?) (set-finalizer! v ext-free))
359	(if (not init)
360	    v
361	    (begin
362	      (check-uint-length init 8 'make-s8vector)
363	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
364		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
365		(##core#inline "C_u_i_s8vector_set" v i init) ) ) ) ) ) )
366
367  (set! make-u16vector
368    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
369      (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector 2 len ext?))))
370	(when (and ext? fin?) (set-finalizer! v ext-free))
371	(if (not init)
372	    v
373	    (begin
374	      (check-uint-length init 16 'make-u16vector)
375	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
376		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
377		(##core#inline "C_u_i_u16vector_set" v i init) ) ) ) ) ) )
378
379  (set! make-s16vector
380    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
381      (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector 2 len ext?))))
382	(when (and ext? fin?) (set-finalizer! v ext-free))
383	(if (not init)
384	    v
385	    (begin
386	      (check-int-length init 16 'make-s16vector)
387	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
388		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
389		(##core#inline "C_u_i_s16vector_set" v i init) ) ) ) ) ) )
390
391  (set! make-u32vector
392    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
393      (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector 4 len ext?))))
394	(when (and ext? fin?) (set-finalizer! v ext-free))
395	(if (not init)
396	    v
397	    (begin
398	      (check-uint-length init 32 'make-u32vector)
399	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
400		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
401		(##core#inline "C_u_i_u32vector_set" v i init) ) ) ) ) ) )
402
403  (set! make-u64vector
404    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
405      (let ((v (##sys#make-structure 'u64vector (alloc 'make-u64vector 8 len ext?))))
406	(when (and ext? fin?) (set-finalizer! v ext-free))
407	(if (not init)
408	    v
409	    (begin
410	      (check-uint-length init 64 'make-u64vector)
411	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
412		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
413		(##core#inline "C_u_i_u64vector_set" v i init) ) ) ) ) ) )
414
415  (set! make-s32vector
416    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
417      (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector 4 len ext?))))
418	(when (and ext? fin?) (set-finalizer! v ext-free))
419	(if (not init)
420	    v
421	    (begin
422	      (check-int-length init 32 'make-s32vector)
423	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
424		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
425		(##core#inline "C_u_i_s32vector_set" v i init) ) ) ) ) ) )
426
427   (set! make-s64vector
428    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
429      (let ((v (##sys#make-structure 's64vector (alloc 'make-s64vector 8 len ext?))))
430	(when (and ext? fin?) (set-finalizer! v ext-free))
431	(if (not init)
432	    v
433	    (begin
434	      (check-int-length init 64 'make-s64vector)
435	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
436		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
437		(##core#inline "C_u_i_s64vector_set" v i init) ) ) ) ) ) )
438
439  (set! make-f32vector
440    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
441      (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector 4 len ext?))))
442	(when (and ext? fin?) (set-finalizer! v ext-free))
443	(if (not init)
444	    v
445	    (begin
446	      (check-int/flonum init 'make-f32vector)
447	      (unless (##core#inline "C_i_flonump" init)
448		(set! init (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) init)))
449	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
450		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
451		(##core#inline "C_u_i_f32vector_set" v i init) ) ) ) ) ) )
452
453  (set! make-f64vector
454    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
455      (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector 8 len ext?))))
456	(when (and ext? fin?) (set-finalizer! v ext-free))
457	(if (not init)
458	    v
459	    (begin
460	      (check-int/flonum init 'make-f64vector)
461	      (unless (##core#inline "C_i_flonump" init)
462		(set! init (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) init)) )
463	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
464		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
465		(##core#inline "C_u_i_f64vector_set" v i init) ) ) ) ) ) )
466
467  (set! make-c64vector
468    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
469      (let ((v (##sys#make-structure 'c64vector (alloc 'make-c64vector 4 (fx* len 2) ext?))))
470	(when (and ext? fin?) (set-finalizer! v ext-free))
471	(if (not init)
472	    v
473	    (let ((len2 (fx* len 2)))
474	      (check-int/flonum init 'make-c64vector)
475	      (do ((i 0 (fx+ i 2)))
476		  ((fx>= i len2) v)
477		(##core#inline "C_u_i_f32vector_set" v i (real-part init))
478		(##core#inline "C_u_i_f32vector_set" v (fx+ i 1) (imag-part init))))))))
479
480  (set! make-c128vector
481    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
482      (let ((v (##sys#make-structure 'c128vector (alloc 'make-c128vector 8 (fx* len 2) ext?))))
483	(when (and ext? fin?) (set-finalizer! v ext-free))
484	(if (not init)
485	    v
486	    (let ((len2 (fx* len 2)))
487	      (check-int/flonum init 'make-c128vector)
488	      (do ((i 0 (fx+ i 2)))
489		  ((fx>= i len2) v)
490		(##core#inline "C_u_i_f64vector_set" v i (real-part init))
491		(##core#inline "C_u_i_f64vector_set" v (fx+ i 1) (imag-part init)))))))))
492
493
494;;; Creating vectors from a list:
495
496(define-syntax list->NNNvector 
497  (er-macro-transformer 
498   (lambda (x r c)
499     (let* ((tag (strip-syntax (cadr x)))
500	    (tagstr (symbol->string tag))
501	    (name (string->symbol (string-append "list->" tagstr)))
502	    (make (string->symbol (string-append "make-" tagstr)))
503	    (set (string->symbol (string-append tagstr "-set!"))))
504       `(define ,name
505	  (let ((,make ,make))
506	    (lambda (lst)
507	      (##sys#check-list lst ',tag)
508	      (let* ((n (##core#inline "C_i_length" lst))
509		     (v (,make n)) )
510		(do ((p lst (##core#inline "C_slot" p 1))
511		     (i 0 (##core#inline "C_fixnum_plus" i 1)) )
512		    ((##core#inline "C_eqp" p '()) v)
513		  (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
514		      (,set v i (##core#inline "C_slot" p 0))
515		      (##sys#error-not-a-proper-list lst ',name) ) ) ) )))))))
516
517(define list->u8vector ##sys#list->bytevector)
518
519(list->NNNvector s8vector)
520(list->NNNvector u16vector)
521(list->NNNvector s16vector)
522(list->NNNvector u32vector)
523(list->NNNvector s32vector)
524(list->NNNvector u64vector)
525(list->NNNvector s64vector)
526(list->NNNvector f32vector)
527(list->NNNvector f64vector)
528(list->NNNvector c64vector)
529(list->NNNvector c128vector)
530
531
532;;; More constructors:
533
534(define u8vector
535  (lambda xs (list->u8vector xs)) )
536
537(define s8vector
538  (lambda xs (list->s8vector xs)) )
539
540(define u16vector
541  (lambda xs (list->u16vector xs)) )
542
543(define s16vector
544  (lambda xs (list->s16vector xs)) )
545
546(define u32vector
547  (lambda xs (list->u32vector xs)) )
548
549(define s32vector
550  (lambda xs (list->s32vector xs)) )
551
552(define u64vector
553  (lambda xs (list->u64vector xs)) )
554
555(define s64vector
556  (lambda xs (list->s64vector xs)) )
557
558(define f32vector
559  (lambda xs (list->f32vector xs)) )
560
561(define f64vector
562  (lambda xs (list->f64vector xs)) )
563
564(define c64vector
565  (lambda xs (list->c64vector xs)) )
566
567(define c128vector
568  (lambda xs (list->c128vector xs)) )
569
570
571;;; Creating lists from a vector:
572
573(define-syntax NNNvector->list
574  (er-macro-transformer
575   (lambda (x r c)
576     (let* ((tag (symbol->string (strip-syntax (cadr x))))
577	    (alloc (and (pair? (cddr x)) (caddr x)))
578	    (name (string->symbol (string-append tag "->list"))))
579       `(define (,name v)
580	  (##sys#check-structure v ',(string->symbol tag) ',name)
581	  (let ((len (##core#inline ,(string-append "C_u_i_" tag "_length") v)))
582	    (let loop ((i 0))
583	      (if (fx>= i len)
584		  '()
585		  (cons 
586		   ,(if alloc
587			`(##core#inline_allocate (,(string-append "C_a_u_i_" tag "_ref") ,alloc) v i)
588			`(##core#inline ,(string-append "C_u_i_" tag "_ref") v i))
589		   (loop (fx+ i 1)) ) ) ) ) ) ) )))
590
591(define (u8vector->list v)
592  (##sys#check-bytevector v 'u8vector->list)
593  (##sys#bytevector->list v))
594  
595(NNNvector->list s8vector)
596(NNNvector->list u16vector)
597(NNNvector->list s16vector)
598;; The alloc amounts here are for 32-bit words; this over-allocates on 64-bits
599(NNNvector->list u32vector 6)
600(NNNvector->list s32vector 6)
601(NNNvector->list u64vector 7)
602(NNNvector->list s64vector 7)
603(NNNvector->list f32vector 4)
604(NNNvector->list f64vector 4)
605
606(define c64vector->list
607  (let ((c64vector-length c64vector-length)
608        (c64vector-ref c64vector-ref))
609    (lambda (v)
610      (##sys#check-structure v 'c64vector 'c64vector->list)
611      (let ((len (c64vector-length v)))
612        (let loop ((i 0))
613          (if (fx>= i len)
614              '()
615              (cons (c64vector-ref v i)
616                    (loop (fx+ i 1)) ) ) ) ))))
617    
618(define c128vector->list
619  (let ((c128vector-length c128vector-length)
620        (c128vector-ref c128vector-ref))
621    (lambda (v)
622      (##sys#check-structure v 'c128vector 'c128vector->list)
623      (let ((len (c128vector-length v)))
624        (let loop ((i 0))
625          (if (fx>= i len)
626              '()
627              (cons (c128vector-ref v i)
628                    (loop (fx+ i 1)) ) ) ) ) )))
629
630
631;;; Predicates:
632
633(define (u8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_bytevectorp" x)))
634(define (s8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s8vectorp" x)))
635(define (u16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u16vectorp" x)))
636(define (s16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s16vectorp" x)))
637(define (u32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u32vectorp" x)))
638(define (s32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s32vectorp" x)))
639(define (u64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u64vectorp" x)))
640(define (s64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s64vectorp" x)))
641(define (f32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f32vectorp" x)))
642(define (f64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f64vectorp" x)))
643(define (c64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c64vector)))
644(define (c128vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c128vector)))
645
646;; Catch-all predicate
647(define (number-vector? x)
648  (or (bytevector? x) (##sys#srfi-4-vector? x)))
649
650;;; Accessing the packed bytevector:
651
652(define (pack tag loc)
653  (lambda (v)
654    (##sys#check-structure v tag loc)
655    (##sys#slot v 1) ) )
656
657(define (pack-copy tag loc)
658  (lambda (v)
659    (##sys#check-structure v tag loc)
660    (let* ((old (##sys#slot v 1))
661	   (new (##sys#make-bytevector (##sys#size old))))
662      (##core#inline "C_copy_block" old new) ) ) )
663
664(define (unpack tag sz loc)
665  (lambda (str)
666    (##sys#check-bytevector str loc)
667    (let ((len (##sys#size str)))
668      (if (or (eq? #t sz)
669	      (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
670	  (##sys#make-structure tag str)
671	  (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
672
673(define (unpack-copy tag sz loc)
674  (lambda (str)
675    (##sys#check-bytevector str loc)
676    (let* ((len (##sys#size str))
677	   (new (##sys#make-bytevector len)))
678      (if (or (eq? #t sz)
679	      (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
680	  (##sys#make-structure
681	   tag
682	   (##core#inline "C_copy_block" str new) )
683	  (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
684
685(define s8vector->bytevector/shared (pack 's8vector 's8vector->bytevector/shared))
686(define u16vector->bytevector/shared (pack 'u16vector 'u16vector->bytevector/shared))
687(define s16vector->bytevector/shared (pack 's16vector 's16vector->bytevector/shared))
688(define u32vector->bytevector/shared (pack 'u32vector 'u32vector->bytevector/shared))
689(define s32vector->bytevector/shared (pack 's32vector 's32vector->bytevector/shared))
690(define u64vector->bytevector/shared (pack 'u64vector 'u64vector->bytevector/shared))
691(define s64vector->bytevector/shared (pack 's64vector 's64vector->bytevector/shared))
692(define f32vector->bytevector/shared (pack 'f32vector 'f32vector->bytevector/shared))
693(define f64vector->bytevector/shared (pack 'f64vector 'f64vector->bytevector/shared))
694(define c64vector->bytevector/shared (pack 'c64vector 'c64vector->bytevector/shared))
695(define c128vector->bytevector/shared (pack 'c128vector 'c128vector->bytevector/shared))
696
697(define s8vector->bytevector (pack-copy 's8vector 's8vector->bytevector))
698(define u16vector->bytevector (pack-copy 'u16vector 'u16vector->bytevector))
699(define s16vector->bytevector (pack-copy 's16vector 's16vector->bytevector))
700(define u32vector->bytevector (pack-copy 'u32vector 'u32vector->bytevector))
701(define s32vector->bytevector (pack-copy 's32vector 's32vector->bytevector))
702(define u64vector->bytevector (pack-copy 'u64vector 'u64vector->bytevector))
703(define s64vector->bytevector (pack-copy 's64vector 's64vector->bytevector))
704(define f32vector->bytevector (pack-copy 'f32vector 'f32vector->bytevector))
705(define f64vector->bytevector (pack-copy 'f64vector 'f64vector->bytevector))
706(define c64vector->bytevector (pack-copy 'c64vector 'c64vector->bytevector))
707(define c128vector->bytevector (pack-copy 'c128vector 'c128vector->bytevector))
708
709(define bytevector->s8vector/shared (unpack 's8vector #t 'bytevector->s8vector/shared))
710(define bytevector->u16vector/shared (unpack 'u16vector 2 'bytevector->u16vector/shared))
711(define bytevector->s16vector/shared (unpack 's16vector 2 'bytevector->s16vector/shared))
712(define bytevector->u32vector/shared (unpack 'u32vector 4 'bytevector->u32vector/shared))
713(define bytevector->s32vector/shared (unpack 's32vector 4 'bytevector->s32vector/shared))
714(define bytevector->u64vector/shared (unpack 'u64vector 4 'bytevector->u64vector/shared))
715(define bytevector->s64vector/shared (unpack 's64vector 4 'bytevector->s64vector/shared))
716(define bytevector->f32vector/shared (unpack 'f32vector 4 'bytevector->f32vector/shared))
717(define bytevector->f64vector/shared (unpack 'f64vector 8 'bytevector->f64vector/shared))
718(define bytevector->c64vector/shared (unpack 'c64vector 8 'bytevector->c64vector/shared))
719(define bytevector->c128vector/shared (unpack 'c128vector 16 'bytevector->c128vector/shared))
720
721(define bytevector->s8vector (unpack-copy 's8vector #t 'bytevector->s8vector))
722(define bytevector->u16vector (unpack-copy 'u16vector 2 'bytevector->u16vector))
723(define bytevector->s16vector (unpack-copy 's16vector 2 'bytevector->s16vector))
724(define bytevector->u32vector (unpack-copy 'u32vector 4 'bytevector->u32vector))
725(define bytevector->s32vector (unpack-copy 's32vector 4 'bytevector->s32vector))
726(define bytevector->u64vector (unpack-copy 'u64vector 4 'bytevector->u64vector))
727(define bytevector->s64vector (unpack-copy 's64vector 4 'bytevector->s64vector))
728(define bytevector->f32vector (unpack-copy 'f32vector 4 'bytevector->f32vector))
729(define bytevector->f64vector (unpack-copy 'f64vector 8 'bytevector->f64vector))
730(define bytevector->c64vector (unpack-copy 'c64vector 8 'bytevector->c64vector))
731(define bytevector->c128vector (unpack-copy 'c128vector 16 'bytevector->c128vector))
732
733;;; Subvectors:
734
735(define (subnvector v t es from to loc)
736  (##sys#check-structure v t loc)
737  (let* ([bv (##sys#slot v 1)]
738	 [len (##sys#size bv)]
739	 [ilen (##core#inline "C_u_fixnum_divide" len es)] )
740    (##sys#check-range/including from 0 ilen loc)
741    (##sys#check-range/including to 0 ilen loc)
742    (let* ([size2 (fx* es (fx- to from))]
743	   [bv2 (##sys#allocate-bytevector size2 #f)] )
744      (let ([v (##sys#make-structure t bv2)])
745	(##core#inline "C_copy_subvector" bv2 bv 0 (fx* from es) size2)
746	v) ) ) )
747
748(define (subu8vector v from to)
749  (##sys#check-bytevector v 'subu8vector)
750  (let ((n (##sys#size v)))
751    (##sys#check-range/including from 0 n 'subu8vector)
752    (##sys#check-range/including to 0 n 'subu8vector)
753    (bytevector-copy v from to)))
754  
755(define (subu16vector v from to) (subnvector v 'u16vector 2 from to 'subu16vector))
756(define (subu32vector v from to) (subnvector v 'u32vector 4 from to 'subu32vector))
757(define (subu64vector v from to) (subnvector v 'u64vector 8 from to 'subu64vector))
758(define (subs8vector v from to) (subnvector v 's8vector 1 from to 'subs8vector))
759(define (subs16vector v from to) (subnvector v 's16vector 2 from to 'subs16vector))
760(define (subs32vector v from to) (subnvector v 's32vector 4 from to 'subs32vector))
761(define (subs64vector v from to) (subnvector v 's64vector 8 from to 'subs64vector))
762(define (subf32vector v from to) (subnvector v 'f32vector 4 from to 'subf32vector))
763(define (subf64vector v from to) (subnvector v 'f64vector 8 from to 'subf64vector))
764(define (subc64vector v from to) (subnvector v 'c64vector 8 from to 'subc64vector))
765(define (subc128vector v from to) (subnvector v 'c128vector 16 from to 'subc128vector))
766
767) ; module chicken.number-vector
768
769(module srfi-4
770  (f32vector f32vector->list
771   f32vector-length f32vector-ref f32vector-set! f32vector?
772   f64vector f64vector->list
773   f64vector-length f64vector-ref f64vector-set! f64vector?
774   s8vector s8vector->list
775   s8vector-length s8vector-ref s8vector-set! s8vector?
776   s16vector s16vector->list
777   s16vector-length s16vector-ref s16vector-set! s16vector?
778   s32vector s32vector->list
779   s32vector-length s32vector-ref s32vector-set! s32vector?
780   s64vector s64vector->list
781   s64vector-length s64vector-ref s64vector-set! s64vector?
782   u8vector u8vector->list
783   u8vector-length u8vector-ref u8vector-set! u8vector?
784   u16vector u16vector->list
785   u16vector-length u16vector-ref u16vector-set! u16vector?
786   u32vector u32vector->list
787   u32vector-length u32vector-ref u32vector-set! u32vector?
788   u64vector u64vector->list
789   u64vector-length u64vector-ref u64vector-set! u64vector?
790   list->f32vector list->f64vector list->s16vector list->s32vector
791   list->s64vector list->s8vector list->u16vector list->u32vector
792   list->u8vector list->u64vector
793   make-f32vector make-f64vector make-s16vector make-s32vector
794   make-s64vector make-s8vector make-u16vector make-u32vector
795   make-u64vector make-u8vector)
796(import (chicken number-vector)))
797
798           
799;;; Read syntax:
800
801(import scheme (chicken number-vector))
802           
803(set! ##sys#user-read-hook
804  (let ((old-hook ##sys#user-read-hook)
805	(consers (list 'u8 chicken.number-vector#list->u8vector
806		       's8 chicken.number-vector#list->s8vector
807		       'u16 chicken.number-vector#list->u16vector
808		       's16 chicken.number-vector#list->s16vector
809		       'u32 chicken.number-vector#list->u32vector
810		       's32 chicken.number-vector#list->s32vector
811		       'u64 chicken.number-vector#list->u64vector
812		       's64 chicken.number-vector#list->s64vector
813		       'f32 chicken.number-vector#list->f32vector
814		       'f64 chicken.number-vector#list->f64vector
815                       'c64 chicken.number-vector#list->c64vector
816                       'c128 chicken.number-vector#list->c128vector) ) )
817    (lambda (char port)
818      (if (memq char '(#\u #\s #\f #\c))
819	  (let* ((x (##sys#read port ##sys#default-read-info-hook))
820		 (tag (and (symbol? x) x)) )
821	    (cond ((or (eq? tag 'f) (eq? tag 'false)) #f)
822		  ((memq tag consers) => 
823                    (lambda (c) 
824                      (let ((d (##sys#read-numvector-data port)))
825                        (cond ((or (null? d) (pair? d))
826                               ((cadr c) (##sys#canonicalize-number-list! d)))
827                              ((eq? tag 'u8) 
828                               ;; reuse already created bytevector
829                               (##core#inline "C_chop_bv" (##sys#slot d 0)))
830                              (else 
831                               ((cadr c) (##sys#string->list d)))))))
832		  (else (##sys#read-error port "invalid sharp-sign read syntax" tag)) ) )
833	  (old-hook char port) ) ) ) )
834
835
836;;; Printing:
837
838(set! ##sys#user-print-hook
839  (let ((old-hook ##sys#user-print-hook))
840    (lambda (x readable port)
841      (let ((tag (assq (##core#inline "C_slot" x 0)
842		       `((u8vector u8 ,chicken.number-vector#u8vector->list)
843			 (s8vector s8 ,chicken.number-vector#s8vector->list)
844			 (u16vector u16 ,chicken.number-vector#u16vector->list)
845			 (s16vector s16 ,chicken.number-vector#s16vector->list)
846			 (u32vector u32 ,chicken.number-vector#u32vector->list)
847			 (s32vector s32 ,chicken.number-vector#s32vector->list)
848			 (u64vector u64 ,chicken.number-vector#u64vector->list)
849			 (s64vector s64 ,chicken.number-vector#s64vector->list)
850			 (f32vector f32 ,chicken.number-vector#f32vector->list)
851			 (f64vector f64 ,chicken.number-vector#f64vector->list)
852                         (c64vector c64 ,chicken.number-vector#c64vector->list)
853                         (c128vector c128 ,chicken.number-vector#c128vector->list)) ) ) )
854	(cond (tag
855	       (##sys#print #\# #f port)
856	       (##sys#print (cadr tag) #f port)
857	       (##sys#print ((caddr tag) x) #t port) )
858	      (else (old-hook x readable port)) ) ) ) ) )