srfi-4.scm

Scheme跨平台编译器

;;;; srfi-4.scm - Homogeneous numeric vectors
;
; Copyright (c) 2000-2007, Felix L. Winkelmann
; Copyright (c) 2008, The Chicken Team
; All rights reserved.
;
; Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following
; conditions are met:
;
;   Redistributions of source code must retain the above copyright notice, this list of conditions and the following
;     disclaimer.
;   Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following
;     disclaimer in the documentation and/or other materials provided with the distribution.
;   Neither the name of the author nor the names of its contributors may be used to endorse or promote
;     products derived from this software without specific prior written permission.
;
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS
; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
; AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
; CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
; OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
; POSSIBILITY OF SUCH DAMAGE.


(declare
 (unit srfi-4)
 (disable-interrupts)
 (disable-warning redef)
 (usual-integrations)
 (hide ##sys#u8vector-set! ##sys#s8vector-set! ##sys#u16vector-set! ##sys#s16vector-set!
       ##sys#u32vector-set! ##sys#s32vector-set! ##sys#f32vector-set! ##sys#f64vector-set!
       ##sys#u8vector-ref ##sys#s8vector-ref ##sys#u16vector-ref ##sys#s16vector-ref subvector
       ##sys#u32vector-ref ##sys#s32vector-ref ##sys#f32vector-ref ##sys#f64vector-ref)
 (foreign-declare #<<EOF
#define C_u8peek(b, i)         C_fix(((unsigned char *)C_data_pointer(b))[ C_unfix(i) ])
#define C_s8peek(b, i)         C_fix(((char *)C_data_pointer(b))[ C_unfix(i) ])
#define C_u16peek(b, i)        C_fix(((unsigned short *)C_data_pointer(b))[ C_unfix(i) ])
#define C_s16peek(b, i)        C_fix(((short *)C_data_pointer(b))[ C_unfix(i) ])
#ifdef C_SIXTY_FOUR
# define C_a_u32peek(ptr, d, b, i) C_fix(((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
# define C_a_s32peek(ptr, d, b, i) C_fix(((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
#else
# define C_a_u32peek(ptr, d, b, i) C_unsigned_int_to_num(ptr, ((C_u32 *)C_data_pointer(b))[ C_unfix(i) ])
# define C_a_s32peek(ptr, d, b, i) C_int_to_num(ptr, ((C_s32 *)C_data_pointer(b))[ C_unfix(i) ])
#endif
#define C_f32peek(b, i)        (C_temporary_flonum = ((float *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
#define C_f64peek(b, i)        (C_temporary_flonum = ((double *)C_data_pointer(b))[ C_unfix(i) ], C_SCHEME_UNDEFINED)
#define C_u8poke(b, i, x)      ((((unsigned char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_s8poke(b, i, x)      ((((char *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_u16poke(b, i, x)     ((((unsigned short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_s16poke(b, i, x)     ((((short *)C_data_pointer(b))[ C_unfix(i) ] = C_unfix(x)), C_SCHEME_UNDEFINED)
#define C_u32poke(b, i, x)     ((((C_u32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_unsigned_int(x)), C_SCHEME_UNDEFINED)
#define C_s32poke(b, i, x)     ((((C_s32 *)C_data_pointer(b))[ C_unfix(i) ] = C_num_to_int(x)), C_SCHEME_UNDEFINED)
#define C_f32poke(b, i, x)     ((((float *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
#define C_f64poke(b, i, x)     ((((double *)C_data_pointer(b))[ C_unfix(i) ] = C_flonum_magnitude(x)), C_SCHEME_UNDEFINED)
#define C_copy_subvector(to, from, start_to, start_from, bytes)   \
  (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)), \
    C_SCHEME_UNDEFINED)
EOF
) )

