Give arrays a proper type in C land

As long as we have a tc7 for arrays, we should be able to access it with
a struct type instead of casting each word.

* libguile/arrays-internal.h: New file.
* libguile/arrays.h (scm_array_p): Take just one argument.
(SCM_I_ARRAYP):
(SCM_I_ARRAY_NDIM):
(SCM_I_ARRAY_V):
(SCM_I_ARRAY_BASE):
(SCM_I_ARRAY_DIMS):
(SCM_I_ARRAY_SET_V):
(SCM_I_ARRAY_SET_BASE): Remove.
(scm_i_raw_array, scm_i_make_array, scm_i_shap2ra, scm_init_arrays):
Remove internally-linked decls.
* libguile/init.c:
* libguile/print.c:
* libguile/array-handle.c: Use interfaces from new file.
* module/system/vm/assembler.scm: Update, as we now shift the dimension
count by only 16.  Requires a rebuild!

libguile/Makefile.am

@@ -522,6 +522,7 @@ noinst_HEADERS = custom-ports.h					\
                  intrinsics.h					\
                  quicksort.i.c                                  \
                  atomics-internal.h				\
+                 arrays-internal.h				\
                  bytevectors-internal.h				\
                  cache-internal.h				\
                  gc-inline.h					\

libguile/array-handle.c

@@ -27,6 +27,7 @@
 #include <string.h>
 
 #include "arrays.h"
+#include "arrays-internal.h"
 #include "boolean.h"
 #include "bitvectors.h"
 #include "bytevectors.h"
@@ -260,11 +261,14 @@ scm_array_get_handle (SCM array, scm_t_array_handle *h)
       }
       break;
     case scm_tc7_array:
-      scm_array_get_handle (SCM_I_ARRAY_V (array), h);
+      {
+        struct scm_array *ra = scm_to_array (array);
+        scm_array_get_handle (scm_array_vector (ra), h);
         h->array = array;
-      h->base = SCM_I_ARRAY_BASE (array);
+        h->base = scm_array_base (ra);
-      h->ndims = SCM_I_ARRAY_NDIM (array);
+        h->ndims = scm_array_dimension_count (ra);
-      h->dims = SCM_I_ARRAY_DIMS (array);
+        h->dims = ra->dims;
+      }
       break;
     default:
       scm_wrong_type_arg_msg (NULL, 0, array, "array");

libguile/arrays-internal.h

@@ -0,0 +1,86 @@
+#ifndef SCM_ARRAYS_INTERNAL_H
+#define SCM_ARRAYS_INTERNAL_H
+
+/* Copyright 1995-1997,1999-2001,2004,2006,2008-2010,2012,2018,2025
+     Free Software Foundation, Inc.
+
+   This file is part of Guile.
+
+   Guile 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 the License, or
+   (at your option) any later version.
+
+   Guile is distributed in the hope that it will be useful, but WITHOUT
+   ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
+   FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
+   License for more details.
+
+   You should have received a copy of the GNU Lesser General Public
+   License along with Guile.  If not, see
+   <https://www.gnu.org/licenses/>.  */
+
+
+
+#include "libguile/arrays.h"
+
+
+
+struct scm_array
+{
+  scm_t_bits tag_and_ndims;
+  SCM vector;
+  size_t base;
+  struct scm_t_array_dim dims[];
+};
+
+/* There is a naming confusion: scm_is_array exists and is used for
+   generalized arrays, allowing e.g. (array? #(1 2 3)) to be true.  Here
+   we are concerned with proper multidimensional arrays, which are their
+   own data type.  Mostly we can use this "struct scm_array" as a way to
+   avoid confusion, but we have to name this function
+   "scm_is_tagged_array" instead of "scm_is_array" as we would like.  */
+static inline int
+scm_is_tagged_array (SCM x)
+{
+  return SCM_HAS_TYP7 (x, scm_tc7_array);
+}
+
+static inline struct scm_array*
+scm_to_array (SCM x)
+{
+  if (!scm_is_tagged_array (x))
+    abort ();
+  return (struct scm_array *) SCM_UNPACK_POINTER (x);
+}
+
+static inline SCM
+scm_from_array (struct scm_array *x)
+{
+  return SCM_PACK_POINTER (x);
+}
+
+static inline size_t
+scm_array_dimension_count (struct scm_array *array)
+{
+  return array->tag_and_ndims >> 16;
+}
+
+static inline SCM
+scm_array_vector (struct scm_array *array)
+{
+  return array->vector;
+}
+
+static inline size_t
+scm_array_base (struct scm_array *array)
+{
+  return array->base;
+}
+
+SCM_INTERNAL struct scm_array* scm_i_make_array (SCM v, size_t base, int ndim);
+SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
+
+SCM_INTERNAL void scm_init_arrays (void);
+
+#endif  /* SCM_ARRAYS_INTERNAL_H */

