mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-19 10:10:23 +02:00
Code Activity

fix c32vector-set!, c64vector-set!

Browse source 
* module/srfi/srfi-4/gnu.scm (bytevector-c32-native-set!):
  (bytevector-c64-native-set!): Fix to actually allow complex numbers.

* test-suite/tests/srfi-4.test: Add tests.
This commit is contained in:
Andy Wingo 2011-04-01 16:45:58 +02:00
parent c6b08d2194
commit 39bed56f67
2 changed files with 88 additions and 6 deletions
Download patch file Download diff file Expand all files Collapse all files

10
module/srfi/srfi-4/gnu.scm
View file

@ -1,6 +1,6 @@
;;; Extensions to SRFI-4 ;;; Extensions to SRFI-4
;; Copyright (C) 2009, 2010 Free Software Foundation, Inc. ;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
;; ;;
;; This library is free software; you can redistribute it and/or ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -83,14 +83,14 @@
(make-rectangular (bytevector-ieee-single-native-ref v i) (make-rectangular (bytevector-ieee-single-native-ref v i)
(bytevector-ieee-single-native-ref v (+ i 4)))) (bytevector-ieee-single-native-ref v (+ i 4))))
(define (bytevector-c32-native-set! v i x) (define (bytevector-c32-native-set! v i x)
(bytevector-ieee-single-native-set! v i x) (bytevector-ieee-single-native-set! v i (real-part x))
(bytevector-ieee-single-native-set! v (+ i 4) x)) (bytevector-ieee-single-native-set! v (+ i 4) (imag-part x)))
(define (bytevector-c64-native-ref v i) (define (bytevector-c64-native-ref v i)
(make-rectangular (bytevector-ieee-double-native-ref v i) (make-rectangular (bytevector-ieee-double-native-ref v i)
(bytevector-ieee-double-native-ref v (+ i 8)))) (bytevector-ieee-double-native-ref v (+ i 8))))
(define (bytevector-c64-native-set! v i x) (define (bytevector-c64-native-set! v i x)
(bytevector-ieee-double-native-set! v i x) (bytevector-ieee-double-native-set! v i (real-part x))
(bytevector-ieee-double-native-set! v (+ i 8) x)) (bytevector-ieee-double-native-set! v (+ i 8) (imag-part x)))
(define-bytevector-type c32 c32-native 8) (define-bytevector-type c32 c32-native 8)
(define-bytevector-type c64 c64-native 16) (define-bytevector-type c64 c64-native 16)

84
test-suite/tests/srfi-4.test
View file

@ -1,7 +1,7 @@
;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*- ;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-06-26 ;;;; Martin Grabmueller, 2001-06-26
;;;; ;;;;
;;;; Copyright (C) 2001, 2006, 2010 Free Software Foundation, Inc. ;;;; Copyright (C) 2001, 2006, 2010, 2011 Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -18,6 +18,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (srfi srfi-4) (use-modules (srfi srfi-4)
(srfi srfi-4 gnu)
(test-suite lib)) (test-suite lib))
(with-test-prefix "u8 vectors" (with-test-prefix "u8 vectors"
@ -396,3 +397,84 @@
(pass-if "+inf.0, -inf.0, +nan.0 in f64vector" (pass-if "+inf.0, -inf.0, +nan.0 in f64vector"
(f64vector? #f64(+inf.0 -inf.0 +nan.0)))) (f64vector? #f64(+inf.0 -inf.0 +nan.0))))
(with-test-prefix "c32 vectors"
(pass-if "c32vector? success"
(c32vector? (c32vector)))
(pass-if "c32vector? failure"
(not (c32vector? (s8vector))))
(pass-if "c32vector-length success 1"
(= (c32vector-length (c32vector)) 0))
(pass-if "c32vector-length success 2"
(= (c32vector-length (c32vector -3-2i)) 1))
(pass-if "c32vector-length failure"
(not (= (c32vector-length (c32vector 3)) 3)))
(pass-if "c32vector-ref"
(= (c32vector-ref (c32vector 1 2+13i 3) 1) 2+13i))
(pass-if "c32vector-set!/ref"
(= (let ((s (make-c32vector 10 0)))
(c32vector-set! s 4 33-1i)
(c32vector-ref s 4)) 33-1i))
(pass-if "c32vector->list/list->c32vector"
(equal? (c32vector->list (c32vector 1 2 3 4))
(c32vector->list (list->c32vector '(1 2 3 4)))))
(pass-if "c32vector->list/uniform-vector->list"
(equal? (c32vector->list (c32vector 1 2 3 4))
(uniform-vector->list (c32vector 1 2 3 4))))
(pass-if "make-c32vector"
(equal? (list->c32vector '(7 7 7 7))
(make-c32vector 4 7)))
(pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
(c32vector? #c32(+inf.0 -inf.0 +nan.0))))
(with-test-prefix "c64 vectors"
(pass-if "c64vector? success"
(c64vector? (c64vector)))
(pass-if "c64vector? failure"
(not (c64vector? (s8vector))))
(pass-if "c64vector-length success 1"
(= (c64vector-length (c64vector)) 0))
(pass-if "c64vector-length success 2"
(= (c64vector-length (c64vector -3-2i)) 1))
(pass-if "c64vector-length failure"
(not (= (c64vector-length (c64vector 3)) 3)))
(pass-if "c64vector-ref"
(= (c64vector-ref (c64vector 1+2i 2+3i 3) 1) 2+3i))
(pass-if "c64vector-set!/ref"
(= (let ((s (make-c64vector 10 0)))
(c64vector-set! s 4 33+1i)
(c64vector-ref s 4)) 33+1i))
(pass-if "c64vector->list/list->c64vector"
(equal? (c64vector->list (c64vector 1 2 3 4))
(c64vector->list (list->c64vector '(1 2 3 4)))))
(pass-if "c64vector->list/uniform-vector->list"
(equal? (c64vector->list (c64vector 1 2 3 4))
(uniform-vector->list (c64vector 1 2 3 4))))
(pass-if "make-c64vector"
(equal? (list->c64vector '(7 7 7 7))
(make-c64vector 4 7)))
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
(c64vector? #c64(+inf.0 -inf.0 +nan.0))))