[bpt/guile.git] / libguile / srfi-4.c

/* srfi-4.c --- Homogeneous numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2004 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 2.1 of the License, or (at your option) any later version.
 *
 * This library 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 this library; if not, write to the Free Software
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
 */

#include <libguile.h>
#include <string.h>
#include <stdio.h>

#include "libguile/srfi-4.h"
#include "libguile/error.h"
#include "libguile/read.h"
#include "libguile/ports.h"
#include "libguile/chars.h"

/* Smob type code for homogeneous numeric vectors.  */
int scm_tc16_uvec = 0;


/* Accessor macros for the three components of a homogeneous numeric
   vector:
   - The type tag (one of the symbolic constants below).
   - The vector's length (counted in elements).
   - The address of the data area (holding the elements of the
     vector). */
#define SCM_UVEC_TYPE(u)   (SCM_CELL_WORD_1(u))
#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
#define SCM_UVEC_BASE(u)   ((void *)SCM_CELL_WORD_3(u))


/* Symbolic constants encoding the various types of homogeneous
   numeric vectors.  */
#define SCM_UVEC_U8  	0
#define SCM_UVEC_S8  	1
#define SCM_UVEC_U16 	2
#define SCM_UVEC_S16 	3
#define SCM_UVEC_U32 	4
#define SCM_UVEC_S32 	5
#define SCM_UVEC_U64 	6
#define SCM_UVEC_S64 	7
#define SCM_UVEC_F32 	8
#define SCM_UVEC_F64 	9


/* This array maps type tags to the size of the elements.  */
static const int uvec_sizes[10] = {
  1, 1,
  2, 2,
  4, 4,
  8, 8,
  sizeof(float), sizeof(double)
};

static const char *uvec_tags[10] = {
  "u8", "s8",
  "u16", "s16",
  "u32", "s32",
  "u64", "s64",
  "f32", "f64"
};

static const char *uvec_names[10] = {
  "u8vector", "s8vector",
  "u16vector", "s16vector",
  "u32vector", "s32vector",
  "u64vector", "s64vector",
  "f32vector", "f64vector"
};

/* ================================================================ */
/* SMOB procedures.                                                 */
/* ================================================================ */


/* Smob print hook for homogeneous vectors.  */
static int
uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
{
  union {
    scm_t_uint8 *u8;
    scm_t_int8 *s8;
    scm_t_uint16 *u16;
    scm_t_int16 *s16;
    scm_t_uint32 *u32;
    scm_t_int32 *s32;
#if SCM_HAVE_T_INT64
    scm_t_uint64 *u64;
    scm_t_int64 *s64;
#endif
    float *f32;
    double *f64;
  } np;

  size_t i = 0;
  const size_t uvlen = SCM_UVEC_LENGTH (uvec);
  void *uptr = SCM_UVEC_BASE (uvec);

  switch (SCM_UVEC_TYPE (uvec))
  {
    case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
    case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
    case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
    case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
    case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
    case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
#if SCM_HAVE_T_INT64
    case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
    case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
#endif
    case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
    case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
    default:
      abort ();			/* Sanity check.  */
      break;
  }

  scm_putc ('#', port);
  scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
  scm_putc ('(', port);

  while (i < uvlen)
    {
      if (i != 0) scm_puts (" ", port);
      switch (SCM_UVEC_TYPE (uvec))
	{
	case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
	case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
	case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
	case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
	case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
	case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
#if SCM_HAVE_T_INT64
	case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
	case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
#endif
	case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
	case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
	default:
	  abort ();			/* Sanity check.  */
	  break;
	}
      i++;
    }
  scm_remember_upto_here_1 (uvec);
  scm_puts (")", port);
  return 1;
}

const char *
scm_i_uniform_vector_tag (SCM uvec)
{
  return uvec_tags[SCM_UVEC_TYPE (uvec)];
}

static SCM
uvec_equalp (SCM a, SCM b)
{
  SCM result = SCM_BOOL_T;
  if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
    result = SCM_BOOL_F;
  else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
    result = SCM_BOOL_F;
  else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
		   SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
    result = SCM_BOOL_F;

  scm_remember_upto_here_2 (a, b);
  return result;
}

/* Smob free hook for homogeneous numeric vectors. */
static size_t
uvec_free (SCM uvec)
{
  int type = SCM_UVEC_TYPE (uvec);
  scm_gc_free (SCM_UVEC_BASE (uvec),
	       SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
	       uvec_names[type]);
  return 0;
}

/* ================================================================ */
/* Utility procedures.                                              */
/* ================================================================ */

static SCM_C_INLINE int
is_uvec (int type, SCM obj)
{
  return (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj)
	  && SCM_UVEC_TYPE (obj) == type);
}

static SCM_C_INLINE SCM
uvec_p (int type, SCM obj)
{
  return scm_from_bool (is_uvec (type, obj));
}

static SCM_C_INLINE void
uvec_assert (int type, SCM obj)
{
  if (!is_uvec (type, obj))
    scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
}

static SCM
take_uvec (int type, const void *base, size_t len)
{
  SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
}
  
/* Create a new, uninitialized homogeneous numeric vector of type TYPE
   with space for LEN elements.  */
static SCM
alloc_uvec (int type, size_t len)
{
  void *base = scm_gc_malloc (len * uvec_sizes[type], uvec_names[type]);
  return take_uvec (type, base, len);
}

/* GCC doesn't seem to want to optimize unused switch clauses away,
   so we use a big 'if' in the next two functions.
*/

static SCM_C_INLINE SCM
uvec_fast_ref (int type, void *base, size_t c_idx)
{
  if (type == SCM_UVEC_U8)
    return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
  else if (type == SCM_UVEC_S8)
    return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
  else if (type == SCM_UVEC_U16)
    return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
  else if (type == SCM_UVEC_S16)
    return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
  else if (type == SCM_UVEC_U32)
    return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
  else if (type == SCM_UVEC_S32)
    return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
#if SCM_HAVE_T_INT64
  else if (type == SCM_UVEC_U64)
    return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
  else if (type == SCM_UVEC_S64)
    return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
#endif
  else if (type == SCM_UVEC_F32)
    return scm_from_double (((float*)base)[c_idx]);
  else if (type == SCM_UVEC_F64)
    return scm_from_double (((double*)base)[c_idx]);
}

