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

/* srfi-4.c --- Uniform numeric vector datatypes.
 *
 * 	Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * 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., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
#  include <config.h>
#endif

#include "libguile/_scm.h"
#include "libguile/__scm.h"
#include "libguile/bdw-gc.h"
#include "libguile/srfi-4.h"
#include "libguile/bytevectors.h"
#include "libguile/error.h"
#include "libguile/eval.h"
#include "libguile/extensions.h"
#include "libguile/uniform.h"
#include "libguile/generalized-vectors.h"
#include "libguile/validate.h"


#define DEFINE_SCHEME_PROXY100(cname, modname, scmname)                   \
  SCM cname (SCM arg1)                                                  \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_1 (SCM_VARIABLE_REF (var), arg1);                   \
  }

#define DEFINE_SCHEME_PROXY001(cname, modname, scmname)                 \
  SCM cname (SCM args)                                                  \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_apply_0 (SCM_VARIABLE_REF (var), args);                  \
  }

#define DEFINE_SCHEME_PROXY110(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM opt1)                                        \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    if (SCM_UNBNDP (opt1))                                              \
      return scm_call_1 (SCM_VARIABLE_REF (var), arg1);                 \
    else                                                                \
      return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1);           \
  }

#define DEFINE_SCHEME_PROXY200(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM arg2)                                        \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2);             \
  }

#define DEFINE_SCHEME_PROXY300(cname, modname, scmname)                   \
  SCM cname (SCM arg1, SCM arg2, SCM arg3)                              \
  {                                                                     \
    static SCM var = SCM_BOOL_F;                                        \
    if (scm_is_false (var))                                             \
      var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
    return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3);       \
  }

#define DEFPROXY100(cname, scmname)               \
  DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
#define DEFPROXY110(cname, scmname)               \
  DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
#define DEFPROXY001(cname, scmname)               \
  DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
#define DEFPROXY200(cname, scmname)               \
  DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
#define DEFPROXY300(cname, scmname)               \
  DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)

#define DEFVECT(sym, str, func)\

#define DEFINE_SRFI_4_PROXIES(tag)                                      \
  DEFPROXY100 (scm_##tag##vector_p, #tag "vector?");                    \
  DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector");          \
  DEFPROXY001 (scm_##tag##vector, #tag "vector");                       \
  DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length");         \
  DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref");               \
  DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!");            \
  DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector");       \
  DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list");         \
  
  
#define ETYPE(TAG) \
  SCM_ARRAY_ELEMENT_TYPE_##TAG

#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width)                   \
  SCM scm_take_##tag##vector (ctype *data, size_t n)                    \
  {                                                                     \
    return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG));   \
  }                                                                     \
  const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
  {                                                                     \
    if (h->element_type != ETYPE (TAG))                                 \
      scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector");        \
    return ((const ctype*) h->elements) + h->base*width;                \
  }                                                                     \
  ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
  {                                                                     \
    if (h->element_type != ETYPE (TAG))                                 \
      scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector");        \
    return ((ctype*) h->writable_elements) + h->base*width;             \
  }                                                                     \
  const ctype *scm_##tag##vector_elements (SCM uvec,                    \
                                           scm_t_array_handle *h,       \
                                           size_t *lenp, ssize_t *incp) \
  {                                                                     \
    return scm_##tag##vector_writable_elements (uvec, h, lenp, incp);   \
  }                                                                     \
  ctype *scm_##tag##vector_writable_elements (SCM uvec,                 \
                                              scm_t_array_handle *h,    \
                                              size_t *lenp, ssize_t *incp) \
  {                                                                     \
    scm_uniform_vector_elements (uvec, h, lenp, incp);                  \
    if (h->element_type == ETYPE (TAG))                                 \
      return ((ctype*)h->writable_elements) + h->base*width;            \
    /* otherwise... */                                                  \
    else                                                                \
      {                                                                 \
        size_t sfrom, sto, lfrom, lto;                                  \
        if (h->dims != &h->dim0)                                        \
          {                                                             \
            h->dim0 = h->dims[0];                                       \
            h->dims = &h->dim0;                                         \
          }                                                             \
        sfrom = scm_i_array_element_type_sizes [h->element_type];       \
        sto = scm_i_array_element_type_sizes [ETYPE (TAG)];             \
        lfrom = h->dim0.ubnd - h->dim0.lbnd + 1;                        \
        lto = lfrom * sfrom / sto;                                      \
        if (lto * sto != lfrom * sfrom)                                 \
          {                                                             \
            scm_array_handle_release (h);                               \
            scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
          }                                                             \
        h->dim0.ubnd = h->dim0.lbnd + lto;                              \
        h->base = h->base * sto / sfrom;                                \
        h->element_type = ETYPE (TAG);                                  \
        return ((ctype*)h->writable_elements) + h->base*width;          \
      }                                                                 \
  }