libguile/arrays.c

@@ -28,6 +28,7 @@
 #include <errno.h>
 #include <string.h>
 
+#include "arrays-internal.h"
 #include "bitvectors.h"
 #include "boolean.h"
 #include "chars.h"
@@ -53,8 +54,6 @@
 #include "variable.h"
 #include "vectors.h"
 
-#include "arrays.h"
-
 SCM_INTERNAL SCM scm_i_array_ref (SCM v,
                                   SCM idx0, SCM idx1, SCM idxN);
 SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
@@ -80,26 +79,16 @@ scm_is_array (SCM obj)
     }
 }
 
-SCM_DEFINE (scm_array_p_2, "array?", 1, 0, 0,
+SCM_DEFINE (scm_array_p, "array?", 1, 0, 0,
             (SCM obj),
             "Return @code{#t} if the @var{obj} is an array, and @code{#f} if\n"
             "not.")
-#define FUNC_NAME s_scm_array_p_2
+#define FUNC_NAME s_scm_array_p
 {
   return scm_from_bool (scm_is_array (obj));
 }
 #undef FUNC_NAME
 
-/* The array type predicate, with an extra argument kept for backward
-   compatibility.  Note that we can't use `SCM_DEFINE' directly because there
-   would be an argument count mismatch that would be caught by
-   `snarf-check-and-output-texi.scm'.  */
-SCM
-scm_array_p (SCM obj, SCM unused)
-{
-  return scm_array_p_2 (obj);
-}
-
 int
 scm_is_typed_array (SCM obj, SCM type)
 {
@@ -423,8 +412,8 @@ SCM_DEFINE (scm_array_to_list, "array->list", 1, 0, 0,
 size_t
 scm_c_array_rank (SCM array)
 {
-  if (SCM_I_ARRAYP (array))
+  if (scm_is_tagged_array (array))
-    return SCM_I_ARRAY_NDIM (array);
+    return scm_array_dimension_count (scm_to_array (array));
   else if (scm_is_array (array))
     return 1;
   else
@@ -446,8 +435,8 @@ SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
             "Return the root vector of a shared array.")
 #define FUNC_NAME s_scm_shared_array_root
 {
-  if (SCM_I_ARRAYP (ra))
+  if (scm_is_tagged_array (ra))
-    return SCM_I_ARRAY_V (ra);
+    return scm_array_vector (scm_to_array (ra));
   else if (scm_is_array (ra))
     return ra;
   else
@@ -461,8 +450,8 @@ SCM_DEFINE (scm_shared_array_offset, "shared-array-offset", 1, 0, 0,
             "Return the root vector index of the first element in the array.")
 #define FUNC_NAME s_scm_shared_array_offset
 {
-  if (SCM_I_ARRAYP (ra))
+  if (scm_is_tagged_array (ra))
-    return scm_from_size_t (SCM_I_ARRAY_BASE (ra));
+    return scm_from_size_t (scm_array_base (scm_to_array (ra)));
   else if (scm_is_array (ra))
     return scm_from_size_t (0);
   else
@@ -476,11 +465,12 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
             "For each dimension, return the distance between elements in the root vector.")
 #define FUNC_NAME s_scm_shared_array_increments
 {
-  if (SCM_I_ARRAYP (ra))
+  if (scm_is_tagged_array (ra))
     {
-      size_t k = SCM_I_ARRAY_NDIM (ra);
+      struct scm_array *array = scm_to_array (ra);
+      size_t k = scm_array_dimension_count (array);
       SCM res = SCM_EOL;
-      scm_t_array_dim *dims = SCM_I_ARRAY_DIMS (ra);
+      scm_t_array_dim *dims = array->dims;
       while (k--)
         res = scm_cons (scm_from_ssize_t (dims[k].inc), res);
       return res;
@@ -493,30 +483,33 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
 #undef FUNC_NAME
 
 
-SCM
+struct scm_array *
-scm_i_make_array (int ndim)
+scm_i_make_array (SCM v, size_t base, int ndim)
 {
-  SCM ra = scm_i_raw_array (ndim);
+  struct scm_array *array = scm_gc_malloc (sizeof (struct scm_array)
-  SCM_I_ARRAY_SET_V (ra, SCM_BOOL_F);
+                                           + ndim * sizeof (scm_t_array_dim),
-  SCM_I_ARRAY_SET_BASE (ra, 0);
+                                           "array");
-  /* dimensions are unset */
+  /* FIXME: Shift ndim by something more reasonable instead.  */
-  return ra;
+  array->tag_and_ndims = scm_tc7_array | (ndim << 16);
+  array->vector = v;
+  array->base = base;
+  /* Dimensions need initialization; they are initially zero. */
+  return array;
 }
 
 /* Increments will still need to be set. */
 
-SCM
+static struct scm_array *
 scm_i_shap2ra (SCM args)
 {
-  scm_t_array_dim *s;
   int ndim = scm_ilength (args);
   if (ndim < 0)
     scm_misc_error (NULL, "bad array bounds ~a", scm_list_1 (args));
 
-  SCM ra = scm_i_make_array (ndim);
+  struct scm_array *array = scm_i_make_array (SCM_BOOL_F, 0, ndim);
-  SCM_I_ARRAY_SET_BASE (ra, 0);
+  for (scm_t_array_dim *s = array->dims;
-  s = SCM_I_ARRAY_DIMS (ra);
+       !scm_is_null (args);
-  for (; !scm_is_null (args); s++, args = SCM_CDR (args))
+       s++, args = SCM_CDR (args))
     {
       SCM spec = SCM_CAR (args);
       if (scm_is_integer (spec))
@@ -543,7 +536,7 @@ scm_i_shap2ra (SCM args)
         }
       s->inc = 1;
     }
-  return ra;
+  return array;
 }
 
 SCM_DEFINE (scm_make_typed_array, "make-typed-array", 2, 0, 1,
@@ -553,11 +546,10 @@ 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);
+  struct scm_array *ra = scm_i_shap2ra (bounds);
-  s = SCM_I_ARRAY_DIMS (ra);
+  s = ra->dims;
-  k = SCM_I_ARRAY_NDIM (ra);
+  k = scm_array_dimension_count (ra);
 
   while (k--)
     {
@@ -569,13 +561,13 @@ 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_SET_V (ra, scm_make_generalized_vector (type, scm_from_size_t (rlen), fill));
+  ra->vector = 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 (1 == scm_array_dimension_count (ra) && 0 == scm_array_base (ra)
-    if (0 == s->lbnd)
+      && 0 == s->lbnd)
-      return SCM_I_ARRAY_V (ra);
+    return ra->vector;
 
-  return ra;
+  return scm_from_array (ra);
 }
 #undef FUNC_NAME
 
@@ -611,7 +603,6 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 #define FUNC_NAME s_scm_make_shared_array
 {
   scm_t_array_handle old_handle;
-  SCM ra;
   SCM inds, indptr;
   SCM imap;
   size_t k;
@@ -621,14 +612,15 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 
   SCM_VALIDATE_REST_ARGUMENT (dims);
   SCM_VALIDATE_PROC (2, mapfunc);
-  ra = scm_i_shap2ra (dims);
+  struct scm_array *ra = scm_i_shap2ra (dims);
 
   scm_array_get_handle (oldra, &old_handle);
 
-  if (SCM_I_ARRAYP (oldra))
+  if (scm_is_tagged_array (oldra))
     {
-      SCM_I_ARRAY_SET_V (ra, SCM_I_ARRAY_V (oldra));
+      struct scm_array *old = scm_to_array (oldra);
-      old_base = old_min = old_max = SCM_I_ARRAY_BASE (oldra);
+      ra->vector = old->vector;
+      old_base = old_min = old_max = old->base;
       s = scm_array_handle_dims (&old_handle);
       k = scm_array_handle_rank (&old_handle);
       while (k--)
@@ -641,35 +633,40 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
     }
   else
     {
-      SCM_I_ARRAY_SET_V (ra, oldra);
+      ra->vector = oldra;
       old_base = old_min = 0;
       old_max = scm_c_array_length (oldra) - 1;
     }
 
   inds = SCM_EOL;
-  s = SCM_I_ARRAY_DIMS (ra);
+  s = ra->dims;
-  for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+  for (k = 0; k < scm_array_dimension_count (ra); k++)
     {
       inds = scm_cons (scm_from_ssize_t (s[k].lbnd), inds);
       if (s[k].ubnd < s[k].lbnd)
         {
-          if (1 == SCM_I_ARRAY_NDIM (ra))
+          SCM ret;
-            ra = scm_make_generalized_vector (scm_array_type (ra),
+          if (1 == scm_array_dimension_count (ra)) 
+            ret = scm_make_generalized_vector (scm_array_type (scm_from_array (ra)),
                                                SCM_INUM0, SCM_UNDEFINED);
           else
-            SCM_I_ARRAY_SET_V (ra, scm_make_generalized_vector (scm_array_type (ra),
+            {
-                                                                SCM_INUM0, SCM_UNDEFINED));
+              ret = scm_from_array (ra);
+              ra->vector =
+                scm_make_generalized_vector (scm_array_type (ret),
+                                             SCM_INUM0, SCM_UNDEFINED);
+            }
           scm_array_handle_release (&old_handle);
-          return ra;
+          return ret;
         }
     }
 
   imap = scm_apply_0 (mapfunc, scm_reverse (inds));
   i = scm_array_handle_pos (&old_handle, imap);
   new_min = new_max = i + old_base;
-  SCM_I_ARRAY_SET_BASE (ra, new_min);
+  ra->base = new_min;
   indptr = inds;
-  k = SCM_I_ARRAY_NDIM (ra);
+  k = scm_array_dimension_count (ra);
   while (k--)
     {
       if (s[k].ubnd > s[k].lbnd)
@@ -692,17 +689,17 @@ SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
 
   if (old_min > new_min || old_max < new_max)
     scm_misc_error (FUNC_NAME, "mapping out of range", SCM_EOL);
-  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+  if (1 == scm_array_dimension_count (ra) && 0 == scm_array_base (ra))
     {
-      SCM v = SCM_I_ARRAY_V (ra);
+      SCM v = scm_array_vector (ra);
       size_t length = scm_c_array_length (v);
       if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
         return v;
       if (s->ubnd < s->lbnd)
-        return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
+        return scm_make_generalized_vector (scm_array_type (scm_from_array (ra)),
-                                            SCM_UNDEFINED);
+                                            SCM_INUM0, SCM_UNDEFINED);
     }
-  return ra;
+  return scm_from_array (ra);
 }
 #undef FUNC_NAME
 
@@ -733,16 +730,17 @@ array_from_get_o (scm_t_array_handle *handle, size_t k, scm_t_array_dim *s, ssiz
     *o = handle->array;
   else
     {
-      *o = scm_i_make_array (k);
+      struct scm_array *array =
-      SCM_I_ARRAY_SET_V (*o, handle->vector);
+        scm_i_make_array (handle->vector, pos + handle->base, k);
-      SCM_I_ARRAY_SET_BASE (*o, pos + handle->base);
+      for (scm_t_array_dim *os = array->dims;
-      scm_t_array_dim * os = SCM_I_ARRAY_DIMS (*o);
+           k > 0;
-      for (; k>0; --k, ++s, ++os)
+           --k, ++s, ++os)
         {
           os->ubnd = s->ubnd;
           os->lbnd = s->lbnd;
           os->inc = s->inc;
         }
+      *o = scm_from_array (array);
     }
 }
 
@@ -770,7 +768,8 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
   if (!s)
     {
       scm_array_handle_release (&handle);
-      scm_misc_error (FUNC_NAME, "indices ~a out of range for array bounds ~a", scm_list_2 (indices, scm_array_dimensions (ra)));
+      scm_misc_error (FUNC_NAME, "indices ~a out of range for array bounds ~a",
+                      scm_list_2 (indices, scm_array_dimensions (ra)));
     }
   SCM o;
   if (scm_is_null (i))
@@ -788,7 +787,7 @@ SCM_DEFINE (scm_array_slice, "array-slice", 1, 0, 1,
 
 /* args are RA . DIMS */
 SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
-            (SCM ra, SCM args),
+            (SCM array, SCM args),
             "Return an array sharing contents with @var{ra}, but with\n"
             "dimensions arranged in a different order.  There must be one\n"
             "@var{dim} argument for each dimension of @var{ra}.\n"
@@ -810,19 +809,17 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
             "@end lisp")
 #define FUNC_NAME s_scm_transpose_array
 {
-  SCM res, vargs;
   scm_t_array_dim *s, *r;
   int ndim, i, k;
 
   SCM_VALIDATE_REST_ARGUMENT (args);
-  SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
 
-  switch (scm_c_array_rank (ra))
+  switch (scm_c_array_rank (array))
     {
     case 0:
       if (!scm_is_null (args))
         SCM_WRONG_NUM_ARGS ();
-      return ra;
+      return array;
     case 1:
       /* Make sure that we are called with a single zero as
          arguments.
@@ -831,33 +828,38 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
         SCM_WRONG_NUM_ARGS ();
       SCM_VALIDATE_INT_COPY (SCM_ARG2, SCM_CAR (args), i);
       SCM_ASSERT_RANGE (SCM_ARG2, SCM_CAR (args), i == 0);
-      return ra;
+      return array;
     default:
-      vargs = scm_vector (args);
+      break;
-      if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != SCM_I_ARRAY_NDIM (ra))
+    }
+
+  SCM vargs = scm_vector (args);
+  struct scm_array *ra = scm_to_array (array);
+  if (SCM_SIMPLE_VECTOR_LENGTH (vargs) != scm_array_dimension_count (ra))
     SCM_WRONG_NUM_ARGS ();
   ndim = 0;
-      for (k = 0; k < SCM_I_ARRAY_NDIM (ra); k++)
+  for (k = 0; k < scm_array_dimension_count (ra); k++)
     {
       i = scm_to_signed_integer (SCM_SIMPLE_VECTOR_REF (vargs, k),
-                                     0, SCM_I_ARRAY_NDIM(ra));
+                                 0, scm_array_dimension_count (ra));
       if (ndim < i)
         ndim = i;
     }
   ndim++;
-      res = scm_i_make_array (ndim);
+
-      SCM_I_ARRAY_SET_V (res, SCM_I_ARRAY_V (ra));
+  struct scm_array *res = scm_i_make_array (ra->vector, ra->base, ndim);
-      SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (ra));
+
   for (k = ndim; k--;)
     {
-          SCM_I_ARRAY_DIMS (res)[k].lbnd = 0;
+      res->dims[k].lbnd = 0;
-          SCM_I_ARRAY_DIMS (res)[k].ubnd = -1;
+      res->dims[k].ubnd = -1;
     }
-      for (k = SCM_I_ARRAY_NDIM (ra); k--;)
+
+  for (k = scm_array_dimension_count (ra); k--;)
     {
       i = scm_to_int (SCM_SIMPLE_VECTOR_REF (vargs, k));
-          s = &(SCM_I_ARRAY_DIMS (ra)[k]);
+      s = &(ra->dims[k]);
-          r = &(SCM_I_ARRAY_DIMS (res)[i]);
+      r = &(res->dims[i]);
       if (r->ubnd < r->lbnd)
         {
           r->lbnd = s->lbnd;
@@ -871,16 +873,17 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
             r->ubnd = s->ubnd;
           if (r->lbnd < s->lbnd)
             {
-                  SCM_I_ARRAY_SET_BASE (res, SCM_I_ARRAY_BASE (res) + (s->lbnd - r->lbnd) * r->inc);
+              res->base += (s->lbnd - r->lbnd) * r->inc;
               r->lbnd = s->lbnd;
             }
           r->inc += s->inc;
         }
     }
+
   if (ndim > 0)
     SCM_MISC_ERROR ("bad argument list", SCM_EOL);
-      return res;
+
-    }
+  return scm_from_array (res);
 }
 #undef FUNC_NAME
 
@@ -889,7 +892,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
 /* if strict is true, return #f if returned array
    wouldn't have contiguous elements.  */
 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
-            (SCM ra, SCM strict),
+            (SCM array, SCM strict),
             "If @var{ra} may be @dfn{unrolled} into a one dimensional shared\n"
             "array without changing their order (last subscript changing\n"
             "fastest), then @code{array-contents} returns that shared array,\n"
@@ -901,11 +904,12 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
             "in memory.")
 #define FUNC_NAME s_scm_array_contents
 {
-  if (SCM_I_ARRAYP (ra))
+  if (scm_is_tagged_array (array))
     {
+      struct scm_array *ra = scm_to_array (array);
       SCM v;
-      size_t ndim = SCM_I_ARRAY_NDIM (ra);
+      size_t ndim = scm_array_dimension_count (ra);
-      scm_t_array_dim *s = SCM_I_ARRAY_DIMS (ra);
+      scm_t_array_dim *s = ra->dims;
       size_t k = ndim;
       size_t len = 1;
 
@@ -924,31 +928,30 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
         {
           if (ndim && (1 != s[ndim - 1].inc))
             return SCM_BOOL_F;
-          if (scm_is_bitvector (SCM_I_ARRAY_V (ra))
+          if (scm_is_bitvector (scm_array_vector (ra))
-              && (len != scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) ||
+              && (len != scm_c_bitvector_length (scm_array_vector (ra)) ||
-                  SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT ||
+                  scm_array_base (ra) % SCM_LONG_BIT ||
                   len % SCM_LONG_BIT))
             return SCM_BOOL_F;
         }
 
-      v = SCM_I_ARRAY_V (ra);
+      v = scm_array_vector (ra);
-      if ((len == scm_c_array_length (v)) && (0 == SCM_I_ARRAY_BASE (ra)))
+      if ((len == scm_c_array_length (v)) && (0 == scm_array_base (ra)))
         return v;
       else
         {
-          SCM sra = scm_i_make_array (1);
+          struct scm_array *sra = scm_i_make_array (v, scm_array_base (ra), 1);
-          SCM_I_ARRAY_DIMS (sra)->lbnd = 0;
+          sra->dims->lbnd = 0;
-          SCM_I_ARRAY_DIMS (sra)->ubnd = len - 1;
+          sra->dims->ubnd = len - 1;
-          SCM_I_ARRAY_SET_V (sra, v);
+          sra->dims->inc =
-          SCM_I_ARRAY_SET_BASE (sra, SCM_I_ARRAY_BASE (ra));
+            (ndim ? ra->dims[ndim - 1].inc : 1);
-          SCM_I_ARRAY_DIMS (sra)->inc = (ndim ? SCM_I_ARRAY_DIMS (ra)[ndim - 1].inc : 1);
+          return scm_from_array (sra);
-          return sra;
         }
     }
-  else if (scm_is_array (ra))
+  else if (scm_is_array (array))
-    return ra;
+    return array;
   else
-    scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+    scm_wrong_type_arg_msg (NULL, 0, array, "array");
 }
 #undef FUNC_NAME
 

libguile/arrays.h

@@ -58,8 +58,7 @@ SCM_API size_t scm_c_array_rank (SCM ra);
 SCM_API SCM scm_array_rank (SCM ra);
 
 SCM_API int scm_is_array (SCM obj);
-SCM_API SCM scm_array_p (SCM v, SCM unused);
+SCM_API SCM scm_array_p (SCM v);
-SCM_INTERNAL SCM scm_array_p_2 (SCM);
 
 SCM_API int scm_is_typed_array (SCM obj, SCM type);
 SCM_API SCM scm_typed_array_p (SCM v, SCM type);
@@ -93,28 +92,5 @@ typedef struct scm_t_array_dim
   ssize_t inc;
 } scm_t_array_dim;
 
-/* internal. */
-
-#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_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)
-
-/* See the array cases in system/vm/assembler.scm. */
-
-static inline SCM
-scm_i_raw_array (int ndim)
-{
-  return scm_words (((scm_t_bits) ndim << 17) + scm_tc7_array, 3 + ndim*3);
-}
-
-SCM_INTERNAL SCM scm_i_make_array (int ndim);
-SCM_INTERNAL int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate);
-SCM_INTERNAL SCM scm_i_shap2ra (SCM args);
-
-SCM_INTERNAL void scm_init_arrays (void);
 
 #endif  /* SCM_ARRAYS_H */

libguile/init.c

@@ -41,7 +41,7 @@
 
 /* Everybody has an init function.  */
 #include "alist.h"
-#include "arrays.h"
+#include "arrays-internal.h"
 #include "async.h"
 #include "atomic.h"
 #include "backtrace.h"

libguile/print.c

@@ -31,7 +31,7 @@
 #include <unictype.h>
 
 #include "alist.h"
-#include "arrays.h"
+#include "arrays-internal.h"
 #include "atomic.h"
 #include "bitvectors.h"
 #include "bytevectors-internal.h"

module/system/vm/assembler.scm

@@ -2068,7 +2068,7 @@ should be .data or .rodata), and return the resulting linker object.
         (let-values
             ;; array tag + rank
             ;; see libguile/arrays.h: SCM_I_ARRAY_NDIM, SCM_I_ARRAYP, scm_i_raw_array
-            (((tag) (logior tc7-array (ash (array-rank obj) 17)))
+            (((tag) (logior tc7-array (ash (array-rank obj) 16)))
              ((bv-set! bvs-set!)
               (case word-size
                 ((4) (values bytevector-u32-set! bytevector-s32-set!))