mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-21 19:20:21 +02:00
Code Activity

Merge remote-tracking branch 'origin/stable-2.0'

Browse source 
Conflicts:
	libguile/array-handle.c
	libguile/deprecated.h
	libguile/inline.c
	libguile/inline.h
	module/ice-9/deprecated.scm
	module/language/tree-il/peval.scm
This commit is contained in:
Andy Wingo 2013-02-18 17:59:38 +01:00
commit 9b977c836b
36 changed files with 873 additions and 384 deletions
Download patch file Download diff file Expand all files Collapse all files

44
libguile/array-handle.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
* 2006, 2009, 2011, 2013 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
@ -97,6 +98,47 @@ scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
return pos;
}
static void
check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
{
if (idx < dim->lbnd || idx > dim->ubnd)
scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
scm_list_3 (scm_from_ssize_t (dim->lbnd),
scm_from_ssize_t (dim->ubnd),
scm_from_ssize_t (idx)),
scm_list_1 (scm_from_ssize_t (idx)));
}
ssize_t
scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
if (scm_array_handle_rank (h) != 1)
scm_misc_error (NULL, "wrong number of indices, expecting ~A",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
check_array_index_bounds (&dim[0], idx0);
return (idx0 - dim[0].lbnd) * dim[0].inc;
}
ssize_t
scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
if (scm_array_handle_rank (h) != 2)
scm_misc_error (NULL, "wrong number of indices, expecting ~A",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
check_array_index_bounds (&dim[0], idx0);
check_array_index_bounds (&dim[1], idx1);
return ((idx0 - dim[0].lbnd) * dim[0].inc
+ (idx1 - dim[1].lbnd) * dim[1].inc);
}
SCM
scm_array_handle_element_type (scm_t_array_handle *h)
{

36
libguile/array-handle.h
View file

@ -4,7 +4,7 @@
#define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006,
* 2008, 2009, 2011 Free Software Foundation, Inc.
* 2008, 2009, 2011, 2013 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
@ -25,6 +25,8 @@
#include "libguile/__scm.h"
#include "libguile/error.h"
#include "libguile/numbers.h"
@ -112,12 +114,42 @@ typedef struct scm_t_array_handle {
SCM_API void scm_array_get_handle (SCM array, scm_t_array_handle *h);
SCM_API ssize_t scm_array_handle_pos (scm_t_array_handle *h, SCM indices);
SCM_API ssize_t scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0);
SCM_API ssize_t scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1);
SCM_API SCM scm_array_handle_element_type (scm_t_array_handle *h);
SCM_API void scm_array_handle_release (scm_t_array_handle *h);
SCM_API const SCM* scm_array_handle_elements (scm_t_array_handle *h);
SCM_API SCM* scm_array_handle_writable_elements (scm_t_array_handle *h);
/* See inline.h for scm_array_handle_ref and scm_array_handle_set */
SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
/* Either inlining, or being included from inline.c. */
SCM_INLINE_IMPLEMENTATION SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
return h->impl->vref (h, h->base + p);
}
SCM_INLINE_IMPLEMENTATION void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
h->impl->vset (h, h->base + p, v);
}
#endif
SCM_INTERNAL void scm_init_array_handle (void);

84
libguile/deprecated.c
View file

