srfi-4.scm

Scheme跨平台编译器

    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-s32vector)
      (let ((v (##sys#make-structure 's32vector (alloc 'make-s32vector (##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-s32vector)
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#s32vector-set! v i init) ) ) ) ) ) )

  (set! make-f32vector
    (lambda (len #!optional (init #f)  (ext? #f) (fin #t))
      (##sys#check-exact len 'make-f32vector)
      (let ((v (##sys#make-structure 'f32vector (alloc 'make-f32vector (##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-number init 'make-f32vector)
	      (unless (##core#inline "C_blockp" init)
		(set! init (exact->inexact init)) )
	      (do ((i 0 (##core#inline "C_fixnum_plus" i 1)))
		  ((##core#inline "C_fixnum_greater_or_equal_p" i len) v)
		(##sys#f32vector-set! v i init) ) ) ) ) ) )

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


;;; Creating vectors from a list:

(let ()

  (define (init make set loc)
    (lambda (lst)
      (##sys#check-list lst loc)
      (let* ((n (length lst))
	     (v (make n)) )
	(do ((p lst (##core#inline "C_slot" p 1))
	     (i 0 (##core#inline "C_fixnum_plus" i 1)) )
	    ((##core#inline "C_eqp" p '()) v)
	  (if (and (##core#inline "C_blockp" p) (##core#inline "C_pairp" p))
	      (set v i (##core#inline "C_slot" p 0))
	      (##sys#not-a-proper-list-error lst) ) ) ) ) )

  (set! list->u8vector (init make-u8vector u8vector-set! 'list->u8vector))
  (set! list->s8vector (init make-s8vector s8vector-set! 'list->s8vector))
  (set! list->u16vector (init make-u16vector u16vector-set! 'list->u16vector))
  (set! list->s16vector (init make-s16vector s16vector-set! 'list->s16vector))
  (set! list->u32vector (init make-u32vector u32vector-set! 'list->u32vector))
  (set! list->s32vector (init make-s32vector s32vector-set! 'list->s32vector))
  (set! list->f32vector (init make-f32vector f32vector-set! 'list->f32vector))
  (set! list->f64vector (init make-f64vector f64vector-set! 'list->f64vector)) )


;;; More constructors:

(define u8vector
  (let ((list->u8vector list->u8vector))
    (lambda xs (list->u8vector xs)) ) )

(define s8vector
  (let ((list->s8vector list->s8vector))
    (lambda xs (list->s8vector xs)) ) )

(define u16vector
  (let ((list->u16vector list->u16vector))
    (lambda xs (list->u16vector xs)) ) )

(define s16vector
  (let ((list->s16vector list->s16vector))
    (lambda xs (list->s16vector xs)) ) )

(define u32vector
  (let ((list->u32vector list->u32vector))
    (lambda xs (list->u32vector xs)) ) )

(define s32vector
  (let ((list->s32vector list->s32vector))
    (lambda xs (list->s32vector xs)) ) )

(define f32vector
  (let ((list->f32vector list->f32vector))
    (lambda xs (list->f32vector xs)) ) )

(define f64vector
  (let ((list->f64vector list->f64vector))
    (lambda xs (list->f64vector xs)) ) )


;;; Creating lists from a vector:

(let ()

  (define (init tag length ref)
    (lambda (v)
      (let ((len (length v)))
	(let loop ((i 0))
	  (if (fx>= i len)
	      '()
	      (cons (ref v i)
		    (loop (fx+ i 1)) ) ) ) ) ) )

  (set! u8vector->list (init 'u8vector u8vector-length ##sys#u8vector-ref))
  (set! s8vector->list (init 's8vector s8vector-length ##sys#s8vector-ref))
  (set! u16vector->list (init 'u16vector u16vector-length ##sys#u16vector-ref))
  (set! s16vector->list (init 's16vector s16vector-length ##sys#s16vector-ref))
  (set! u32vector->list (init 'u32vector u32vector-length ##sys#u32vector-ref))
  (set! s32vector->list (init 's32vector s32vector-length ##sys#s32vector-ref))
  (set! f32vector->list (init 'f32vector f32vector-length ##sys#f32vector-ref))
  (set! f64vector->list (init 'f64vector f64vector-length ##sys#f64vector-ref)) )


;;; Predicates:

(define (u8vector? x) (##sys#structure? x 'u8vector))
(define (s8vector? x) (##sys#structure? x 's8vector))
(define (u16vector? x) (##sys#structure? x 'u16vector))
(define (s16vector? x) (##sys#structure? x 's16vector))
(define (u32vector? x) (##sys#structure? x 'u32vector))
(define (s32vector? x) (##sys#structure? x 's32vector))
(define (f32vector? x) (##sys#structure? x 'f32vector))
(define (f64vector? x) (##sys#structure? x 'f64vector))


;;; Accessing the packed bytevector:

(let ()

  (define (pack tag loc)
    (lambda (v)
      (##sys#check-structure v tag loc)
      (##sys#slot v 1) ) )

  (define (pack-copy tag loc)
    (lambda (v)
      (##sys#check-structure v tag loc)
      (let* ((old (##sys#slot v 1))
	     (new (##sys#make-blob (##sys#size old))))
	(##core#inline "C_copy_block" old new) ) ) )

  (define (unpack tag sz loc)
    (lambda (str)
      (##sys#check-byte-vector str loc)
      (let ([len (##sys#size str)])
	(if (or (eq? #t sz)
		(eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
	    (##sys#make-structure tag str)
	    (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )

  (define (unpack-copy tag sz loc)
    (lambda (str)
      (##sys#check-byte-vector str loc)
      (let* ((len (##sys#size str))
	     (new (##sys#make-blob len)))
	(if (or (eq? #t sz)
		(eq? 0 (##core#inline "C_fixnum_modulo" len sz)))
	    (##sys#make-structure
	     tag
	     (##core#inline "C_copy_block" str new) )
	    (##sys#error loc "blob does not have correct size for packing" tag len sz) ) ) ) )

  (set! u8vector->byte-vector (pack 'u8vector 'u8vector->byte-vector)) ; DEPRECATED
  (set! s8vector->byte-vector (pack 's8vector 's8vector->byte-vector)) ; DEPRECATED
  (set! u16vector->byte-vector (pack 'u16vector 'u16vector->byte-vector)) ; DEPRECATED
  (set! s16vector->byte-vector (pack 's16vector 's16vector->byte-vector)) ; DEPRECATED
  (set! u32vector->byte-vector (pack 'u32vector 'u32vector->byte-vector)) ; DEPRECATED
  (set! s32vector->byte-vector (pack 's32vector 's32vector->byte-vector)) ; DEPRECATED
  (set! f32vector->byte-vector (pack 'f32vector 'f32vector->byte-vector)) ; DEPRECATED
  (set! f64vector->byte-vector (pack 'f64vector 'f64vector->byte-vector)) ; DEPRECATED

  (set! u8vector->blob/shared (pack 'u8vector 'u8vector->blob/shared))
  (set! s8vector->blob/shared (pack 's8vector 's8vector->blob/shared))
  (set! u16vector->blob/shared (pack 'u16vector 'u16vector->blob/shared))
  (set! s16vector->blob/shared (pack 's16vector 's16vector->blob/shared))
  (set! u32vector->blob/shared (pack 'u32vector 'u32vector->blob/shared))
  (set! s32vector->blob/shared (pack 's32vector 's32vector->blob/shared))
  (set! f32vector->blob/shared (pack 'f32vector 'f32vector->blob/shared))
  (set! f64vector->blob/shared (pack 'f64vector 'f64vector->blob/shared))

  (set! u8vector->blob (pack-copy 'u8vector 'u8vector->blob))
  (set! s8vector->blob (pack-copy 's8vector 's8vector->blob))
  (set! u16vector->blob (pack-copy 'u16vector 'u16vector->blob))
  (set! s16vector->blob (pack-copy 's16vector 's16vector->blob))
  (set! u32vector->blob (pack-copy 'u32vector 'u32vector->blob))
  (set! s32vector->blob (pack-copy 's32vector 's32vector->blob))
  (set! f32vector->blob (pack-copy 'f32vector 'f32vector->blob))
  (set! f64vector->blob (pack-copy 'f64vector 'f64vector->blob))

  (set! byte-vector->u8vector (unpack 'u8vector #t 'byte-vector->u8vector)) ; DEPRECATED
  (set! byte-vector->s8vector (unpack 's8vector #t 'byte-vector->s8vector)) ; DEPRECATED
  (set! byte-vector->u16vector (unpack 'u16vector 2 'byte-vector->u16vector)) ; DEPRECATED
  (set! byte-vector->s16vector (unpack 's16vector 2 'byte-vector->s16vector)) ; DEPRECATED
  (set! byte-vector->u32vector (unpack 'u32vector 4 'byte-vector->u32vector)) ; DEPRECATED
  (set! byte-vector->s32vector (unpack 's32vector 4 'byte-vector->s32vector)) ; DEPRECATED
  (set! byte-vector->f32vector (unpack 'f32vector 4 'byte-vector->f32vector)) ; DEPRECATED
  (set! byte-vector->f64vector (unpack 'f64vector 8 'byte-vector->f64vector)) ; DEPRECATED

  (set! blob->u8vector/shared (unpack 'u8vector #t 'blob->u8vector/shared))
  (set! blob->s8vector/shared (unpack 's8vector #t 'blob->s8vector/shared))
  (set! blob->u16vector/shared (unpack 'u16vector 2 'blob->u16vector/shared))
  (set! blob->s16vector/shared (unpack 's16vector 2 'blob->s16vector/shared))
  (set! blob->u32vector/shared (unpack 'u32vector 4 'blob->u32vector/shared))
  (set! blob->s32vector/shared (unpack 's32vector 4 'blob->s32vector/shared))
  (set! blob->f32vector/shared (unpack 'f32vector 4 'blob->f32vector/shared))
  (set! blob->f64vector/shared (unpack 'f64vector 8 'blob->f64vector/shared))

  (set! blob->u8vector (unpack-copy 'u8vector #t 'blob->u8vector))
  (set! blob->s8vector (unpack-copy 's8vector #t 'blob->s8vector))
  (set! blob->u16vector (unpack-copy 'u16vector 2 'blob->u16vector))
  (set! blob->s16vector (unpack-copy 's16vector 2 'blob->s16vector))
  (set! blob->u32vector (unpack-copy 'u32vector 4 'blob->u32vector))
  (set! blob->s32vector (unpack-copy 's32vector 4 'blob->s32vector))
  (set! blob->f32vector (unpack-copy 'f32vector 4 'blob->f32vector))
  (set! blob->f64vector (unpack-copy 'f64vector 8 'blob->f64vector)) )


;;; Read syntax:

(set! ##sys#user-read-hook
  (let ([old-hook ##sys#user-read-hook]
	[read read]
	[consers (list 'u8 list->u8vector
		       's8 list->s8vector
		       'u16 list->u16vector
		       's16 list->s16vector
		       'u32 list->u32vector
		       's32 list->s32vector
		       'f32 list->f32vector
		       'f64 list->f64vector) ] )
    (lambda (char port)
      (if (memq char '(#\u #\s #\f #\U #\S #\F))
	  (let* ([x (read port)]
		 [tag (and (symbol? x) x)] )
	    (cond [(or (eq? tag 'f) (eq? tag 'F)) #f]
		  [(memq tag consers) => (lambda (c) ((##sys#slot (##sys#slot c 1) 0) (read port)))]
		  [else (##sys#read-error port "illegal bytevector syntax" tag)] ) )
	  (old-hook char port) ) ) ) )


;;; Printing:

(set! ##sys#user-print-hook
  (let ((old-hook ##sys#user-print-hook))
    (lambda (x readable port)
      (let ((tag (assq (##core#inline "C_slot" x 0)
		       `((u8vector u8 ,u8vector->list)
			 (s8vector s8 ,s8vector->list)
			 (u16vector u16 ,u16vector->list)
			 (s16vector s16 ,s16vector->list)
			 (u32vector u32 ,u32vector->list)
			 (s32vector s32 ,s32vector->list)
			 (f32vector f32 ,f32vector->list)
			 (f64vector f64 ,f64vector->list) ) ) ) )
	(cond (tag
	       (##sys#print #\# #f port)
	       (##sys#print (cadr tag) #f port)
	       (##sys#print ((caddr tag) x) #t port) )
	      (else (old-hook x readable port)) ) ) ) ) )


;;; Subvectors:

(define (subvector v t es from to loc)
  (##sys#check-structure v t loc)
  (let* ([bv (##sys#slot v 1)]
	 [len (##sys#size bv)]
	 [ilen (##core#inline "C_fixnum_divide" len es)] )
    (##sys#check-range from 0 (fx+ ilen 1) loc)
    (##sys#check-range to 0 (fx+ ilen 1) loc)
    (let* ([size2 (fx* es (fx- to from))]
	   [bv2 (##sys#allocate-vector size2 #t #f #t)] )
      (##core#inline "C_string_to_bytevector" bv2)
      (let ([v (##sys#make-structure t bv2)])
	(##core#inline "C_copy_subvector" bv2 bv 0 (fx* from es) size2)
	v) ) ) )

(define (subu8vector v from to) (subvector v 'u8vector 1 from to 'subu8vector))
(define (subu16vector v from to) (subvector v 'u16vector 2 from to 'subu16vector))
(define (subu32vector v from to) (subvector v 'u32vector 4 from to 'subu32vector))
(define (subs8vector v from to) (subvector v 's8vector 1 from to 'subs8vector))
(define (subs16vector v from to) (subvector v 's16vector 2 from to 'subs16vector))
(define (subs32vector v from to) (subvector v 's32vector 4 from to 'subs32vector))
(define (subf32vector v from to) (subvector v 'f32vector 4 from to 'subf32vector))
(define (subf64vector v from to) (subvector v 'f64vector 8 from to 'subf64vector))

(define (write-u8vector v #!optional (port ##sys#standard-output) (from 0) (to (u8vector-length v)))
  (##sys#check-structure v 'u8vector 'write-u8vector)
  (##sys#check-port port 'write-u8vector)
  (let ((buf (##sys#slot v 1)))
    (do ((i from (fx+ i 1)))
	((fx>= i to))
      (##sys#write-char-0 (integer->char (##core#inline "C_u8peek" buf i)) port) ) ) )

(define (read-u8vector! n dest #!optional (port ##sys#standard-input) (start 0))
  (##sys#check-port port 'read-u8vector!)
  (##sys#check-exact start 'read-u8vector!)
  (##sys#check-structure dest 'u8vector 'read-u8vector!)
  (let ((dest (##sys#slot dest 1)))
    (when n
      (##sys#check-exact n 'read-u8vector!)
      (when (fx> (fx+ start n) (##sys#size dest))
	(set! n (fx- (##sys#size dest) start))))
    (##sys#read-string! n dest port start) ) )

(define read-u8vector
  (let ((open-output-string open-output-string)
	(get-output-string get-output-string) )
    (define (wrap str n)
      (##sys#make-structure
       'u8vector
       (let ((str2 (##sys#allocate-vector n #t #f #t)))
	 (##core#inline "C_string_to_bytevector" str2)
	 (##core#inline "C_substring_copy" str str2 0 n 0)
	 str2) ) )
    (lambda (#!optional n (p ##sys#standard-input))
      (##sys#check-port p 'read-u8vector)
      (cond (n (##sys#check-exact n 'read-u8vector)
	       (let* ((str (##sys#allocate-vector n #t #f #t))
		      (n2 (##sys#read-string! n str p 0)) )
		 (##core#inline "C_string_to_bytevector" str)
		 (if (eq? n n2)
		     (##sys#make-structure 'u8vector str)
		     (wrap str n2) ) ) )
	    (else
	     (let ([str (open-output-string)])
	       (let loop ()
		 (let ([c (##sys#read-char-0 p)])
		   (if (eof-object? c)
		       (let* ((s (get-output-string str))
			      (n (##sys#size s)) )
			 (wrap s n) )
		       (begin
			 (##sys#write-char/port c str)
			 (loop)))))))))))

(register-feature! 'srfi-4)