static SCM_C_INLINE void
uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
{
  if (type == SCM_UVEC_U8)
    (((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
  else if (type == SCM_UVEC_S8)
    (((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
  else if (type == SCM_UVEC_U16)
    (((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
  else if (type == SCM_UVEC_S16)
    (((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
  else if (type == SCM_UVEC_U32)
    (((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
  else if (type == SCM_UVEC_S32)
    (((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
#if SCM_HAVE_T_INT64
  else if (type == SCM_UVEC_U64)
    (((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
  else if (type == SCM_UVEC_S64)
    (((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
#endif
  else if (type == SCM_UVEC_F32)
    (((float*)base)[c_idx]) = scm_to_double (val);
  else if (type == SCM_UVEC_F64)
    (((double*)base)[c_idx]) = scm_to_double (val);
}

static SCM_C_INLINE SCM
make_uvec (int type, SCM len, SCM fill)
{
  size_t c_len = scm_to_unsigned_integer (len, 0, SIZE_MAX / uvec_sizes[type]);
  SCM uvec = alloc_uvec (type, c_len);
  if (!SCM_UNBNDP (fill))
    {
      size_t idx;
      void *base = SCM_UVEC_BASE (uvec);
      for (idx = 0; idx < c_len; idx++)
	uvec_fast_set_x (type, base, idx, fill);
    }
  return uvec;
}

static SCM_C_INLINE SCM
uvec_length (int type, SCM uvec)
{
  uvec_assert (type, uvec);
  return scm_from_size_t (SCM_UVEC_LENGTH (uvec));
}

static SCM_C_INLINE SCM
uvec_ref (int type, SCM uvec, SCM idx)
{
  size_t c_idx;
  SCM res;

  uvec_assert (type, uvec);
  c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
  res = uvec_fast_ref (type, SCM_UVEC_BASE(uvec), c_idx);
  scm_remember_upto_here_1 (uvec);
  return res;
}

static SCM_C_INLINE SCM
uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
{
  size_t c_idx;

  uvec_assert (type, uvec);
  c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
  uvec_fast_set_x (type, SCM_UVEC_BASE(uvec), c_idx, val);
  scm_remember_upto_here_1 (uvec);
  return SCM_UNSPECIFIED;
}

static SCM_C_INLINE SCM
uvec_to_list (int type, SCM uvec)
{
  size_t c_idx;
  void *base;
  SCM res = SCM_EOL;

  uvec_assert (type, uvec);
  c_idx = SCM_UVEC_LENGTH (uvec);
  base = SCM_UVEC_BASE (uvec);
  while (c_idx-- > 0)
    res = scm_cons (uvec_fast_ref (type, base, c_idx), res);
  scm_remember_upto_here_1 (uvec);
  return res;
}

static SCM_C_INLINE SCM
list_to_uvec (int type, SCM list)
{
  SCM uvec;
  void *base;
  long idx;
  long len = scm_ilength (list);
  if (len < 0)
    scm_wrong_type_arg_msg (NULL, 0, list, "proper list");

  uvec = alloc_uvec (type, len);
  base = SCM_UVEC_BASE (uvec);
  idx = 0;
  while (scm_is_pair (list) && idx < len)
    {
      uvec_fast_set_x (type, base, idx, SCM_CAR (list));
      list = SCM_CDR (list);
      idx++;
    }
  return uvec;
}

SCM
scm_i_read_homogenous_vector (SCM port, char pfx)
{
  /* We have read '#f', '#u', or '#s'.  Next must be a decimal integer
     followed immediately by a list.
  */

  int c;
  char tok[80];
  int n_digs;
  SCM list;

  n_digs = 0;
  while ((c = scm_getc (port)) != EOF && '0' <= c && c <= '9' && n_digs < 80)
    tok[n_digs++] = c;
  
  if (c != EOF)
    scm_ungetc (c, port);
  
  if (n_digs == 0 && pfx == 'f')
      return SCM_BOOL_F;

  if (c != '(')
    scm_i_input_error (NULL, port,
		       "#~a~a must be followed immediately by a '('",
		       scm_list_2 (SCM_MAKE_CHAR (pfx),
				   scm_from_locale_stringn (tok, n_digs)));
  
  list = scm_read (port);

  if (n_digs == 1 && strncmp (tok, "8", n_digs) == 0)
    {
      if (pfx == 'u')
	return scm_list_to_u8vector (list);
      else if (pfx == 's')
	return scm_list_to_s8vector (list);
    }
  else if (n_digs == 2 && strncmp (tok, "16", n_digs) == 0)
    {
      if (pfx == 'u')
	return scm_list_to_u16vector (list);
      else if (pfx == 's')
	return scm_list_to_s16vector (list);
    }
  else if (n_digs == 2 && strncmp (tok, "32", n_digs) == 0)
    {
      if (pfx == 'u')
	return scm_list_to_u32vector (list);
      else if (pfx == 's')
	return scm_list_to_s32vector (list);
      else if (pfx == 'f')
	return scm_list_to_f32vector (list);
    }
  else if (n_digs == 2 && strncmp (tok, "64", n_digs) == 0)
    {
      if (pfx == 'u')
	return scm_list_to_u64vector (list);
      else if (pfx == 's')
	return scm_list_to_s64vector (list);
      else if (pfx == 'f')
	return scm_list_to_f64vector (list);
    }

  scm_i_input_error (NULL, port,
		     "unrecognized homogenous vector prefix #~a~a",
		     scm_list_2 (SCM_MAKE_CHAR (pfx),
				 scm_from_locale_stringn (tok, n_digs)));
  return SCM_BOOL_F;
}

SCM
scm_i_uniform_vector_prototype (SCM uvec)
{
  switch (SCM_UVEC_TYPE (uvec))
    {
    case SCM_UVEC_U8:
      return SCM_BOOL_F;
    case SCM_UVEC_S8:
      return SCM_MAKE_CHAR ('\0');
    case SCM_UVEC_U16:
      return SCM_BOOL_F;
    case SCM_UVEC_S16:
      return SCM_BOOL_F;
    case SCM_UVEC_U32:
      return SCM_BOOL_F;
    case SCM_UVEC_S32:
      return SCM_BOOL_F;
    case SCM_UVEC_U64:
      return SCM_BOOL_F;
    case SCM_UVEC_S64:
      return SCM_BOOL_F;
    case SCM_UVEC_F32:
      return SCM_BOOL_F;
    case SCM_UVEC_F64:
      return SCM_BOOL_F;
    default:
      return SCM_BOOL_F;
    }
}

int
scm_is_uniform_vector (SCM obj)
{
  return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj);
}

size_t
scm_c_uniform_vector_length (SCM v)
{
  if (scm_is_uniform_vector (v))
    return SCM_UVEC_LENGTH (v);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
}

size_t
scm_c_uniform_vector_size (SCM v)
{
  if (scm_is_uniform_vector (v))
    return SCM_UVEC_LENGTH (v) * uvec_sizes[SCM_UVEC_TYPE (v)];
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
}

SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
	    (SCM obj),
	    "Return @code{#t} if @var{obj} is a uniform vector.")
#define FUNC_NAME s_scm_uniform_vector_p
{
  return scm_from_bool (scm_is_uniform_vector (obj));
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
	    (SCM v, SCM idx),
	    "Return the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v}.")
#define FUNC_NAME s_scm_uniform_vector_ref
{
  /* Support old argument convention.
   */
  if (scm_is_pair (idx))
    {
      if (!scm_is_null (SCM_CDR (idx)))
	scm_wrong_num_args (NULL);
      idx = SCM_CAR (idx);
    }

  if (scm_is_uniform_vector (v))
    return uvec_ref (SCM_UVEC_TYPE (v), v, idx);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
	    (SCM v, SCM idx, SCM val),
	    "Set the element at index @var{idx} of the\n"
	    "homogenous numeric vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_uniform_vector_set_x
{
  /* Support old argument convention.
   */
  if (scm_is_pair (idx))
    {
      if (!scm_is_null (SCM_CDR (idx)))
	scm_wrong_num_args (NULL);
      idx = SCM_CAR (idx);
    }

  if (scm_is_uniform_vector (v))
    return uvec_set_x (SCM_UVEC_TYPE (v), v, idx, val);
  else
    scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
}
#undef FUNC_NAME

SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
            (SCM uvec),
	    "Convert the homogeneous numeric vector @var{uvec} to a list.")
#define FUNC_NAME s_uniform_vector_to_list
{
  if (scm_is_uniform_vector (uvec))
    return uvec_to_list (SCM_UVEC_TYPE (uvec), uvec);
  else
    scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}
#undef FUNC_NAME

void *
scm_uniform_vector_elements (SCM uvec)
{
  if (scm_is_uniform_vector (uvec))
    return SCM_UVEC_BASE (uvec);
  else
    scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}

void
scm_uniform_vector_release (SCM uvec)
{
  /* Nothing to do right now, but this function might come in handy
     when uniform vectors need to be locked when giving away a pointer
     to their elements.
     
     Also, a call to scm_uniform_vector acts like
     scm_remember_upto_here, which is needed in any case.
  */
}

size_t
scm_uniform_vector_element_size (SCM uvec)
{
  if (scm_is_uniform_vector (uvec))
    return uvec_sizes[SCM_UVEC_TYPE (uvec)];
  else
    scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
}
  
/* return the size of an element in a uniform array or 0 if type not
   found.  */
size_t
scm_uniform_element_size (SCM obj)
{
  size_t result;

  if (scm_is_uniform_vector (obj))
    return scm_uniform_vector_element_size (obj);

  switch (SCM_TYP7 (obj))
    {
    case scm_tc7_bvect:
    case scm_tc7_uvect:
    case scm_tc7_ivect:
      result = sizeof (long);
      break;

    case scm_tc7_svect:
      result = sizeof (short);
      break;

#if SCM_SIZEOF_LONG_LONG != 0
    case scm_tc7_llvect:
      result = sizeof (long long);
      break;
#endif 

    case scm_tc7_fvect:
      result = sizeof (float);
      break;

    case scm_tc7_dvect:
      result = sizeof (double);
      break;

    case scm_tc7_cvect:
      result = 2 * sizeof (double);
      break;
      
    default:
      result = 0;
    }
  return result;
}

SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0, 
	    (SCM v),
	    "Return the number of elements in @var{uve}.")
#define FUNC_NAME s_scm_uniform_vector_length
{
  if (scm_is_uniform_vector (v))
    return scm_from_size_t (SCM_UVEC_LENGTH (v));

  SCM_ASRTGO (SCM_NIMP (v), badarg1);
  switch SCM_TYP7 (v)
    {
    default:
    badarg1:SCM_WRONG_TYPE_ARG (1, v);
    case scm_tc7_vector:
    case scm_tc7_wvect:
      return scm_from_size_t (SCM_VECTOR_LENGTH (v));
    case scm_tc7_string:
      return scm_from_size_t (scm_i_string_length (v));
    case scm_tc7_bvect:
      return scm_from_size_t (SCM_BITVECTOR_LENGTH (v));
    case scm_tc7_uvect:
    case scm_tc7_ivect:
    case scm_tc7_fvect:
    case scm_tc7_dvect:
    case scm_tc7_cvect:
    case scm_tc7_svect:
#if SCM_SIZEOF_LONG_LONG != 0
    case scm_tc7_llvect:
#endif
      return scm_from_size_t (SCM_UVECTOR_LENGTH (v));
    }
}
#undef FUNC_NAME

/* ================================================================ */
/* Exported procedures.                                             */
/* ================================================================ */

#define TYPE  SCM_UVEC_U8
#define TAG   u8
#define CTYPE scm_t_uint8
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S8
#define TAG   s8
#define CTYPE scm_t_int8
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U16
#define TAG   u16
#define CTYPE scm_t_uint16
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S16
#define TAG   s16
#define CTYPE scm_t_int16
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U32
#define TAG   u32
#define CTYPE scm_t_uint32
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S32
#define TAG   s32
#define CTYPE scm_t_int32
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_U64
#define TAG   u64
#define CTYPE scm_t_uint64
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_S64
#define TAG   s64
#define CTYPE scm_t_int64
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_F32
#define TAG   f32
#define CTYPE float
#include "libguile/srfi-4.i.c"

#define TYPE  SCM_UVEC_F64
#define TAG   f64
#define CTYPE double
#include "libguile/srfi-4.i.c"


/* Create the smob type for homogeneous numeric vectors and install
   the primitives.  */
void
scm_init_srfi_4 (void)
{
  scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
  scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
  scm_set_smob_free (scm_tc16_uvec, uvec_free);
  scm_set_smob_print (scm_tc16_uvec, uvec_print);
#include "libguile/srfi-4.x"
}

/* End of srfi-4.c.  */
Commit	Line	Data
f8579182 MV	1	/* srfi-4.c --- Homogeneous numeric vector datatypes.
	2	*
	3	* Copyright (C) 2001, 2004 Free Software Foundation, Inc.
	4	*
	5	* This library is free software; you can redistribute it and/or
	6	* modify it under the terms of the GNU Lesser General Public
	7	* License as published by the Free Software Foundation; either
	8	* version 2.1 of the License, or (at your option) any later version.
	9	*
	10	* This library is distributed in the hope that it will be useful,
	11	* but WITHOUT ANY WARRANTY; without even the implied warranty of
	12	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
	13	* Lesser General Public License for more details.
	14	*
	15	* You should have received a copy of the GNU Lesser General Public
	16	* License along with this library; if not, write to the Free Software
	17	* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
	18	*/
	19
	20	#include <libguile.h>
	21	#include <string.h>
	22	#include <stdio.h>
	23
	24	#include "libguile/srfi-4.h"
	25	#include "libguile/error.h"
	26	#include "libguile/read.h"
	27	#include "libguile/ports.h"
	28	#include "libguile/chars.h"
	29
	30	/* Smob type code for homogeneous numeric vectors. */
	31	int scm_tc16_uvec = 0;
	32
	33
	34	/* Accessor macros for the three components of a homogeneous numeric
	35	vector:
	36	- The type tag (one of the symbolic constants below).
	37	- The vector's length (counted in elements).
	38	- The address of the data area (holding the elements of the
	39	vector). */
	40	#define SCM_UVEC_TYPE(u) (SCM_CELL_WORD_1(u))
	41	#define SCM_UVEC_LENGTH(u) ((size_t)SCM_CELL_WORD_2(u))
	42	#define SCM_UVEC_BASE(u) ((void *)SCM_CELL_WORD_3(u))
	43
	44
	45	/* Symbolic constants encoding the various types of homogeneous
	46	numeric vectors. */
	47	#define SCM_UVEC_U8 0
	48	#define SCM_UVEC_S8 1
	49	#define SCM_UVEC_U16 2
	50	#define SCM_UVEC_S16 3
	51	#define SCM_UVEC_U32 4
	52	#define SCM_UVEC_S32 5
	53	#define SCM_UVEC_U64 6
	54	#define SCM_UVEC_S64 7
	55	#define SCM_UVEC_F32 8
	56	#define SCM_UVEC_F64 9
	57
	58
	59	/* This array maps type tags to the size of the elements. */
	60	static const int uvec_sizes[10] = {
	61	1, 1,
	62	2, 2,
	63	4, 4,
	64	8, 8,
65	sizeof(float), sizeof(double)
66	};
67
e0e49670 MV	68	static const char *uvec_tags[10] = {
	69	"u8", "s8",
	70	"u16", "s16",
	71	"u32", "s32",
	72	"u64", "s64",
	73	"f32", "f64"
	74	};
	75
f8579182 MV	76	static const char *uvec_names[10] = {
	77	"u8vector", "s8vector",
	78	"u16vector", "s16vector",
	79	"u32vector", "s32vector",
	80	"u64vector", "s64vector",
	81	"f32vector", "f64vector"
	82	};
	83
	84	/* ================================================================ */
	85	/* SMOB procedures. */
	86	/* ================================================================ */
	87
	88
	89	/* Smob print hook for homogeneous vectors. */
	90	static int
	91	uvec_print (SCM uvec, SCM port, scm_print_state *pstate)
	92	{
	93	union {
	94	scm_t_uint8 *u8;
	95	scm_t_int8 *s8;
	96	scm_t_uint16 *u16;
	97	scm_t_int16 *s16;
	98	scm_t_uint32 *u32;
	99	scm_t_int32 *s32;
	100	#if SCM_HAVE_T_INT64
	101	scm_t_uint64 *u64;
	102	scm_t_int64 *s64;
	103	#endif
	104	float *f32;
	105	double *f64;
	106	} np;
	107
	108	size_t i = 0;
	109	const size_t uvlen = SCM_UVEC_LENGTH (uvec);
f8579182 MV	110	void *uptr = SCM_UVEC_BASE (uvec);
	111
	112	switch (SCM_UVEC_TYPE (uvec))
	113	{
e0e49670 MV	114	case SCM_UVEC_U8: np.u8 = (scm_t_uint8 *) uptr; break;
	115	case SCM_UVEC_S8: np.s8 = (scm_t_int8 *) uptr; break;
	116	case SCM_UVEC_U16: np.u16 = (scm_t_uint16 *) uptr; break;
	117	case SCM_UVEC_S16: np.s16 = (scm_t_int16 *) uptr; break;
	118	case SCM_UVEC_U32: np.u32 = (scm_t_uint32 *) uptr; break;
	119	case SCM_UVEC_S32: np.s32 = (scm_t_int32 *) uptr; break;
f8579182	120	#if SCM_HAVE_T_INT64
e0e49670 MV	121	case SCM_UVEC_U64: np.u64 = (scm_t_uint64 *) uptr; break;
e0e49670 MV	122	case SCM_UVEC_S64: np.s64 = (scm_t_int64 *) uptr; break;
f8579182	123	#endif
e0e49670 MV	124	case SCM_UVEC_F32: np.f32 = (float *) uptr; break;
e0e49670 MV	125	case SCM_UVEC_F64: np.f64 = (double *) uptr; break;
f8579182 MV	126	default:
	127	abort (); /* Sanity check. */
	128	break;
	129	}
	130
	131	scm_putc ('#', port);
e0e49670	132	scm_puts (uvec_tags [SCM_UVEC_TYPE (uvec)], port);
f8579182 MV	133	scm_putc ('(', port);
	134
	135	while (i < uvlen)
	136	{
	137	if (i != 0) scm_puts (" ", port);
	138	switch (SCM_UVEC_TYPE (uvec))
	139	{
	140	case SCM_UVEC_U8: scm_uintprint (*np.u8, 10, port); np.u8++; break;
	141	case SCM_UVEC_S8: scm_intprint (*np.s8, 10, port); np.s8++; break;
	142	case SCM_UVEC_U16: scm_uintprint (*np.u16, 10, port); np.u16++; break;
	143	case SCM_UVEC_S16: scm_intprint (*np.s16, 10, port); np.s16++; break;
	144	case SCM_UVEC_U32: scm_uintprint (*np.u32, 10, port); np.u32++; break;
	145	case SCM_UVEC_S32: scm_intprint (*np.s32, 10, port); np.s32++; break;
	146	#if SCM_HAVE_T_INT64
	147	case SCM_UVEC_U64: scm_uintprint (*np.u64, 10, port); np.u64++; break;
	148	case SCM_UVEC_S64: scm_intprint (*np.s64, 10, port); np.s64++; break;
	149	#endif
	150	case SCM_UVEC_F32: scm_i_print_double (*np.f32, port); np.f32++; break;
	151	case SCM_UVEC_F64: scm_i_print_double (*np.f64, port); np.f64++; break;
	152	default:
	153	abort (); /* Sanity check. */
	154	break;
	155	}
	156	i++;
	157	}
	158	scm_remember_upto_here_1 (uvec);
	159	scm_puts (")", port);
	160	return 1;
	161	}
	162
e0e49670 MV	163	const char *
	164	scm_i_uniform_vector_tag (SCM uvec)
	165	{
	166	return uvec_tags[SCM_UVEC_TYPE (uvec)];
	167	}
	168
f8579182 MV	169	static SCM
	170	uvec_equalp (SCM a, SCM b)
	171	{
	172	SCM result = SCM_BOOL_T;
	173	if (SCM_UVEC_TYPE (a) != SCM_UVEC_TYPE (b))
	174	result = SCM_BOOL_F;
	175	else if (SCM_UVEC_LENGTH (a) != SCM_UVEC_LENGTH (b))
	176	result = SCM_BOOL_F;
	177	else if (memcmp (SCM_UVEC_BASE (a), SCM_UVEC_BASE (b),
	178	SCM_UVEC_LENGTH (a) * uvec_sizes[SCM_UVEC_TYPE(a)]) != 0)
	179	result = SCM_BOOL_F;
	180
	181	scm_remember_upto_here_2 (a, b);
	182	return result;
	183	}
	184
	185	/* Smob free hook for homogeneous numeric vectors. */
	186	static size_t
	187	uvec_free (SCM uvec)
	188	{
	189	int type = SCM_UVEC_TYPE (uvec);
	190	scm_gc_free (SCM_UVEC_BASE (uvec),
	191	SCM_UVEC_LENGTH (uvec) * uvec_sizes[type],
	192	uvec_names[type]);
	193	return 0;
	194	}
	195
	196	/* ================================================================ */
	197	/* Utility procedures. */
	198	/* ================================================================ */
	199
	200	static SCM_C_INLINE int
	201	is_uvec (int type, SCM obj)
	202	{
	203	return (SCM_SMOB_PREDICATE (scm_tc16_uvec, obj)
	204	&& SCM_UVEC_TYPE (obj) == type);
	205	}
	206
	207	static SCM_C_INLINE SCM
	208	uvec_p (int type, SCM obj)
	209	{
	210	return scm_from_bool (is_uvec (type, obj));
	211	}
	212
	213	static SCM_C_INLINE void
	214	uvec_assert (int type, SCM obj)
	215	{
	216	if (!is_uvec (type, obj))
	217	scm_wrong_type_arg_msg (NULL, 0, obj, uvec_names[type]);
	218	}
	219
faa00365 MV	220	static SCM
	221	take_uvec (int type, const void *base, size_t len)
	222	{
	223	SCM_RETURN_NEWSMOB3 (scm_tc16_uvec, type, len, (scm_t_bits) base);
	224	}
	225
f8579182 MV	226	/* Create a new, uninitialized homogeneous numeric vector of type TYPE
	227	with space for LEN elements. */
	228	static SCM
faa00365	229	alloc_uvec (int type, size_t len)
f8579182	230	{
faa00365 MV	231	void base = scm_gc_malloc (len uvec_sizes[type], uvec_names[type]);
faa00365 MV	232	return take_uvec (type, base, len);
f8579182 MV	233	}
	234
	235	/* GCC doesn't seem to want to optimize unused switch clauses away,
	236	so we use a big 'if' in the next two functions.
	237	*/
	238
	239	static SCM_C_INLINE SCM
	240	uvec_fast_ref (int type, void *base, size_t c_idx)
	241	{
	242	if (type == SCM_UVEC_U8)
	243	return scm_from_uint8 (((scm_t_uint8*)base)[c_idx]);
	244	else if (type == SCM_UVEC_S8)
	245	return scm_from_int8 (((scm_t_int8*)base)[c_idx]);
	246	else if (type == SCM_UVEC_U16)
	247	return scm_from_uint16 (((scm_t_uint16*)base)[c_idx]);
	248	else if (type == SCM_UVEC_S16)
	249	return scm_from_int16 (((scm_t_int16*)base)[c_idx]);
	250	else if (type == SCM_UVEC_U32)
	251	return scm_from_uint32 (((scm_t_uint32*)base)[c_idx]);
	252	else if (type == SCM_UVEC_S32)
	253	return scm_from_int32 (((scm_t_int32*)base)[c_idx]);
	254	#if SCM_HAVE_T_INT64
	255	else if (type == SCM_UVEC_U64)
	256	return scm_from_uint64 (((scm_t_uint64*)base)[c_idx]);
	257	else if (type == SCM_UVEC_S64)
	258	return scm_from_int64 (((scm_t_int64*)base)[c_idx]);
	259	#endif
	260	else if (type == SCM_UVEC_F32)
	261	return scm_from_double (((float*)base)[c_idx]);
	262	else if (type == SCM_UVEC_F64)
	263	return scm_from_double (((double*)base)[c_idx]);
	264	}
	265
	266	static SCM_C_INLINE void
	267	uvec_fast_set_x (int type, void *base, size_t c_idx, SCM val)
	268	{
	269	if (type == SCM_UVEC_U8)
	270	(((scm_t_uint8*)base)[c_idx]) = scm_to_uint8 (val);
	271	else if (type == SCM_UVEC_S8)
	272	(((scm_t_int8*)base)[c_idx]) = scm_to_int8 (val);
	273	else if (type == SCM_UVEC_U16)
	274	(((scm_t_uint16*)base)[c_idx]) = scm_to_uint16 (val);
	275	else if (type == SCM_UVEC_S16)
	276	(((scm_t_int16*)base)[c_idx]) = scm_to_int16 (val);
	277	else if (type == SCM_UVEC_U32)
	278	(((scm_t_uint32*)base)[c_idx]) = scm_to_uint32 (val);
	279	else if (type == SCM_UVEC_S32)
	280	(((scm_t_int32*)base)[c_idx]) = scm_to_int32 (val);
	281	#if SCM_HAVE_T_INT64
	282	else if (type == SCM_UVEC_U64)
	283	(((scm_t_uint64*)base)[c_idx]) = scm_to_uint64 (val);
	284	else if (type == SCM_UVEC_S64)
	285	(((scm_t_int64*)base)[c_idx]) = scm_to_int64 (val);
	286	#endif
	287	else if (type == SCM_UVEC_F32)
	288	(((float*)base)[c_idx]) = scm_to_double (val);
	289	else if (type == SCM_UVEC_F64)
	290	(((double*)base)[c_idx]) = scm_to_double (val);
	291	}
	292
	293	static SCM_C_INLINE SCM
	294	make_uvec (int type, SCM len, SCM fill)
	295	{
	296	size_t c_len = scm_to_unsigned_integer (len, 0, SIZE_MAX / uvec_sizes[type]);
297	SCM uvec = alloc_uvec (type, c_len);
298	if (!SCM_UNBNDP (fill))
299	{
300	size_t idx;
301	void *base = SCM_UVEC_BASE (uvec);
302	for (idx = 0; idx < c_len; idx++)
303	uvec_fast_set_x (type, base, idx, fill);
304	}
305	return uvec;
306	}
307
308	static SCM_C_INLINE SCM
309	uvec_length (int type, SCM uvec)
310	{
311	uvec_assert (type, uvec);
312	return scm_from_size_t (SCM_UVEC_LENGTH (uvec));
313	}
314
315	static SCM_C_INLINE SCM
316	uvec_ref (int type, SCM uvec, SCM idx)
317	{
318	size_t c_idx;
319	SCM res;
320
321	uvec_assert (type, uvec);
322	c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
323	res = uvec_fast_ref (type, SCM_UVEC_BASE(uvec), c_idx);
324	scm_remember_upto_here_1 (uvec);
325	return res;
326	}
327
328	static SCM_C_INLINE SCM
329	uvec_set_x (int type, SCM uvec, SCM idx, SCM val)
330	{
331	size_t c_idx;
332
333	uvec_assert (type, uvec);
334	c_idx = scm_to_unsigned_integer (idx, 0, SCM_UVEC_LENGTH (uvec)-1);
335	uvec_fast_set_x (type, SCM_UVEC_BASE(uvec), c_idx, val);
336	scm_remember_upto_here_1 (uvec);
337	return SCM_UNSPECIFIED;
338	}
339
340	static SCM_C_INLINE SCM
341	uvec_to_list (int type, SCM uvec)
342	{
343	size_t c_idx;
344	void *base;
345	SCM res = SCM_EOL;
346
347	uvec_assert (type, uvec);
348	c_idx = SCM_UVEC_LENGTH (uvec);
349	base = SCM_UVEC_BASE (uvec);
350	while (c_idx-- > 0)
351	res = scm_cons (uvec_fast_ref (type, base, c_idx), res);
352	scm_remember_upto_here_1 (uvec);
353	return res;
354	}
355
356	static SCM_C_INLINE SCM
357	list_to_uvec (int type, SCM list)
358	{
359	SCM uvec;
360	void *base;
361	long idx;
362	long len = scm_ilength (list);
363	if (len < 0)
364	scm_wrong_type_arg_msg (NULL, 0, list, "proper list");
365
366	uvec = alloc_uvec (type, len);
367	base = SCM_UVEC_BASE (uvec);
368	idx = 0;
369	while (scm_is_pair (list) && idx < len)
370	{
371	uvec_fast_set_x (type, base, idx, SCM_CAR (list));
372	list = SCM_CDR (list);
373	idx++;
374	}
375	return uvec;
376	}
377
378	SCM
379	scm_i_read_homogenous_vector (SCM port, char pfx)
380	{
381	/* We have read '#f', '#u', or '#s'. Next must be a decimal integer
382	followed immediately by a list.
383	*/
384
385	int c;
386	char tok[80];
387	int n_digs;
388	SCM list;
389
390	n_digs = 0;
391	while ((c = scm_getc (port)) != EOF && '0' <= c && c <= '9' && n_digs < 80)
392	tok[n_digs++] = c;
393
394	if (c != EOF)
395	scm_ungetc (c, port);
396
397	if (n_digs == 0 && pfx == 'f')
398	return SCM_BOOL_F;
399
400	if (c != '(')
401	scm_i_input_error (NULL, port,
402	"#~a~a must be followed immediately by a '('",
403	scm_list_2 (SCM_MAKE_CHAR (pfx),
404	scm_from_locale_stringn (tok, n_digs)));
405
406	list = scm_read (port);
407
408	if (n_digs == 1 && strncmp (tok, "8", n_digs) == 0)
409	{
410	if (pfx == 'u')
411	return scm_list_to_u8vector (list);
412	else if (pfx == 's')
413	return scm_list_to_s8vector (list);
414	}
415	else if (n_digs == 2 && strncmp (tok, "16", n_digs) == 0)
416	{
417	if (pfx == 'u')
418	return scm_list_to_u16vector (list);
419	else if (pfx == 's')
420	return scm_list_to_s16vector (list);
421	}
422	else if (n_digs == 2 && strncmp (tok, "32", n_digs) == 0)
423	{
424	if (pfx == 'u')
425	return scm_list_to_u32vector (list);
426	else if (pfx == 's')
427	return scm_list_to_s32vector (list);
428	else if (pfx == 'f')
429	return scm_list_to_f32vector (list);
430	}
431	else if (n_digs == 2 && strncmp (tok, "64", n_digs) == 0)
432	{
433	if (pfx == 'u')
434	return scm_list_to_u64vector (list);
435	else if (pfx == 's')
436	return scm_list_to_s64vector (list);
437	else if (pfx == 'f')
438	return scm_list_to_f64vector (list);
439	}
440
441	scm_i_input_error (NULL, port,
442	"unrecognized homogenous vector prefix #~a~a",
443	scm_list_2 (SCM_MAKE_CHAR (pfx),
444	scm_from_locale_stringn (tok, n_digs)));
445	return SCM_BOOL_F;
446	}
447
e0e49670 MV	448	SCM
	449	scm_i_uniform_vector_prototype (SCM uvec)
	450	{
	451	switch (SCM_UVEC_TYPE (uvec))
	452	{
	453	case SCM_UVEC_U8:
	454	return SCM_BOOL_F;
	455	case SCM_UVEC_S8:
	456	return SCM_MAKE_CHAR ('\0');
	457	case SCM_UVEC_U16:
	458	return SCM_BOOL_F;
	459	case SCM_UVEC_S16:
	460	return SCM_BOOL_F;
	461	case SCM_UVEC_U32:
	462	return SCM_BOOL_F;
	463	case SCM_UVEC_S32:
	464	return SCM_BOOL_F;
	465	case SCM_UVEC_U64:
	466	return SCM_BOOL_F;
	467	case SCM_UVEC_S64:
	468	return SCM_BOOL_F;
	469	case SCM_UVEC_F32:
	470	return SCM_BOOL_F;
	471	case SCM_UVEC_F64:
	472	return SCM_BOOL_F;
	473	default:
	474	return SCM_BOOL_F;
	475	}
	476	}
	477
	478	int
	479	scm_is_uniform_vector (SCM obj)
	480	{
	481	return SCM_SMOB_PREDICATE (scm_tc16_uvec, obj);
	482	}
	483
	484	size_t
	485	scm_c_uniform_vector_length (SCM v)
	486	{
	487	if (scm_is_uniform_vector (v))
	488	return SCM_UVEC_LENGTH (v);
	489	else
	490	scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
	491	}
	492
	493	size_t
	494	scm_c_uniform_vector_size (SCM v)
	495	{
	496	if (scm_is_uniform_vector (v))
	497	return SCM_UVEC_LENGTH (v) * uvec_sizes[SCM_UVEC_TYPE (v)];
	498	else
	499	scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
	500	}
	501
	502	SCM_DEFINE (scm_uniform_vector_p, "uniform-vector?", 1, 0, 0,
	503	(SCM obj),
	504	"Return @code{#t} if @var{obj} is a uniform vector.")
	505	#define FUNC_NAME s_scm_uniform_vector_p
	506	{
	507	return scm_from_bool (scm_is_uniform_vector (obj));
	508	}
	509	#undef FUNC_NAME
	510
	511	SCM_DEFINE (scm_uniform_vector_ref, "uniform-vector-ref", 2, 0, 0,
512	(SCM v, SCM idx),
513	"Return the element at index @var{idx} of the\n"
514	"homogenous numeric vector @var{v}.")
515	#define FUNC_NAME s_scm_uniform_vector_ref
516	{
517	/* Support old argument convention.
518	*/
519	if (scm_is_pair (idx))
520	{
521	if (!scm_is_null (SCM_CDR (idx)))
522	scm_wrong_num_args (NULL);
523	idx = SCM_CAR (idx);
524	}
525
526	if (scm_is_uniform_vector (v))
527	return uvec_ref (SCM_UVEC_TYPE (v), v, idx);
528	else
529	scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
530	}
531	#undef FUNC_NAME
532
533	SCM_DEFINE (scm_uniform_vector_set_x, "uniform-vector-set!", 3, 0, 0,
534	(SCM v, SCM idx, SCM val),
535	"Set the element at index @var{idx} of the\n"
536	"homogenous numeric vector @var{v} to @var{val}.")
537	#define FUNC_NAME s_scm_uniform_vector_set_x
538	{
539	/* Support old argument convention.
540	*/
541	if (scm_is_pair (idx))
542	{
543	if (!scm_is_null (SCM_CDR (idx)))
544	scm_wrong_num_args (NULL);
545	idx = SCM_CAR (idx);
546	}
547
548	if (scm_is_uniform_vector (v))
549	return uvec_set_x (SCM_UVEC_TYPE (v), v, idx, val);
550	else
551	scm_wrong_type_arg_msg (NULL, 0, v, "uniform vector");
552	}
553	#undef FUNC_NAME
554
555	SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
556	(SCM uvec),
557	"Convert the homogeneous numeric vector @var{uvec} to a list.")
558	#define FUNC_NAME s_uniform_vector_to_list
559	{
560	if (scm_is_uniform_vector (uvec))
561	return uvec_to_list (SCM_UVEC_TYPE (uvec), uvec);
562	else
563	scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
564	}
565	#undef FUNC_NAME
566
567	void *
568	scm_uniform_vector_elements (SCM uvec)
569	{
570	if (scm_is_uniform_vector (uvec))
571	return SCM_UVEC_BASE (uvec);
572	else
573	scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
574	}
575
576	void
577	scm_uniform_vector_release (SCM uvec)
578	{
579	/* Nothing to do right now, but this function might come in handy
580	when uniform vectors need to be locked when giving away a pointer
581	to their elements.
faa00365 MV	582
	583	Also, a call to scm_uniform_vector acts like
	584	scm_remember_upto_here, which is needed in any case.
e0e49670 MV	585	*/
	586	}
	587
	588	size_t
	589	scm_uniform_vector_element_size (SCM uvec)
	590	{
	591	if (scm_is_uniform_vector (uvec))
	592	return uvec_sizes[SCM_UVEC_TYPE (uvec)];
	593	else
	594	scm_wrong_type_arg_msg (NULL, 0, uvec, "uniform vector");
	595	}
	596
	597	/* return the size of an element in a uniform array or 0 if type not
	598	found. */
	599	size_t
	600	scm_uniform_element_size (SCM obj)
	601	{
	602	size_t result;
	603
	604	if (scm_is_uniform_vector (obj))
	605	return scm_uniform_vector_element_size (obj);
	606
	607	switch (SCM_TYP7 (obj))
	608	{
	609	case scm_tc7_bvect:
	610	case scm_tc7_uvect:
	611	case scm_tc7_ivect:
	612	result = sizeof (long);
	613	break;
	614
	615	case scm_tc7_svect:
	616	result = sizeof (short);
	617	break;
	618
	619	#if SCM_SIZEOF_LONG_LONG != 0
	620	case scm_tc7_llvect:
	621	result = sizeof (long long);
	622	break;
	623	#endif
	624
	625	case scm_tc7_fvect:
	626	result = sizeof (float);
	627	break;
	628
	629	case scm_tc7_dvect:
	630	result = sizeof (double);
	631	break;
	632
	633	case scm_tc7_cvect:
	634	result = 2 * sizeof (double);
	635	break;
	636
	637	default:
	638	result = 0;
	639	}
	640	return result;
	641	}
	642
	643	SCM_DEFINE (scm_uniform_vector_length, "uniform-vector-length", 1, 0, 0,
	644	(SCM v),
	645	"Return the number of elements in @var{uve}.")
	646	#define FUNC_NAME s_scm_uniform_vector_length
	647	{
	648	if (scm_is_uniform_vector (v))
649	return scm_from_size_t (SCM_UVEC_LENGTH (v));
650
651	SCM_ASRTGO (SCM_NIMP (v), badarg1);
652	switch SCM_TYP7 (v)
653	{
654	default:
655	badarg1:SCM_WRONG_TYPE_ARG (1, v);
656	case scm_tc7_vector:
657	case scm_tc7_wvect:
658	return scm_from_size_t (SCM_VECTOR_LENGTH (v));
659	case scm_tc7_string:
660	return scm_from_size_t (scm_i_string_length (v));
661	case scm_tc7_bvect:
662	return scm_from_size_t (SCM_BITVECTOR_LENGTH (v));
663	case scm_tc7_uvect:
664	case scm_tc7_ivect:
665	case scm_tc7_fvect:
666	case scm_tc7_dvect:
667	case scm_tc7_cvect:
668	case scm_tc7_svect:
669	#if SCM_SIZEOF_LONG_LONG != 0
670	case scm_tc7_llvect:
671	#endif
672	return scm_from_size_t (SCM_UVECTOR_LENGTH (v));
673	}
674	}
675	#undef FUNC_NAME
676
f8579182 MV	677	/* ================================================================ */
	678	/* Exported procedures. */
	679	/* ================================================================ */
	680
e0e49670 MV	681	#define TYPE SCM_UVEC_U8
	682	#define TAG u8
	683	#define CTYPE scm_t_uint8
f8579182 MV	684	#include "libguile/srfi-4.i.c"
f8579182 MV	685
e0e49670 MV	686	#define TYPE SCM_UVEC_S8
	687	#define TAG s8
	688	#define CTYPE scm_t_int8
f8579182 MV	689	#include "libguile/srfi-4.i.c"
f8579182 MV	690
e0e49670 MV	691	#define TYPE SCM_UVEC_U16
	692	#define TAG u16
	693	#define CTYPE scm_t_uint16
f8579182 MV	694	#include "libguile/srfi-4.i.c"
f8579182 MV	695
e0e49670 MV	696	#define TYPE SCM_UVEC_S16
	697	#define TAG s16
	698	#define CTYPE scm_t_int16
f8579182 MV	699	#include "libguile/srfi-4.i.c"
f8579182 MV	700
e0e49670 MV	701	#define TYPE SCM_UVEC_U32
	702	#define TAG u32
	703	#define CTYPE scm_t_uint32
f8579182 MV	704	#include "libguile/srfi-4.i.c"
f8579182 MV	705
e0e49670 MV	706	#define TYPE SCM_UVEC_S32
	707	#define TAG s32
	708	#define CTYPE scm_t_int32
f8579182 MV	709	#include "libguile/srfi-4.i.c"
f8579182 MV	710
e0e49670 MV	711	#define TYPE SCM_UVEC_U64
	712	#define TAG u64
	713	#define CTYPE scm_t_uint64
f8579182 MV	714	#include "libguile/srfi-4.i.c"
f8579182 MV	715
e0e49670 MV	716	#define TYPE SCM_UVEC_S64
	717	#define TAG s64
	718	#define CTYPE scm_t_int64
f8579182 MV	719	#include "libguile/srfi-4.i.c"
f8579182 MV	720
e0e49670 MV	721	#define TYPE SCM_UVEC_F32
	722	#define TAG f32
	723	#define CTYPE float
f8579182 MV	724	#include "libguile/srfi-4.i.c"
f8579182 MV	725
e0e49670 MV	726	#define TYPE SCM_UVEC_F64
	727	#define TAG f64
	728	#define CTYPE double
f8579182 MV	729	#include "libguile/srfi-4.i.c"
	730
	731
	732	/* Create the smob type for homogeneous numeric vectors and install
	733	the primitives. */
	734	void
	735	scm_init_srfi_4 (void)
	736	{
	737	scm_tc16_uvec = scm_make_smob_type ("uvec", 0);
	738	scm_set_smob_equalp (scm_tc16_uvec, uvec_equalp);
	739	scm_set_smob_free (scm_tc16_uvec, uvec_free);
	740	scm_set_smob_print (scm_tc16_uvec, uvec_print);
	741	#include "libguile/srfi-4.x"
	742	}
	743
	744	/* End of srfi-4.c. */