@ -2,7 +2,7 @@
deprecate something, move it here when that is feasible.
*/
/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013 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
@ -79,6 +79,88 @@ scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a vector, string,\n"
"bitvector, or uniform numeric vector.")
#define FUNC_NAME s_scm_generalized_vector_p
{
scm_c_issue_deprecation_warning
("generalized-vector? is deprecated. Use array? and check the "
"array-rank instead.");
return scm_from_bool (scm_is_generalized_vector (obj));
}
#undef FUNC_NAME
SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
(SCM v),
"Return the length of the generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_length
{
scm_c_issue_deprecation_warning
("generalized-vector-length is deprecated. Use array-length instead.");
return scm_from_size_t (scm_c_generalized_vector_length (v));
}
#undef FUNC_NAME
SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
(SCM v, SCM idx),
"Return the element at index @var{idx} of the\n"
"generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_ref
{
scm_c_issue_deprecation_warning
("generalized-vector-ref is deprecated. Use array-ref instead.");
return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME
SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
(SCM v, SCM idx, SCM val),
"Set the element at index @var{idx} of the\n"
"generalized vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_generalized_vector_set_x
{
scm_c_issue_deprecation_warning
("generalized-vector-set! is deprecated. Use array-set! instead. "
"Note the change in argument order!");
scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
(SCM v),
"Return a new list whose elements are the elements of the\n"
"generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_to_list
{
/* FIXME: This duplicates `array_to_list'. */
SCM ret = SCM_EOL;
long inc;
ssize_t pos, i;
scm_t_array_handle h;
scm_c_issue_deprecation_warning
("generalized-vector->list is deprecated. Use array->list instead.");
scm_generalized_vector_get_handle (v, &h);
i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
inc = h.dims[0].inc;
pos = (i - 1) * inc;
for (; i > 0; i--, pos -= inc)
ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
scm_array_handle_release (&h);
return ret;
}
#undef FUNC_NAME
void
scm_i_init_deprecated ()
{

24
libguile/foreign.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2010, 2011, 2012, 2013 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
@ -53,6 +53,8 @@ SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t");
SCM_SYMBOL (sym_ssize_t, "ssize_t");
SCM_SYMBOL (sym_ptrdiff_t, "ptrdiff_t");
/* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*");
@ -1279,6 +1281,26 @@ scm_init_foreign (void)
scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (size_t)
#endif
);
scm_define (sym_ssize_t,
#if SIZEOF_SIZE_T == 8
scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SIZEOF_SIZE_T == 4
scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (ssize_t)
#endif
);
scm_define (sym_ptrdiff_t,
#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (scm_t_ptrdiff)
#endif
);

19
libguile/gen-scmconfig.c
View file

@ -1,3 +1,20 @@
/* Copyright (C) 2003-2013 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
*/
/**********************************************************************
@ -268,7 +285,7 @@ main (int argc, char *argv[])
pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
pf ("\n");
pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
pf ("/* scm_t_ptrdiff and size, always defined -- defined to long if\n"
" platform doesn't have ptrdiff_t. */\n");
pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
if (0 == strcmp ("long", SCM_I_GSC_T_PTRDIFF))

143
libguile/generalized-arrays.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 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,6 +33,12 @@
#include "libguile/generalized-arrays.h"
SCM_INTERNAL SCM scm_i_array_ref (SCM v,
SCM idx0, SCM idx1, SCM idxN);
SCM_INTERNAL SCM scm_i_array_set_x (SCM v, SCM obj,
SCM idx0, SCM idx1, SCM idxN);
int
scm_is_array (SCM obj)
{
@ -107,6 +113,35 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
#undef FUNC_NAME
size_t
scm_c_array_length (SCM array)
{
scm_t_array_handle handle;
size_t res;
scm_array_get_handle (array, &handle);
if (scm_array_handle_rank (&handle) < 1)
{
scm_array_handle_release (&handle);
scm_wrong_type_arg_msg (NULL, 0, array, "array of nonzero rank");
}
res = handle.dims[0].ubnd - handle.dims[0].lbnd + 1;
scm_array_handle_release (&handle);
return res;
}
SCM_DEFINE (scm_array_length, "array-length", 1, 0, 0,
(SCM array),
"Return the length of an array: its first dimension.\n"
"It is an error to ask for the length of an array of rank 0.")
#define FUNC_NAME s_scm_array_rank
{
return scm_from_size_t (scm_c_array_length (array));
}
#undef FUNC_NAME
SCM_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
(SCM ra),
"@code{array-dimensions} is similar to @code{array-shape} but replaces\n"
@ -195,11 +230,35 @@ SCM_DEFINE (scm_array_in_bounds_p, "array-in-bounds?", 1, 0, 1,
}
#undef FUNC_NAME
SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
(SCM v, SCM args),
"Return the element at the @code{(index1, index2)} element in\n"
"array @var{v}.")
#define FUNC_NAME s_scm_array_ref
SCM
scm_c_array_ref_1 (SCM array, ssize_t idx0)
{
scm_t_array_handle handle;
SCM res;
scm_array_get_handle (array, &handle);
res = scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, idx0));
scm_array_handle_release (&handle);
return res;
}
SCM
scm_c_array_ref_2 (SCM array, ssize_t idx0, ssize_t idx1)
{
scm_t_array_handle handle;
SCM res;
scm_array_get_handle (array, &handle);
res = scm_array_handle_ref (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1));
scm_array_handle_release (&handle);
return res;
}
SCM
scm_array_ref (SCM v, SCM args)
{
scm_t_array_handle handle;
SCM res;
@ -209,15 +268,34 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
scm_array_handle_release (&handle);
return res;
}
#undef FUNC_NAME
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
(SCM v, SCM obj, SCM args),
"Set the element at the @code{(index1, index2)} element in array\n"
"@var{v} to @var{obj}. The value returned by @code{array-set!}\n"
"is unspecified.")
#define FUNC_NAME s_scm_array_set_x
void
scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
{
scm_t_array_handle handle;
scm_array_get_handle (array, &handle);
scm_array_handle_set (&handle, scm_array_handle_pos_1 (&handle, idx0),
obj);
scm_array_handle_release (&handle);
}
void
scm_c_array_set_2_x (SCM array, SCM obj, ssize_t idx0, ssize_t idx1)
{
scm_t_array_handle handle;
scm_array_get_handle (array, &handle);
scm_array_handle_set (&handle, scm_array_handle_pos_2 (&handle, idx0, idx1),
obj);
scm_array_handle_release (&handle);
}
SCM
scm_array_set_x (SCM v, SCM obj, SCM args)
{
scm_t_array_handle handle;
@ -226,8 +304,47 @@ SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1,
scm_array_handle_release (&handle);
return SCM_UNSPECIFIED;
}
SCM_DEFINE (scm_i_array_ref, "array-ref", 1, 2, 1,
(SCM v, SCM idx0, SCM idx1, SCM idxN),
"Return the element at the @code{(idx0, idx1, idxN...)}\n"
"position in array @var{v}.")
#define FUNC_NAME s_scm_i_array_ref
{
if (SCM_UNBNDP (idx0))
return scm_array_ref (v, SCM_EOL);
else if (SCM_UNBNDP (idx1))
return scm_c_array_ref_1 (v, scm_to_ssize_t (idx0));
else if (scm_is_null (idxN))
return scm_c_array_ref_2 (v, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
else
return scm_array_ref (v, scm_cons (idx0, scm_cons (idx1, idxN)));
}
#undef FUNC_NAME
SCM_DEFINE (scm_i_array_set_x, "array-set!", 2, 2, 1,
(SCM v, SCM obj, SCM idx0, SCM idx1, SCM idxN),
"Set the element at the @code{(idx0, idx1, idxN...)} position\n"
"in the array @var{v} to @var{obj}. The value returned by\n"
"@code{array-set!} is unspecified.")
#define FUNC_NAME s_scm_i_array_set_x
{
if (SCM_UNBNDP (idx0))
scm_array_set_x (v, obj, SCM_EOL);
else if (SCM_UNBNDP (idx1))
scm_c_array_set_1_x (v, obj, scm_to_ssize_t (idx0));
else if (scm_is_null (idxN))
scm_c_array_set_2_x (v, obj, scm_to_ssize_t (idx0), scm_to_ssize_t (idx1));
else
scm_array_set_x (v, obj, scm_cons (idx0, scm_cons (idx1, idxN)));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos)
{

11
libguile/generalized-arrays.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_ARRAYS_H
#define SCM_GENERALIZED_ARRAYS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 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
@ -44,10 +44,19 @@ SCM_API SCM scm_typed_array_p (SCM v, SCM type);
SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_rank (SCM ra);
SCM_API size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
SCM_API SCM scm_array_dimensions (SCM ra);
SCM_API SCM scm_array_type (SCM ra);
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0);
SCM_API SCM scm_c_array_ref_2 (SCM v, ssize_t idx0, ssize_t idx1);
SCM_API void scm_c_array_set_1_x (SCM v, SCM obj, ssize_t idx0);
SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t idx0, ssize_t idx1);
SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v);

