guile-srfi-123

commit 988cf22ad345c0d9b3bbef40bc4753d24a49bbdb
parent 4dd99cea8eb2adce4f6a9d349c0bdbd66bd019d2
Author: Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com>
Date:   Sun, 23 Aug 2015 14:59:31 +0200

Handle SRFI-4 vectors that are bytevectors.

Diffstat:
M
srfi/123.body.scm
 | 
25
+++++++++++++++++++++----

1 file changed, 21 insertions(+), 4 deletions(-)
diff --git a/srfi/123.body.scm b/srfi/123.body.scm
@@ -55,6 +55,11 @@
 
 ;;; SRFI-4 support
 
+;;; In some implementations, SRFI-4 vectors are also bytevectors.  We accomodate
+;;; for those implementations by using generic bytevector-ref/set! procedures
+;;; which possibly dispatch to an SRFI-4 type's getter/setter, but also
+;;; inserting the SRFI-4 getters/setters into the top-level dispatch tables.
+
 (cond-expand
  ((library (srfi 4))
   (define srfi-4-getters
@@ -77,11 +82,23 @@
           (cons u64vector? u64vector-set!)))
   (define srfi-4-types
     (list s8vector? u8vector? s16vector? u16vector? s32vector? u32vector?
-          s64vector? u64vector?)))
+          s64vector? u64vector?))
+  (define srfi-4-getters-table (alist->hashtable srfi-4-getters))
+  (define srfi-4-setters-table (alist->hashtable srfi-4-setters))
+  (define (bytevector-ref bytevector index)
+    (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
+           (getter (ref srfi-4-getters-table type bytevector-u8-ref)))
+      (getter bytevector index)))
+  (define (bytevector-set! bytevector index value)
+    (let* ((type (find (lambda (pred) (pred bytevector))) srfi-4-types)
+           (setter (ref srfi-4-setters-table type bytevector-u8-set!)))
+      (setter bytevector index value))))
  (else
   (define srfi-4-getters '())
   (define srfi-4-setters '())
-  (define srfi-4-types '())))
+  (define srfi-4-types '())
+  (define bytevector-ref bytevector-u8-ref)
+  (define bytevector-set! bytevector-u8-set!)))
 
 ;;; Main
 
@@ -145,7 +162,7 @@
 (define getter-table
   (alist->hashtable
    (append
-    (list (cons bytevector? bytevector-u8-ref)
+    (list (cons bytevector? bytevector-ref)
           (cons hashtable? hashtable-ref)
           (cons pair? pair-ref)
           (cons string? string-ref)
@@ -155,7 +172,7 @@
 (define setter-table
   (alist->hashtable
    (append
-    (list (cons bytevector? bytevector-u8-set!)
+    (list (cons bytevector? bytevector-set!)
           (cons hashtable? hashtable-set!)
           (cons pair? pair-set!)
           (cons string? string-set!)