~ 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
279       i 0 (##core#inline "C_u_fixnum_divide"
280             (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
281             8)
282       'c64vector-ref)
283     (let ((p (##core#inline "C_fixnum_times" i 2)))
284       (make-rectangular
285         (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4) x p)
286         (##core#inline_allocate ("C_a_u_i_f32vector_ref" 4)
287           x (##core#inline "C_u_fixnum_plus" p 1)))))
288   c64vector-set!
289   "(chicken.number-vector#c64vector-ref v i)"))
290
291(define c128vector-ref
292  (getter-with-setter
293   (lambda (x i)
294     (##sys#check-structure x 'c128vector 'c128vector-ref)
295     (##sys#check-range
296       i 0 (##core#inline "C_u_fixnum_divide"
297             (##core#inline "C_i_bytevector_length" (##sys#slot x 1))
298             16)
299       'c128vector-ref)
300     (let ((p (##core#inline "C_fixnum_times" i 2)))
301       (make-rectangular
302          (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4) x p)
303          (##core#inline_allocate ("C_a_u_i_f64vector_ref" 4)
304            x (##core#inline "C_u_fixnum_plus" p 1)))))
305   c128vector-set!
306   "(chicken.number-vector#c128vector-ref v i)"))
307
308
309;;; Basic constructors:
310
311(define make-f32vector)
312(define make-f64vector)
313(define make-s16vector)
314(define make-s32vector)
315(define make-s64vector)
316(define make-s8vector)
317(define make-u8vector)
318(define make-u16vector)
319(define make-u32vector)
320(define make-u64vector)
321(define make-c64vector)
322(define make-c128vector)
323(define release-number-vector)
324
325(let* ((ext-alloc
326        (foreign-lambda* scheme-object ((size_t bytes))
327          "if (bytes > C_HEADER_SIZE_MASK) C_return(C_SCHEME_FALSE);"
328          "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
329          "if(buf == NULL) C_return(C_SCHEME_FALSE);"
330          "C_block_header_init(buf, C_make_header(C_BYTEVECTOR_TYPE, bytes));"
331          "C_return(buf);") )
332       (ext-free
333        (foreign-lambda* void ((scheme-object bv))
334          "C_free((void *)C_block_item(bv, 1));") )
335       (real-part real-part)
336       (imag-part imag-part)
337       (alloc
338        (lambda (loc elem-size elems ext?)
339          (##sys#check-fixnum elems loc)
340          (when (fx< elems 0) (##sys#error loc "size is negative" elems))
341          (let ((len (fx*? elems elem-size)))
342            (unless len (##sys#error "overflow - cannot allocate the required number of elements" elems))
343            (if ext?
344                (let ((bv (ext-alloc len)))
345                  (or bv
346                      (##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
347                (##sys#allocate-bytevector len #f))))))
348
349  (set! release-number-vector
350    (lambda (v)
351      (if (number-vector? v)
352          (ext-free v)
353          (##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )
354
355  (set! make-u8vector
356    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
357      (let ((v (alloc 'make-u8vector 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-u8vector)
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_setsubbyte" v i init) ) ) ) ) ) )
366
367  (set! make-s8vector
368    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
369      (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector 1 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 8 'make-s8vector)
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_s8vector_set" v i init) ) ) ) ) ) )
378
379  (set! make-u16vector
380    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
381      (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector 2 len ext?))))
382        (when (and ext? fin?) (set-finalizer! v ext-free))
383        (if (not init)
384            v
385            (begin
386              (check-uint-length init 16 'make-u16vector)
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_u16vector_set" v i init) ) ) ) ) ) )
390
391  (set! make-s16vector
392    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
393      (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector 2 len ext?))))
394        (when (and ext? fin?) (set-finalizer! v ext-free))
395        (if (not init)
396            v
397            (begin
398              (check-int-length init 16 'make-s16vector)
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_s16vector_set" v i init) ) ) ) ) ) )
402
403  (set! make-u32vector
404    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
405      (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector 4 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 32 'make-u32vector)
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_u32vector_set" v i init) ) ) ) ) ) )
414
415  (set! make-u64vector
416    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
417      (let ((v (##sys#make-structure 'u64vector (alloc 'make-u64vector 8 len ext?))))
418        (when (and ext? fin?) (set-finalizer! v ext-free))
419        (if (not init)
420            v
421            (begin
422              (check-uint-length init 64 'make-u64vector)
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_u64vector_set" v i init) ) ) ) ) ) )
426
427  (set! make-s32vector
428    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
429      (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector 4 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 32 'make-s32vector)
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_s32vector_set" v i init) ) ) ) ) ) )
438
439   (set! make-s64vector
440    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
441      (let ((v (##sys#make-structure 's64vector (alloc 'make-s64vector 8 len ext?))))
442        (when (and ext? fin?) (set-finalizer! v ext-free))
443        (if (not init)
444            v
445            (begin
446              (check-int-length init 64 'make-s64vector)
447              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
448                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
449                (##core#inline "C_u_i_s64vector_set" v i init) ) ) ) ) ) )
450
451  (set! make-f32vector
452    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
453      (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector 4 len ext?))))
454        (when (and ext? fin?) (set-finalizer! v ext-free))
455        (if (not init)
456            v
457            (begin
458              (check-int/flonum init 'make-f32vector)
459              (unless (##core#inline "C_i_flonump" init)
460                (set! init (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) init)))
461              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
462                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
463                (##core#inline "C_u_i_f32vector_set" v i init) ) ) ) ) ) )
464
465  (set! make-f64vector
466    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
467      (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector 8 len ext?))))
468        (when (and ext? fin?) (set-finalizer! v ext-free))
469        (if (not init)
470            v
471            (begin
472              (check-int/flonum init 'make-f64vector)
473              (unless (##core#inline "C_i_flonump" init)
474                (set! init (##core#inline_allocate ("C_a_u_i_int_to_flo" 4) init)) )
475              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
476                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
477                (##core#inline "C_u_i_f64vector_set" v i init) ) ) ) ) ) )
478
479  (set! make-c64vector
480    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
481      (let ((v (##sys#make-structure 'c64vector (alloc 'make-c64vector 4 (fx* len 2) ext?))))
482        (when (and ext? fin?) (set-finalizer! v ext-free))
483        (if (not init)
484            v
485            (let ((len2 (fx* len 2))
486                  (rp (->f (real-part init)))
487                  (ip (->f (imag-part init))))
488              (check-int/flonum init 'make-c64vector)
489              (do ((i 0 (fx+ i 2)))
490                  ((fx>= i len2) v)
491                (##core#inline "C_u_i_f32vector_set" v i rp)
492                (##core#inline "C_u_i_f32vector_set" v (fx+ i 1) ip)))))))
493
494  (set! make-c128vector
495    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
496      (let ((v (##sys#make-structure 'c128vector (alloc 'make-c128vector 8 (fx* len 2) ext?))))
497        (when (and ext? fin?) (set-finalizer! v ext-free))
498        (if (not init)
499            v
500            (let ((len2 (fx* len 2))
501                  (rp (->f (real-part init)))
502                  (ip (->f (imag-part init))))
503              (check-int/flonum init 'make-c128vector)
504              (do ((i 0 (fx+ i 2)))
505                  ((fx>= i len2) v)
506                (##core#inline "C_u_i_f64vector_set" v i rp)
507                (##core#inline "C_u_i_f64vector_set" v (fx+ i 1) ip))))))))
508
509
510;;; Creating vectors from a list:
511
512(define-syntax list->NNNvector
513  (er-macro-transformer
514   (lambda (x r c)
515     (let* ((tag (strip-syntax (cadr x)))
516            (tagstr (symbol->string tag))
517            (name (string->symbol (string-append "list->" tagstr)))
518            (make (string->symbol (string-append "make-" tagstr)))
519            (set (string->symbol (string-append tagstr "-set!"))))
520       `(define ,name
521          (let ((,make ,make))
522            (lambda (lst)
523              (##sys#check-list lst ',tag)
524              (let* ((n (##core#inline "C_i_length" lst))
525                     (v (,make n)) )
526                (do ((p lst (##core#inline "C_slot" p 1))
527                     (i 0 (##core#inline "C_fixnum_plus" i 1)) )
528                    ((##core#inline "C_eqp" p '()) v)
529                  (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
530                      (,set v i (##core#inline "C_slot" p 0))
531                      (##sys#error-not-a-proper-list lst ',name) ) ) ) )))))))
532
533(define list->u8vector ##sys#list->bytevector)
534
535(list->NNNvector s8vector)
536(list->NNNvector u16vector)
537(list->NNNvector s16vector)
538(list->NNNvector u32vector)
539(list->NNNvector s32vector)
540(list->NNNvector u64vector)
541(list->NNNvector s64vector)
542(list->NNNvector f32vector)
543(list->NNNvector f64vector)
544
545(define list->c64vector
546  (let ((real-part real-part)
547        (imag-part imag-part)
548        (make-c64vector make-c64vector))
549    (lambda (lst)
550      (##sys#check-list lst 'list->c64vector)
551      (let* ((n (##core#inline "C_i_length" lst))
552             (v (make-c64vector n)))
553        (do ((i 0 (##core#inline "C_u_fixnum_plus" i 2))
554             (lst lst (##core#inline "C_slot" lst 1)))
555            ((##core#inline "C_eqp" lst '()) v)
556            (let ((x (##core#inline "C_slot" lst 0)))
557              (##core#inline "C_u_i_f32vector_set" v i (->f (real-part x)))
558              (##core#inline "C_u_i_f32vector_set"
559               v (##core#inline "C_u_fixnum_plus" i 1)
560               (->f (imag-part x)))))))))
561
562(define list->c128vector
563  (let ((real-part real-part)
564        (imag-part imag-part)
565        (make-c128vector make-c128vector))
566    (lambda (lst)
567      (##sys#check-list lst 'list->c128vector)
568      (let* ((n (##core#inline "C_i_length" lst))
569             (v (make-c128vector n)))
570        (do ((i 0 (##core#inline "C_u_fixnum_plus" i 2))
571             (lst lst (##core#inline "C_slot" lst 1)))
572            ((##core#inline "C_eqp" lst '()) v)
573            (let ((x (##core#inline "C_slot" lst 0)))
574              (##core#inline "C_u_i_f64vector_set" v i (->f (real-part x)))
575              (##core#inline "C_u_i_f64vector_set"
576               v (##core#inline "C_u_fixnum_plus" i 1)
577               (->f (imag-part x)))))))))
578
579
580;;; More constructors:
581
582(define u8vector
583  (lambda xs (list->u8vector xs)) )
584
585(define s8vector
586  (lambda xs (list->s8vector xs)) )
587
588(define u16vector
589  (lambda xs (list->u16vector xs)) )
590
591(define s16vector
592  (lambda xs (list->s16vector xs)) )
593
594(define u32vector
595  (lambda xs (list->u32vector xs)) )
596
597(define s32vector
598  (lambda xs (list->s32vector xs)) )
599
600(define u64vector
601  (lambda xs (list->u64vector xs)) )
602
603(define s64vector
604  (lambda xs (list->s64vector xs)) )
605
606(define f32vector
607  (lambda xs (list->f32vector xs)) )
608
609(define f64vector
610  (lambda xs (list->f64vector xs)) )
611
612(define c64vector
613  (lambda xs (list->c64vector xs)) )
614
615(define c128vector
616  (lambda xs (list->c128vector xs)) )
617
618
619;;; Creating lists from a vector:
620
621(define-syntax NNNvector->list
622  (er-macro-transformer
623   (lambda (x r c)
624     (let* ((tag (symbol->string (strip-syntax (cadr x))))
625            (alloc (and (pair? (cddr x)) (caddr x)))
626            (name (string->symbol (string-append tag "->list"))))
627       `(define (,name v)
628          (##sys#check-structure v ',(string->symbol tag) ',name)
629          (let ((len (##core#inline ,(string-append "C_u_i_" tag "_length") v)))
630            (let loop ((i 0))
631              (if (fx>= i len)
632                  '()
633                  (cons
634                   ,(if alloc
635                        `(##core#inline_allocate (,(string-append "C_a_u_i_" tag "_ref") ,alloc) v i)
636                        `(##core#inline ,(string-append "C_u_i_" tag "_ref") v i))
637                   (loop (fx+ i 1)) ) ) ) ) ) ) )))
638
639(define (u8vector->list v)
640  (##sys#check-bytevector v 'u8vector->list)
641  (##sys#bytevector->list v))
642
643(NNNvector->list s8vector)
644(NNNvector->list u16vector)
645(NNNvector->list s16vector)
646;; The alloc amounts here are for 32-bit words; this over-allocates on 64-bits
647(NNNvector->list u32vector 6)
648(NNNvector->list s32vector 6)
649(NNNvector->list u64vector 7)
650(NNNvector->list s64vector 7)
651(NNNvector->list f32vector 4)
652(NNNvector->list f64vector 4)
653
654(define c64vector->list
655  (let ((c64vector-length c64vector-length)
656        (c64vector-ref c64vector-ref))
657    (lambda (v)
658      (##sys#check-structure v 'c64vector 'c64vector->list)
659      (let ((len (c64vector-length v)))
660        (let loop ((i 0))
661          (if (fx>= i len)
662              '()
663              (cons (c64vector-ref v i)
664                    (loop (fx+ i 1)) ) ) ) ))))
665    
666(define c128vector->list
667  (let ((c128vector-length c128vector-length)
668        (c128vector-ref c128vector-ref))
669    (lambda (v)
670      (##sys#check-structure v 'c128vector 'c128vector->list)
671      (let ((len (c128vector-length v)))
672        (let loop ((i 0))
673          (if (fx>= i len)
674              '()
675              (cons (c128vector-ref v i)
676                    (loop (fx+ i 1)) ) ) ) ) )))
677
678
679;;; Predicates:
680
681(define (u8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_bytevectorp" x)))
682(define (s8vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s8vectorp" x)))
683(define (u16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u16vectorp" x)))
684(define (s16vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s16vectorp" x)))
685(define (u32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u32vectorp" x)))
686(define (s32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s32vectorp" x)))
687(define (u64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_u64vectorp" x)))
688(define (s64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_s64vectorp" x)))
689(define (f32vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f32vectorp" x)))
690(define (f64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_f64vectorp" x)))
691(define (c64vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c64vector)))
692(define (c128vector? x) (and (##core#inline "C_blockp" x) (##core#inline "C_i_structurep" x 'c128vector)))
693
694;; Catch-all predicate
695(define (number-vector? x)
696  (or (bytevector? x) (##sys#srfi-4-vector? x)))
697
698;;; Accessing the packed bytevector:
699
700(define (pack tag loc)
701  (lambda (v)
702    (##sys#check-structure v tag loc)
703    (##sys#slot v 1) ) )
704
705(define (pack-copy tag loc)
706  (lambda (v)
707    (##sys#check-structure v tag loc)
708    (let* ((old (##sys#slot v 1))
709	   (new (##sys#make-bytevector (##sys#size old))))
710      (##core#inline "C_copy_block" old new) ) ) )
711
712(define (unpack tag sz loc)
713  (lambda (str)
714    (##sys#check-bytevector str loc)
715    (let ((len (##sys#size str)))
716      (if (or (eq? #t sz)
717	      (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
718	  (##sys#make-structure tag str)
719	  (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
720
721(define (unpack-copy tag sz loc)
722  (lambda (str)
723    (##sys#check-bytevector str loc)
724    (let* ((len (##sys#size str))
725	   (new (##sys#make-bytevector len)))
726      (if (or (eq? #t sz)
727	      (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
728	  (##sys#make-structure
729	   tag
730	   (##core#inline "C_copy_block" str new) )
731	  (##sys#error loc "bytevector does not have correct size for packing" tag len sz) ) ) ) )
732
733(define s8vector->bytevector/shared (pack 's8vector 's8vector->bytevector/shared))
734(define u16vector->bytevector/shared (pack 'u16vector 'u16vector->bytevector/shared))
735(define s16vector->bytevector/shared (pack 's16vector 's16vector->bytevector/shared))
736(define u32vector->bytevector/shared (pack 'u32vector 'u32vector->bytevector/shared))
737(define s32vector->bytevector/shared (pack 's32vector 's32vector->bytevector/shared))
738(define u64vector->bytevector/shared (pack 'u64vector 'u64vector->bytevector/shared))
739(define s64vector->bytevector/shared (pack 's64vector 's64vector->bytevector/shared))
740(define f32vector->bytevector/shared (pack 'f32vector 'f32vector->bytevector/shared))
741(define f64vector->bytevector/shared (pack 'f64vector 'f64vector->bytevector/shared))
742(define c64vector->bytevector/shared (pack 'c64vector 'c64vector->bytevector/shared))
743(define c128vector->bytevector/shared (pack 'c128vector 'c128vector->bytevector/shared))
744
745(define s8vector->bytevector (pack-copy 's8vector 's8vector->bytevector))
746(define u16vector->bytevector (pack-copy 'u16vector 'u16vector->bytevector))
747(define s16vector->bytevector (pack-copy 's16vector 's16vector->bytevector))
748(define u32vector->bytevector (pack-copy 'u32vector 'u32vector->bytevector))
749(define s32vector->bytevector (pack-copy 's32vector 's32vector->bytevector))
750(define u64vector->bytevector (pack-copy 'u64vector 'u64vector->bytevector))
751(define s64vector->bytevector (pack-copy 's64vector 's64vector->bytevector))
752(define f32vector->bytevector (pack-copy 'f32vector 'f32vector->bytevector))
753(define f64vector->bytevector (pack-copy 'f64vector 'f64vector->bytevector))
754(define c64vector->bytevector (pack-copy 'c64vector 'c64vector->bytevector))
755(define c128vector->bytevector (pack-copy 'c128vector 'c128vector->bytevector))
756
757(define bytevector->s8vector/shared (unpack 's8vector #t 'bytevector->s8vector/shared))
758(define bytevector->u16vector/shared (unpack 'u16vector 2 'bytevector->u16vector/shared))
759(define bytevector->s16vector/shared (unpack 's16vector 2 'bytevector->s16vector/shared))
760(define bytevector->u32vector/shared (unpack 'u32vector 4 'bytevector->u32vector/shared))
761(define bytevector->s32vector/shared (unpack 's32vector 4 'bytevector->s32vector/shared))
762(define bytevector->u64vector/shared (unpack 'u64vector 4 'bytevector->u64vector/shared))
763(define bytevector->s64vector/shared (unpack 's64vector 4 'bytevector->s64vector/shared))
764(define bytevector->f32vector/shared (unpack 'f32vector 4 'bytevector->f32vector/shared))
765(define bytevector->f64vector/shared (unpack 'f64vector 8 'bytevector->f64vector/shared))
766(define bytevector->c64vector/shared (unpack 'c64vector 8 'bytevector->c64vector/shared))
767(define bytevector->c128vector/shared (unpack 'c128vector 16 'bytevector->c128vector/shared))
768
769(define bytevector->s8vector (unpack-copy 's8vector #t 'bytevector->s8vector))
770(define bytevector->u16vector (unpack-copy 'u16vector 2 'bytevector->u16vector))
771(define bytevector->s16vector (unpack-copy 's16vector 2 'bytevector->s16vector))
772(define bytevector->u32vector (unpack-copy 'u32vector 4 'bytevector->u32vector))
773(define bytevector->s32vector (unpack-copy 's32vector 4 'bytevector->s32vector))
774(define bytevector->u64vector (unpack-copy 'u64vector 4 'bytevector->u64vector))
775(define bytevector->s64vector (unpack-copy 's64vector 4 'bytevector->s64vector))
776(define bytevector->f32vector (unpack-copy 'f32vector 4 'bytevector->f32vector))
777(define bytevector->f64vector (unpack-copy 'f64vector 8 'bytevector->f64vector))
778(define bytevector->c64vector (unpack-copy 'c64vector 8 'bytevector->c64vector))
779(define bytevector->c128vector (unpack-copy 'c128vector 16 'bytevector->c128vector))
780
781;;; Subvectors:
782
783(define (subnvector v t es from to loc)
784  (##sys#check-structure v t loc)
785  (let* ([bv (##sys#slot v 1)]
786	 [len (##sys#size bv)]
787	 [ilen (##core#inline "C_u_fixnum_divide" len es)] )
788    (##sys#check-range/including from 0 ilen loc)
789    (##sys#check-range/including to 0 ilen loc)
790    (let* ([size2 (fx* es (fx- to from))]
791	   [bv2 (##sys#allocate-bytevector size2 #f)] )
792      (let ([v (##sys#make-structure t bv2)])
793	(##core#inline "C_copy_subvector" bv2 bv 0 (fx* from es) size2)
794	v) ) ) )
795
796(define (subu8vector v from to)
797  (##sys#check-bytevector v 'subu8vector)
798  (let ((n (##sys#size v)))
799    (##sys#check-range/including from 0 n 'subu8vector)
800    (##sys#check-range/including to 0 n 'subu8vector)
801    (bytevector-copy v from to)))
802  
803(define (subu16vector v from to) (subnvector v 'u16vector 2 from to 'subu16vector))
804(define (subu32vector v from to) (subnvector v 'u32vector 4 from to 'subu32vector))
805(define (subu64vector v from to) (subnvector v 'u64vector 8 from to 'subu64vector))
806(define (subs8vector v from to) (subnvector v 's8vector 1 from to 'subs8vector))
807(define (subs16vector v from to) (subnvector v 's16vector 2 from to 'subs16vector))
808(define (subs32vector v from to) (subnvector v 's32vector 4 from to 'subs32vector))
809(define (subs64vector v from to) (subnvector v 's64vector 8 from to 'subs64vector))
810(define (subf32vector v from to) (subnvector v 'f32vector 4 from to 'subf32vector))
811(define (subf64vector v from to) (subnvector v 'f64vector 8 from to 'subf64vector))
812(define (subc64vector v from to) (subnvector v 'c64vector 8 from to 'subc64vector))
813(define (subc128vector v from to) (subnvector v 'c128vector 16 from to 'subc128vector))
814
815) ; module chicken.number-vector
816
817(module srfi-4
818  (f32vector f32vector->list
819   f32vector-length f32vector-ref f32vector-set! f32vector?
820   f64vector f64vector->list
821   f64vector-length f64vector-ref f64vector-set! f64vector?
822   s8vector s8vector->list
823   s8vector-length s8vector-ref s8vector-set! s8vector?
824   s16vector s16vector->list
825   s16vector-length s16vector-ref s16vector-set! s16vector?
826   s32vector s32vector->list
827   s32vector-length s32vector-ref s32vector-set! s32vector?
828   s64vector s64vector->list
829   s64vector-length s64vector-ref s64vector-set! s64vector?
830   u8vector u8vector->list
831   u8vector-length u8vector-ref u8vector-set! u8vector?
832   u16vector u16vector->list
833   u16vector-length u16vector-ref u16vector-set! u16vector?
834   u32vector u32vector->list
835   u32vector-length u32vector-ref u32vector-set! u32vector?
836   u64vector u64vector->list
837   u64vector-length u64vector-ref u64vector-set! u64vector?
838   list->f32vector list->f64vector list->s16vector list->s32vector
839   list->s64vector list->s8vector list->u16vector list->u32vector
840   list->u8vector list->u64vector
841   make-f32vector make-f64vector make-s16vector make-s32vector
842   make-s64vector make-s8vector make-u16vector make-u32vector
843   make-u64vector make-u8vector)
844(import (chicken number-vector)))
845
846           
847;;; Read syntax:
848
849(import scheme (chicken number-vector))
850           
851(set! ##sys#user-read-hook
852  (let ((old-hook ##sys#user-read-hook)
853	(consers (list 'u8 chicken.number-vector#list->u8vector
854		       's8 chicken.number-vector#list->s8vector
855		       'u16 chicken.number-vector#list->u16vector
856		       's16 chicken.number-vector#list->s16vector
857		       'u32 chicken.number-vector#list->u32vector
858		       's32 chicken.number-vector#list->s32vector
859		       'u64 chicken.number-vector#list->u64vector
860		       's64 chicken.number-vector#list->s64vector
861		       'f32 chicken.number-vector#list->f32vector
862		       'f64 chicken.number-vector#list->f64vector
863                       'c64 chicken.number-vector#list->c64vector
864                       'c128 chicken.number-vector#list->c128vector) ) )
865    (lambda (char port)
866      (if (memq char '(#\u #\s #\f #\c))
867	  (let* ((x (##sys#read port ##sys#default-read-info-hook))
868		 (tag (and (symbol? x) x)) )
869	    (cond ((or (eq? tag 'f) (eq? tag 'false)) #f)
870		  ((memq tag consers) => 
871                    (lambda (c) 
872                      (let ((d (##sys#read-numvector-data port)))
873                        (cond ((or (null? d) (pair? d))
874                               ((cadr c) (##sys#canonicalize-number-list! d)))
875                              ((eq? tag 'u8) 
876                               ;; reuse already created bytevector
877                               (##core#inline "C_chop_bv" (##sys#slot d 0)))
878                              (else 
879                               ((cadr c) (##sys#string->list d)))))))
880		  (else (##sys#read-error port "invalid sharp-sign read syntax" tag)) ) )
881	  (old-hook char port) ) ) ) )
882
883
884;;; Printing:
885
886(set! ##sys#user-print-hook
887  (let ((old-hook ##sys#user-print-hook))
888    (lambda (x readable port)
889      (let ((tag (assq (##core#inline "C_slot" x 0)
890		       `((u8vector u8 ,chicken.number-vector#u8vector->list)
891			 (s8vector s8 ,chicken.number-vector#s8vector->list)
892			 (u16vector u16 ,chicken.number-vector#u16vector->list)
893			 (s16vector s16 ,chicken.number-vector#s16vector->list)
894			 (u32vector u32 ,chicken.number-vector#u32vector->list)
895			 (s32vector s32 ,chicken.number-vector#s32vector->list)
896			 (u64vector u64 ,chicken.number-vector#u64vector->list)
897			 (s64vector s64 ,chicken.number-vector#s64vector->list)
898			 (f32vector f32 ,chicken.number-vector#f32vector->list)
899			 (f64vector f64 ,chicken.number-vector#f64vector->list)
900                         (c64vector c64 ,chicken.number-vector#c64vector->list)
901                         (c128vector c128 ,chicken.number-vector#c128vector->list)) ) ) )
902	(cond (tag
903	       (##sys#print #\# #f port)
904	       (##sys#print (cadr tag) #f port)
905	       (##sys#print ((caddr tag) x) #t port) )
906	      (else (old-hook x readable port)) ) ) ) ) )