source: project/chicken/branches/inlining/srfi-4.scm @ 15323

Last change on this file since 15323 was 15323, checked in by felix winkelmann, 11 years ago

more intelligent inlining; standard-extension procedure in setup-api

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