#define MOD "srfi srfi-4"

DEFINE_SRFI_4_PROXIES (u8);
DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);

DEFINE_SRFI_4_PROXIES (s8);
DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);

DEFINE_SRFI_4_PROXIES (u16);
DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);

DEFINE_SRFI_4_PROXIES (s16);
DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);

DEFINE_SRFI_4_PROXIES (u32);
DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);

DEFINE_SRFI_4_PROXIES (s32);
DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);

DEFINE_SRFI_4_PROXIES (u64);
DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);

DEFINE_SRFI_4_PROXIES (s64);
DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);

DEFINE_SRFI_4_PROXIES (f32);
DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);

DEFINE_SRFI_4_PROXIES (f64);
DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);

#undef MOD
#define MOD "srfi srfi-4 gnu"

DEFINE_SRFI_4_PROXIES (c32);
DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);

DEFINE_SRFI_4_PROXIES (c64);
DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);

#define DEFINE_SRFI_4_GNU_PROXIES(tag)                              \
  DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")

#undef MOD
#define MOD "srfi srfi-4 gnu"
DEFINE_SRFI_4_GNU_PROXIES (u8);
DEFINE_SRFI_4_GNU_PROXIES (s8);
DEFINE_SRFI_4_GNU_PROXIES (u16);
DEFINE_SRFI_4_GNU_PROXIES (s16);
DEFINE_SRFI_4_GNU_PROXIES (u32);
DEFINE_SRFI_4_GNU_PROXIES (s32);
DEFINE_SRFI_4_GNU_PROXIES (u64);
DEFINE_SRFI_4_GNU_PROXIES (s64);
DEFINE_SRFI_4_GNU_PROXIES (f32);
DEFINE_SRFI_4_GNU_PROXIES (f64);
DEFINE_SRFI_4_GNU_PROXIES (c32);
DEFINE_SRFI_4_GNU_PROXIES (c64);


SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
            (SCM type, SCM len, SCM fill),
            "Make a srfi-4 vector")
#define FUNC_NAME s_scm_make_srfi_4_vector
{
  int i;
  for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
    if (scm_is_eq (type, scm_i_array_element_types[i]))
      break;
  if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
    scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
  switch (i)
    {
    case SCM_ARRAY_ELEMENT_TYPE_U8:
    case SCM_ARRAY_ELEMENT_TYPE_S8:
    case SCM_ARRAY_ELEMENT_TYPE_U16:
    case SCM_ARRAY_ELEMENT_TYPE_S16:
    case SCM_ARRAY_ELEMENT_TYPE_U32:
    case SCM_ARRAY_ELEMENT_TYPE_S32:
    case SCM_ARRAY_ELEMENT_TYPE_U64:
    case SCM_ARRAY_ELEMENT_TYPE_S64:
    case SCM_ARRAY_ELEMENT_TYPE_F32:
    case SCM_ARRAY_ELEMENT_TYPE_F64:
    case SCM_ARRAY_ELEMENT_TYPE_C32:
    case SCM_ARRAY_ELEMENT_TYPE_C64:
      {
        SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);

        if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
          ; /* pass */
        else if (scm_is_true (scm_zero_p (fill)))
          memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
                  SCM_BYTEVECTOR_LENGTH (ret));
        else
          {
            scm_t_array_handle h;
            size_t len;
            ssize_t pos, inc;

            scm_uniform_vector_writable_elements (ret, &h, &len, &inc);

            for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
              scm_array_handle_set (&h, pos, fill);

	    /* Initialize the last element.  */
	    scm_array_handle_set (&h, pos, fill);

            scm_array_handle_release (&h);
          }
        return ret;
      }
    default:
      scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type");
      return SCM_BOOL_F; /* not reached */
    }
}
#undef FUNC_NAME

