reimplement srfi-4 vectors on top of bytevectors

* libguile/srfi-4.h:
* libguile/srfi-4.c (scm_make_srfi_4_vector): New function, exported by
  (srfi srfi-4 gnu).
* libguile/srfi-4.i.c: Removed.
* module/srfi/srfi-4.scm:
* module/srfi/srfi-4/gnu.scm: Reimplement srfi-4 vectors on top of
  bytevectors. The implementation is mostly in Scheme now.

* test-suite/tests/unif.test: Update to use (srfi srfi-4 gnu).

* libguile/bytevectors.c (bytevector_ref_c32, bytevector_ref_c64)
  (bytevector_set_c32, bytevector_set_c64): Fix some embarrassing bugs.
  Still need to do an upper bounds check.

* libguile/deprecated.h: Remove deprecated array functions:
  scm_i_arrayp, scm_i_array_ndim, scm_i_array_mem, scm_i_array_v,
  scm_i_array_base, scm_i_array_dims, and the deprecated macros:
  SCM_ARRAYP, SCM_ARRAY_NDIM, SCM_ARRAY_CONTP, SCM_ARRAY_MEM,
  SCM_ARRAY_V, SCM_ARRAY_BASE, SCM_ARRAY_DIMS.
* libguile/deprecated.c (scm_uniform_vector_read_x)
  (scm_uniform_vector_write, scm_uniform_array_read_x)
  (scm_uniform_array_write): Newly deprecated functions.

* libguile/generalized-arrays.c (scm_array_type): Remove the bytevector
  hack.

* libguile/objcodes.c (scm_bytecode_to_objcode, scm_objcode_to_bytecode):
  Rework to operate on bytevectors, as scm_make_u8vector now causes a
  module lookup, which can't be done e.g. when loading the VM boot
  program for psyntax-pp.go on a fresh bootstrap.

* libguile/objcodes.h (SCM_F_OBJCODE_IS_BYTEVECTOR):
  (SCM_OBJCODE_IS_BYTEVECTOR): s/U8VECTOR/BYTEVECTOR/.

* module/ice-9/boot-9.scm (the-scm-module): A terrible hack to pull in
  (srfi srfi-4), as the bindings are primarily there now. We'll worry
  about this later.

1 files changed, 107 insertions, 42 deletions

diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index b133f2106..8438ba33a 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -1,6 +1,6 @@
 ;;; srfi-4.scm --- Homogeneous Numeric Vector Datatypes
 
-;; 	Copyright (C) 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; 	Copyright (C) 2001, 2002, 2004, 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
@@ -26,46 +26,111 @@
 
 ;;; Code:
 
