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

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