and it works!srfi-4-bytevectors

7 files changed, 98 insertions, 54 deletions

diff --git a/libguile/array.c b/libguile/array.c
index 945b9c5e1..121156f4c 100644
--- a/libguile/array.c
+++ b/libguile/array.c
@@ -234,10 +234,20 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
   sz = scm_array_handle_uniform_element_size (&h);
   scm_array_handle_release (&h);
 
-  if (byte_len % sz)
-    SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
-  if (byte_len / sz != rlen)
-    SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+  if (sz < 8)
+    {
+      if (byte_len > SCM_I_SIZE_MAX / 8)
+        SCM_MISC_ERROR ("byte length too large for unit size", SCM_EOL);
+      else if (byte_len * 8 % sz)
+        SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+    }
+  else
+    {
+      if (byte_len % (sz / 8))
+        SCM_MISC_ERROR ("byte length not a multiple of the unit size", SCM_EOL);
+      if (byte_len / (sz / 8) != rlen)
+        SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+    }
 
   memcpy (base, bytes, byte_len);
 
@@ -524,7 +534,7 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 	return SCM_BOOL_F;
       for (k = 0; k < ndim; k++)
 	len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
-      if (!SCM_UNBNDP (strict))
+      if (!SCM_UNBNDP (strict) && scm_is_true (strict))
 	{
 	  if (ndim && (1 != SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc))
 	    return SCM_BOOL_F;
@@ -558,7 +568,36 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 #undef FUNC_NAME
 
 
-static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
+static void
+list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
+{
+  if (k == scm_array_handle_rank (handle))
+    scm_array_handle_set (handle, pos, lst);
+  else
+    {
+      scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
+      ssize_t inc = dim->inc;
+      size_t len = 1 + dim->ubnd - dim->lbnd, n;
+      char *errmsg = NULL;
+
+      n = len;
+      while (n > 0 && scm_is_pair (lst))
+	{
+	  list_to_array (SCM_CAR (lst), handle, pos, k + 1);
+	  pos += inc;
+	  lst = SCM_CDR (lst);
+	  n -= 1;
+	}
+      if (n != 0)
+	errmsg = "too few elements for array dimension ~a, need ~a";
+      if (!scm_is_null (lst))
+	errmsg = "too many elements for array dimension ~a, want ~a";
+      if (errmsg)
+	scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
+						  scm_from_size_t (len)));
+    }
+}
+  
 
 SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
            (SCM type, SCM shape, SCM lst),
@@ -623,7 +662,7 @@ SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
 			     scm_reverse_x (shape, SCM_EOL));
 
   scm_array_get_handle (ra, &handle);
-  l2ra (lst, &handle, 0, 0);
+  list_to_array (lst, &handle, 0, 0);
   scm_array_handle_release (&handle);
 
   return ra;
@@ -639,36 +678,6 @@ SCM_DEFINE (scm_list_to_array, "list->array", 2, 0, 0,
 }
 #undef FUNC_NAME
 
-static void
-l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
-{
-  if (k == scm_array_handle_rank (handle))
-    scm_array_handle_set (handle, pos, lst);
-  else
-    {
-      scm_t_array_dim *dim = scm_array_handle_dims (handle) + k;
-      ssize_t inc = dim->inc;
-      size_t len = 1 + dim->ubnd - dim->lbnd, n;
-      char *errmsg = NULL;
-
-      n = len;
-      while (n > 0 && scm_is_pair (lst))
-	{
-	  l2ra (SCM_CAR (lst), handle, pos, k + 1);
-	  pos += inc;
-	  lst = SCM_CDR (lst);
-	  n -= 1;
-	}
-      if (n != 0)
-	errmsg = "too few elements for array dimension ~a, need ~a";
-      if (!scm_is_null (lst))
-	errmsg = "too many elements for array dimension ~a, want ~a";
-      if (errmsg)
-	scm_misc_error (NULL, errmsg, scm_list_2 (scm_from_ulong (k),
-						  scm_from_size_t (len)));
-    }
-}
-
 /* Print dimension DIM of ARRAY.
  */
 