-(define-module (srfi srfi-4))
+(define-module (srfi srfi-4)
+  #:use-module (rnrs bytevector)
+  #:export (;; Unsigned 8-bit vectors.
+            u8vector? make-u8vector u8vector u8vector-length u8vector-ref
+            u8vector-set! u8vector->list list->u8vector
+
+            ;; Signed 8-bit vectors.
+            s8vector? make-s8vector s8vector s8vector-length s8vector-ref
+            s8vector-set! s8vector->list list->s8vector
+
+            ;; Unsigned 16-bit vectors.
+            u16vector? make-u16vector u16vector u16vector-length u16vector-ref
+            u16vector-set! u16vector->list list->u16vector
+
+            ;; Signed 16-bit vectors.
+            s16vector? make-s16vector s16vector s16vector-length s16vector-ref
+            s16vector-set! s16vector->list list->s16vector
+
+            ;; Unsigned 32-bit vectors.
+            u32vector? make-u32vector u32vector u32vector-length u32vector-ref
+            u32vector-set! u32vector->list list->u32vector
+
+            ;; Signed 32-bit vectors.
+            s32vector? make-s32vector s32vector s32vector-length s32vector-ref
+            s32vector-set! s32vector->list list->s32vector
+
+            ;; Unsigned 64-bit vectors.
+            u64vector? make-u64vector u64vector u64vector-length u64vector-ref
+            u64vector-set! u64vector->list list->u64vector
+
+            ;; Signed 64-bit vectors.
+            s64vector? make-s64vector s64vector s64vector-length s64vector-ref
+            s64vector-set! s64vector->list list->s64vector
+
+            ;; 32-bit floating point vectors.
+            f32vector? make-f32vector f32vector f32vector-length f32vector-ref
+            f32vector-set! f32vector->list list->f32vector
+
+            ;; 64-bit floating point vectors.
+            f64vector? make-f64vector f64vector f64vector-length f64vector-ref
+            f64vector-set! f64vector->list list->f64vector))
+
+
+;; Need quasisyntax to do this effectively using syntax-case
+(define-macro (define-bytevector-type tag infix size)
+  `(begin
+     (define (,(symbol-append tag 'vector?) obj)
+       (and (uniform-vector? obj)
+            (eq? (uniform-vector-element-type obj) ',tag)))
+     (define (,(symbol-append 'make- tag 'vector) len . fill)
+       (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)))))
+         (if (integer? len)
+             len
+             (error "fractional length" v ',tag ,size))))
+     (define (,(symbol-append tag 'vector) . elts)
+       (,(symbol-append 'list-> tag 'vector) elts))
+     (define (,(symbol-append 'list-> tag 'vector) elts)
+       (let* ((len (length elts))
+              (v (,(symbol-append 'make- tag 'vector) len)))
+         (let lp ((i 0) (elts elts))
+           (if (and (< i len) (pair? elts))
+               (begin
+                 (,(symbol-append tag 'vector-set!) v i (car elts))
+                 (lp (1+ i) (cdr elts)))
+               v))))
+     (define (,(symbol-append tag 'vector->list) v)
+       (let lp ((i (1- (,(symbol-append tag 'vector-length) v))) (elts '()))
+         (if (< i 0)
+             elts
+             (lp (1- i) (cons (,(symbol-append tag 'vector-ref) v i) elts)))))
+     (define (,(symbol-append tag 'vector-ref) v i)
+       (,(symbol-append 'bytevector- infix '-ref) v (* i ,size)))
+     (define (,(symbol-append tag 'vector-set!) v i x)
+       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))
+     (define (,(symbol-append tag 'vector-set!) v i x)
+       (,(symbol-append 'bytevector- infix '-set!) v (* i ,size) x))))
+
+(define-bytevector-type u8 u8 1)
+(define-bytevector-type s8 s8 1)
+(define-bytevector-type u16 u16-native 2)
+(define-bytevector-type s16 s16-native 2)
+(define-bytevector-type u32 u32-native 4)
+(define-bytevector-type s32 s32-native 4)
+(define-bytevector-type u64 u64-native 8)
+(define-bytevector-type s64 s64-native 8)
+(define-bytevector-type f32 ieee-single-native 4)
+(define-bytevector-type f64 ieee-double-native 8)
+
+(define (bytevector-c32-ref v i)
+  (make-rectangular (bytevector-ieee-single-native-ref v i)
+                    (bytevector-ieee-single-native-ref v (+ i 4))))
+(define (bytevector-c32-set! v i x)
+  (bytevector-ieee-single-native-set! v i x)
+  (bytevector-ieee-single-native-set! v (+ i 4) x))
+(define-bytevector-type c32 c32 8)
+
+(define (bytevector-c64-ref v i)
+  (make-rectangular (bytevector-ieee-double-native-ref v i)
+                    (bytevector-ieee-double-native-ref v (+ i 8))))
+(define (bytevector-c64-set! v i x)
+  (bytevector-ieee-double-native-set! v i x)
+  (bytevector-ieee-double-native-set! v (+ i 8) x))
+(define-bytevector-type c64 c64 16)
 
-(re-export
-;;; Unsigned 8-bit vectors.
- u8vector? make-u8vector u8vector u8vector-length u8vector-ref
- u8vector-set! u8vector->list list->u8vector
 
-;;; Signed 8-bit vectors.
- s8vector? make-s8vector s8vector s8vector-length s8vector-ref
- s8vector-set! s8vector->list list->s8vector
-
-;;; Unsigned 16-bit vectors.
- u16vector? make-u16vector u16vector u16vector-length u16vector-ref
- u16vector-set! u16vector->list list->u16vector
-
-;;; Signed 16-bit vectors.
- s16vector? make-s16vector s16vector s16vector-length s16vector-ref
- s16vector-set! s16vector->list list->s16vector
-
-;;; Unsigned 32-bit vectors.
- u32vector? make-u32vector u32vector u32vector-length u32vector-ref
- u32vector-set! u32vector->list list->u32vector
-
-;;; Signed 32-bit vectors.
- s32vector? make-s32vector s32vector s32vector-length s32vector-ref
- s32vector-set! s32vector->list list->s32vector
-
-;;; Unsigned 64-bit vectors.
- u64vector? make-u64vector u64vector u64vector-length u64vector-ref
- u64vector-set! u64vector->list list->u64vector
-
-;;; Signed 64-bit vectors.
- s64vector? make-s64vector s64vector s64vector-length s64vector-ref
- s64vector-set! s64vector->list list->s64vector
-
-;;; 32-bit floating point vectors.
- f32vector? make-f32vector f32vector f32vector-length f32vector-ref
- f32vector-set! f32vector->list list->f32vector
-
-;;; 64-bit floating point vectors.
- f64vector? make-f64vector f64vector f64vector-length f64vector-ref
- f64vector-set! f64vector->list list->f64vector
- )