mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

Merge commit 'dc65b88d83'

Browse source 
Conflicts:
	libguile/srfi-4.c
This commit is contained in:
Andy Wingo 2014-02-08 14:56:16 +01:00
commit 54f17b7b59
1 changed files with 25 additions and 43 deletions
Download patch file Download diff file Expand all files Collapse all files

68
libguile/srfi-4.c
View file

@ -1,6 +1,6 @@
/* srfi-4.c --- Uniform numeric vector datatypes. /* srfi-4.c --- Uniform numeric vector datatypes.
* *
* Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc. * Copyright (C) 2001, 2004, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
* *
* This library is free software; you can redistribute it and/or * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -137,32 +137,15 @@
scm_t_array_handle *h, \ scm_t_array_handle *h, \
size_t *lenp, ssize_t *incp) \ size_t *lenp, ssize_t *incp) \
{ \ { \
scm_uniform_vector_elements (uvec, h, lenp, incp); \ if (!scm_is_bytevector (uvec) \
if (h->element_type == ETYPE (TAG)) \ || (scm_c_bytevector_length (uvec) % width)) \
return ((ctype*)h->writable_elements) + h->base*width; \ scm_wrong_type_arg_msg (NULL, 0, uvec, #tag "vector"); \
/* otherwise... */ \ scm_array_get_handle (uvec, h); \
else \ if (lenp) \
{ \ *lenp = scm_c_bytevector_length (uvec) / width; \
size_t sfrom, sto, lfrom, lto; \ if (incp) \
if (h->dims != &h->dim0) \ *incp = 1; \
{ \ return ((ctype *)h->writable_elements); \
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; \
} \
} }
@ -231,13 +214,15 @@ SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
"Make a srfi-4 vector") "Make a srfi-4 vector")
#define FUNC_NAME s_scm_make_srfi_4_vector #define FUNC_NAME s_scm_make_srfi_4_vector
{ {
int i; int c_type;
for (i = 0; i <= SCM_ARRAY_ELEMENT_TYPE_LAST; i++) size_t c_len;
if (scm_is_eq (type, scm_i_array_element_types[i]))
for (c_type = 0; c_type <= SCM_ARRAY_ELEMENT_TYPE_LAST; c_type++)
if (scm_is_eq (type, scm_i_array_element_types[c_type]))
break; break;
if (i > SCM_ARRAY_ELEMENT_TYPE_LAST) if (c_type > SCM_ARRAY_ELEMENT_TYPE_LAST)
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type"); scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, type, "vector type");
switch (i) switch (c_type)
{ {
case SCM_ARRAY_ELEMENT_TYPE_U8: case SCM_ARRAY_ELEMENT_TYPE_U8:
case SCM_ARRAY_ELEMENT_TYPE_S8: case SCM_ARRAY_ELEMENT_TYPE_S8:
@ -252,7 +237,10 @@ SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
case SCM_ARRAY_ELEMENT_TYPE_C32: case SCM_ARRAY_ELEMENT_TYPE_C32:
case SCM_ARRAY_ELEMENT_TYPE_C64: case SCM_ARRAY_ELEMENT_TYPE_C64:
{ {
SCM ret = scm_i_make_typed_bytevector (scm_to_size_t (len), i); SCM ret;
c_len = scm_to_size_t (len);
ret = scm_i_make_typed_bytevector (c_len, c_type);
if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0)) if (SCM_UNBNDP (fill) || scm_is_eq (len, SCM_INUM0))
; /* pass */ ; /* pass */
@ -262,17 +250,11 @@ SCM_DEFINE (scm_make_srfi_4_vector, "make-srfi-4-vector", 2, 1, 0,
else else
{ {
scm_t_array_handle h; scm_t_array_handle h;
size_t len; size_t i;
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_get_handle (ret, &h);
for (i = 0; i < c_len; i++)
scm_array_handle_set (&h, i, fill);
scm_array_handle_release (&h); scm_array_handle_release (&h);
} }
return ret; return ret;