void
scm_init_srfi_4 (void)
{
#define REGISTER(tag, TAG)                                       \
  scm_i_register_vector_constructor                              \
    (scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG],    \
     scm_make_##tag##vector)

  REGISTER (u8, U8); 
  REGISTER (s8, S8); 
  REGISTER (u16, U16);
  REGISTER (s16, S16);
  REGISTER (u32, U32);
  REGISTER (s32, S32);
  REGISTER (u64, U64);
  REGISTER (s64, S64);
  REGISTER (f32, F32);
  REGISTER (f64, F64);
  REGISTER (c32, C32);
  REGISTER (c64, C64);

#include "libguile/srfi-4.x"
}

/* End of srfi-4.c.  */
Commit	Line	Data
69d2000d	1	/* srfi-4.c --- Uniform numeric vector datatypes.
f8579182	2	*
a2689737	3	* Copyright (C) 2001, 2004, 2006, 2009, 2010 Free Software Foundation, Inc.
f8579182 MV	4	*
f8579182 MV	5	* This library is free software; you can redistribute it and/or
53befeb7 NJ	6	* modify it under the terms of the GNU Lesser General Public License
	7	* as published by the Free Software Foundation; either version 3 of
	8	* the License, or (at your option) any later version.
f8579182	9	*
53befeb7 NJ	10	* This library is distributed in the hope that it will be useful, but
53befeb7 NJ	11	* WITHOUT ANY WARRANTY; without even the implied warranty of
f8579182 MV	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
53befeb7 NJ	17	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
53befeb7 NJ	18	* 02110-1301 USA
f8579182 MV	19	*/
f8579182 MV	20
dbb605f5	21	#ifdef HAVE_CONFIG_H
69730f92 MV	22	# include <config.h>
	23	#endif
	24
69730f92 MV	25	#include "libguile/_scm.h"
69730f92 MV	26	#include "libguile/__scm.h"
1c44468d	27	#include "libguile/bdw-gc.h"
f8579182	28	#include "libguile/srfi-4.h"
438974d0	29	#include "libguile/bytevectors.h"
f8579182	30	#include "libguile/error.h"
ac8ed3db	31	#include "libguile/eval.h"
a2689737 AW	32	#include "libguile/extensions.h"
	33	#include "libguile/uniform.h"
	34	#include "libguile/generalized-vectors.h"
	35	#include "libguile/validate.h"
69730f92	36
f8579182	37
a2689737 AW	38	#define DEFINE_SCHEME_PROXY100(cname, modname, scmname) \
	39	SCM cname (SCM arg1) \
	40	{ \
	41	static SCM var = SCM_BOOL_F; \
	42	if (scm_is_false (var)) \
	43	var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
	44	return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
f8579182 MV	45	}
f8579182 MV	46
a2689737 AW	47	#define DEFINE_SCHEME_PROXY001(cname, modname, scmname) \
	48	SCM cname (SCM args) \
	49	{ \
	50	static SCM var = SCM_BOOL_F; \
	51	if (scm_is_false (var)) \
	52	var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
	53	return scm_apply_0 (SCM_VARIABLE_REF (var), args); \
	54	}
f8579182	55
a2689737 AW	56	#define DEFINE_SCHEME_PROXY110(cname, modname, scmname) \
	57	SCM cname (SCM arg1, SCM opt1) \
	58	{ \
	59	static SCM var = SCM_BOOL_F; \
	60	if (scm_is_false (var)) \
	61	var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
	62	if (SCM_UNBNDP (opt1)) \
	63	return scm_call_1 (SCM_VARIABLE_REF (var), arg1); \
	64	else \
	65	return scm_call_2 (SCM_VARIABLE_REF (var), arg1, opt1); \
	66	}
f8579182	67
a2689737 AW	68	#define DEFINE_SCHEME_PROXY200(cname, modname, scmname) \
	69	SCM cname (SCM arg1, SCM arg2) \
	70	{ \
	71	static SCM var = SCM_BOOL_F; \
	72	if (scm_is_false (var)) \
	73	var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
	74	return scm_call_2 (SCM_VARIABLE_REF (var), arg1, arg2); \
	75	}
