[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.5-64-ge082b13

[Mark H Weaver]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".

http://git.savannah.gnu.org/cgit/guile.git/commit/?id=e082b13b662309021c73bae1561fb5c6d191d258

The branch, stable-2.0 has been updated
       via  e082b13b662309021c73bae1561fb5c6d191d258 (commit)
       via  ef405f8ba73fc57706d7155a2e008352416debcf (commit)
      from  d316047326fde9d63ca52c0051fbf09124ef297e (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit e082b13b662309021c73bae1561fb5c6d191d258
Author: Mark H Weaver <address@hidden>
Date:   Sun Feb 26 15:53:11 2012 -0500

    pmatch: always wrap with let, even if the expression appears atomic
    
    * module/system/base/pmatch.scm (pmatch): Always wrap with 'let', even
      if the expression appears atomic, because in the presence of
      'identifier-syntax', we cannot know what an atomic expression will
      later expand to.  Also use '#:export-syntax' instead of '#:export'
      to export 'pmatch'.

commit ef405f8ba73fc57706d7155a2e008352416debcf
Author: Mark H Weaver <address@hidden>
Date:   Thu Mar 1 16:07:28 2012 -0500

    Fix <TAG>vector-length when applied to other uniform vector types
    
    * module/srfi/srfi-4.scm, module/srfi/srfi-4/gnu.scm
      (define-bytevector-type): Fix definition of <TAG>vector-length when
      applied to uniform vectors of different element sizes.  Thanks to
      Tobias Brandt <address@hidden> for reporting this bug.
    
    * test-suite/tests/srfi-4.test: Add tests.

-----------------------------------------------------------------------

Summary of changes:
 module/srfi/srfi-4.scm        |    6 ++++--
 module/srfi/srfi-4/gnu.scm    |    5 +++--
 module/system/base/pmatch.scm |   16 ++++++++--------
 test-suite/tests/srfi-4.test  |   25 +++++++++++++++++++++++++
 4 files changed, 40 insertions(+), 12 deletions(-)

diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index 818ae7a..43f5ef6 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,7 @@
 ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
 
-;;     Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010 Free Software 
Foundation, Inc.
+;; Copyright (C) 2001, 2002, 2004, 2006, 2009, 2010,
+;;   2012 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
@@ -79,7 +80,8 @@
        (apply make-srfi-4-vector ',tag len fill))
      (define (,(symbol-append tag 'vector-length) v)
        (let ((len (* (uniform-vector-length v)
-                     (/ ,size (uniform-vector-element-size v)))))
+                     (uniform-vector-element-size v)
+                     (/ ,size))))
          (if (integer? len)
              len
              (error "fractional length" v ',tag ,size))))
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index ac22809..39d6350 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -1,6 +1,6 @@
 ;;; Extensions to SRFI-4
 
-;;     Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
+;; Copyright (C) 2009, 2010, 2011, 2012 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
@@ -52,7 +52,8 @@
        (apply make-srfi-4-vector ',tag len fill))
      (define (,(symbol-append tag 'vector-length) v)
        (let ((len (* (uniform-vector-length v)
-                     (/ ,size (uniform-vector-element-size v)))))
+                     (uniform-vector-element-size v)
+                     (/ ,size))))
          (if (integer? len)
              len
              (error "fractional length" v ',tag ,size))))
diff --git a/module/system/base/pmatch.scm b/module/system/base/pmatch.scm
index 00563f6..e9b9eb2 100644
--- a/module/system/base/pmatch.scm
+++ b/module/system/base/pmatch.scm
@@ -1,6 +1,6 @@
 ;;; pmatch, a simple matcher
 
-;;; Copyright (C) 2009, 2010 Free Software Foundation, Inc
+;;; Copyright (C) 2009, 2010, 2012 Free Software Foundation, Inc
 ;;; Copyright (C) 2005,2006,2007 Oleg Kiselyov
 ;;; Copyright (C) 2007 Daniel P. Friedman
 ;;;
@@ -35,22 +35,22 @@
 ;;; Code:
 
 (define-module (system base pmatch)
-  #:export (pmatch))
+  #:export-syntax (pmatch))
 
-(define-syntax pmatch
+(define-syntax-rule (pmatch e cs ...)
+  (let ((v e)) (pmatch1 v cs ...)))
+
+(define-syntax pmatch1
   (syntax-rules (else guard)
-    ((_ (op arg ...) cs ...)
-     (let ((v (op arg ...)))
-       (pmatch v cs ...)))
     ((_ v) (if #f #f))
     ((_ v (else e0 e ...)) (let () e0 e ...))
     ((_ v (pat (guard g ...) e0 e ...) cs ...)
-     (let ((fk (lambda () (pmatch v cs ...))))
+     (let ((fk (lambda () (pmatch1 v cs ...))))
        (ppat v pat
              (if (and g ...) (let () e0 e ...) (fk))
              (fk))))
     ((_ v (pat e0 e ...) cs ...)
-     (let ((fk (lambda () (pmatch v cs ...))))
+     (let ((fk (lambda () (pmatch1 v cs ...))))
        (ppat v pat (let () e0 e ...) (fk))))))
 
 (define-syntax ppat
diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test
index 2e7f0d5..033e39f 100644
--- a/test-suite/tests/srfi-4.test
+++ b/test-suite/tests/srfi-4.test
@@ -515,3 +515,28 @@
   (pass-if-exception "generalized-vector-set!, out-of-range"
     exception:out-of-range
     (generalized-vector-set! (c64vector 1.0) 1 2.0)))
+
+(with-test-prefix "accessing uniform vectors of different types"
+
+  (pass-if "u32vector-length of u16vector"
+    (= 2 (u32vector-length (make-u16vector 4))))
+
+  (pass-if "u32vector-length of u8vector"
+    (= 2 (u32vector-length (make-u8vector 8))))
+
+  (pass-if "u8vector-length of u16vector"
+    (= 4 (u8vector-length (make-u16vector 2))))
+
+  (pass-if "u8vector-length of u32vector"
+    (= 8 (u8vector-length (make-u32vector 2))))
+
+  (pass-if "u32vector-set! of u16vector"
+    (let ((v (make-u16vector 4 #xFFFF)))
+      (u32vector-set! v 1 0)
+      (equal? v #u16(#xFFFF #xFFFF 0 0))))
+
+  (pass-if "u16vector-set! of u32vector"
+    (let ((v (make-u32vector 2 #xFFFFFFFF)))
+      (u16vector-set! v 2 0)
+      (u16vector-set! v 3 0)
+      (equal? v #u32(#xFFFFFFFF 0)))))


hooks/post-receive
-- 
GNU Guile