source: project/chicken/trunk/srfi-4.scm @ 13138

Last change on this file since 13138 was 13138, checked in by Kon Lovett, 11 years ago

Chgd "can not" to "cannot" - saves bytes you know ;-)

File size: 27.2 KB
Line 
1;;;; srfi-4.scm - Homogeneous numeric vectors
2;
3; Copyright (c) 2000-2007, Felix L. Winkelmann
4; Copyright (c) 2008-2009, The Chicken Team
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 (disable-interrupts)
31 (disable-warning redef)
32 (usual-integrations)
33 (hide ##sys#u8vector-set! ##sys#s8vector-set! ##sys#u16vector-set! ##sys#s16vector-set!
34       ##sys#u32vector-set! ##sys#s32vector-set! ##sys#f32vector-set! ##sys#f64vector-set!
35       ##sys#u8vector-ref ##sys#s8vector-ref ##sys#u16vector-ref ##sys#s16vector-ref subvector
36       ##sys#u32vector-ref ##sys#s32vector-ref ##sys#f32vector-ref ##sys#f64vector-ref)
37 (foreign-declare #<<EOF
38#define C_u8peek(b, i)         C_fix(((unsigned char *)C_data_pointer(b))[ C_unfix(i) ])
39#define C_s8peek(b, i)         C_fix(((char *)C_data_pointer(b))[ C_unfix(i) ])
40#define C_u16peek(b, i)        C_fix(((unsigned short *)C_data_pointer(b))[ C_unfix(i) ])
41#define C_s16peek(b, i)        C_fix(((short *)C_data_pointer(b))[ C_unfix(i) ])
42#ifdef C_SIXTY_FOUR
43# define C_a_u32peek(ptr, d, b, i) C_fix(((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
44# define C_a_s32peek(ptr, d, b, i) C_fix(((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
45#else
46# define C_a_u32peek(ptr, d, b, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
47# define C_a_s32peek(ptr, d, b, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
48#endif
49#define C_f32peek(b, i)        (C_temporary_flonum = ((float *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
50#define C_f64peek(b, i)        (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
51#define C_u8poke(b, i, x)      ((((unsigned char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
52#define C_s8poke(b, i, x)      ((((char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
53#define C_u16poke(b, i, x)     ((((unsigned short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
54#define C_s16poke(b, i, x)     ((((short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
55#define C_u32poke(b, i, x)     ((((C_u32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_unsigned_int(x)), C_SCHEME_UNDEFINED)
56#define C_s32poke(b, i, x)     ((((C_s32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_int(x)), C_SCHEME_UNDEFINED)
57#define C_f32poke(b, i, x)     ((((float *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
58#define C_f64poke(b, i, x)     ((((double *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
59#define C_copy_subvector(to, from, start_to, start_from, bytes)   \
60  (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)), \
61    C_SCHEME_UNDEFINED)
62EOF
63) )
64
65(cond-expand
66 [paranoia]
67 [else
68  (declare
69    (no-bound-checks)
70    (no-procedure-checks-for-usual-bindings)
71    (bound-to-procedure
72     ##sys#check-exact ##sys#u8vector-ref ##sys#u8vector-set! ##sys#s8vector-ref ##sys#s8vector-set!
73     ##sys#u16vector-ref ##sys#u16vector-set!
74     ##sys#s16vector-ref ##sys#s16vector-set! ##sys#u32vector-ref ##sys#u32vector-set! ##sys#s32vector-ref
75     ##sys#s32vector-set! read list->f64vector list->s32vector list->u32vector list->u16vector list-s8vector
76     list->u8vector set-finalizer!
77     ##sys#f32vector-ref ##sys#f32vector-set! ##sys#f64vector-ref ##sys#f64vector-set! ##sys#check-exact-interval
78     ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#cons-flonum ##sys#check-list
79     ##sys#check-range ##sys#error ##sys#signal-hook
80     ##sys#not-a-proper-list-error ##sys#print ##sys#allocate-vector) ) ] )
81
82(include "unsafe-declarations.scm")
83
84
85;;; Helper routines:
86
87(define ##sys#check-exact-interval
88  (lambda (n from to loc)
89    (##sys#check-exact n loc)
90    (if (or (##core#inline "C_fixnum_lessp" n from)
91            (##core#inline "C_fixnum_greaterp" n to) )
92        (##sys#error loc "numeric value is not in expected range" n from to) ) ) )
93
94(define ##sys#check-inexact-interval
95  (lambda (n from to loc)
96    (##sys#check-number n loc)
97    (if (or (< n from) (> n to))
98        (##sys#error "numeric value is not in expected range" n from to) ) ) )
99
100
101;;; Primitive accessors:
102
103(define (##sys#u8vector-ref v i) (##core#inline "C_u8peek" (##core#inline "C_slot" v 1) i))
104(define (##sys#s8vector-ref v i) (##core#inline "C_s8peek" (##core#inline "C_slot" v 1) i))
105(define (##sys#u16vector-ref v i) (##core#inline "C_u16peek" (##core#inline "C_slot" v 1) i))
106(define (##sys#s16vector-ref v i) (##core#inline "C_s16peek" (##core#inline "C_slot" v 1) i))
107(define (##sys#u32vector-ref v i) (##core#inline_allocate ("C_a_u32peek" 4) (##core#inline "C_slot" v 1) i))
108(define (##sys#s32vector-ref v i) (##core#inline_allocate ("C_a_s32peek" 4) (##core#inline "C_slot" v 1) i))
109
110(define (##sys#f32vector-ref v i)
111  (##core#inline "C_f32peek" (##core#inline "C_slot" v 1) i)
112  (##sys#cons-flonum) )
113
114(define (##sys#f64vector-ref v i)
115  (##core#inline "C_f64peek" (##core#inline "C_slot" v 1) i)
116  (##sys#cons-flonum) )
117
118(define (##sys#u8vector-set! v i x) (##core#inline "C_u8poke" (##core#inline "C_slot" v 1) i x))
119(define (##sys#s8vector-set! v i x) (##core#inline "C_s8poke" (##core#inline "C_slot" v 1) i x))
120(define (##sys#u16vector-set! v i x) (##core#inline "C_u16poke" (##core#inline "C_slot" v 1) i x))
121(define (##sys#s16vector-set! v i x) (##core#inline "C_s16poke" (##core#inline "C_slot" v 1) i x))
122(define (##sys#u32vector-set! v i x) (##core#inline "C_u32poke" (##core#inline "C_slot" v 1) i x))
123(define (##sys#s32vector-set! v i x) (##core#inline "C_s32poke" (##core#inline "C_slot" v 1) i x))
124(define (##sys#f32vector-set! v i x) (##core#inline "C_f32poke" (##core#inline "C_slot" v 1) i x))
125(define (##sys#f64vector-set! v i x) (##core#inline "C_f64poke" (##core#inline "C_slot" v 1) i x))
126
127
128;;; Get vector length:
129
130(let ()
131
132  (define (len tag shift loc)
133    (lambda (v)
134      (##sys#check-structure v tag loc)
135      (let ((bytes (##core#inline "C_block_size" (##core#inline "C_slot" v 1))))
136        (if shift
137            (##core#inline "C_fixnum_shift_right" bytes shift)
138            bytes) ) ) )
139
140  (set! u8vector-length (len 'u8vector #f 'u8vector-length))
141  (set! s8vector-length (len 's8vector #f 's8vector-length))
142  (set! u16vector-length (len 'u16vector 1 'u16vector-length))
143  (set! s16vector-length (len 's16vector 1 's16vector-length))
144  (set! u32vector-length (len 'u32vector 2 'u32vector-length))
145  (set! s32vector-length (len 's32vector 2 's32vector-length))
146  (set! f32vector-length (len 'f32vector 2 'f32vector-length))
147  (set! f64vector-length (len 'f64vector 3 'f64vector-length)) )
148
149
150;;; Safe accessors:
151
152(let ()
153
154  (define (get length acc loc)
155    (lambda (v i)
156      (let ((len (length v)))
157        (##sys#check-range i 0 len loc)
158        (acc v i) ) ) )
159
160  (define (set length upd loc)
161    (lambda (v i x)
162      (let ((len (length v)))
163        (##sys#check-exact x loc)
164        (##sys#check-range i 0 len loc)
165        (upd v i x) ) ) )
166
167  (define (setu length upd loc)
168    (lambda (v i x)
169      (let ((len (length v)))
170        (##sys#check-exact x loc)
171        (if (fx< x 0)
172            (##sys#error loc "argument may not be negative" x) )
173        (##sys#check-range i 0 len loc)
174        (upd v i x) ) ) )
175
176  (define (setw length upd loc)
177    (lambda (v i x)
178      (let ((len (length v)))
179        (if (not (##sys#fits-in-int? x))
180            (##sys#error loc "argument exceeds integer range" x) )
181        (##sys#check-range i 0 len loc)
182        (upd v i x) ) ) )
183
184  (define (setuw length upd loc)
185    (lambda (v i x)
186      (let ((len (length v)))
187        (cond ((negative? x)
188               (##sys#error loc "argument may not be negative" x) )
189              ((not (##sys#fits-in-unsigned-int? x))
190               (##sys#error loc "argument exceeds integer range" x) ) )
191        (##sys#check-range i 0 len loc)
192        (upd v i x) ) ) )
193
194  (define (setf length upd loc)
195    (lambda (v i x)
196      (let ((len (length v)))
197        (##sys#check-number x loc)
198        (##sys#check-range i 0 len loc)
199        (upd v i (if (##core#inline "C_blockp" x)
200                     x
201                     (exact->inexact x) ) ) ) ) )
202
203  (set! u8vector-set! (setu u8vector-length ##sys#u8vector-set! 'u8vector-set!))
204  (set! s8vector-set! (set s8vector-length ##sys#s8vector-set! 's8vector-set!))
205  (set! u16vector-set! (setu u16vector-length ##sys#u16vector-set! 'u16vector-set!))
206  (set! s16vector-set! (set s16vector-length ##sys#s16vector-set! 's16vector-set!))
207  (set! u32vector-set! (setuw u32vector-length ##sys#u32vector-set! 'u32vector-set!))
208  (set! s32vector-set! (setw s32vector-length ##sys#s32vector-set! 's32vector-set!))
209  (set! f32vector-set! (setf f32vector-length ##sys#f32vector-set! 'f32vector-set!))
210  (set! f64vector-set! (setf f64vector-length ##sys#f64vector-set! 'f64vector-set!))
211
212  (set! u8vector-ref
213        (getter-with-setter (get u8vector-length ##sys#u8vector-ref 'u8vector-ref)
214                            u8vector-set!) )
215  (set! s8vector-ref
216        (getter-with-setter (get s8vector-length ##sys#s8vector-ref 's8vector-ref)
217                            s8vector-set!) )
218  (set! u16vector-ref
219        (getter-with-setter (get u16vector-length ##sys#u16vector-ref 'u16vector-ref)
220                            u16vector-set!) )
221  (set! s16vector-ref
222        (getter-with-setter (get s16vector-length ##sys#s16vector-ref 's16vector-ref)
223                            s16vector-set!) )
224  (set! u32vector-ref
225        (getter-with-setter
226         (get u32vector-length ##sys#u32vector-ref 'u32vector-ref)
227         u32vector-set!) )
228  (set! s32vector-ref
229        (getter-with-setter
230         (get s32vector-length ##sys#s32vector-ref 's32vector-ref)
231         s32vector-set!) )
232  (set! f32vector-ref
233        (getter-with-setter
234         (get f32vector-length ##sys#f32vector-ref 'f32vector-ref)
235         f32vector-set!) )
236  (set! f64vector-ref
237        (getter-with-setter
238         (get f64vector-length ##sys#f64vector-ref 'f64vector-ref)
239         f64vector-set!) ) )
240
241
242
243;;; Basic constructors:
244
245(let* ([ext-alloc
246        (foreign-lambda* scheme-object ([int bytes])
247          "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
248          "if(buf == NULL) return(C_SCHEME_FALSE);"
249          "C_block_header(buf) = C_make_header(C_BYTEVECTOR_TYPE, bytes);"
250          "return(buf);") ]
251       [ext-free
252        (foreign-lambda* void ([scheme-object bv])
253          "C_free((void *)C_block_item(bv, 1));") ]
254       [set-finalizer! set-finalizer!]
255       [alloc
256        (lambda (loc len ext?)
257          (if ext?
258              (let ([bv (ext-alloc len)])
259                (or bv
260                    (##sys#error loc "not enough memory - cannot allocate external number vector" len)) )
261              (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better...
262                (##core#inline "C_string_to_bytevector" bv)
263                bv) ) ) ] )
264
265  (set! release-number-vector
266    (lambda (v)
267      (if (and (##sys#generic-structure? v)
268               (memq (##sys#slot v 0) '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)) )
269          (ext-free v)
270          (##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )
271
272  (set! make-u8vector
273    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
274      (##sys#check-exact len 'make-u8vector)
275      (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
276        (when (and ext? fin?) (set-finalizer! v ext-free))
277        (if (not init)
278            v
279            (begin
280              (##sys#check-exact-interval init 0 #xff 'make-u8vector)
281              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
282                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
283                (##sys#u8vector-set! v i init) ) ) ) ) ) )
284
285  (set! make-s8vector
286    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
287      (##sys#check-exact len 'make-s8vector)
288      (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
289        (when (and ext? fin?) (set-finalizer! v ext-free))
290        (if (not init)
291            v
292            (begin
293              (##sys#check-exact-interval init -128 127 'make-s8vector)
294              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
295                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
296                (##sys#s8vector-set! v i init) ) ) ) ) ) )
297
298  (set! make-u16vector
299    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
300      (##sys#check-exact len 'make-u16vector)
301      (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
302        (when (and ext? fin?) (set-finalizer! v ext-free))
303        (if (not init)
304            v
305            (begin
306              (##sys#check-exact-interval init 0 #xffff 'make-u16vector)
307              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
308                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
309                (##sys#u16vector-set! v i init) ) ) ) ) ) )
310
311  (set! make-s16vector
312    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
313      (##sys#check-exact len 'make-s16vector)
314      (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
315        (when (and ext? fin?) (set-finalizer! v ext-free))
316        (if (not init)
317            v
318            (begin
319              (##sys#check-exact-interval init -32768 32767 'make-s16vector)
320              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
321                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
322                (##sys#s16vector-set! v i init) ) ) ) ) ) )
323
324  (set! make-u32vector
325    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
326      (##sys#check-exact len 'make-u32vector)
327      (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
328        (when (and ext? fin?) (set-finalizer! v ext-free))
329        (if (not init)
330            v
331            (begin
332              (##sys#check-exact init 'make-u32vector)
333              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
334                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
335                (##sys#u32vector-set! v i init) ) ) ) ) ) )
336
337  (set! make-s32vector
338    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
339      (##sys#check-exact len 'make-s32vector)
340      (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
341        (when (and ext? fin?) (set-finalizer! v ext-free))
342        (if (not init)
343            v
344            (begin
345              (##sys#check-exact init 'make-s32vector)
346              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
347                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
348                (##sys#s32vector-set! v i init) ) ) ) ) ) )
349
350  (set! make-f32vector
351    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
352      (##sys#check-exact len 'make-f32vector)
353      (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
354        (when (and ext? fin?) (set-finalizer! v ext-free))
355        (if (not init)
356            v
357            (begin
358              (##sys#check-number init 'make-f32vector)
359              (unless (##core#inline "C_blockp" init)
360                (set! init (exact->inexact init)) )
361              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
362                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
363                (##sys#f32vector-set! v i init) ) ) ) ) ) )
364
365  (set! make-f64vector
366    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
367      (##sys#check-exact len 'make-f64vector)
368      (let ((v (##sys#make-structure 'f64vector (alloc 'make-f64vector (##core#inline "C_fixnum_shift_left" len 3) ext?))))
369        (when (and ext? fin?) (set-finalizer! v ext-free))
370        (if (not init)
371            v
372            (begin
373              (##sys#check-number init 'make-f64vector)
374              (unless (##core#inline "C_blockp" init)
375                (set! init (exact->inexact init)) )
376              (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
377                  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
378                (##sys#f64vector-set! v i init) ) ) ) ) ) ) )
379
380
381;;; Creating vectors from a list:
382
383(let ()
384
385  (define (init make set loc)
386    (lambda (lst)
387      (##sys#check-list lst loc)
388      (let* ((n (length lst))
389             (v (make n)) )
390        (do ((p lst (##core#inline "C_slot" p 1))
391             (i 0 (##core#inline "C_fixnum_plus" i 1)) )
392            ((##core#inline "C_eqp" p '()) v)
393          (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
394              (set v i (##core#inline "C_slot" p 0))
395              (##sys#not-a-proper-list-error lst) ) ) ) ) )
396
397  (set! list->u8vector (init make-u8vector u8vector-set! 'list->u8vector))
398  (set! list->s8vector (init make-s8vector s8vector-set! 'list->s8vector))
399  (set! list->u16vector (init make-u16vector u16vector-set! 'list->u16vector))
400  (set! list->s16vector (init make-s16vector s16vector-set! 'list->s16vector))
401  (set! list->u32vector (init make-u32vector u32vector-set! 'list->u32vector))
402  (set! list->s32vector (init make-s32vector s32vector-set! 'list->s32vector))
403  (set! list->f32vector (init make-f32vector f32vector-set! 'list->f32vector))
404  (set! list->f64vector (init make-f64vector f64vector-set! 'list->f64vector)) )
405
406
407;;; More constructors:
408
409(define u8vector
410  (let ((list->u8vector list->u8vector))
411    (lambda xs (list->u8vector xs)) ) )
412
413(define s8vector
414  (let ((list->s8vector list->s8vector))
415    (lambda xs (list->s8vector xs)) ) )
416
417(define u16vector
418  (let ((list->u16vector list->u16vector))
419    (lambda xs (list->u16vector xs)) ) )
420
421(define s16vector
422  (let ((list->s16vector list->s16vector))
423    (lambda xs (list->s16vector xs)) ) )
424
425(define u32vector
426  (let ((list->u32vector list->u32vector))
427    (lambda xs (list->u32vector xs)) ) )
428
429(define s32vector
430  (let ((list->s32vector list->s32vector))
431    (lambda xs (list->s32vector xs)) ) )
432
433(define f32vector
434  (let ((list->f32vector list->f32vector))
435    (lambda xs (list->f32vector xs)) ) )
436
437(define f64vector
438  (let ((list->f64vector list->f64vector))
439    (lambda xs (list->f64vector xs)) ) )
440
441
442;;; Creating lists from a vector:
443
444(let ()
445
446  (define (init tag length ref)
447    (lambda (v)
448      (let ((len (length v)))
449        (let loop ((i 0))
450          (if (fx>= i len)
451              '()
452              (cons (ref v i)
453                    (loop (fx+ i 1)) ) ) ) ) ) )
454
455  (set! u8vector->list (init 'u8vector u8vector-length ##sys#u8vector-ref))
456  (set! s8vector->list (init 's8vector s8vector-length ##sys#s8vector-ref))
457  (set! u16vector->list (init 'u16vector u16vector-length ##sys#u16vector-ref))
458  (set! s16vector->list (init 's16vector s16vector-length ##sys#s16vector-ref))
459  (set! u32vector->list (init 'u32vector u32vector-length ##sys#u32vector-ref))
460  (set! s32vector->list (init 's32vector s32vector-length ##sys#s32vector-ref))
461  (set! f32vector->list (init 'f32vector f32vector-length ##sys#f32vector-ref))
462  (set! f64vector->list (init 'f64vector f64vector-length ##sys#f64vector-ref)) )
463
464
465;;; Predicates:
466
467(define (u8vector? x) (##sys#structure? x 'u8vector))
468(define (s8vector? x) (##sys#structure? x 's8vector))
469(define (u16vector? x) (##sys#structure? x 'u16vector))
470(define (s16vector? x) (##sys#structure? x 's16vector))
471(define (u32vector? x) (##sys#structure? x 'u32vector))
472(define (s32vector? x) (##sys#structure? x 's32vector))
473(define (f32vector? x) (##sys#structure? x 'f32vector))
474(define (f64vector? x) (##sys#structure? x 'f64vector))
475
476
477;;; Accessing the packed bytevector:
478
479(let ()
480
481  (define (pack tag loc)
482    (lambda (v)
483      (##sys#check-structure v tag loc)
484      (##sys#slot v 1) ) )
485
486  (define (pack-copy tag loc)
487    (lambda (v)
488      (##sys#check-structure v tag loc)
489      (let* ((old (##sys#slot v 1))
490             (new (##sys#make-blob (##sys#size old))))
491        (##core#inline "C_copy_block" old new) ) ) )
492
493  (define (unpack tag sz loc)
494    (lambda (str)
495      (##sys#check-byte-vector str loc)
496      (let ([len (##sys#size str)])
497        (if (or (eq? #t sz)
498                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
499            (##sys#make-structure tag str)
500            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )
501
502  (define (unpack-copy tag sz loc)
503    (lambda (str)
504      (##sys#check-byte-vector str loc)
505      (let* ((len (##sys#size str))
506             (new (##sys#make-blob len)))
507        (if (or (eq? #t sz)
508                (eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
509            (##sys#make-structure
510             tag
511             (##core#inline "C_copy_block" str new) )
512            (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )
513
514  (set! u8vector->blob/shared (pack 'u8vector 'u8vector->blob/shared))
515  (set! s8vector->blob/shared (pack 's8vector 's8vector->blob/shared))
516  (set! u16vector->blob/shared (pack 'u16vector 'u16vector->blob/shared))
517  (set! s16vector->blob/shared (pack 's16vector 's16vector->blob/shared))
518  (set! u32vector->blob/shared (pack 'u32vector 'u32vector->blob/shared))
519  (set! s32vector->blob/shared (pack 's32vector 's32vector->blob/shared))
520  (set! f32vector->blob/shared (pack 'f32vector 'f32vector->blob/shared))
521  (set! f64vector->blob/shared (pack 'f64vector 'f64vector->blob/shared))
522
523  (set! u8vector->blob (pack-copy 'u8vector 'u8vector->blob))
524  (set! s8vector->blob (pack-copy 's8vector 's8vector->blob))
525  (set! u16vector->blob (pack-copy 'u16vector 'u16vector->blob))
526  (set! s16vector->blob (pack-copy 's16vector 's16vector->blob))
527  (set! u32vector->blob (pack-copy 'u32vector 'u32vector->blob))
528  (set! s32vector->blob (pack-copy 's32vector 's32vector->blob))
529  (set! f32vector->blob (pack-copy 'f32vector 'f32vector->blob))
530  (set! f64vector->blob (pack-copy 'f64vector 'f64vector->blob))
531
532  (set! blob->u8vector/shared (unpack 'u8vector #t 'blob->u8vector/shared))
533  (set! blob->s8vector/shared (unpack 's8vector #t 'blob->s8vector/shared))
534  (set! blob->u16vector/shared (unpack 'u16vector 2 'blob->u16vector/shared))
535  (set! blob->s16vector/shared (unpack 's16vector 2 'blob->s16vector/shared))
536  (set! blob->u32vector/shared (unpack 'u32vector 4 'blob->u32vector/shared))
537  (set! blob->s32vector/shared (unpack 's32vector 4 'blob->s32vector/shared))
538  (set! blob->f32vector/shared (unpack 'f32vector 4 'blob->f32vector/shared))
539  (set! blob->f64vector/shared (unpack 'f64vector 8 'blob->f64vector/shared))
540
541  (set! blob->u8vector (unpack-copy 'u8vector #t 'blob->u8vector))
542  (set! blob->s8vector (unpack-copy 's8vector #t 'blob->s8vector))
543  (set! blob->u16vector (unpack-copy 'u16vector 2 'blob->u16vector))
544  (set! blob->s16vector (unpack-copy 's16vector 2 'blob->s16vector))
545  (set! blob->u32vector (unpack-copy 'u32vector 4 'blob->u32vector))
546  (set! blob->s32vector (unpack-copy 's32vector 4 'blob->s32vector))
547  (set! blob->f32vector (unpack-copy 'f32vector 4 'blob->f32vector))
548  (set! blob->f64vector (unpack-copy 'f64vector 8 'blob->f64vector)) )
549
550
551;;; Read syntax:
552
553(set! ##sys#user-read-hook
554  (let ([old-hook ##sys#user-read-hook]
555        [read read]
556        [consers (list 'u8 list->u8vector
557                       's8 list->s8vector
558                       'u16 list->u16vector
559                       's16 list->s16vector
560                       'u32 list->u32vector
561                       's32 list->s32vector
562                       'f32 list->f32vector
563                       'f64 list->f64vector) ] )
564    (lambda (char port)
565      (if (memq char '(#\u #\s #\f #\U #\S #\F))
566          (let* ([x (read port)]
567                 [tag (and (symbol? x) x)] )
568            (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
569                  [(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
570                  [else (##sys#read-error port "illegal bytevector syntax" tag)] ) )
571          (old-hook char port) ) ) ) )
572
573
574;;; Printing:
575
576(set! ##sys#user-print-hook
577  (let ((old-hook ##sys#user-print-hook))
578    (lambda (x readable port)
579      (let ((tag (assq (##core#inline "C_slot" x 0)
580                       `((u8vector u8 ,u8vector->list)
581                         (s8vector s8 ,s8vector->list)
582                         (u16vector u16 ,u16vector->list)
583                         (s16vector s16 ,s16vector->list)
584                         (u32vector u32 ,u32vector->list)
585                         (s32vector s32 ,s32vector->list)
586                         (f32vector f32 ,f32vector->list)
587                         (f64vector f64 ,f64vector->list) ) ) ) )
588        (cond (tag
589               (##sys#print #\# #f port)
590               (##sys#print (cadr tag) #f port)
591               (##sys#print ((caddr tag) x) #t port) )
592              (else (old-hook x readable port)) ) ) ) ) )
593
594
595;;; Subvectors:
596
597(define (subvector v t es from to loc)
598  (##sys#check-structure v t loc)
599  (let* ([bv (##sys#slot v 1)]
600         [len (##sys#size bv)]
601         [ilen (##core#inline "C_fixnum_divide" len es)] )
602    (##sys#check-range from 0 (fx+ ilen 1) loc)
603    (##sys#check-range to 0 (fx+ ilen 1) loc)
604    (let* ([size2 (fx* es (fx- to from))]
605           [bv2 (##sys#allocate-vector size2 #t #f #t)] )
606      (##core#inline "C_string_to_bytevector" bv2)
607      (let ([v (##sys#make-structure t bv2)])
608        (##core#inline "C_copy_subvector" bv2 bv 0 (fx* from es) size2)
609        v) ) ) )
610
611(define (subu8vector v from to) (subvector v 'u8vector 1 from to 'subu8vector))
612(define (subu16vector v from to) (subvector v 'u16vector 2 from to 'subu16vector))
613(define (subu32vector v from to) (subvector v 'u32vector 4 from to 'subu32vector))
614(define (subs8vector v from to) (subvector v 's8vector 1 from to 'subs8vector))
615(define (subs16vector v from to) (subvector v 's16vector 2 from to 'subs16vector))
616(define (subs32vector v from to) (subvector v 's32vector 4 from to 'subs32vector))
617(define (subf32vector v from to) (subvector v 'f32vector 4 from to 'subf32vector))
618(define (subf64vector v from to) (subvector v 'f64vector 8 from to 'subf64vector))
619
620(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0) (to (u8vector-length v)))
621  (##sys#check-structure v 'u8vector 'write-u8vector)
622  (##sys#check-port port 'write-u8vector)
623  (let ((buf (##sys#slot v 1)))
624    (do ((i from (fx+ i 1)))
625        ((fx>= i to))
626      (##sys#write-char-0 (integer->char (##core#inline "C_u8peek" buf i)) port) ) ) )
627
628(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
629  (##sys#check-port port 'read-u8vector!)
630  (##sys#check-exact start 'read-u8vector!)
631  (##sys#check-structure dest 'u8vector 'read-u8vector!)
632  (let ((dest (##sys#slot dest 1)))
633    (when n
634      (##sys#check-exact n 'read-u8vector!)
635      (when (fx> (fx+ start n) (##sys#size dest))
636        (set! n (fx- (##sys#size dest) start))))
637    (##sys#read-string! n dest port start) ) )
638
639(define read-u8vector
640  (let ((open-output-string open-output-string)
641        (get-output-string get-output-string) )
642    (define (wrap str n)
643      (##sys#make-structure
644       'u8vector
645       (let ((str2 (##sys#allocate-vector n #t #f #t)))
646         (##core#inline "C_string_to_bytevector" str2)
647         (##core#inline "C_substring_copy" str str2 0 n 0)
648         str2) ) )
649    (lambda (#!optional n (p ##sys#standard-input))
650      (##sys#check-port p 'read-u8vector)
651      (cond (n (##sys#check-exact n 'read-u8vector)
652               (let* ((str (##sys#allocate-vector n #t #f #t))
653                      (n2 (##sys#read-string! n str p 0)) )
654                 (##core#inline "C_string_to_bytevector" str)
655                 (if (eq? n n2)
656                     (##sys#make-structure 'u8vector str)
657                     (wrap str n2) ) ) )
658            (else
659             (let ([str (open-output-string)])
660               (let loop ()
661                 (let ([c (##sys#read-char-0 p)])
662                   (if (eof-object? c)
663                       (let* ((s (get-output-string str))
664                              (n (##sys#size s)) )
665                         (wrap s n) )
666                       (begin
667                         (##sys#write-char/port c str)
668                         (loop)))))))))))
669
670(register-feature! 'srfi-4)
Note: See TracBrowser for help on using the repository browser.