source: project/chicken/branches/beyond-hope/srfi-4.scm @ 10352

Last change on this file since 10352 was 8361, checked in by felix winkelmann, 13 years ago

probably fixed 64-bit literal bug and changed copyrights

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