@@ -958,6 +967,38 @@ array_free (SCM ptr)
   return 0;
 }
 
+static SCM
+array_handle_ref (scm_t_array_handle *h, size_t pos)
+{
+  return scm_c_generalized_vector_ref (SCM_I_ARRAY_V (h->array), pos);
+}
+
+static void
+array_handle_set (scm_t_array_handle *h, size_t pos, SCM val)
+{
+  scm_c_generalized_vector_set_x (SCM_I_ARRAY_V (h->array), pos, val);
+}
+
+/* FIXME: should be handle for vect? maybe not, because of dims */
+static void
+array_get_handle (SCM array, scm_t_array_handle *h)
+{
+  scm_t_array_handle vh;
+  scm_array_get_handle (SCM_I_ARRAY_V (array), &vh);
+  h->element_type = vh.element_type;
+  h->elements = vh.elements;
+  h->writable_elements = vh.writable_elements;
+  scm_array_handle_release (&vh);
+
+  h->dims = SCM_I_ARRAY_DIMS (array);
+  h->ndims = SCM_I_ARRAY_NDIM (array);
+  h->base = SCM_I_ARRAY_BASE (array);
+}
+
+SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+                          array_handle_ref, array_handle_set,
+                          array_get_handle);
+
 void
 scm_init_array ()
 {
diff --git a/libguile/bytevectors.c b/libguile/bytevectors.c
index 8706b2531..4f3d7533e 100644
--- a/libguile/bytevectors.c
+++ b/libguile/bytevectors.c
@@ -253,7 +253,7 @@ make_bytevector (size_t len, scm_t_array_element_type element_type)
   else
     {
       void *buf = scm_gc_malloc (c_len, SCM_GC_BYTEVECTOR);
-      return make_bytevector_from_buffer (c_len, buf, element_type);
+      return make_bytevector_from_buffer (len, buf, element_type);
     }
 }
 
@@ -433,7 +433,7 @@ bv_handle_ref (scm_t_array_handle *h, size_t index)
   
   ref_fn = bytevector_ref_fns[h->element_type];
   byte_index =
-    scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+    scm_from_size_t (index * (scm_array_handle_uniform_element_size (h)/8));
   return ref_fn (h->array, byte_index);
 }
 
@@ -487,7 +487,7 @@ bv_handle_set_x (scm_t_array_handle *h, size_t index, SCM val)
   
   set_fn = bytevector_set_fns[h->element_type];
   byte_index =
-    scm_from_size_t (index * scm_array_handle_uniform_element_size (h));
+    scm_from_size_t (index * (scm_array_handle_uniform_element_size (h)/8));
   set_fn (h->array, byte_index, val);
 }
 
@@ -2197,7 +2197,7 @@ bytevector_get_handle (SCM v, scm_t_array_handle *h)
   h->ndims = 1;
   h->dims = &h->dim0;
   h->dim0.lbnd = 0;
-  h->dim0.ubnd = SCM_BYTEVECTOR_LENGTH (v) - 1;
+  h->dim0.ubnd = SCM_BYTEVECTOR_TYPED_LENGTH (v) - 1;
   h->dim0.inc = 1;
   h->element_type = SCM_BYTEVECTOR_ELEMENT_TYPE (v);
   h->elements = h->writable_elements = SCM_BYTEVECTOR_CONTENTS (v);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 36a463ad3..b081070fb 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -3429,6 +3429,9 @@ module '(ice-9 q) '(make-q q-length))}."
 ;; 		 (module-eval-closure (current-module))))
 ;;     (deannotate/source-properties (sc-expand (annotate exp)))))
 