f8579182	76
a2689737 AW	77	#define DEFINE_SCHEME_PROXY300(cname, modname, scmname) \
	78	SCM cname (SCM arg1, SCM arg2, SCM arg3) \
	79	{ \
	80	static SCM var = SCM_BOOL_F; \
	81	if (scm_is_false (var)) \
	82	var = scm_c_module_lookup (scm_c_resolve_module (modname), scmname); \
	83	return scm_call_3 (SCM_VARIABLE_REF (var), arg1, arg2, arg3); \
	84	}
d7e7a02a	85
a2689737 AW	86	#define DEFPROXY100(cname, scmname) \
	87	DEFINE_SCHEME_PROXY100 (cname, MOD, scmname)
	88	#define DEFPROXY110(cname, scmname) \
	89	DEFINE_SCHEME_PROXY110 (cname, MOD, scmname)
	90	#define DEFPROXY001(cname, scmname) \
	91	DEFINE_SCHEME_PROXY001 (cname, MOD, scmname)
	92	#define DEFPROXY200(cname, scmname) \
	93	DEFINE_SCHEME_PROXY200 (cname, MOD, scmname)
	94	#define DEFPROXY300(cname, scmname) \
	95	DEFINE_SCHEME_PROXY300 (cname, MOD, scmname)
	96
	97	#define DEFVECT(sym, str, func)\
	98
	99	#define DEFINE_SRFI_4_PROXIES(tag) \
	100	DEFPROXY100 (scm_##tag##vector_p, #tag "vector?"); \
	101	DEFPROXY110 (scm_make_##tag##vector, "make-" #tag "vector"); \
	102	DEFPROXY001 (scm_##tag##vector, #tag "vector"); \
	103	DEFPROXY100 (scm_##tag##vector_length, #tag "vector-length"); \
	104	DEFPROXY200 (scm_##tag##vector_ref, #tag "vector-ref"); \
	105	DEFPROXY300 (scm_##tag##vector_set_x, #tag "vector-set!"); \
	106	DEFPROXY100 (scm_list_to_##tag##vector, "list->"#tag "vector"); \
	107	DEFPROXY100 (scm_##tag##vector_to_list, #tag "vector->list"); \
faa00365	108
a2689737 AW	109
	110	#define ETYPE(TAG) \
	111	SCM_ARRAY_ELEMENT_TYPE_##TAG
69730f92	112
0d782201	113	#define DEFINE_SRFI_4_C_FUNCS(TAG, tag, ctype, width) \
a2689737 AW	114	SCM scm_take_##tag##vector (ctype *data, size_t n) \
	115	{ \
	116	return scm_c_take_typed_bytevector ((scm_t_int8*)data, n, ETYPE (TAG)); \
	117	} \
	118	const ctype* scm_array_handle_##tag##_elements (scm_t_array_handle *h) \
	119	{ \
	120	if (h->element_type != ETYPE (TAG)) \
	121	scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
0d782201	122	return ((const ctype) h->elements) + h->basewidth; \
a2689737 AW	123	} \
	124	ctype* scm_array_handle_##tag##_writable_elements (scm_t_array_handle *h) \
	125	{ \
	126	if (h->element_type != ETYPE (TAG)) \
	127	scm_wrong_type_arg_msg (NULL, 0, h->array, #tag "vector"); \
0d782201	128	return ((ctype) h->writable_elements) + h->basewidth; \
a2689737 AW	129	} \
	130	const ctype *scm_##tag##vector_elements (SCM uvec, \
	131	scm_t_array_handle *h, \
	132	size_t lenp, ssize_t incp) \
	133	{ \
	134	return scm_##tag##vector_writable_elements (uvec, h, lenp, incp); \
	135	} \
	136	ctype *scm_##tag##vector_writable_elements (SCM uvec, \
	137	scm_t_array_handle *h, \
	138	size_t lenp, ssize_t incp) \
	139	{ \
	140	scm_uniform_vector_elements (uvec, h, lenp, incp); \
	141	if (h->element_type == ETYPE (TAG)) \
0d782201	142	return ((ctype)h->writable_elements) + h->basewidth; \
a2689737 AW	143	/* otherwise... */ \
	144	else \
	145	{ \
	146	size_t sfrom, sto, lfrom, lto; \
	147	if (h->dims != &h->dim0) \
	148	{ \
	149	h->dim0 = h->dims[0]; \
	150	h->dims = &h->dim0; \
	151	} \
	152	sfrom = scm_i_array_element_type_sizes [h->element_type]; \
	153	sto = scm_i_array_element_type_sizes [ETYPE (TAG)]; \
	154	lfrom = h->dim0.ubnd - h->dim0.lbnd + 1; \
	155	lto = lfrom * sfrom / sto; \
	156	if (lto * sto != lfrom * sfrom) \
	157	{ \
	158	scm_array_handle_release (h); \
	159	scm_wrong_type_arg (#tag"vector-elements", SCM_ARG1, uvec); \
	160	} \
	161	h->dim0.ubnd = h->dim0.lbnd + lto; \
	162	h->base = h->base * sto / sfrom; \
	163	h->element_type = ETYPE (TAG); \
0d782201	164	return ((ctype)h->writable_elements) + h->basewidth; \
a2689737 AW	165	} \
a2689737 AW	166	}
69730f92	167
fea99690	168
a2689737	169	#define MOD "srfi srfi-4"
69730f92	170
a2689737	171	DEFINE_SRFI_4_PROXIES (u8);
0d782201	172	DEFINE_SRFI_4_C_FUNCS (U8, u8, scm_t_uint8, 1);
69730f92	173
a2689737	174	DEFINE_SRFI_4_PROXIES (s8);
0d782201	175	DEFINE_SRFI_4_C_FUNCS (S8, s8, scm_t_int8, 1);
69730f92	176
a2689737	177	DEFINE_SRFI_4_PROXIES (u16);
0d782201	178	DEFINE_SRFI_4_C_FUNCS (U16, u16, scm_t_uint16, 1);
69730f92	179
a2689737	180	DEFINE_SRFI_4_PROXIES (s16);
0d782201	181	DEFINE_SRFI_4_C_FUNCS (S16, s16, scm_t_int16, 1);
69730f92	182
a2689737	183	DEFINE_SRFI_4_PROXIES (u32);
0d782201	184	DEFINE_SRFI_4_C_FUNCS (U32, u32, scm_t_uint32, 1);
fea99690	185
a2689737	186	DEFINE_SRFI_4_PROXIES (s32);
0d782201	187	DEFINE_SRFI_4_C_FUNCS (S32, s32, scm_t_int32, 1);
69730f92	188
a2689737	189	DEFINE_SRFI_4_PROXIES (u64);
0d782201	190	DEFINE_SRFI_4_C_FUNCS (U64, u64, scm_t_uint64, 1);
f8579182	191
a2689737	192	DEFINE_SRFI_4_PROXIES (s64);
0d782201	193	DEFINE_SRFI_4_C_FUNCS (S64, s64, scm_t_int64, 1);
f8579182	194
a2689737	195	DEFINE_SRFI_4_PROXIES (f32);
0d782201	196	DEFINE_SRFI_4_C_FUNCS (F32, f32, float, 1);
f8579182	197
a2689737	198	DEFINE_SRFI_4_PROXIES (f64);
0d782201	199	DEFINE_SRFI_4_C_FUNCS (F64, f64, double, 1);
cbdc8379	200
a2689737 AW	201	#undef MOD
a2689737 AW	202	#define MOD "srfi srfi-4 gnu"
cbdc8379	203
a2689737	204	DEFINE_SRFI_4_PROXIES (c32);
0d782201	205	DEFINE_SRFI_4_C_FUNCS (C32, c32, float, 2);
ac8ed3db	206
a2689737	207	DEFINE_SRFI_4_PROXIES (c64);
0d782201	208	DEFINE_SRFI_4_C_FUNCS (C64, c64, double, 2);
ac8ed3db AW	209
	210	#define DEFINE_SRFI_4_GNU_PROXIES(tag) \
	211	DEFPROXY100 (scm_any_to_##tag##vector, "any->" #tag "vector")
	212
a2689737	213	#undef MOD
ac8ed3db AW	214	#define MOD "srfi srfi-4 gnu"
	215	DEFINE_SRFI_4_GNU_PROXIES (u8);
	216	DEFINE_SRFI_4_GNU_PROXIES (s8);
	217	DEFINE_SRFI_4_GNU_PROXIES (u16);
	218	DEFINE_SRFI_4_GNU_PROXIES (s16);
	219	DEFINE_SRFI_4_GNU_PROXIES (u32);
	220	DEFINE_SRFI_4_GNU_PROXIES (s32);
	221	DEFINE_SRFI_4_GNU_PROXIES (u64);
	222	DEFINE_SRFI_4_GNU_PROXIES (s64);
	223	DEFINE_SRFI_4_GNU_PROXIES (f32);
	224	DEFINE_SRFI_4_GNU_PROXIES (f64);
	225	DEFINE_SRFI_4_GNU_PROXIES (c32);
	226	DEFINE_SRFI_4_GNU_PROXIES (c64);
	227
	228
a2689737 AW	229	SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
	230	(SCM type, SCM len, SCM fill),
	231	"Make a srfi-4 vector")
	232	#define FUNC_NAME s_scm_make_srfi_4_vector
4ea4bc4c	233	{
a2689737 AW	234	int i;
	235	for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++)
	236	if (scm_is_eq (type, scm_i_array_element_types[i]))
	237	break;
	238	if (i > SCM_ARRAY_ELEMENT_TYPE_LAST)
	239	scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
	240	switch (i)
	241	{
	242	case SCM_ARRAY_ELEMENT_TYPE_U8:
	243	case SCM_ARRAY_ELEMENT_TYPE_S8:
	244	case SCM_ARRAY_ELEMENT_TYPE_U16:
	245	case SCM_ARRAY_ELEMENT_TYPE_S16:
	246	case SCM_ARRAY_ELEMENT_TYPE_U32:
	247	case SCM_ARRAY_ELEMENT_TYPE_S32:
	248	case SCM_ARRAY_ELEMENT_TYPE_U64:
	249	case SCM_ARRAY_ELEMENT_TYPE_S64:
	250	case SCM_ARRAY_ELEMENT_TYPE_F32:
	251	case SCM_ARRAY_ELEMENT_TYPE_F64:
	252	case SCM_ARRAY_ELEMENT_TYPE_C32:
	253	case SCM_ARRAY_ELEMENT_TYPE_C64:
	254	{
	255	SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i);
dc327575 LC	256
dc327575 LC	257	if (SCM_UNBNDP (fill) \|\| scm_is_eq (len, SCM_INUM0))
a2689737 AW	258	; /* pass */
	259	else if (scm_is_true (scm_zero_p (fill)))
	260	memset (SCM_BYTEVECTOR_CONTENTS (ret), 0,
	261	SCM_BYTEVECTOR_LENGTH (ret));
	262	else
	263	{
	264	scm_t_array_handle h;
	265	size_t len;
	266	ssize_t pos, inc;
d900a855	267
a2689737	268	scm_uniform_vector_writable_elements (ret, &h, &len, &inc);
d900a855	269
a2689737 AW	270	for (pos = 0; pos != h.dims[0].ubnd; pos += inc)
a2689737 AW	271	scm_array_handle_set (&h, pos, fill);
d900a855 LC	272
	273	/* Initialize the last element. */
	274	scm_array_handle_set (&h, pos, fill);
	275
a2689737 AW	276	scm_array_handle_release (&h);
	277	}
	278	return ret;
	279	}
	280	default:
	281	scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "uniform vector type");
	282	return SCM_BOOL_F; /* not reached */
	283	}
4ea4bc4c	284	}
a2689737	285	#undef FUNC_NAME
2a610be5	286
f8579182 MV	287	void
	288	scm_init_srfi_4 (void)
	289	{
f45eccff AW	290	#define REGISTER(tag, TAG) \
	291	scm_i_register_vector_constructor \
	292	(scm_i_array_element_types[SCM_ARRAY_ELEMENT_TYPE_##TAG], \
	293	scm_make_##tag##vector)
	294
	295	REGISTER (u8, U8);
	296	REGISTER (s8, S8);
	297	REGISTER (u16, U16);
	298	REGISTER (s16, S16);
	299	REGISTER (u32, U32);
	300	REGISTER (s32, S32);
	301	REGISTER (u64, U64);
	302	REGISTER (s64, S64);
	303	REGISTER (f32, F32);
	304	REGISTER (f64, F64);
	305	REGISTER (c32, C32);
	306	REGISTER (c64, C64);
	307
f8579182 MV	308	#include "libguile/srfi-4.x"
	309	}
	310
	311	/* End of srfi-4.c. */