Merge remote-tracking branch 'local-2.0/stable-2.0'
[bpt/guile.git] / libguile / arrays.c
index 8dc1d78..f0f9012 100644 (file)
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2011 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
@@ -33,7 +33,6 @@
 #include "libguile/chars.h"
 #include "libguile/eval.h"
 #include "libguile/fports.h"
-#include "libguile/smob.h"
 #include "libguile/feature.h"
 #include "libguile/root.h"
 #include "libguile/strings.h"
 #include "libguile/uniform.h"
 
 
-scm_t_bits scm_i_tc16_array;
 #define SCM_SET_ARRAY_CONTIGUOUS_FLAG(x) \
-  (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
+  (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) | (SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
 #define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
-  (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
+  (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~(SCM_I_ARRAY_FLAG_CONTIGUOUS << 16)))
 
 
 SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0, 
@@ -111,14 +109,14 @@ SCM_DEFINE (scm_shared_array_increments, "shared-array-increments", 1, 0, 0,
 }
 #undef FUNC_NAME
 
-SCM 
+SCM
 scm_i_make_array (int ndim)
 {
   SCM ra;
-  SCM_NEWSMOB(ra, ((scm_t_bits) ndim << 17) + scm_i_tc16_array,
-              scm_gc_malloc ((sizeof (scm_i_t_array) +
-                             ndim * sizeof (scm_t_array_dim)),
-                            "array"));
+  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;
   return ra;
 }
@@ -260,6 +258,41 @@ scm_from_contiguous_typed_array (SCM type, SCM bounds, const void *bytes,
 }
 #undef FUNC_NAME
 
+SCM
+scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
+#define FUNC_NAME "scm_from_contiguous_array"
+{
+  size_t k, rlen = 1;
+  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);
+  k = SCM_I_ARRAY_NDIM (ra);
+
+  while (k--)
+    {
+      s[k].inc = rlen;
+      SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
+      rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
+    }
+  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_array_get_handle (ra, &h);
+  memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
+  scm_array_handle_release (&h);
+
+  if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
+    if (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
+      return SCM_I_ARRAY_V (ra);
+  return ra;
+}
+#undef FUNC_NAME
+
 SCM_DEFINE (scm_make_array, "make-array", 1, 0, 1,
            (SCM fill, SCM bounds),
            "Create and return an array.")
@@ -293,11 +326,12 @@ scm_i_ra_set_contp (SCM ra)
 
 SCM_DEFINE (scm_make_shared_array, "make-shared-array", 2, 0, 1,
            (SCM oldra, SCM mapfunc, SCM dims),
-           "@code{make-shared-array} can be used to create shared subarrays of other\n"
-           "arrays.  The @var{mapper} is a function that translates coordinates in\n"
-           "the new array into coordinates in the old array.  A @var{mapper} must be\n"
-           "linear, and its range must stay within the bounds of the old array, but\n"
-           "it can be otherwise arbitrary.  A simple example:\n"
+           "@code{make-shared-array} can be used to create shared subarrays\n"
+           "of other arrays.  The @var{mapfunc} is a function that\n"
+           "translates coordinates in the new array into coordinates in the\n"
+           "old array.  A @var{mapfunc} must be linear, and its range must\n"
+           "stay within the bounds of the old array, but it can be\n"
+           "otherwise arbitrary.  A simple example:\n"
            "@lisp\n"
            "(define fred (make-array #f 8 8))\n"
            "(define freds-diagonal\n"
@@ -411,18 +445,18 @@ 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 ra, SCM args),
-           "Return an array sharing contents with @var{array}, but with\n"
+           "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{array}.\n"
+           "@var{dim} argument for each dimension of @var{ra}.\n"
            "@var{dim0}, @var{dim1}, @dots{} should be integers between 0\n"
            "and the rank of the array to be returned.  Each integer in that\n"
            "range must appear at least once in the argument list.\n"
            "\n"
            "The values of @var{dim0}, @var{dim1}, @dots{} correspond to\n"
            "dimensions in the array to be returned, their positions in the\n"
-           "argument list to dimensions of @var{array}.  Several @var{dim}s\n"
+           "argument list to dimensions of @var{ra}.  Several @var{dim}s\n"
            "may have the same value, in which case the returned array will\n"
-           "have smaller rank than @var{array}.\n"
+           "have smaller rank than @var{ra}.\n"
            "\n"
            "@lisp\n"
            "(transpose-array '#2((a b) (c d)) 1 0) @result{} #2((a c) (b d))\n"
@@ -437,7 +471,7 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
   int ndim, i, k;
 
   SCM_VALIDATE_REST_ARGUMENT (args);
-  SCM_ASSERT (SCM_NIMP (ra), ra, SCM_ARG1, FUNC_NAME);
+  SCM_ASSERT (SCM_HEAP_OBJECT_P (ra), ra, SCM_ARG1, FUNC_NAME);
 
   if (scm_is_generalized_vector (ra))
     {
@@ -513,15 +547,15 @@ SCM_DEFINE (scm_transpose_array, "transpose-array", 1, 0, 1,
                     wouldn't have contiguous elements.  */
 SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
            (SCM ra, SCM strict),
-           "If @var{array} may be @dfn{unrolled} into a one dimensional shared array\n"
-           "without changing their order (last subscript changing fastest), then\n"
-           "@code{array-contents} returns that shared array, otherwise it returns\n"
-           "@code{#f}.  All arrays made by @var{make-array} and\n"
-           "@var{make-uniform-array} may be unrolled, some arrays made by\n"
-           "@var{make-shared-array} may not be.\n\n"
-           "If the optional argument @var{strict} is provided, a shared array will\n"
-           "be returned only if its elements are stored internally contiguous in\n"
-           "memory.")
+           "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"
+           "otherwise it returns @code{#f}.  All arrays made by\n"
+           "@code{make-array} and @code{make-uniform-array} may be unrolled,\n"
+           "some arrays made by @code{make-shared-array} may not be.  If\n"
+           "the optional argument @var{strict} is provided, a shared array\n"
+           "will be returned only if its elements are stored internally\n"
+           "contiguous in memory.")
 #define FUNC_NAME s_scm_array_contents
 {
   SCM sra;
@@ -570,150 +604,6 @@ SCM_DEFINE (scm_array_contents, "array-contents", 1, 1, 0,
 #undef FUNC_NAME
 
 
-SCM 
-scm_ra2contig (SCM ra, int copy)
-{
-  SCM ret;
-  long inc = 1;
-  size_t k, len = 1;
-  for (k = SCM_I_ARRAY_NDIM (ra); k--;)
-    len *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
-  k = SCM_I_ARRAY_NDIM (ra);
-  if (SCM_I_ARRAY_CONTP (ra) && ((0 == k) || (1 == SCM_I_ARRAY_DIMS (ra)[k - 1].inc)))
-    {
-      if (!scm_is_bitvector (SCM_I_ARRAY_V (ra)))
-       return ra;
-      if ((len == scm_c_bitvector_length (SCM_I_ARRAY_V (ra)) &&
-          0 == SCM_I_ARRAY_BASE (ra) % SCM_LONG_BIT &&
-          0 == len % SCM_LONG_BIT))
-       return ra;
-    }
-  ret = scm_i_make_array (k);
-  SCM_I_ARRAY_BASE (ret) = 0;
-  while (k--)
-    {
-      SCM_I_ARRAY_DIMS (ret)[k].lbnd = SCM_I_ARRAY_DIMS (ra)[k].lbnd;
-      SCM_I_ARRAY_DIMS (ret)[k].ubnd = SCM_I_ARRAY_DIMS (ra)[k].ubnd;
-      SCM_I_ARRAY_DIMS (ret)[k].inc = inc;
-      inc *= SCM_I_ARRAY_DIMS (ra)[k].ubnd - SCM_I_ARRAY_DIMS (ra)[k].lbnd + 1;
-    }
-  SCM_I_ARRAY_V (ret) = scm_make_generalized_vector (scm_array_type (ra),
-                                                     scm_from_long (inc),
-                                                     SCM_UNDEFINED);
-  if (copy)
-    scm_array_copy_x (ra, ret);
-  return ret;
-}
-
-
-
-SCM_DEFINE (scm_uniform_array_read_x, "uniform-array-read!", 1, 3, 0,
-           (SCM ura, SCM port_or_fd, SCM start, SCM end),
-           "@deffnx {Scheme Procedure} uniform-vector-read! uve [port-or-fdes] [start] [end]\n"
-           "Attempt to read all elements of @var{ura}, in lexicographic order, as\n"
-           "binary objects from @var{port-or-fdes}.\n"
-           "If an end of file is encountered,\n"
-           "the objects up to that point are put into @var{ura}\n"
-           "(starting at the beginning) and the remainder of the array is\n"
-           "unchanged.\n\n"
-           "The optional arguments @var{start} and @var{end} allow\n"
-           "a specified region of a vector (or linearized array) to be read,\n"
-           "leaving the remainder of the vector unchanged.\n\n"
-           "@code{uniform-array-read!} returns the number of objects read.\n"
-           "@var{port-or-fdes} may be omitted, in which case it defaults to the value\n"
-           "returned by @code{(current-input-port)}.")
-#define FUNC_NAME s_scm_uniform_array_read_x
-{
-  if (SCM_UNBNDP (port_or_fd))
-    port_or_fd = scm_current_input_port ();
-
-  if (scm_is_uniform_vector (ura))
-    {
-      return scm_uniform_vector_read_x (ura, port_or_fd, start, end);
-    }
-  else if (SCM_I_ARRAYP (ura))
-    {
-      size_t base, vlen, cstart, cend;
-      SCM cra, ans;
-      
-      cra = scm_ra2contig (ura, 0);
-      base = SCM_I_ARRAY_BASE (cra);
-      vlen = SCM_I_ARRAY_DIMS (cra)->inc *
-       (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
-      cstart = 0;
-      cend = vlen;
-      if (!SCM_UNBNDP (start))
-       {
-         cstart = scm_to_unsigned_integer (start, 0, vlen);
-         if (!SCM_UNBNDP (end))
-           cend = scm_to_unsigned_integer (end, cstart, vlen);
-       }
-
-      ans = scm_uniform_vector_read_x (SCM_I_ARRAY_V (cra), port_or_fd,
-                                      scm_from_size_t (base + cstart),
-                                      scm_from_size_t (base + cend));
-
-      if (!scm_is_eq (cra, ura))
-       scm_array_copy_x (cra, ura);
-      return ans;
-    }
-  else
-    scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_uniform_array_write, "uniform-array-write", 1, 3, 0,
-           (SCM ura, SCM port_or_fd, SCM start, SCM end),
-           "Writes all elements of @var{ura} as binary objects to\n"
-           "@var{port-or-fdes}.\n\n"
-           "The optional arguments @var{start}\n"
-           "and @var{end} allow\n"
-           "a specified region of a vector (or linearized array) to be written.\n\n"
-           "The number of objects actually written is returned.\n"
-           "@var{port-or-fdes} may be\n"
-           "omitted, in which case it defaults to the value returned by\n"
-           "@code{(current-output-port)}.")
-#define FUNC_NAME s_scm_uniform_array_write
-{
-  if (SCM_UNBNDP (port_or_fd))
-    port_or_fd = scm_current_output_port ();
-
-  if (scm_is_uniform_vector (ura))
-    {
-      return scm_uniform_vector_write (ura, port_or_fd, start, end);
-    }
-  else if (SCM_I_ARRAYP (ura))
-    {
-      size_t base, vlen, cstart, cend;
-      SCM cra, ans;
-      
-      cra = scm_ra2contig (ura, 1);
-      base = SCM_I_ARRAY_BASE (cra);
-      vlen = SCM_I_ARRAY_DIMS (cra)->inc *
-       (SCM_I_ARRAY_DIMS (cra)->ubnd - SCM_I_ARRAY_DIMS (cra)->lbnd + 1);
-
-      cstart = 0;
-      cend = vlen;
-      if (!SCM_UNBNDP (start))
-       {
-         cstart = scm_to_unsigned_integer (start, 0, vlen);
-         if (!SCM_UNBNDP (end))
-           cend = scm_to_unsigned_integer (end, cstart, vlen);
-       }
-
-      ans = scm_uniform_vector_write (SCM_I_ARRAY_V (cra), port_or_fd,
-                                     scm_from_size_t (base + cstart),
-                                     scm_from_size_t (base + cend));
-
-      return ans;
-    }
-  else
-    scm_wrong_type_arg_msg (NULL, 0, ura, "array");
-}
-#undef FUNC_NAME
-
-
 static void
 list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
 {
@@ -836,15 +726,15 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
   else
     {
       ssize_t i;
-      scm_putc ('(', port);
+      scm_putc_unlocked ('(', port);
       for (i = h->dims[dim].lbnd; i <= h->dims[dim].ubnd;
            i++, pos += h->dims[dim].inc)
         {
           scm_i_print_array_dimension (h, dim+1, pos, port, pstate);
           if (i < h->dims[dim].ubnd)
-            scm_putc (' ', port);
+            scm_putc_unlocked (' ', port);
         }
-      scm_putc (')', port);
+      scm_putc_unlocked (')', port);
     }
   return 1;
 }
@@ -852,7 +742,7 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
 /* Print an array.
 */
 
-static int
+int
 scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
 {
   scm_t_array_handle h;
@@ -861,7 +751,7 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
 
   scm_array_get_handle (array, &h);
 
-  scm_putc ('#', port);
+  scm_putc_unlocked ('#', port);
   if (h.ndims != 1 || h.dims[0].lbnd != 0)
     scm_intprint (h.ndims, 10, port);
   if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
@@ -882,12 +772,12 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
       {
        if (print_lbnds)
          {
-           scm_putc ('@', port);
+           scm_putc_unlocked ('@', port);
            scm_intprint (h.dims[i].lbnd, 10, port);
          }
        if (print_lens)
          {
-           scm_putc (':', port);
+           scm_putc_unlocked (':', port);
            scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
                          10, port);
          }
@@ -915,9 +805,9 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
          not really the same as Scheme values since they are boxed and
          can be modified with array-set!, say.
       */
-      scm_putc ('(', port);
+      scm_putc_unlocked ('(', port);
       scm_i_print_array_dimension (&h, 0, 0, port, pstate);
-      scm_putc (')', port);
+      scm_putc_unlocked (')', port);
       return 1;
     }
   else
@@ -931,15 +821,6 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
    C is the first character read after the '#'.
 */
 
-static SCM
-tag_to_type (const char *tag, SCM port)
-{
-  if (*tag == '\0')
-    return SCM_BOOL_T;
-  else
-    return scm_from_locale_symbol (tag);
-}
-
 static int
 read_decimal_integer (SCM port, int c, ssize_t *resp)
 {
@@ -950,14 +831,14 @@ read_decimal_integer (SCM port, int c, ssize_t *resp)
   if (c == '-')
     {
       sign = -1;
-      c = scm_getc (port);
+      c = scm_getc_unlocked (port);
     }
 
   while ('0' <= c && c <= '9')
     {
       res = 10*res + c-'0';
       got_it = 1;
-      c = scm_getc (port);
+      c = scm_getc_unlocked (port);
     }
 
   if (got_it)
@@ -969,11 +850,10 @@ SCM
 scm_i_read_array (SCM port, int c)
 {
   ssize_t rank;
-  int got_rank;
-  char tag[80];
+  scm_t_wchar tag_buf[8];
   int tag_len;
 
-  SCM shape = SCM_BOOL_F, elements;
+  SCM tag, shape = SCM_BOOL_F, elements;
 
   /* XXX - shortcut for ordinary vectors.  Shouldn't be necessary but
      the array code can not deal with zero-length dimensions yet, and
@@ -981,7 +861,7 @@ scm_i_read_array (SCM port, int c)
   */
   if (c == '(')
     {
-      scm_ungetc (c, port);
+      scm_ungetc_unlocked (c, port);
       return scm_vector (scm_read (port));
     }
 
@@ -989,16 +869,15 @@ scm_i_read_array (SCM port, int c)
    */
   if (c == 'f')
     {
-      c = scm_getc (port);
+      c = scm_getc_unlocked (port);
       if (c != '3' && c != '6')
        {
          if (c != EOF)
-           scm_ungetc (c, port);
+           scm_ungetc_unlocked (c, port);
          return SCM_BOOL_F;
        }
       rank = 1;
-      got_rank = 1;
-      tag[0] = 'f';
+      tag_buf[0] = 'f';
       tag_len = 1;
       goto continue_reading_tag;
     }
@@ -1015,13 +894,22 @@ scm_i_read_array (SCM port, int c)
    */
   tag_len = 0;
  continue_reading_tag:
-  while (c != EOF && c != '(' && c != '@' && c != ':' && tag_len < 80)
+  while (c != EOF && c != '(' && c != '@' && c != ':'
+         && tag_len < sizeof tag_buf / sizeof tag_buf[0])
     {
-      tag[tag_len++] = c;
-      c = scm_getc (port);
+      tag_buf[tag_len++] = c;
+      c = scm_getc_unlocked (port);
     }
-  tag[tag_len] = '\0';
-  
+  if (tag_len == 0)
+    tag = SCM_BOOL_T;
+  else
+    {
+      tag = scm_string_to_symbol (scm_from_utf32_stringn (tag_buf, tag_len));
+      if (tag_len == sizeof tag_buf / sizeof tag_buf[0])
+        scm_i_input_error (NULL, port, "invalid array tag, starting with: ~a",
+                           scm_list_1 (tag));
+    }
+    
   /* Read shape. 
    */
   if (c == '@' || c == ':')
@@ -1035,7 +923,7 @@ scm_i_read_array (SCM port, int c)
 
          if (c == '@')
            {
-             c = scm_getc (port);
+             c = scm_getc_unlocked (port);
              c = read_decimal_integer (port, c, &lbnd);
            }
          
@@ -1043,7 +931,7 @@ scm_i_read_array (SCM port, int c)
 
          if (c == ':')
            {
-             c = scm_getc (port);
+             c = scm_getc_unlocked (port);
              c = read_decimal_integer (port, c, &len);
              if (len < 0)
                scm_i_input_error (NULL, port,
@@ -1065,7 +953,7 @@ scm_i_read_array (SCM port, int c)
     scm_i_input_error (NULL, port,
                       "missing '(' in vector or array literal",
                       SCM_EOL);
-  scm_ungetc (c, port);
+  scm_ungetc_unlocked (c, port);
   elements = scm_read (port);
 
   if (scm_is_false (shape))
@@ -1094,7 +982,7 @@ scm_i_read_array (SCM port, int c)
 
   /* Construct array. 
    */
-  return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
+  return scm_list_to_typed_array (tag, shape, elements);
 }
 
 
@@ -1126,17 +1014,14 @@ array_get_handle (SCM array, scm_t_array_handle *h)
   h->base = SCM_I_ARRAY_BASE (array);
 }
 
-SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (scm_tc7_array,
+                          0x7f,
                           array_handle_ref, array_handle_set,
-                          array_get_handle);
+                          array_get_handle)
 
 void
 scm_init_arrays ()
 {
-  scm_i_tc16_array = scm_make_smob_type ("array", 0);
-  scm_set_smob_print (scm_i_tc16_array, scm_i_print_array);
-  scm_set_smob_equalp (scm_i_tc16_array, scm_array_equal_p);
-
   scm_add_feature ("array");
 
 #include "libguile/arrays.x"