-/* 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
#include "libguile/bytevectors.h"
#include "libguile/list.h"
#include "libguile/dynwind.h"
+#include "libguile/read.h"
#include "libguile/validate.h"
#include "libguile/arrays.h"
-#include "libguile/generalized-arrays.h"
-#include "libguile/generalized-vectors.h"
#include "libguile/array-map.h"
-#include "libguile/print.h"
-#include "libguile/read.h"
-
-#ifdef HAVE_UNISTD_H
-#include <unistd.h>
-#endif
-
-#ifdef HAVE_IO_H
-#include <io.h>
-#endif
+#include "libguile/generalized-vectors.h"
+#include "libguile/generalized-arrays.h"
+#include "libguile/uniform.h"
-\f
-/* The set of uniform scm_vector types is:
- * Vector of: Called: Replaced by:
- * unsigned char string
- * char byvect s8 or u8, depending on signedness of 'char'
- * boolean bvect
- * signed long ivect s32
- * unsigned long uvect u32
- * float fvect f32
- * double dvect d32
- * complex double cvect c64
- * short svect s16
- * long long llvect s64
- */
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_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) | SCM_I_ARRAY_FLAG_CONTIGUOUS))
#define SCM_CLR_ARRAY_CONTIGUOUS_FLAG(x) \
- (SCM_SET_CELL_WORD_0 ((x), SCM_CELL_WORD_0 (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
-
-typedef SCM creator_proc (SCM len, SCM fill);
-
-struct {
- char *type_name;
- SCM type;
- creator_proc *creator;
-} type_creator_table[] = {
- { "a", SCM_UNSPECIFIED, scm_make_string },
- { "b", SCM_UNSPECIFIED, scm_make_bitvector },
- { "u8", SCM_UNSPECIFIED, scm_make_u8vector },
- { "s8", SCM_UNSPECIFIED, scm_make_s8vector },
- { "u16", SCM_UNSPECIFIED, scm_make_u16vector },
- { "s16", SCM_UNSPECIFIED, scm_make_s16vector },
- { "u32", SCM_UNSPECIFIED, scm_make_u32vector },
- { "s32", SCM_UNSPECIFIED, scm_make_s32vector },
- { "u64", SCM_UNSPECIFIED, scm_make_u64vector },
- { "s64", SCM_UNSPECIFIED, scm_make_s64vector },
- { "f32", SCM_UNSPECIFIED, scm_make_f32vector },
- { "f64", SCM_UNSPECIFIED, scm_make_f64vector },
- { "c32", SCM_UNSPECIFIED, scm_make_c32vector },
- { "c64", SCM_UNSPECIFIED, scm_make_c64vector },
- { "vu8", SCM_UNSPECIFIED, scm_make_bytevector },
- { NULL }
-};
-
-static void
-init_type_creator_table ()
-{
- int i;
- for (i = 0; type_creator_table[i].type_name; i++)
- {
- SCM sym = scm_from_locale_symbol (type_creator_table[i].type_name);
- type_creator_table[i].type = scm_permanent_object (sym);
- }
-}
-
-static creator_proc *
-type_to_creator (SCM type)
-{
- int i;
-
- if (scm_is_eq (type, SCM_BOOL_T))
- return scm_make_vector;
- for (i = 0; type_creator_table[i].type_name; i++)
- if (scm_is_eq (type, type_creator_table[i].type))
- return type_creator_table[i].creator;
-
- scm_misc_error (NULL, "unknown array type: ~a", scm_list_1 (type));
-}
-
-static SCM
-make_typed_vector (SCM type, size_t len)
-{
- creator_proc *creator = type_to_creator (type);
- return creator (scm_from_size_t (len), SCM_UNDEFINED);
-}
+ (SCM_SET_SMOB_FLAGS ((x), SCM_SMOB_FLAGS (x) & ~SCM_I_ARRAY_FLAG_CONTIGUOUS))
SCM_DEFINE (scm_shared_array_root, "shared-array-root", 1, 0, 0,
return SCM_I_ARRAY_V (ra);
else if (scm_is_generalized_vector (ra))
return ra;
- scm_wrong_type_arg_msg (NULL, 0, ra, "array");
+ scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, ra, "array");
}
#undef FUNC_NAME
{
size_t k, rlen = 1;
scm_t_array_dim *s;
- creator_proc *creator;
SCM ra;
- creator = type_to_creator (type);
ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
if (scm_is_eq (fill, SCM_UNSPECIFIED))
fill = SCM_UNDEFINED;
- SCM_I_ARRAY_V (ra) = creator (scm_from_size_t (rlen), fill);
+ SCM_I_ARRAY_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 (s->ubnd < s->lbnd || (0 == s->lbnd && 1 == s->inc))
{
size_t k, rlen = 1;
scm_t_array_dim *s;
- creator_proc *creator;
SCM ra;
scm_t_array_handle h;
- void *base;
+ void *elts;
size_t sz;
- creator = type_to_creator (type);
ra = scm_i_shap2ra (bounds);
SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
s = SCM_I_ARRAY_DIMS (ra);
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) = creator (scm_from_size_t (rlen), SCM_UNDEFINED);
+ SCM_I_ARRAY_V (ra) =
+ scm_make_generalized_vector (type, scm_from_size_t (rlen), SCM_UNDEFINED);
scm_array_get_handle (ra, &h);
- base = scm_array_handle_uniform_writable_elements (&h);
- sz = scm_array_handle_uniform_element_size (&h);
+ elts = h.writable_elements;
+ sz = scm_array_handle_uniform_element_bit_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 && ((sz % 8) == 0))
+ {
+ 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);
+ }
+ else if (sz < 8)
+ {
+ /* byte_len ?= ceil (rlen * sz / 8) */
+ if (byte_len != (rlen * sz + 7) / 8)
+ SCM_MISC_ERROR ("byte length and dimensions do not match", SCM_EOL);
+ }
+ else
+ /* an internal guile error, really */
+ SCM_MISC_ERROR ("uniform elements larger than 8 bits must fill whole bytes", SCM_EOL);
- memcpy (base, bytes, byte_len);
+ memcpy (elts, bytes, byte_len);
+
+ 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
+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))
if (s[k].ubnd < s[k].lbnd)
{
if (1 == SCM_I_ARRAY_NDIM (ra))
- ra = make_typed_vector (scm_array_type (ra), 0);
+ ra = scm_make_generalized_vector (scm_array_type (ra),
+ SCM_INUM0, SCM_UNDEFINED);
else
- SCM_I_ARRAY_V (ra) = make_typed_vector (scm_array_type (ra), 0);
+ SCM_I_ARRAY_V (ra) =
+ scm_make_generalized_vector (scm_array_type (ra),
+ SCM_INUM0, SCM_UNDEFINED);
scm_array_handle_release (&old_handle);
return ra;
}
if (1 == s->inc && 0 == s->lbnd && length == 1 + s->ubnd)
return v;
if (s->ubnd < s->lbnd)
- return make_typed_vector (scm_array_type (ra), 0);
+ return scm_make_generalized_vector (scm_array_type (ra), SCM_INUM0,
+ SCM_UNDEFINED);
}
scm_i_ra_set_contp (ra);
return ra;
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))
{
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;
#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) = make_typed_vector (scm_array_type (ra), inc);
- 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
+static void
+list_to_array (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k)
{
- 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;
- }
+ if (k == scm_array_handle_rank (handle))
+ scm_array_handle_set (handle, pos, lst);
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))
+ 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))
{
- cstart = scm_to_unsigned_integer (start, 0, vlen);
- if (!SCM_UNBNDP (end))
- cend = scm_to_unsigned_integer (end, cstart, vlen);
+ list_to_array (SCM_CAR (lst), handle, pos, k + 1);
+ pos += inc;
+ lst = SCM_CDR (lst);
+ n -= 1;
}
-
- 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;
+ 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)));
}
- else
- scm_wrong_type_arg_msg (NULL, 0, ura, "array");
}
-#undef FUNC_NAME
-
-
-static void l2ra (SCM lst, scm_t_array_handle *handle, ssize_t pos, size_t k);
+
SCM_DEFINE (scm_list_to_typed_array, "list->typed-array", 3, 0, 0,
(SCM type, SCM shape, SCM lst),
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;
}
#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.
*/
static int
-scm_i_print_array_dimension (SCM array, int dim, int base,
+scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
SCM port, scm_print_state *pstate)
{
- scm_t_array_dim *dim_spec = SCM_I_ARRAY_DIMS (array) + dim;
- long idx;
-
- scm_putc ('(', port);
-
- for (idx = dim_spec->lbnd; idx <= dim_spec->ubnd; idx++)
+ if (dim == h->ndims)
+ scm_iprin1 (scm_array_handle_ref (h, pos), port, pstate);
+ else
{
- if (dim < SCM_I_ARRAY_NDIM(array)-1)
- scm_i_print_array_dimension (array, dim+1, base,
- port, pstate);
- else
- scm_iprin1 (scm_c_generalized_vector_ref (SCM_I_ARRAY_V (array), base),
- port, pstate);
- if (idx < dim_spec->ubnd)
- scm_putc (' ', port);
- base += dim_spec->inc;
+ ssize_t i;
+ scm_putc ('(', 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 (')', port);
}
-
- scm_putc (')', port);
return 1;
}
-/* Print an array. (Only for strict arrays, not for generalized vectors.)
+/* Print an array.
*/
static int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{
- long ndim = SCM_I_ARRAY_NDIM (array);
- scm_t_array_dim *dim_specs = SCM_I_ARRAY_DIMS (array);
- SCM v = SCM_I_ARRAY_V (array);
- unsigned long base = SCM_I_ARRAY_BASE (array);
+ scm_t_array_handle h;
long i;
int print_lbnds = 0, zero_size = 0, print_lens = 0;
+ scm_array_get_handle (array, &h);
+
scm_putc ('#', port);
- if (ndim != 1 || dim_specs[0].lbnd != 0)
- scm_intprint (ndim, 10, port);
- if (scm_is_uniform_vector (v))
- scm_puts (scm_i_uniform_vector_tag (v), port);
- else if (scm_is_bitvector (v))
- scm_puts ("b", port);
- else if (scm_is_string (v))
- scm_puts ("a", port);
- else if (!scm_is_vector (v))
- scm_puts ("?", 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)
+ scm_write (scm_array_handle_element_type (&h), port);
- for (i = 0; i < ndim; i++)
+ for (i = 0; i < h.ndims; i++)
{
- if (dim_specs[i].lbnd != 0)
+ if (h.dims[i].lbnd != 0)
print_lbnds = 1;
- if (dim_specs[i].ubnd - dim_specs[i].lbnd + 1 == 0)
+ if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
zero_size = 1;
else if (zero_size)
print_lens = 1;
}
if (print_lbnds || print_lens)
- for (i = 0; i < ndim; i++)
+ for (i = 0; i < h.ndims; i++)
{
if (print_lbnds)
{
scm_putc ('@', port);
- scm_intprint (dim_specs[i].lbnd, 10, port);
+ scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
scm_putc (':', port);
- scm_intprint (dim_specs[i].ubnd - dim_specs[i].lbnd + 1,
+ scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
}
- if (ndim == 0)
+ if (h.ndims == 0)
{
/* Rank zero arrays, which are really just scalars, are printed
specially. The consequent way would be to print them as
can be modified with array-set!, say.
*/
scm_putc ('(', port);
- scm_iprin1 (scm_c_generalized_vector_ref (v, base), port, pstate);
+ scm_i_print_array_dimension (&h, 0, 0, port, pstate);
scm_putc (')', port);
return 1;
}
else
- return scm_i_print_array_dimension (array, 0, base, port, pstate);
+ return scm_i_print_array_dimension (&h, 0, 0, port, pstate);
}
/* Read an array. This function can also read vectors and uniform
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)
{
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
return SCM_BOOL_F;
}
rank = 1;
- got_rank = 1;
- tag[0] = 'f';
+ tag_buf[0] = 'f';
tag_len = 1;
goto continue_reading_tag;
}
*/
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;
+ tag_buf[tag_len++] = c;
c = scm_getc (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 == ':')
/* Construct array.
*/
- return scm_list_to_typed_array (tag_to_type (tag, port), shape, elements);
-}
-
-
-static SCM
-array_mark (SCM ptr)
-{
- return SCM_I_ARRAY_V (ptr);
+ return scm_list_to_typed_array (tag, shape, elements);
}
-static size_t
-array_free (SCM ptr)
-{
- scm_gc_free (SCM_I_ARRAY_MEM (ptr),
- (sizeof (scm_i_t_array)
- + SCM_I_ARRAY_NDIM (ptr) * sizeof (scm_t_array_dim)),
- "array");
- return 0;
-}
static SCM
array_handle_ref (scm_t_array_handle *h, size_t pos)
h->base = SCM_I_ARRAY_BASE (array);
}
-SCM_ARRAY_IMPLEMENTATION (scm_i_tc16_array, 0xffff,
+SCM_ARRAY_IMPLEMENTATION (SCM_SMOB_TYPE_BITS (scm_i_tc16_array),
+ SCM_SMOB_TYPE_MASK,
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_mark (scm_i_tc16_array, array_mark);
- scm_set_smob_free (scm_i_tc16_array, array_free);
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");
- init_type_creator_table ();
-
#include "libguile/arrays.x"
}
HCoop / bpt / guile.git / blobdiff