From 0142d376b85f963269f8aa1788d92a4910b0b9a9 Mon Sep 17 00:00:00 2001 From: Andy Wingo Date: Sun, 29 Aug 2010 20:48:32 -0700 Subject: [PATCH] bitvector work * test-suite/Makefile.am: * test-suite/tests/bitvectors.test: Add a new file to test bitvectors. * libguile/uniform.c (scm_c_uniform_vector_length): Don't call scm_uniform_vector_elements, as we don't need to be able to access the elements with pointers to bytes. Fixes uniform-vector-length on bitvectors. --- libguile/uniform.c | 14 ++++---- test-suite/Makefile.am | 1 + test-suite/tests/bitvectors.test | 59 ++++++++++++++++++++++++++++++++ 3 files changed, 66 insertions(+), 8 deletions(-) create mode 100644 test-suite/tests/bitvectors.test diff --git a/libguile/uniform.c b/libguile/uniform.c index 229c092ac..cab976e4c 100644 --- a/libguile/uniform.c +++ b/libguile/uniform.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc. +/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or * modify it under the terms of the GNU Lesser General Public License @@ -99,13 +99,11 @@ scm_is_uniform_vector (SCM obj) size_t scm_c_uniform_vector_length (SCM uvec) { - scm_t_array_handle h; - size_t len; - ssize_t inc; - - scm_uniform_vector_elements (uvec, &h, &len, &inc); - scm_array_handle_release (&h); - return len; + if (!scm_is_uniform_vector (uvec)) + scm_wrong_type_arg_msg ("uniform-vector-length", 1, uvec, + "uniform vector"); + + return scm_c_generalized_vector_length (uvec); } SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0, diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index eab1cd5f0..eaa751296 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -28,6 +28,7 @@ SCM_TESTS = tests/00-initial-env.test \ tests/arrays.test \ tests/asm-to-bytecode.test \ tests/bit-operations.test \ + tests/bitvectors.test \ tests/brainfuck.test \ tests/bytevectors.test \ tests/c-api.test \ diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test new file mode 100644 index 000000000..9833b3bfd --- /dev/null +++ b/test-suite/tests/bitvectors.test @@ -0,0 +1,59 @@ +;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*- +;;;; +;;;; Copyright 2010 Free Software Foundation, Inc. +;;;; +;;;; This library is free software; you can redistribute it and/or +;;;; modify it under the terms of the GNU Lesser General Public +;;;; License as published by the Free Software Foundation; either +;;;; version 3 of the License, or (at your option) any later version. +;;;; +;;;; This library is distributed in the hope that it will be useful, +;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;;; Lesser General Public License for more details. +;;;; +;;;; You should have received a copy of the GNU Lesser General Public +;;;; License along with this library; if not, write to the Free Software +;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (test-suite test-bitvectors) + #:use-module (test-suite lib)) + + +(with-test-prefix "predicates" + (pass-if (bitvector? #*1010101010)) + (pass-if (generalized-vector? #*1010101010)) + (pass-if (uniform-vector? #*1010101010)) + (pass-if (array? #*1010101010))) + + +(with-test-prefix "equality" + (pass-if (equal? #*1010101 #*1010101)) + (pass-if (array-equal? #*1010101 #*1010101)) + + (pass-if (not (equal? #*10101010 #*1010101))) + (pass-if (not (array-equal? #*10101010 #*1010101)))) + +(with-test-prefix "lists" + (pass-if (equal? (bitvector->list #*10010) '(#t #f #f #t #f))) + (pass-if (equal? (array->list #*10010) '(#t #f #f #t #f))) + (pass-if (equal? (uniform-vector->list #*10010) '(#t #f #f #t #f))) + (pass-if (equal? #*10010 (list->bitvector '(#t #f #f #t #f))))) + +(with-test-prefix "ref and set" + (with-test-prefix "bv" + (let ((bv (list->bitvector '(#f #f #t #f #t)))) + (pass-if (eqv? (bitvector-ref bv 0) #f)) + (pass-if (eqv? (bitvector-ref bv 2) #t)) + (bitvector-set! bv 0 #t) + (pass-if (eqv? (bitvector-ref bv 0) #t)))) + + (with-test-prefix "uv" + (let ((bv (list->bitvector '(#f #f #t #f #t)))) + (pass-if (eqv? (uniform-vector-ref bv 0) #f)) + (pass-if (eqv? (uniform-vector-ref bv 2) #t)) + (uniform-vector-set! bv 0 #t) + (pass-if (eqv? (uniform-vector-ref bv 0) #t))))) + + + -- 2.20.1