68
libguile/generalized-vectors.c
View file

@ -1,5 +1,5 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 2000, 2001, 2002, 2003, 2004,
* 2005, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
* 2005, 2006, 2009, 2010, 2011, 2012, 2013 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
@ -83,16 +83,6 @@ scm_is_generalized_vector (SCM obj)
return ret;
}
SCM_DEFINE (scm_generalized_vector_p, "generalized-vector?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a vector, string,\n"
"bitvector, or uniform numeric vector.")
#define FUNC_NAME s_scm_generalized_vector_p
{
return scm_from_bool (scm_is_generalized_vector (obj));
}
#undef FUNC_NAME
#define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle)
@ -119,15 +109,6 @@ scm_c_generalized_vector_length (SCM v)
return ret;
}
SCM_DEFINE (scm_generalized_vector_length, "generalized-vector-length", 1, 0, 0,
(SCM v),
"Return the length of the generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_length
{
return scm_from_size_t (scm_c_generalized_vector_length (v));
}
#undef FUNC_NAME
SCM
scm_c_generalized_vector_ref (SCM v, size_t idx)
{
@ -141,16 +122,6 @@ scm_c_generalized_vector_ref (SCM v, size_t idx)
return ret;
}
SCM_DEFINE (scm_generalized_vector_ref, "generalized-vector-ref", 2, 0, 0,
(SCM v, SCM idx),
"Return the element at index @var{idx} of the\n"
"generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_ref
{
return scm_c_generalized_vector_ref (v, scm_to_size_t (idx));
}
#undef FUNC_NAME
void
scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
{
@ -162,43 +133,6 @@ scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val)
scm_array_handle_release (&h);
}
SCM_DEFINE (scm_generalized_vector_set_x, "generalized-vector-set!", 3, 0, 0,
(SCM v, SCM idx, SCM val),
"Set the element at index @var{idx} of the\n"
"generalized vector @var{v} to @var{val}.")
#define FUNC_NAME s_scm_generalized_vector_set_x
{
scm_c_generalized_vector_set_x (v, scm_to_size_t (idx), val);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
SCM_DEFINE (scm_generalized_vector_to_list, "generalized-vector->list", 1, 0, 0,
(SCM v),
"Return a new list whose elements are the elements of the\n"
"generalized vector @var{v}.")
#define FUNC_NAME s_scm_generalized_vector_to_list
{
/* FIXME: This duplicates `array_to_list'. */
SCM ret = SCM_EOL;
long inc;
ssize_t pos, i;
scm_t_array_handle h;
scm_generalized_vector_get_handle (v, &h);
i = h.dims[0].ubnd - h.dims[0].lbnd + 1;
inc = h.dims[0].inc;
pos = (i - 1) * inc;
for (; i > 0; i--, pos -= inc)
ret = scm_cons (h.impl->vref (&h, h.base + pos), ret);
scm_array_handle_release (&h);
return ret;
}
#undef FUNC_NAME
void
scm_init_generalized_vectors ()
{

8
libguile/generalized-vectors.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_VECTORS_H
#define SCM_GENERALIZED_VECTORS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 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
@ -30,12 +30,6 @@
/* Generalized vectors */
SCM_API SCM scm_generalized_vector_p (SCM v);
SCM_API SCM scm_generalized_vector_length (SCM v);
SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
SCM_API SCM scm_generalized_vector_to_list (SCM v);
SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);

28
libguile/hashtab.c
View file

@ -205,6 +205,7 @@ SCM_DEFINE (scm_hash_table_p, "hash-table?", 1, 0, 0,
}
#undef FUNC_NAME
/* Accessing hash table entries. */
@ -966,6 +967,33 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
}
#undef FUNC_NAME
static SCM
count_proc (void *pred, SCM key, SCM data, SCM value)
{
if (scm_is_false (scm_call_2 (SCM_PACK (pred), key, data)))
return value;
else
return scm_oneplus(value);
}
SCM_DEFINE (scm_hash_count, "hash-count", 2, 0, 0,
(SCM pred, SCM table),
"Return the number of elements in the given hash TABLE that\n"
"cause `(PRED KEY VALUE)' to return true. To quickly determine\n"
"the total number of elements, use `(const #t)' for PRED.")
#define FUNC_NAME s_scm_hash_count
{
SCM init;
SCM_VALIDATE_PROC (1, pred);
SCM_VALIDATE_HASHTABLE (2, table);
init = scm_from_int (0);
return scm_internal_hash_fold ((scm_t_hash_fold_fn) count_proc,
(void *) SCM_UNPACK (pred), init, table);
}
#undef FUNC_NAME
SCM

1
libguile/hashtab.h
View file

@ -134,6 +134,7 @@ SCM_API SCM scm_hash_fold (SCM proc, SCM init, SCM hash);
SCM_API SCM scm_hash_for_each (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (SCM proc, SCM hash);
SCM_API SCM scm_hash_map_to_list (SCM proc, SCM hash);
SCM_API SCM scm_hash_count (SCM hash, SCM pred);
SCM_INTERNAL void scm_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_hashtab (void);

3
libguile/inline.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2006, 2008, 2011, 2012, 2013 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
@ -23,6 +23,7 @@
#define SCM_IMPLEMENT_INLINES 1
#define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h"
#include "libguile/array-handle.h"
#include "libguile/gc.h"
#include "libguile/smob.h"
#include "libguile/pairs.h"

25
libguile/inline.h
View file

@ -4,7 +4,7 @@
#define SCM_INLINE_H
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010,
* 2011, 2012 Free Software Foundation, Inc.
* 2011, 2012, 2013 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
@ -37,9 +37,6 @@
#include "libguile/error.h"
SCM_INLINE SCM scm_array_handle_ref (scm_t_array_handle *h, ssize_t pos);
SCM_INLINE void scm_array_handle_set (scm_t_array_handle *h, ssize_t pos, SCM val);
SCM_INLINE int scm_is_string (SCM x);
SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr);
@ -50,26 +47,6 @@ SCM_INLINE SCM scm_words (scm_t_bits car, scm_t_uint32 n_words);
#if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
/* Either inlining, or being included from inline.c. */
SCM_INLINE_IMPLEMENTATION SCM
scm_array_handle_ref (scm_t_array_handle *h, ssize_t p)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
return h->impl->vref (h, h->base + p);
}
SCM_INLINE_IMPLEMENTATION void
scm_array_handle_set (scm_t_array_handle *h, ssize_t p, SCM v)
{
if (SCM_UNLIKELY (p < 0 && ((size_t)-p) > h->base))
/* catch overflow */
scm_out_of_range (NULL, scm_from_ssize_t (p));
/* perhaps should catch overflow here too */
h->impl->vset (h, h->base + p, v);
}
SCM_INLINE_IMPLEMENTATION int
scm_is_string (SCM x)
{

15
libguile/numbers.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006,
* 2008, 2009, 2010, 2011, 2013 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
@ -500,6 +501,18 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif
#endif
#if SCM_SIZEOF_SCM_T_PTRDIFF == 4
#define scm_to_ptrdiff_t scm_to_int32
#define scm_from_ptrdiff_t scm_from_int32
#else
#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
#define scm_to_ptrdiff_t scm_to_int64
#define scm_from_ptrdiff_t scm_from_int64
#else
#error sizeof(scm_t_ptrdiff) is not 4 or 8.
#endif
#endif
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);

4
libguile/posix.c
View file

@ -265,8 +265,10 @@ SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
GETGROUPS_T *groups;
ngroups = getgroups (0, NULL);
if (ngroups <= 0)
if (ngroups < 0)
SCM_SYSERROR;
else if (ngroups == 0)
return scm_c_make_vector (0, SCM_BOOL_F);
size = ngroups * sizeof (GETGROUPS_T);
groups = scm_malloc (size);

4
libguile/uniform.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 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
@ -193,7 +193,7 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
{
if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
return scm_generalized_vector_to_list (uvec);
return scm_array_to_list (uvec);
}
#undef FUNC_NAME