+;; FIXME:
+(module-use! the-root-module (resolve-interface '(srfi srfi-4)))
+
 (define-module (guile-user)
   #:autoload (system base compile) (compile))
 
diff --git a/module/language/glil/compile-assembly.scm b/module/language/glil/compile-assembly.scm
index 0b92a4e7d..4aaa08bb2 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -387,11 +387,13 @@
                             (addr+ addr code)))))))
    ((and (array? x) (symbol? (array-type x)))
     (let* ((type (dump-object (array-type x) addr))
-           (shape (dump-object (array-shape x) (addr+ addr type))))
+           (shape (dump-object (array-shape x) (addr+ addr type)))
+           (contig (or (array-contents x #t)
+                       (error "non-contiguous array" x))))
       `(,@type
         ,@shape
         ,@(align-code
-           `(load-array ,(uniform-array->bytevector x))
+           `(load-array ,(shared-array-root contig))
            (addr+ (addr+ addr type) shape)
            8
            4))))
diff --git a/module/rnrs/bytevector.scm b/module/rnrs/bytevector.scm
index 32929c698..f065b55fa 100644
--- a/module/rnrs/bytevector.scm
+++ b/module/rnrs/bytevector.scm
@@ -33,7 +33,6 @@
   :export (native-endianness bytevector?
            make-bytevector bytevector-length bytevector=? bytevector-fill!
            bytevector-copy! bytevector-copy
-           uniform-array->bytevector
            bytevector-u8-ref bytevector-s8-ref
            bytevector-u8-set! bytevector-s8-set! bytevector->u8-list
            u8-list->bytevector
diff --git a/module/srfi/srfi-4.scm b/module/srfi/srfi-4.scm
index b72780f43..53e007ef2 100644
--- a/module/srfi/srfi-4.scm
+++ b/module/srfi/srfi-4.scm
@@ -27,6 +27,7 @@
 ;;; Code:
 
 (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
@@ -68,11 +69,6 @@
             f64vector-set! f64vector->list list->f64vector))
 
 
-<<<<<<< Updated upstream:module/srfi/srfi-4.scm
-(load-extension "libguile" "scm_init_srfi_4_internal")
-
-=======
->>>>>>> Stashed changes:module/srfi/srfi-4.scm
 ;; Need quasisyntax to do this effectively using syntax-case
 (define-macro (define-bytevector-type tag infix size)
   `(begin
diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm
index 95c52e835..2a8073969 100644
--- a/module/srfi/srfi-4/gnu.scm
+++ b/module/srfi/srfi-4/gnu.scm
@@ -23,12 +23,13 @@
 ;;; Code:
 
 (define-module (srfi srfi-4 gnu)
+  #:use-module (rnrs bytevector)
   #:use-module (srfi srfi-4)
   #:export (;; Complex numbers with 32- and 64-bit components.
-            c32vector? make-c32vector c32vector c32vector-length c32vector-rec
+            c32vector? make-c32vector c32vector c32vector-length c32vector-ref
             c32vector-set! c32vector->list list->c32vector
 
-            c64vector? make-c64vector c64vector c64vector-length c64vector-rec
+            c64vector? make-c64vector c64vector c64vector-length c64vector-ref
             c64vector-set! c64vector->list list->c64vector
 
             make-srfi-4-vector
@@ -39,13 +40,15 @@
             any->f32vector any->f64vector any->c32vector any->c64vector))
 
 
+(define make-srfi-4-vector (@@ (srfi srfi-4) make-srfi-4-vector))
+
 ;; 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 (bytevector? obj) (eq? (bytevector-type obj) ',tag)))
      (define (,(symbol-append 'make- tag 'vector) len . fill)
-       (apply make-srfi-4-vector len ',tag fill))
+       (apply make-srfi-4-vector ',tag len fill))
      (define (,(symbol-append tag 'vector-length) v)
        (bytevector-typed-length v ',tag))
      (define (,(symbol-append tag 'vector) . elts)
@@ -83,8 +86,8 @@
 (define (bytevector-c64-native-set! v i x)
   (bytevector-ieee-double-native-set! v i x)
   (bytevector-ieee-double-native-set! v (+ i 8) x))
-(define-bytevector-type c32 c32 8)
-(define-bytevector-type c64 c64 16)
+(define-bytevector-type c32 c32-native 8)
+(define-bytevector-type c64 c64-native 16)
 
 (define-macro (define-any->vector . tags)
   `(begin