(cond-expand
 [paranoia]
 [else
  (declare
    (no-bound-checks)
    (no-procedure-checks-for-usual-bindings)
    (bound-to-procedure
     ##sys#check-exact ##sys#u8vector-ref ##sys#u8vector-set! ##sys#s8vector-ref ##sys#s8vector-set!
     ##sys#u16vector-ref ##sys#u16vector-set!
     ##sys#s16vector-ref ##sys#s16vector-set! ##sys#u32vector-ref ##sys#u32vector-set! ##sys#s32vector-ref
     ##sys#s32vector-set! read list->f64vector list->s32vector list->u32vector list->u16vector list-s8vector
     list->u8vector set-finalizer!
     ##sys#f32vector-ref ##sys#f32vector-set! ##sys#f64vector-ref ##sys#f64vector-set! ##sys#check-exact-interval
     ##sys#check-inexact-interval ##sys#check-number ##sys#check-structure ##sys#cons-flonum ##sys#check-list
     ##sys#check-range ##sys#error ##sys#signal-hook
     ##sys#not-a-proper-list-error ##sys#print ##sys#allocate-vector) ) ] )

(cond-expand
 [unsafe
  (eval-when (compile)
    (define-macro (##sys#check-structure . _) '(##core#undefined))
    (define-macro (##sys#check-range . _) '(##core#undefined))
    (define-macro (##sys#check-pair . _) '(##core#undefined))
    (define-macro (##sys#check-list . _) '(##core#undefined))
    (define-macro (##sys#check-symbol . _) '(##core#undefined))
    (define-macro (##sys#check-string . _) '(##core#undefined))
    (define-macro (##sys#check-char . _) '(##core#undefined))
    (define-macro (##sys#check-exact . _) '(##core#undefined))
    (define-macro (##sys#check-port . _) '(##core#undefined))
    (define-macro (##sys#check-number . _) '(##core#undefined))
    (define-macro (##sys#check-bytevector . _) '(##core#undefined)) ) ]
 [else
  (declare (emit-exports "srfi-4.exports"))] )


;;; Helper routines:

(define ##sys#check-exact-interval
  (lambda (n from to loc)
    (##sys#check-exact n loc)
    (if (or (##core#inline "C_fixnum_lessp" n from)
	    (##core#inline "C_fixnum_greaterp" n to) )
	(##sys#error loc "numeric value is not in expected range" n from to) ) ) )

(define ##sys#check-inexact-interval
  (lambda (n from to loc)
    (##sys#check-number n loc)
    (if (or (< n from) (> n to))
	(##sys#error "numeric value is not in expected range" n from to) ) ) )


;;; Primitive accessors:

(define (##sys#u8vector-ref v i) (##core#inline "C_u8peek" (##core#inline "C_slot" v 1) i))
(define (##sys#s8vector-ref v i) (##core#inline "C_s8peek" (##core#inline "C_slot" v 1) i))
(define (##sys#u16vector-ref v i) (##core#inline "C_u16peek" (##core#inline "C_slot" v 1) i))
(define (##sys#s16vector-ref v i) (##core#inline "C_s16peek" (##core#inline "C_slot" v 1) i))
(define (##sys#u32vector-ref v i) (##core#inline_allocate ("C_a_u32peek" 4) (##core#inline "C_slot" v 1) i))
(define (##sys#s32vector-ref v i) (##core#inline_allocate ("C_a_s32peek" 4) (##core#inline "C_slot" v 1) i))

(define (##sys#f32vector-ref v i)
  (##core#inline "C_f32peek" (##core#inline "C_slot" v 1) i)
  (##sys#cons-flonum) )

(define (##sys#f64vector-ref v i)
  (##core#inline "C_f64peek" (##core#inline "C_slot" v 1) i)
  (##sys#cons-flonum) )

(define (##sys#u8vector-set! v i x) (##core#inline "C_u8poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#s8vector-set! v i x) (##core#inline "C_s8poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#u16vector-set! v i x) (##core#inline "C_u16poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#s16vector-set! v i x) (##core#inline "C_s16poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#u32vector-set! v i x) (##core#inline "C_u32poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#s32vector-set! v i x) (##core#inline "C_s32poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#f32vector-set! v i x) (##core#inline "C_f32poke" (##core#inline "C_slot" v 1) i x))
(define (##sys#f64vector-set! v i x) (##core#inline "C_f64poke" (##core#inline "C_slot" v 1) i x))


;;; Get vector length:

(let ()

  (define (len tag shift loc)
    (lambda (v)
      (##sys#check-structure v tag loc)
      (let ((bytes (##core#inline "C_block_size" (##core#inline "C_slot" v 1))))
	(if shift
	    (##core#inline "C_fixnum_shift_right" bytes shift)
	    bytes) ) ) )

  (set! u8vector-length (len 'u8vector #f 'u8vector-length))
  (set! s8vector-length (len 's8vector #f 's8vector-length))
  (set! u16vector-length (len 'u16vector 1 'u16vector-length))
  (set! s16vector-length (len 's16vector 1 's16vector-length))
  (set! u32vector-length (len 'u32vector 2 'u32vector-length))
  (set! s32vector-length (len 's32vector 2 's32vector-length))
  (set! f32vector-length (len 'f32vector 2 'f32vector-length))
  (set! f64vector-length (len 'f64vector 3 'f64vector-length)) )


;;; Safe accessors:

(let ()

  (define (get length acc loc)
    (lambda (v i)
      (let ((len (length v)))
	(##sys#check-range i 0 len loc)
	(acc v i) ) ) )

  (define (set length upd loc)
    (lambda (v i x)
      (let ((len (length v)))
	(##sys#check-exact x loc)
	(##sys#check-range i 0 len loc)
	(upd v i x) ) ) )

  (define (setu length upd loc)
    (lambda (v i x)
      (let ((len (length v)))
	(##sys#check-exact x loc)
	(if (fx< x 0)
	    (##sys#error loc "argument may not be negative" x) )
	(##sys#check-range i 0 len loc)
	(upd v i x) ) ) )

  (define (setw length upd loc)
    (lambda (v i x)
      (let ((len (length v)))
	(if (not (##sys#fits-in-int? x))
	    (##sys#error loc "argument exceeds integer range" x) )
	(##sys#check-range i 0 len loc)
	(upd v i x) ) ) )

  (define (setuw length upd loc)
    (lambda (v i x)
      (let ((len (length v)))
	(cond ((negative? x)
	       (##sys#error loc "argument may not be negative" x) )
	      ((not (##sys#fits-in-unsigned-int? x))
	       (##sys#error loc "argument exceeds integer range" x) ) )
	(##sys#check-range i 0 len loc)
	(upd v i x) ) ) )

  (define (setf length upd loc)
    (lambda (v i x)
      (let ((len (length v)))
	(##sys#check-number x loc)
	(##sys#check-range i 0 len loc)
	(upd v i (if (##core#inline "C_blockp" x)
		     x
		     (exact->inexact x) ) ) ) ) )

  (set! u8vector-set! (setu u8vector-length ##sys#u8vector-set! 'u8vector-set!))
  (set! s8vector-set! (set s8vector-length ##sys#s8vector-set! 's8vector-set!))
  (set! u16vector-set! (setu u16vector-length ##sys#u16vector-set! 'u16vector-set!))
  (set! s16vector-set! (set s16vector-length ##sys#s16vector-set! 's16vector-set!))
  (set! u32vector-set! (setuw u32vector-length ##sys#u32vector-set! 'u32vector-set!))
  (set! s32vector-set! (setw s32vector-length ##sys#s32vector-set! 's32vector-set!))
  (set! f32vector-set! (setf f32vector-length ##sys#f32vector-set! 'f32vector-set!))
  (set! f64vector-set! (setf f64vector-length ##sys#f64vector-set! 'f64vector-set!))

  (set! u8vector-ref
	(getter-with-setter (get u8vector-length ##sys#u8vector-ref 'u8vector-ref)
			    u8vector-set!) )
  (set! s8vector-ref
	(getter-with-setter (get s8vector-length ##sys#s8vector-ref 's8vector-ref)
			    s8vector-set!) )
  (set! u16vector-ref
	(getter-with-setter (get u16vector-length ##sys#u16vector-ref 'u16vector-ref)
			    u16vector-set!) )
  (set! s16vector-ref
	(getter-with-setter (get s16vector-length ##sys#s16vector-ref 's16vector-ref)
			    s16vector-set!) )
  (set! u32vector-ref
	(getter-with-setter
	 (get u32vector-length ##sys#u32vector-ref 'u32vector-ref)
	 u32vector-set!) )
  (set! s32vector-ref
	(getter-with-setter
	 (get s32vector-length ##sys#s32vector-ref 's32vector-ref)
	 s32vector-set!) )
  (set! f32vector-ref
	(getter-with-setter
	 (get f32vector-length ##sys#f32vector-ref 'f32vector-ref)
	 f32vector-set!) )
  (set! f64vector-ref
	(getter-with-setter
	 (get f64vector-length ##sys#f64vector-ref 'f64vector-ref)
	 f64vector-set!) ) )



;;; Basic constructors:

(let* ([ext-alloc
	(foreign-lambda* scheme-object ([int bytes])
	  "C_word *buf = (C_word *)C_malloc(bytes + sizeof(C_header));"
	  "if(buf == NULL) return(C_SCHEME_FALSE);"
	  "C_block_header(buf) = C_make_header(C_BYTEVECTOR_TYPE, bytes);"
	  "return(buf);") ]
       [ext-free
	(foreign-lambda* void ([scheme-object bv])
	  "C_free((void *)C_block_item(bv, 1));") ]
       [set-finalizer! set-finalizer!]
       [alloc
	(lambda (loc len ext?)
	  (if ext?
	      (let ([bv (ext-alloc len)])
		(or bv
		    (##sys#error loc "not enough memory - can not allocate external number vector" len)) )
	      (let ([bv (##sys#allocate-vector len #t #f #t)]) ; this could be made better...
		(##core#inline "C_string_to_bytevector" bv)
		bv) ) ) ] )

  (set! release-number-vector
    (lambda (v)
      (if (and (##sys#generic-structure? v)
	       (memq (##sys#slot v 0) '(u8vector u16vector s8vector s16vector u32vector s32vector f32vector f64vector)) )
	  (ext-free v)
	  (##sys#error 'release-number-vector "bad argument type - not a number vector" v)) ) )

  (set! make-u8vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin? #t))
      (##sys#check-exact len 'make-u8vector)
      (let ((v (##sys#make-structure 'u8vector (alloc 'make-u8vector len ext?))))
	(when (and ext? fin?) (set-finalizer! v ext-free))
	(if (not init)
	    v
	    (begin
	      (##sys#check-exact-interval init 0 #xff 'make-u8vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#u8vector-set! v i init) ) ) ) ) ) )

  (set! make-s8vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-s8vector)
      (let ((v (##sys#make-structure 's8vector (alloc 'make-s8vector len ext?))))
	(when (and ext? fin?) (set-finalizer! v ext-free))
	(if (not init)
	    v
	    (begin
	      (##sys#check-exact-interval init -128 127 'make-s8vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#s8vector-set! v i init) ) ) ) ) ) )

  (set! make-u16vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-u16vector)
      (let ((v (##sys#make-structure 'u16vector (alloc 'make-u16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
	(when (and ext? fin?) (set-finalizer! v ext-free))
	(if (not init)
	    v
	    (begin
	      (##sys#check-exact-interval init 0 #xffff 'make-u16vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#u16vector-set! v i init) ) ) ) ) ) )

  (set! make-s16vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-s16vector)
      (let ((v (##sys#make-structure 's16vector (alloc 'make-s16vector (##core#inline "C_fixnum_shift_left" len 1) ext?))))
	(when (and ext? fin?) (set-finalizer! v ext-free))
	(if (not init)
	    v
	    (begin
	      (##sys#check-exact-interval init -32768 32767 'make-s16vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#s16vector-set! v i init) ) ) ) ) ) )

  (set! make-u32vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-u32vector)
      (let ((v (##sys#make-structure 'u32vector (alloc 'make-u32vector (##core#inline "C_fixnum_shift_left" len 2) ext?))))
	(when (and ext? fin?) (set-finalizer! v ext-free))
	(if (not init)
	    v
	    (begin
	      (##sys#check-exact init 'make-u32vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#u32vector-set! v i init) ) ) ) ) ) )

  (set! make-s32vector