Re: [patch] literal arrays in master

[Daniel Llorens <daniel.llorens@bluewin.ch>]

[-- Attachment #1: Type: text/plain, Size: 516 bytes --]


Now with a test. The first patch makes most of test-suite/tests/arrays.test run under both the compiler and the interpreter. It produces a large amount of errors under the compiler. The next two patches are the same as in the last email and fix these errors.

However, it's interesting to me that the errors in arrays.test somehow don't count as a failure in the final summary of the test suite. I believe this could be a bug in the test framework, but I'm not familiar with that code.

Regards,

	Daniel


[-- Attachment #2: 0001-Run-some-of-arrays.test-under-both-compiler-interpre.patch --]
[-- Type: application/octet-stream, Size: 5295 bytes --]

From 235e46ba42b19ac970d0ed268e32214e80662cff Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Fri, 19 Sep 2014 13:58:59 +0200
Subject: [PATCH 1/3] Run some of arrays.test under both compiler &
 interpreter

* test-suite/test-suite/lib.scm (c&e): accept (pass-if exp) clause.

* test-suite/tests/arrays.test: use with-prefix/c&e instead of
  with-prefix where possible.
---
 test-suite/test-suite/lib.scm |    2 ++
 test-suite/tests/arrays.test  |   52 ++++++++++++++++++++---------------------
 2 files changed, 28 insertions(+), 26 deletions(-)

diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index 9ecaf89..b571122 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -462,6 +462,8 @@
 (define-syntax c&e
   (syntax-rules (pass-if pass-if-equal pass-if-exception)
     "Run the given tests both with the evaluator and the compiler/VM."
+    ((_ (pass-if exp))
+     (c&e (pass-if "[unnamed test]" exp)))
     ((_ (pass-if test-name exp))
      (begin (pass-if (string-append test-name " (eval)")
                      (primitive-eval 'exp))
diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test
index 415f183..803c297 100644
--- a/test-suite/tests/arrays.test
+++ b/test-suite/tests/arrays.test
@@ -200,7 +200,7 @@
 ;;; array-equal?
 ;;;

-(with-test-prefix "array-equal?"
+(with-test-prefix/c&e "array-equal?"

   (pass-if "#s16(...)"
     (array-equal? #s16(1 2 3) #s16(1 2 3))))
@@ -212,7 +212,7 @@
 (define exception:mapping-out-of-range
   (cons 'misc-error "^mapping out of range"))  ;; per scm_make_shared_array

-(with-test-prefix "make-shared-array"
+(with-test-prefix/c&e "make-shared-array"

   ;; this failed in guile 1.8.0
   (pass-if "vector unchanged"
@@ -283,9 +283,9 @@
 ;;; array-contents
 ;;;

-(with-test-prefix "array-contents"
+(define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))

-  (define (every-two x) (make-shared-array x (lambda (i) (list (* i 2))) 2))
+(with-test-prefix/c&e "array-contents"

   (pass-if "simple vector"
     (let* ((a (make-array 0 4)))
@@ -362,10 +362,10 @@
 ;;; shared-array-root
 ;;;

-(with-test-prefix "shared-array-root"
+(define amap1 (lambda (i) (list (* 2 i))))
+(define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))

-  (define amap1 (lambda (i) (list (* 2 i))))
-  (define amap2 (lambda (i j) (list (+ 1 (* 2 i)) (+ 1 (* 2 j)))))
+(with-test-prefix/c&e "shared-array-root"

   (pass-if "plain vector"
     (let* ((a (make-vector 4 0))
@@ -395,7 +395,7 @@
 (define exception:wrong-type-arg
   (cons #t "Wrong type"))

-(with-test-prefix "transpose-array"
+(with-test-prefix/c&e "transpose-array"

   (pass-if-exception "non array argument" exception:wrong-type-arg
     (transpose-array 99))
@@ -436,11 +436,11 @@
 ;;; array->list
 ;;;

-(with-test-prefix "array->list"
-  (pass-if-equal '(1 2 3) (array->list #s16(1 2 3)))
-  (pass-if-equal '(1 2 3) (array->list #(1 2 3)))
-  (pass-if-equal '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
-  (pass-if-equal '()  (array->list #()))
+(with-test-prefix/c&e "array->list"
+  (pass-if-equal "uniform vector" '(1 2 3) (array->list #s16(1 2 3)))
+  (pass-if-equal "vector" '(1 2 3) (array->list #(1 2 3)))
+  (pass-if-equal "rank 2 array" '((1 2) (3 4) (5 6)) (array->list #2((1 2) (3 4) (5 6))))
+  (pass-if-equal "empty vector" '()  (array->list #()))

   (pass-if-equal "http://bugs.gnu.org/12465 - ok"
       '(3 4)
@@ -531,7 +531,7 @@
 ;;; array-in-bounds?
 ;;;

-(with-test-prefix "array-in-bounds?"
+(with-test-prefix/c&e "array-in-bounds?"

   (pass-if (let ((a (make-array #f '(425 425))))
 	     (eq? #f (array-in-bounds? a 0)))))
@@ -542,7 +542,7 @@

 (with-test-prefix "array-type"

-  (with-test-prefix "on make-foo-vector"
+  (with-test-prefix/c&e "on make-foo-vector"

     (pass-if "bool"
       (eq? 'b (array-type (make-bitvector 1))))
@@ -728,7 +728,7 @@
 ;;; syntax
 ;;;

-(with-test-prefix "syntax"
+(with-test-prefix/c&e "syntax"

   (pass-if "rank and lower bounds"
     ;; uniform u32 array of rank 2 with index ranges 2..3 and 7..8.
@@ -770,7 +770,7 @@
 ;;; equal? with vector and one-dimensional array
 ;;;

-(with-test-prefix "equal?"
+(with-test-prefix/c&e "equal?"
   (pass-if "array and non-array"
     (not (equal? #2f64((0 1) (2 3)) 100)))

@@ -805,12 +805,12 @@
 ;;; slices as generalized vectors
 ;;;

-(let ((array #2u32((0 1) (2 3))))
-  (define (array-row a i)
-    (make-shared-array a (lambda (j) (list i j))
-                       (cadr (array-dimensions a))))
-  (with-test-prefix "generalized vector slices"
-    (pass-if (equal? (array-row array 1)
-                     #u32(2 3)))
-    (pass-if (equal? (array-ref (array-row array 1) 0)
-                     2))))
+(define (array-row a i)
+  (make-shared-array a (lambda (j) (list i j))
+                     (cadr (array-dimensions a))))
+
+(with-test-prefix/c&e "generalized vector slices"
+  (pass-if (equal? (array-row #2u32((0 1) (2 3)) 1)
+                   #u32(2 3)))
+  (pass-if (equal? (array-ref (array-row #2u32((0 1) (2 3)) 1) 0)
+                   2)))
--
1.7.9.5

[-- Attachment #3: 0002-Pack-array-dimensions-in-array-object.patch --]
[-- Type: application/octet-stream, Size: 14237 bytes --]

From 8d2d5641fdacaae31996e9afcfc0eb4a35555b70 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 17 Sep 2014 07:15:42 +0200
Subject: [PATCH 2/3] Pack array dimensions in array object

* libguile/arrays.c (scm_i_make_array): redo object layout.

* libguile/arrays.h (SCM_I_ARRAY_V, SCM_ARRAY_BASE, SCM_I_ARRAY_DIMS):
  to match new layout.

  (SCM_I_ARRAY_SET_V, SCM_ARRAY_SET_BASE): new setters.

  (SCM_I_ARRAY_MEM, scm_i_t_array): unused, remove.

  (scm_i_shap2ra, scm_make_typed_array, scm_from_contiguous_typed_array,
  scm_from_contiguous_array, scm_make_shared_array, scm_transpose_array,
  scm_array_contents): fix uses of SCM_I_ARRAY_V, SCM_ARRAY_BASE as
  lvalues.

* libguile/array-map.c (make1array, scm_ramapc): fix uses of
  SCM_I_ARRAY_V, SCM_ARRAY_BASE as lvalues.
---
 libguile/array-map.c  |   20 +++++++--------
 libguile/arrays.c     |   67 ++++++++++++++++++++++++++-----------------------
 libguile/arrays.h     |   17 +++++--------
 libguile/deprecated.h |    1 -
 4 files changed, 52 insertions(+), 53 deletions(-)

diff --git a/libguile/array-map.c b/libguile/array-map.c
index 2d68f5f..938f0a7 100644
--- a/libguile/array-map.c
+++ b/libguile/array-map.c
@@ -1,6 +1,6 @@
 /* Copyright (C) 1996, 1998, 2000, 2001, 2004, 2005, 2006, 2008, 2009,
  *   2010, 2011, 2012, 2013, 2014 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
@@ -63,11 +63,11 @@ static SCM
 make1array (SCM v, ssize_t inc)
 {
   SCM a = scm_i_make_array (1);
-  SCM_I_ARRAY_BASE (a) = 0;
+  SCM_I_ARRAY_SET_BASE (a, 0);
   SCM_I_ARRAY_DIMS (a)->lbnd = 0;
   SCM_I_ARRAY_DIMS (a)->ubnd = scm_c_array_length (v) - 1;
   SCM_I_ARRAY_DIMS (a)->inc = inc;
-  SCM_I_ARRAY_V (a) = v;
+  SCM_I_ARRAY_SET_V (a, v);
   return a;
 }

@@ -195,9 +195,9 @@ scm_ramapc (void *cproc_ptr, SCM data, SCM ra0, SCM lra, const char *what)
       if (k == kroll)
         {
           SCM y = lra;
-          SCM_I_ARRAY_BASE (va0) = cindk (ra0, vi, kroll);
+          SCM_I_ARRAY_SET_BASE (va0, cindk (ra0, vi, kroll));
           for (z = lva; !scm_is_null (z); z = SCM_CDR (z), y = SCM_CDR (y))
-            SCM_I_ARRAY_BASE (SCM_CAR (z)) = cindk (SCM_CAR (y), vi, kroll);
+            SCM_I_ARRAY_SET_BASE (SCM_CAR (z), cindk (SCM_CAR (y), vi, kroll));
           if (! (SCM_UNBNDP (data) ? cproc (va0, lva) : cproc (va0, data, lva)))
             return 0;
           --k;
@@ -815,7 +815,7 @@ array_compare (scm_t_array_handle *hx, scm_t_array_handle *hy,
         return 0;

       i = hx->dims[dim].ubnd - hx->dims[dim].lbnd + 1;
-
+
       incx = hx->dims[dim].inc;
       incy = hy->dims[dim].inc;
       posx += (i - 1) * incx;
@@ -832,11 +832,11 @@ SCM
 scm_array_equal_p (SCM x, SCM y)
 {
   scm_t_array_handle hx, hy;
-  SCM res;
-
+  SCM res;
+
   scm_array_get_handle (x, &hx);
   scm_array_get_handle (y, &hy);
-
+
   res = scm_from_bool (hx.ndims == hy.ndims
                        && hx.element_type == hy.element_type);

@@ -860,7 +860,7 @@ SCM_DEFINE (scm_i_array_equal_p, "array-equal?", 0, 2, 1,
 {
   if (SCM_UNBNDP (ra0) || SCM_UNBNDP (ra1))
     return SCM_BOOL_T;
-
+
   while (!scm_is_null (rest))
     { if (scm_is_false (scm_array_equal_p (ra0, ra1)))
         return SCM_BOOL_F;
diff --git a/libguile/arrays.c b/libguile/arrays.c
index 702faac..1fd6066 100644
--- a/libguile/arrays.c
+++ b/libguile/arrays.c
@@ -1,6 +1,6 @@
 /* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004,2005,
  *   2006, 2009, 2010, 2011, 2012, 2013, 2014 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
@@ -29,6 +29,8 @@
 #include <string.h>
 #include <assert.h>

+#include "verify.h"
+
 #include "libguile/_scm.h"
 #include "libguile/__scm.h"
 #include "libguile/eq.h"
@@ -92,7 +94,7 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
 #undef FUNC_NAME


-SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
+SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
            (SCM ra),
 	    "For each dimension, return the distance between elements in the root vector.")
 #define FUNC_NAME s_scm_shared_array_increments
@@ -112,15 +114,20 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
 }
 #undef FUNC_NAME

+/* FIXME: to avoid this assumption, fix the accessors in arrays.h,
+   scm_i_make_array, and the array cases in system/vm/assembler.scm. */
+
+verify (sizeof (scm_t_array_dim) == 3*sizeof (scm_t_bits));
+
+/* Matching SCM_I_ARRAY accessors in arrays.h */
 SCM
 scm_i_make_array (int ndim)
 {
-  SCM ra;
-  ra = scm_cell (((scm_t_bits) ndim << 17) + scm_tc7_array,
-		 (scm_t_bits) scm_gc_malloc (sizeof (scm_i_t_array) +
-					     ndim * sizeof (scm_t_array_dim),
-					     "array"));
-  SCM_I_ARRAY_V (ra) = SCM_BOOL_F;
+  verify (sizeof(size_t)==sizeof(scm_t_bits));
+  SCM ra = scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
+  SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
+  SCM_I_ARRAY_SET_BASE (ra, 0);
+  /* dimensions are unset */
   return ra;
 }

@@ -139,7 +146,7 @@ scm_i_shap2ra (SCM args)
     scm_misc_error (NULL, s_bad_spec, SCM_EOL);

   ra = scm_i_make_array (ndim);
-  SCM_I_ARRAY_BASE (ra) = 0;
+  SCM_I_ARRAY_SET_BASE (ra, 0);
   s = SCM_I_ARRAY_DIMS (ra);
   for (; !scm_is_null (args); s++, args = SCM_CDR (args))
     {
@@ -179,7 +186,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
   size_t k, rlen = 1;
   scm_t_array_dim *s;
   SCM ra;
-
+
   ra = scm_i_shap2ra (bounds);
   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
   s = SCM_I_ARRAY_DIMS (ra);
@@ -195,8 +202,7 @@ SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
   if (scm_is_eq (fill, SCM_UNSPECIFIED))
     fill = SCM_UNDEFINED;

-  SCM_I_ARRAY_V (ra) =
-    scm_make_generalized_vector (type, scm_from_size_t (rlen), fill);
+  SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill));

   if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
     if (0 == s->lbnd)
@@ -217,7 +223,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
   scm_t_array_handle h;
   void *elts;
   size_t sz;
-
+
   ra = scm_i_shap2ra (bounds);
   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
   s = SCM_I_ARRAY_DIMS (ra);
@@ -229,8 +235,7 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
       SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
       rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
     }
-  SCM_I_ARRAY_V (ra) =
-    scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
+  SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED));


   scm_array_get_handle (ra, &h);
@@ -273,7 +278,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
   scm_t_array_dim *s;
   SCM ra;
   scm_t_array_handle h;
-
+
   ra = scm_i_shap2ra (bounds);
   SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
   s = SCM_I_ARRAY_DIMS (ra);
@@ -288,7 +293,7 @@ scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
   if (rlen != len)
     SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);

-  SCM_I_ARRAY_V (ra) = scm_c_make_vector (rlen, SCM_UNDEFINED);
+  SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
   scm_array_get_handle (ra, &h);
   memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
   scm_array_handle_release (&h);
@@ -323,7 +328,7 @@ scm_i_ra_set_contp (SCM ra)
 	      SCM_CLR_ARRAY_CONTIGUOUS_FLAG (ra);
 	      return;
 	    }
-	  inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
+	  inc *= (SCM_I_ARRAY_DIMS (ra)[k].ubnd
 		  - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1);
 	}
     }
@@ -368,7 +373,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,

   if (SCM_I_ARRAYP (oldra))
     {
-      SCM_I_ARRAY_V (ra) = SCM_I_ARRAY_V (oldra);
+      SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
       old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
       s = scm_array_handle_dims (&old_handle);
       k = scm_array_handle_rank (&old_handle);
@@ -382,7 +387,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
     }
   else
     {
-      SCM_I_ARRAY_V (ra) = oldra;
+      SCM_I_ARRAY_SET_V (ra, oldra);
       old_base = old_min = 0;
       old_max = scm_c_array_length (oldra) - 1;
     }
@@ -398,9 +403,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 	    ra = scm_make_generalized_vector (scm_array_type (ra),
                                               SCM_INUM0, SCM_UNDEFINED);
 	  else
-	    SCM_I_ARRAY_V (ra) =
-              scm_make_generalized_vector (scm_array_type (ra),
-                                           SCM_INUM0, SCM_UNDEFINED);
+	    SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra),
+                                                                SCM_INUM0, SCM_UNDEFINED));
 	  scm_array_handle_release (&old_handle);
 	  return ra;
 	}
@@ -408,7 +412,8 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,

   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
   i = scm_array_handle_pos (&old_handle, imap);
-  SCM_I_ARRAY_BASE (ra) = new_min = new_max = i + old_base;
+  new_min = new_max = i + old_base;
+  SCM_I_ARRAY_SET_BASE (ra, new_min);
   indptr = inds;
   k = SCM_I_ARRAY_NDIM (ra);
   while (k--)
@@ -450,7 +455,7 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,


 /* args are RA . DIMS */
-SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
+SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
            (SCM ra, SCM args),
 	    "Return an array sharing contents with @var{ra}, but with\n"
 	    "dimensions arranged in a different order.  There must be one\n"
@@ -509,8 +514,8 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 	}
       ndim++;
       res = scm_i_make_array (ndim);
-      SCM_I_ARRAY_V (res) = SCM_I_ARRAY_V (ra);
-      SCM_I_ARRAY_BASE (res) = SCM_I_ARRAY_BASE (ra);
+      SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
+      SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
       for (k = ndim; k--;)
 	{
 	  SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
@@ -534,7 +539,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 		r->ubnd = s->ubnd;
 	      if (r->lbnd < s->lbnd)
 		{
-		  SCM_I_ARRAY_BASE (res) += (s->lbnd - r->lbnd) * r->inc;
+		  SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc);
 		  r->lbnd = s->lbnd;
 		}
 	      r->inc += s->inc;
@@ -596,8 +601,8 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
           SCM sra = scm_i_make_array (1);
           SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
           SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
-          SCM_I_ARRAY_V (sra) = v;
-          SCM_I_ARRAY_BASE (sra) = SCM_I_ARRAY_BASE (ra);
+          SCM_I_ARRAY_SET_V (sra, v);
+          SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
           SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
           return sra;
         }
@@ -760,7 +765,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
     scm_intprint (h.ndims, 10, port);
   if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
     scm_write (scm_array_handle_element_type (&h), port);
-
+
   for (i = 0; i < h.ndims; i++)
     {
       if (h.dims[i].lbnd != 0)
diff --git a/libguile/arrays.h b/libguile/arrays.h
index 6045ab6..5f40597 100644
--- a/libguile/arrays.h
+++ b/libguile/arrays.h
@@ -54,23 +54,18 @@ SCM_API SCM scm_list_to_typed_array (SCM type, SCM ndim, SCM lst);

 /* internal. */

-typedef struct scm_i_t_array
-{
-  SCM v;  /* the contents of the array, e.g., a vector or uniform vector.  */
-  unsigned long base;
-} scm_i_t_array;
-
 #define SCM_I_ARRAY_FLAG_CONTIGUOUS (1 << 0)

 #define SCM_I_ARRAYP(a)	    SCM_TYP16_PREDICATE (scm_tc7_array, a)
 #define SCM_I_ARRAY_NDIM(x)  ((size_t) (SCM_CELL_WORD_0 (x)>>17))
 #define SCM_I_ARRAY_CONTP(x) (SCM_CELL_WORD_0 (x) & (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16))

-#define SCM_I_ARRAY_MEM(a)  ((scm_i_t_array *) SCM_CELL_WORD_1 (a))
-#define SCM_I_ARRAY_V(a)    (SCM_I_ARRAY_MEM (a)->v)
-#define SCM_I_ARRAY_BASE(a) (SCM_I_ARRAY_MEM (a)->base)
-#define SCM_I_ARRAY_DIMS(a) \
-  ((scm_t_array_dim *)((char *) SCM_I_ARRAY_MEM (a) + sizeof (scm_i_t_array)))
+#define SCM_I_ARRAY_V(a)    SCM_CELL_OBJECT_1 (a)
+#define SCM_I_ARRAY_BASE(a) ((size_t) SCM_CELL_WORD_2 (a))
+#define SCM_I_ARRAY_DIMS(a) ((scm_t_array_dim *) SCM_CELL_OBJECT_LOC (a, 3))
+
+#define SCM_I_ARRAY_SET_V(a, v)       SCM_SET_CELL_OBJECT_1(a, v)
+#define SCM_I_ARRAY_SET_BASE(a, base) SCM_SET_CELL_WORD_2(a, base)

 SCM_INTERNAL SCM scm_i_make_array (int ndim);
 SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
diff --git a/libguile/deprecated.h b/libguile/deprecated.h
index ae1fb04..d642b79 100644
--- a/libguile/deprecated.h
+++ b/libguile/deprecated.h
@@ -129,7 +129,6 @@ SCM_DEPRECATED SCM scm_internal_dynamic_wind (scm_t_guard before,
 #define scm_substring_move_right_x scm_substring_move_right_x__GONE__REPLACE_WITH__scm_substring_move_x
 #define scm_vtable_index_printer scm_vtable_index_printer__GONE__REPLACE_WITH__scm_vtable_index_instance_printer
 #define scm_vtable_index_vtable scm_vtable_index_vtable__GONE__REPLACE_WITH__scm_vtable_index_self
-typedef scm_i_t_array scm_i_t_array__GONE__REPLACE_WITH__scm_t_array;

 #ifndef BUILDING_LIBGUILE
 #define SCM_ASYNC_TICK  SCM_ASYNC_TICK__GONE__REPLACE_WITH__scm_async_tick
--
1.7.9.5

[-- Attachment #4: 0003-Intern-general-arrays.patch --]
[-- Type: application/octet-stream, Size: 4359 bytes --]

From a8fbee42e09c65e0965ffce63808a2c11f580739 Mon Sep 17 00:00:00 2001
From: Daniel Llorens <daniel.llorens@bluewin.ch>
Date: Wed, 17 Sep 2014 07:28:25 +0200
Subject: [PATCH 3/3] Intern general arrays

* module/system/vm/assembler.scm (intern-constant, link-data): handle
  the array case.
---
 module/system/vm/assembler.scm |   33 ++++++++++++++++++++++++++++++---
 1 file changed, 30 insertions(+), 3 deletions(-)

diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index e944e68..cf8bbdd 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -900,14 +900,15 @@ table, its existing label is used directly."
                          ,(recur (make-uniform-vector-backing-store
                                   (uniform-array->bytevector obj)
                                   width))))))
+     ((array? obj)
+      `((static-patch! ,label 1 ,(recur (shared-array-root obj)))))
      (else
       (error "don't know how to intern" obj))))
   (cond
    ((immediate? obj) #f)
    ((vhash-assoc obj (asm-constants asm)) => cdr)
    (else
-    ;; Note that calling intern may mutate asm-constants and
-    ;; asm-constant-inits.
+    ;; Note that calling intern may mutate asm-constants and asm-inits.
     (let* ((label (gensym "constant"))
            (inits (intern obj label)))
       (set-asm-constants! asm (vhash-cons obj label (asm-constants asm)))
@@ -1218,6 +1219,7 @@ should be .data or .rodata), and return the resulting linker object.
     (+ address
        (modulo (- alignment (modulo address alignment)) alignment)))

+  ;; redefined in libguile/tags.h
   (define tc7-vector 13)
   (define stringbuf-shared-flag #x100)
   (define stringbuf-wide-flag #x400)
@@ -1230,6 +1232,7 @@ should be .data or .rodata), and return the resulting linker object.
   (define tc7-program 69)
   (define tc7-bytevector 77)
   (define tc7-bitvector 95)
+  (define tc7-array 93)

   (let ((word-size (asm-word-size asm))
         (endianness (asm-endianness asm)))
@@ -1254,6 +1257,8 @@ should be .data or .rodata), and return the resulting linker object.
         (* 4 word-size))
        ((uniform-vector-backing-store? x)
         (bytevector-length (uniform-vector-backing-store-bytes x)))
+       ((array? x)
+        (* word-size (+ 3 (* 3 (array-rank x)))))
        (else
         word-size)))

@@ -1310,7 +1315,7 @@ should be .data or .rodata), and return the resulting linker object.
         (write-immediate asm buf pos #f))

        ((string? obj)
-        (let ((tag (logior tc7-ro-string (ash (string-length obj) 8))))
+        (let ((tag (logior tc7-ro-string (ash (string-length obj) 8)))) ; FIXME: unused?
           (case word-size
             ((4)
              (bytevector-u32-set! buf pos tc7-ro-string endianness)
@@ -1385,6 +1390,28 @@ should be .data or .rodata), and return the resulting linker object.
             ;; Need to swap units of element-size bytes
             (error "FIXME: Implement byte order swap"))))

+       ((array? obj)
+        (let ((tag (logior tc7-array (ash (array-rank obj) 17)))
+              (bv-set! (case word-size
+                         ((4) bytevector-u32-set!)
+                         ((8) bytevector-u64-set!)
+                         (else (error "bad word size"))))
+              (bvs-set! (case word-size
+                          ((4) bytevector-s32-set!)
+                          ((8) bytevector-s64-set!)
+                          (else (error "bad word size")))))
+          (bv-set! buf pos tag endianness)
+          (write-immediate asm buf (+ pos word-size) #f) ; root vector (fixed later)
+          (bv-set! buf (+ pos (* word-size 2)) 0 endianness) ; base
+          (let lp ((pos (+ pos (* word-size 3)))
+                   (bounds (array-shape obj))
+                   (incs (shared-array-increments obj)))
+            (when (pair? bounds)
+              (bvs-set! buf pos (first (first bounds)) endianness)
+              (bvs-set! buf (+ pos word-size) (second (first bounds)) endianness)
+              (bvs-set! buf (+ pos (* word-size 2)) (first incs) endianness)
+              (lp (+ pos (* 3 word-size)) (cdr bounds) (cdr incs))))))
+
        (else
         (error "unrecognized object" obj))))

--
1.7.9.5