diff options
| author | Andy Wingo <wingo@pobox.com> | 2013-02-18 17:59:38 +0100 |
|---|---|---|
| committer | Andy Wingo <wingo@pobox.com> | 2013-02-18 17:59:38 +0100 |
| commit | 9b977c836bf147d386944c401113aba32776fa68 (patch) | |
| tree | d097e1a2376e26bc6b03447445ae239d5514a7a8 | |
| parent | 180ac9d7b0bac97bdead2813a1b0b23d19002c3e (diff) | |
| parent | 739941679c2c7dc36c29c30aff7d4c1b436ba773 (diff) | |
| download | guile-9b977c836bf147d386944c401113aba32776fa68.tar.gz | |
Merge remote-tracking branch 'origin/stable-2.0'
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
36 files changed, 873 insertions, 384 deletions
diff --git a/doc/ref/api-compound.texi b/doc/ref/api-compound.texi index be3d65f4e..6dfc5fdc0 100644 --- a/doc/ref/api-compound.texi +++ b/doc/ref/api-compound.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. @c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, -@c 2007, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +@c 2007, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Compound Data Types @@ -22,7 +22,6 @@ values can be looked up within them. * Lists:: Special list functions supported by Guile. * Vectors:: One-dimensional arrays of Scheme objects. * Bit Vectors:: Vectors of bits. -* Generalized Vectors:: Treating all vector-like things uniformly. * Arrays:: Matrices, etc. * VLists:: Vector-like lists. * Record Overview:: Walking through the maze of record APIs. @@ -993,9 +992,8 @@ are displayed as a sequence of @code{0}s and @code{1}s prefixed by #*00000000 @end example -Bit vectors are also generalized vectors, @xref{Generalized -Vectors}, and can thus be used with the array procedures, @xref{Arrays}. -Bit vectors are the special case of one dimensional bit arrays. +Bit vectors are the special case of one dimensional bit arrays, and can +thus be used with the array procedures, @xref{Arrays}. @deffn {Scheme Procedure} bitvector? obj @deffnx {C Function} scm_bitvector_p (obj) @@ -1163,74 +1161,6 @@ Like @code{scm_bitvector_elements}, but the pointer is good for reading and writing. @end deftypefn -@node Generalized Vectors -@subsection Generalized Vectors - -Guile has a number of data types that are generally vector-like: -strings, uniform numeric vectors, bytevectors, bitvectors, and of course -ordinary vectors of arbitrary Scheme values. These types are disjoint: -a Scheme value belongs to at most one of the five types listed above. - -If you want to gloss over this distinction and want to treat all four -types with common code, you can use the procedures in this section. -They work with the @emph{generalized vector} type, which is the union -of the five vector-like types. - -@deffn {Scheme Procedure} generalized-vector? obj -@deffnx {C Function} scm_generalized_vector_p (obj) -Return @code{#t} if @var{obj} is a vector, bytevector, string, -bitvector, or uniform numeric vector. -@end deffn - -@deffn {Scheme Procedure} generalized-vector-length v -@deffnx {C Function} scm_generalized_vector_length (v) -Return the length of the generalized vector @var{v}. -@end deffn - -@deffn {Scheme Procedure} generalized-vector-ref v idx -@deffnx {C Function} scm_generalized_vector_ref (v, idx) -Return the element at index @var{idx} of the -generalized vector @var{v}. -@end deffn - -@deffn {Scheme Procedure} generalized-vector-set! v idx val -@deffnx {C Function} scm_generalized_vector_set_x (v, idx, val) -Set the element at index @var{idx} of the -generalized vector @var{v} to @var{val}. -@end deffn - -@deffn {Scheme Procedure} generalized-vector->list v -@deffnx {C Function} scm_generalized_vector_to_list (v) -Return a new list whose elements are the elements of the -generalized vector @var{v}. -@end deffn - -@deftypefn {C Function} int scm_is_generalized_vector (SCM obj) -Return @code{1} if @var{obj} is a vector, string, -bitvector, or uniform numeric vector; else return @code{0}. -@end deftypefn - -@deftypefn {C Function} size_t scm_c_generalized_vector_length (SCM v) -Return the length of the generalized vector @var{v}. -@end deftypefn - -@deftypefn {C Function} SCM scm_c_generalized_vector_ref (SCM v, size_t idx) -Return the element at index @var{idx} of the generalized vector @var{v}. -@end deftypefn - -@deftypefn {C Function} void scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) -Set the element at index @var{idx} of the generalized vector @var{v} -to @var{val}. -@end deftypefn - -@deftypefn {C Function} void scm_generalized_vector_get_handle (SCM v, scm_t_array_handle *handle) -Like @code{scm_array_get_handle} but an error is signalled when @var{v} -is not of rank one. You can use @code{scm_array_handle_ref} and -@code{scm_array_handle_set} to read and write the elements of @var{v}, -or you can use functions like @code{scm_array_handle_<foo>_elements} to -deal with specific types of vectors. -@end deftypefn - @node Arrays @subsection Arrays @tpindex Arrays @@ -1239,13 +1169,13 @@ deal with specific types of vectors. number of dimensions. Each cell can be accessed in constant time by supplying an index for each dimension. -In the current implementation, an array uses a generalized vector for -the actual storage of its elements. Any kind of generalized vector -will do, so you can have arrays of uniform numeric values, arrays of -characters, arrays of bits, and of course, arrays of arbitrary Scheme -values. For example, arrays with an underlying @code{c64vector} might -be nice for digital signal processing, while arrays made from a -@code{u8vector} might be used to hold gray-scale images. +In the current implementation, an array uses a vector of some kind for +the actual storage of its elements. Any kind of vector will do, so you +can have arrays of uniform numeric values, arrays of characters, arrays +of bits, and of course, arrays of arbitrary Scheme values. For example, +arrays with an underlying @code{c64vector} might be nice for digital +signal processing, while arrays made from a @code{u8vector} might be +used to hold gray-scale images. The number of dimensions of an array is called its @dfn{rank}. Thus, a matrix is an array of rank 2, while a vector has rank 1. When @@ -1267,9 +1197,9 @@ matrix with zero columns and 3 rows is different from a matrix with 3 columns and zero rows, which again is different from a vector of length zero. -Generalized vectors, such as strings, uniform numeric vectors, -bytevectors, bit vectors and ordinary vectors, are the special case of -one dimensional arrays. +The array procedures are all polymorphic, treating strings, uniform +numeric vectors, bytevectors, bit vectors and ordinary vectors as one +dimensional arrays. @menu * Array Syntax:: @@ -1462,6 +1392,7 @@ as elements in the list. @end deffn @deffn {Scheme Procedure} array-type array +@deffnx {C Function} scm_array_type (array) Return the type of @var{array}. This is the `vectag' used for printing @var{array} (or @code{#t} for ordinary arrays) and can be used with @code{make-typed-array} to create an array of the same kind @@ -1469,6 +1400,7 @@ as @var{array}. @end deffn @deffn {Scheme Procedure} array-ref array idx @dots{} +@deffnx {C Function} scm_array_ref (array, idxlist) Return the element at @code{(idx @dots{})} in @var{array}. @example @@ -1479,7 +1411,7 @@ Return the element at @code{(idx @dots{})} in @var{array}. @deffn {Scheme Procedure} array-in-bounds? array idx @dots{} @deffnx {C Function} scm_array_in_bounds_p (array, idxlist) -Return @code{#t} if the given index would be acceptable to +Return @code{#t} if the given indices would be acceptable to @code{array-ref}. @example @@ -1520,6 +1452,13 @@ For example, @end example @end deffn +@deffn {Scheme Procedure} array-length array +@deffnx {C Function} scm_array_length (array) +@deffnx {C Function} size_t scm_c_array_length (array) +Return the length of an array: its first dimension. It is an error to +ask for the length of an array of rank 0. +@end deffn + @deffn {Scheme Procedure} array-rank array @deffnx {C Function} scm_array_rank (array) Return the rank of @var{array}. @@ -3796,8 +3735,9 @@ key is not found. #f @end lisp -There is no procedure for calculating the number of key/value-pairs in -a hash table, but @code{hash-fold} can be used for doing exactly that. +Interesting results can be computed by using @code{hash-fold} to work +through each element. This example will count the total number of +elements: @lisp (hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) @@ -3805,6 +3745,24 @@ a hash table, but @code{hash-fold} can be used for doing exactly that. 3 @end lisp +The same thing can be done with the procedure @code{hash-count}, which +can also count the number of elements matching a particular predicate. +For example, count the number of elements with string values: + +@lisp +(hash-count (lambda (key value) (string? value)) h) +@result{} +2 +@end lisp + +Counting all the elements is a simple task using @code{const}: + +@lisp +(hash-count (const #t) h) +@result{} +3 +@end lisp + @node Hash Table Reference @subsubsection Hash Table Reference @@ -4032,6 +3990,13 @@ For example, the following returns a count of how many keys in @end example @end deffn +@deffn {Scheme Procedure} hash-count pred table +@deffnx {C Function} scm_hash_count (pred, table) +Return the number of elements in the given hash @var{table} that cause +@code{(@var{pred} @var{key} @var{value})} to return true. To quickly +determine the total number of elements, use @code{(const #t)} for +@var{pred}. +@end deffn @c Local Variables: @c TeX-master: "guile.texi" diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 28160c88c..9bb674a96 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -1,7 +1,7 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 -@c Free Software Foundation, Inc. +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, +@c 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @node Simple Data Types @@ -414,6 +414,7 @@ function will always succeed and will always return an exact number. @deftypefnx {C Function} {unsigned long long} scm_to_ulong_long (SCM x) @deftypefnx {C Function} size_t scm_to_size_t (SCM x) @deftypefnx {C Function} ssize_t scm_to_ssize_t (SCM x) +@deftypefnx {C Function} scm_t_ptrdiff scm_to_ptrdiff_t (SCM x) @deftypefnx {C Function} scm_t_int8 scm_to_int8 (SCM x) @deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x) @deftypefnx {C Function} scm_t_int16 scm_to_int16 (SCM x) @@ -447,6 +448,7 @@ the corresponding types are. @deftypefnx {C Function} SCM scm_from_ulong_long (unsigned long long x) @deftypefnx {C Function} SCM scm_from_size_t (size_t x) @deftypefnx {C Function} SCM scm_from_ssize_t (ssize_t x) +@deftypefnx {C Function} SCM scm_from_ptrdiff_t (scm_t_ptrdiff x) @deftypefnx {C Function} SCM scm_from_int8 (scm_t_int8 x) @deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x) @deftypefnx {C Function} SCM scm_from_int16 (scm_t_int16 x) @@ -4548,7 +4550,7 @@ R6RS (@pxref{R6RS I/O Ports}). * Bytevectors and Integer Lists:: Converting to/from an integer list. * Bytevectors as Floats:: Interpreting bytes as real numbers. * Bytevectors as Strings:: Interpreting bytes as Unicode strings. -* Bytevectors as Generalized Vectors:: Guile extension to the bytevector API. +* Bytevectors as Arrays:: Guile extension to the bytevector API. * Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4. @end menu @@ -4934,25 +4936,27 @@ or UTF-32-decoded contents of bytevector @var{utf}. For UTF-16 and UTF-32, it defaults to big endian. @end deffn -@node Bytevectors as Generalized Vectors -@subsubsection Accessing Bytevectors with the Generalized Vector API +@node Bytevectors as Arrays +@subsubsection Accessing Bytevectors with the Array API As an extension to the R6RS, Guile allows bytevectors to be manipulated -with the @dfn{generalized vector} procedures (@pxref{Generalized -Vectors}). This also allows bytevectors to be accessed using the -generic @dfn{array} procedures (@pxref{Array Procedures}). When using -these APIs, bytes are accessed one at a time as 8-bit unsigned integers: +with the @dfn{array} procedures (@pxref{Arrays}). When using these +APIs, bytes are accessed one at a time as 8-bit unsigned integers: @example (define bv #vu8(0 1 2 3)) -(generalized-vector? bv) +(array? bv) @result{} #t -(generalized-vector-ref bv 2) +(array-rank bv) +@result{} 1 + +(array-ref bv 2) @result{} 2 -(generalized-vector-set! bv 2 77) +;; Note the different argument order on array-set!. +(array-set! bv 77 2) (array-ref bv 2) @result{} 77 diff --git a/doc/ref/api-foreign.texi b/doc/ref/api-foreign.texi index f8ed4ccd7..e59566849 100644 --- a/doc/ref/api-foreign.texi +++ b/doc/ref/api-foreign.texi @@ -489,6 +489,8 @@ platform-dependent size: @defvrx {Scheme Variable} long @defvrx {Scheme Variable} unsigned-long @defvrx {Scheme Variable} size_t +@defvrx {Scheme Variable} ssize_t +@defvrx {Scheme Variable} ptrdiff_t Values exported by the @code{(system foreign)} module, representing C numeric types. For example, @code{long} may be @code{equal?} to @code{int64} on a 64-bit platform. @@ -801,8 +803,8 @@ int64_t a; uint8_t b; @}}: @end example As yet, Guile only has convenience routines to support -conventionally-packed structs. But given the @code{bytevector->foreign} -and @code{foreign->bytevector} routines, one can create and parse +conventionally-packed structs. But given the @code{bytevector->pointer} +and @code{pointer->bytevector} routines, one can create and parse tightly packed structs and unions by hand. See the code for @code{(system foreign)} for details. diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index f92ddafc2..17b1918bf 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -1,6 +1,6 @@ @c -*-texinfo-*- @c This is part of the GNU Guile Reference Manual. -@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012 +@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013 @c Free Software Foundation, Inc. @c See the file guile.texi for copying conditions. @@ -1770,8 +1770,8 @@ Like @code{scm_vector_writable_elements} (@pxref{Vector Accessing from C}), but returns a pointer to the elements of a uniform numeric vector. @end deftypefn -Unless you really need to the limited generality of these functions, it is best -to use the type-specific functions, or the generalized vector accessors. +Unless you really need to the limited generality of these functions, it +is best to use the type-specific functions, or the array accessors. @node SRFI-4 and Bytevectors @subsubsection SRFI-4 - Relation to bytevectors diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 7114f78e0..62d8520f3 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -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) { diff --git a/libguile/array-handle.h b/libguile/array-handle.h index 2e8af77b6..fa2449dea 100644 --- a/libguile/array-handle.h +++ b/libguile/array-handle.h @@ -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); diff --git a/libguile/deprecated.c b/libguile/deprecated.c index cf4402435..cca145414 100644 --- a/libguile/deprecated.c +++ b/libguile/deprecated.c @@ -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 () { diff --git a/libguile/foreign.c b/libguile/foreign.c index 47077f7f8..c81c5f407 100644 --- a/libguile/foreign.c +++ b/libguile/foreign.c @@ -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, "*"); @@ -1282,6 +1284,26 @@ scm_init_foreign (void) #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 + ); + null_pointer = scm_cell (scm_tc7_pointer, 0); scm_define (sym_null, null_pointer); } diff --git a/libguile/gen-scmconfig.c b/libguile/gen-scmconfig.c index e1cc0305e..d8dea7f54 100644 --- a/libguile/gen-scmconfig.c +++ b/libguile/gen-scmconfig.c @@ -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)) diff --git a/libguile/generalized-arrays.c b/libguile/generalized-arrays.c index 3a0ce25c7..9382e817e 100644 --- a/libguile/generalized-arrays.c +++ b/libguile/generalized-arrays.c @@ -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) { diff --git a/libguile/generalized-arrays.h b/libguile/generalized-arrays.h index 1f9b6ad3d..d9fcea63d 100644 --- a/libguile/generalized-arrays.h +++ b/libguile/generalized-arrays.h @@ -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); diff --git a/libguile/generalized-vectors.c b/libguile/generalized-vectors.c index 4da0e884f..5e3e5526a 100644 --- a/libguile/generalized-vectors.c +++ b/libguile/generalized-vectors.c @@ -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 () { diff --git a/libguile/generalized-vectors.h b/libguile/generalized-vectors.h index 71b58d291..e2acb9879 100644 --- a/libguile/generalized-vectors.h +++ b/libguile/generalized-vectors.h @@ -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); diff --git a/libguile/hashtab.c b/libguile/hashtab.c index fc7fa424e..fff48b857 100644 --- a/libguile/hashtab.c +++ b/libguile/hashtab.c @@ -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 diff --git a/libguile/hashtab.h b/libguile/hashtab.h index 8eb685a0e..82ed22e66 100644 --- a/libguile/hashtab.h +++ b/libguile/hashtab.h @@ -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); diff --git a/libguile/inline.c b/libguile/inline.c index e005b2690..6e7688c37 100644 --- a/libguile/inline.c +++ b/libguile/inline.c @@ -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" diff --git a/libguile/inline.h b/libguile/inline.h index 89bbf9de7..3c9b09b6a 100644 --- a/libguile/inline.h +++ b/libguile/inline.h @@ -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) { diff --git a/libguile/numbers.h b/libguile/numbers.h index cef2b863b..3c43ae421 100644 --- a/libguile/numbers.h +++ b/libguile/numbers.h @@ -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); diff --git a/libguile/posix.c b/libguile/posix.c index b9097d41a..383ab76fd 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -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); diff --git a/libguile/uniform.c b/libguile/uniform.c index d3ecb1bc9..a58242d81 100644 --- a/libguile/uniform.c +++ b/libguile/uniform.c @@ -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 diff --git a/meta/guild.in b/meta/guild.in index 183323f75..d501a0daf 100755 --- a/meta/guild.in +++ b/meta/guild.in @@ -8,7 +8,7 @@ exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' ;;;; guild --- running scripts bundled with Guile ;;;; Andy Wingo <wingo@pobox.com> --- April 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -51,7 +51,13 @@ exec ${GUILE:-@bindir@/@guile_program_name@} $GUILE_FLAGS -e '(@@ (guild) main)' (define (main args) (if (defined? 'setlocale) - (setlocale LC_ALL "")) + (catch 'system-error + (lambda () + (setlocale LC_ALL "")) + (lambda args + (format (current-error-port) + "warning: failed to install locale: ~a~%" + (strerror (system-error-errno args)))))) (let* ((options (getopt-long args *option-grammar* #:stop-at-first-non-option #t)) diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm index 735ffcfcc..5f42ef4dd 100644 --- a/module/ice-9/boot-9.scm +++ b/module/ice-9/boot-9.scm @@ -627,12 +627,10 @@ file with the given name already exists, the effect is unspecified." datum (syntax->datum clause) (syntax->datum whole-expr))) - (if (memv datum seen) - (warn-datum 'duplicate-case-datum)) - (if (or (pair? datum) - (array? datum) - (generalized-vector? datum)) - (warn-datum 'bad-case-datum)) + (when (memv datum seen) + (warn-datum 'duplicate-case-datum)) + (when (or (pair? datum) (array? datum)) + (warn-datum 'bad-case-datum)) (cons datum seen)) seen (map syntax->datum #'(datums ...))))) @@ -966,6 +964,8 @@ information is unavailable." #'(define-macro macro doc (lambda args body1 body ...))) ((_ (macro . args) body ...) #'(define-macro macro #f (lambda args body ...))) + ((_ macro transformer) + #'(define-macro macro #f transformer)) ((_ macro doc transformer) (or (string? (syntax->datum #'doc)) (not (syntax->datum #'doc))) diff --git a/module/language/tree-il/peval.scm b/module/language/tree-il/peval.scm index 5ae691ddd..2d2c30ba6 100644 --- a/module/language/tree-il/peval.scm +++ b/module/language/tree-il/peval.scm @@ -431,6 +431,13 @@ top-level bindings from ENV and return the resulting expression." new)) vars)) + (define (fresh-temporaries ls) + (map (lambda (elt) + (let ((new (gensym "tmp "))) + (record-new-temporary! 'tmp new 1) + new)) + ls)) + (define (assigned-lexical? sym) (var-set? (lookup-var sym))) @@ -508,7 +515,7 @@ top-level bindings from ENV and return the resulting expression." (else (residualize-call)))) - (define (inline-values exp src names gensyms body) + (define (inline-values src exp nmin nmax consumer) (let loop ((exp exp)) (match exp ;; Some expression types are always singly-valued. @@ -524,17 +531,15 @@ top-level bindings from ENV and return the resulting expression." ($ <toplevel-set>) ; could return zero values in ($ <toplevel-define>) ; the future ($ <module-set>) ; - ($ <dynset>)) ; - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) - (($ <primcall> src (? singly-valued-primitive? name)) - (and (= (length names) 1) - (make-let src names gensyms (list exp) body))) + ($ <dynset>) ; + ($ <primcall> src (? singly-valued-primitive?))) + (and (<= nmin 1) (or (not nmax) (>= nmax 1)) + (make-call src (make-lambda #f '() consumer) (list exp)))) ;; Statically-known number of values. (($ <primcall> src 'values vals) - (and (= (length names) (length vals)) - (make-let src names gensyms vals body))) + (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals))) + (make-call src (make-lambda #f '() consumer) vals))) ;; Not going to copy code into both branches. (($ <conditional>) #f) @@ -692,6 +697,49 @@ top-level bindings from ENV and return the resulting expression." ((vhash-assq var env) => cdr) (else (error "unbound var" var)))) + ;; Find a value referenced a specific number of times. This is a hack + ;; that's used for propagating fresh data structures like rest lists and + ;; prompt tags. Usually we wouldn't copy consed data, but we can do so in + ;; some special cases like `apply' or prompts if we can account + ;; for all of its uses. + ;; + ;; You don't want to use this in general because it introduces a slight + ;; nonlinearity by running peval again (though with a small effort and size + ;; counter). + ;; + (define (find-definition x n-aliases) + (cond + ((lexical-ref? x) + (cond + ((lookup (lexical-ref-gensym x)) + => (lambda (op) + (let ((y (or (operand-residual-value op) + (visit-operand op counter 'value 10 10) + (operand-source op)))) + (cond + ((and (lexical-ref? y) + (= (lexical-refcount (lexical-ref-gensym x)) 1)) + ;; X is a simple alias for Y. Recurse, regardless of + ;; the number of aliases we were expecting. + (find-definition y n-aliases)) + ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) + ;; We found a definition that is aliased the right + ;; number of times. We still recurse in case it is a + ;; lexical. + (values (find-definition y 1) + op)) + (else + ;; We can't account for our aliases. + (values #f #f)))))) + (else + ;; A formal parameter. Can't say anything about that. + (values #f #f)))) + ((= n-aliases 1) + ;; Not a lexical: success, but only if we are looking for an + ;; unaliased value. + (values x #f)) + (else (values #f #f)))) + (define (visit exp ctx) (loop exp env counter ctx)) @@ -820,6 +868,30 @@ top-level bindings from ENV and return the resulting expression." (begin (record-operand-use op) (make-lexical-set src name (operand-sym op) (for-value exp)))))) + (($ <let> src + (names ... rest) + (gensyms ... rest-sym) + (vals ... ($ <primcall> _ 'list rest-args)) + ($ <primcall> asrc (or 'apply '@apply) + (proc args ... + ($ <lexical-ref> _ + (? (cut eq? <> rest)) + (? (lambda (sym) + (and (eq? sym rest-sym) + (= (lexical-refcount sym) 1)))))))) + (let* ((tmps (make-list (length rest-args) 'tmp)) + (tmp-syms (fresh-temporaries tmps))) + (for-tail + (make-let src + (append names tmps) + (append gensyms tmp-syms) + (append vals rest-args) + (make-call + asrc + proc + (append args + (map (cut make-lexical-ref #f <> <>) + tmps tmp-syms))))))) (($ <let> src names gensyms vals body) (define (compute-alias exp) ;; It's very common for macros to introduce something like: @@ -915,11 +987,13 @@ top-level bindings from ENV and return the resulting expression." ;; reconstruct the let-values, pevaling the consumer. (let ((producer (for-values producer))) (or (match consumer - (($ <lambda-case> src req #f #f #f () gensyms body #f) - (cond - ((inline-values producer src req gensyms body) - => for-tail) - (else #f))) + (($ <lambda-case> src req opt rest #f inits gensyms body #f) + (let* ((nmin (length req)) + (nmax (and (not rest) (+ nmin (if opt (length opt) 0))))) + (cond + ((inline-values lv-src producer nmin nmax consumer) + => for-tail) + (else #f)))) (_ #f)) (make-let-values lv-src producer (for-tail consumer))))) (($ <dynwind> src winder pre body post unwinder) @@ -1102,15 +1176,30 @@ top-level bindings from ENV and return the resulting expression." (make-primcall src 'values vals)))))) (($ <primcall> src (or 'apply '@apply) (proc args ... tail)) - (match (for-value tail) - (($ <const> _ (args* ...)) - (let ((args* (map (lambda (x) (make-const #f x)) args*))) - (for-tail (make-call src proc (append args args*))))) - (($ <primcall> _ 'list args*) - (for-tail (make-call src proc (append args args*)))) - (tail - (let ((args (append (map for-value args) (list tail)))) - (make-primcall src '@apply (cons (for-value proc) args)))))) + (let lp ((tail* (find-definition tail 1)) (speculative? #t)) + (define (copyable? x) + ;; Inlining a result from find-definition effectively copies it, + ;; relying on the let-pruning to remove its original binding. We + ;; shouldn't copy non-constant expressions. + (or (not speculative?) (constant-expression? x))) + (match tail* + (($ <const> _ (args* ...)) + (let ((args* (map (cut make-const #f <>) args*))) + (for-tail (make-call src proc (append args args*))))) + (($ <primcall> _ 'cons + ((and head (? copyable?)) (and tail (? copyable?)))) + (for-tail (make-primcall src '@apply + (cons proc + (append args (list head tail)))))) + (($ <primcall> _ 'list + (and args* ((? copyable?) ...))) + (for-tail (make-call src proc (append args args*)))) + (tail* + (if speculative? + (lp (for-value tail) #f) + (let ((args (append (map for-value args) (list tail*)))) + (make-primcall src '@apply + (cons (for-value proc) args)))))))) (($ <primcall> src (? constructor-primitive? name) args) (cond @@ -1219,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression." (($ <call> src orig-proc orig-args) ;; todo: augment the global env with specialized functions - (let ((proc (visit orig-proc 'operator))) + (let revisit-proc ((proc (visit orig-proc 'operator))) (match proc (($ <primitive-ref> _ name) (for-tail (make-primcall src name orig-args))) (($ <lambda> _ _ - ($ <lambda-case> _ req opt #f #f inits gensyms body #f)) - ;; Simple case: no rest, no keyword arguments. + ($ <lambda-case> _ req opt rest #f inits gensyms body #f)) + ;; Simple case: no keyword arguments. ;; todo: handle the more complex cases (let* ((nargs (length orig-args)) (nreq (length req)) (nopt (if opt (length opt) 0)) (key (source-expression proc))) + (define (inlined-call) + (make-let src + (append req + (or opt '()) + (if rest (list rest) '())) + gensyms + (if (> nargs (+ nreq nopt)) + (append (list-head orig-args (+ nreq nopt)) + (list + (make-primcall + #f 'list + (drop orig-args (+ nreq nopt))))) + (append orig-args + (drop inits (- nargs nreq)) + (if rest + (list (make-const #f '())) + '()))) + body)) + (cond - ((or (< nargs nreq) (> nargs (+ nreq nopt))) + ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt)))) ;; An error, or effecting arguments. (make-call src (for-call orig-proc) (map for-value orig-args))) ((or (and=> (find-counter key counter) counter-recursive?) @@ -1256,12 +1364,7 @@ top-level bindings from ENV and return the resulting expression." (lp (counter-prev counter))))))) (log 'inline-recurse key) - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env counter ctx)) + (loop (inlined-call) env counter ctx)) (else ;; An integration at the top-level, the first ;; recursion of a recursive procedure, or a nested @@ -1292,12 +1395,7 @@ top-level bindings from ENV and return the resulting expression." (make-top-counter effort-limit operand-size-limit abort key)))) (define result - (loop (make-let src (append req (or opt '())) - gensyms - (append orig-args - (drop inits (- nargs nreq))) - body) - env new-counter ctx)) + (loop (inlined-call) env new-counter ctx)) (if counter ;; The nested inlining attempt succeeded. @@ -1307,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression." (log 'inline-end result exp) result))))) + (($ <let> _ _ _ vals _) + ;; Attempt to inline `let' in the operator position. + ;; + ;; We have to re-visit the proc in value mode, since the + ;; `let' bindings might have been introduced or renamed, + ;; whereas the lambda (if any) in operator position has not + ;; been renamed. + (if (or (and-map constant-expression? vals) + (and-map constant-expression? orig-args)) + ;; The arguments and the let-bound values commute. + (match (for-value orig-proc) + (($ <let> lsrc names syms vals body) + (log 'inline-let orig-proc) + (for-tail + (make-let lsrc names syms vals + (make-call src body orig-args)))) + ;; It's possible for a `let' to go away after the + ;; visit due to the fact that visiting a procedure in + ;; value context will prune unused bindings, whereas + ;; visiting in operator mode can't because it doesn't + ;; traverse through lambdas. In that case re-visit + ;; the procedure. + (proc (revisit-proc proc))) + (make-call src (for-call orig-proc) + (map for-value orig-args)))) (_ (make-call src (for-call orig-proc) (map for-value orig-args)))))) (($ <lambda> src meta body) @@ -1365,37 +1488,6 @@ top-level bindings from ENV and return the resulting expression." (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?)))) #t) (_ #f))) - (define (find-definition x n-aliases) - (cond - ((lexical-ref? x) - (cond - ((lookup (lexical-ref-gensym x)) - => (lambda (op) - (let ((y (or (operand-residual-value op) - (visit-operand op counter 'value 10 10)))) - (cond - ((and (lexical-ref? y) - (= (lexical-refcount (lexical-ref-gensym x)) 1)) - ;; X is a simple alias for Y. Recurse, regardless of - ;; the number of aliases we were expecting. - (find-definition y n-aliases)) - ((= (lexical-refcount (lexical-ref-gensym x)) n-aliases) - ;; We found a definition that is aliased the right - ;; number of times. We still recurse in case it is a - ;; lexical. - (values (find-definition y 1) - op)) - (else - ;; We can't account for our aliases. - (values #f #f)))))) - (else - ;; A formal parameter. Can't say anything about that. - (values #f #f)))) - ((= n-aliases 1) - ;; Not a lexical: success, but only if we are looking for an - ;; unaliased value. - (values x #f)) - (else (values #f #f)))) (let ((tag (for-value tag)) (body (for-tail body))) diff --git a/module/srfi/srfi-4/gnu.scm b/module/srfi/srfi-4/gnu.scm index 39d6350e7..7f595d628 100644 --- a/module/srfi/srfi-4/gnu.scm +++ b/module/srfi/srfi-4/gnu.scm @@ -1,6 +1,6 @@ ;;; Extensions to SRFI-4 -;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;; Copyright (C) 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 @@ -101,14 +101,14 @@ `(define (,(symbol-append 'any-> tag 'vector) obj) (cond ((,(symbol-append tag 'vector?) obj) obj) ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj)) - ((generalized-vector? obj) - (let* ((len (generalized-vector-length obj)) + ((and (array? obj) (eqv? 1 (array-rank obj))) + (let* ((len (array-length obj)) (v (,(symbol-append 'make- tag 'vector) len))) (let lp ((i 0)) (if (< i len) (begin (,(symbol-append tag 'vector-set!) - v i (generalized-vector-ref obj i)) + v i (array-ref obj i)) (lp (1+ i))) v)))) (else (scm-error 'wrong-type-arg #f "" '() (list obj)))))) diff --git a/module/system/foreign.scm b/module/system/foreign.scm index e6e965545..01a71b8b9 100644 --- a/module/system/foreign.scm +++ b/module/system/foreign.scm @@ -1,4 +1,4 @@ -;;;; Copyright (C) 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -25,7 +25,7 @@ float double short unsigned-short - int unsigned-int long unsigned-long size_t + int unsigned-int long unsigned-long size_t ssize_t ptrdiff_t int8 uint8 uint16 int16 uint32 int32 diff --git a/module/texinfo.scm b/module/texinfo.scm index 519db485d..edee5b397 100644 --- a/module/texinfo.scm +++ b/module/texinfo.scm @@ -1,6 +1,6 @@ ;;;; (texinfo) -- parsing of texinfo into SXML ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2004, 2009 Andy Wingo <wingo at pobox dot com> ;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg at pobox dot com> ;;;; @@ -187,6 +187,7 @@ lambda. Only present for @code{INLINE-ARGS}, @code{EOL-ARGS}, (sample INLINE-TEXT) (samp INLINE-TEXT) (code INLINE-TEXT) + (math INLINE-TEXT) (kbd INLINE-TEXT) (key INLINE-TEXT) (var INLINE-TEXT) diff --git a/module/texinfo/docbook.scm b/module/texinfo/docbook.scm index c5a8d659f..f3f993db8 100644 --- a/module/texinfo/docbook.scm +++ b/module/texinfo/docbook.scm @@ -135,7 +135,7 @@ each other. @xref{texinfo docbook sdocbook-flatten,,sdocbook-flatten}, for more information." '(para programlisting informalexample indexterm variablelist orderedlist refsect1 refsect2 refsect3 refsect4 title example - note itemizedlist)) + note itemizedlist informaltable)) (define (inline-command? command) (not (memq command *sdocbook-block-commands*))) diff --git a/module/texinfo/plain-text.scm b/module/texinfo/plain-text.scm index 87e43e5bb..83e5e38f9 100644 --- a/module/texinfo/plain-text.scm +++ b/module/texinfo/plain-text.scm @@ -1,6 +1,6 @@ ;;;; (texinfo plain-text) -- rendering stexinfo as plain text ;;;; -;;;; Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -238,6 +238,7 @@ (sample ,code) (samp ,code) (code ,code) + (math ,passthrough) (kbd ,code) (key ,key) (var ,var) diff --git a/module/texinfo/serialize.scm b/module/texinfo/serialize.scm index 1436ad5f9..d0c6f50e5 100644 --- a/module/texinfo/serialize.scm +++ b/module/texinfo/serialize.scm @@ -1,6 +1,6 @@ ;;;; (texinfo serialize) -- rendering stexinfo as texinfo ;;;; -;;;; Copyright (C) 2009, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2012, 2013 Free Software Foundation, Inc. ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com> ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -185,7 +185,8 @@ (define (wrap strings) (fill-string (string-concatenate strings) - #:line-width 72)) + #:line-width 72 + #:break-long-words? #f)) (define (paragraph exp lp command type formals args accum) (list* "\n\n" diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index f13b1a2ac..d88a1cb8c 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -1,6 +1,6 @@ ;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; -;;;; Copyright 2004, 2006, 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright 2004, 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 @@ -228,26 +228,6 @@ (array->list b)))) ;;; -;;; generalized-vector->list -;;; - -(with-test-prefix "generalized-vector->list" - (pass-if-equal '(1 2 3) (generalized-vector->list #s16(1 2 3))) - (pass-if-equal '(1 2 3) (generalized-vector->list #(1 2 3))) - (pass-if-equal '() (generalized-vector->list #())) - - (pass-if-equal "http://bugs.gnu.org/12465 - ok" - '(3 4) - (let* ((a #2((1 2) (3 4))) - (b (make-shared-array a (lambda (j) (list 1 j)) 2))) - (generalized-vector->list b))) - (pass-if-equal "http://bugs.gnu.org/12465 - bad" - '(2 4) - (let* ((a #2((1 2) (3 4))) - (b (make-shared-array a (lambda (i) (list i 1)) 2))) - (generalized-vector->list b)))) - -;;; ;;; array-fill! ;;; @@ -451,7 +431,7 @@ (array-set! a 'y 2)) (pass-if-exception "end+1" exception:out-of-range (array-set! a 'y 6)) - (pass-if-exception "two indexes" exception:out-of-range + (pass-if-exception "two indexes" exception:wrong-num-indices (array-set! a 'y 6 7)))) (with-test-prefix "two dim" @@ -649,6 +629,4 @@ (pass-if (equal? (array-row array 1) #u32(2 3))) (pass-if (equal? (array-ref (array-row array 1) 0) - 2)) - (pass-if (equal? (generalized-vector-ref (array-row array 1) 0) 2)))) diff --git a/test-suite/tests/bitvectors.test b/test-suite/tests/bitvectors.test index c16fb4d49..4e32c619c 100644 --- a/test-suite/tests/bitvectors.test +++ b/test-suite/tests/bitvectors.test @@ -1,6 +1,6 @@ ;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*- ;;;; -;;;; Copyright 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright 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 @@ -22,7 +22,6 @@ (with-test-prefix "predicates" (pass-if (bitvector? #*1010101010)) - (pass-if (generalized-vector? #*1010101010)) (pass-if (uniform-vector? #*1010101010)) (pass-if (array? #*1010101010))) diff --git a/test-suite/tests/bytevectors.test b/test-suite/tests/bytevectors.test index 4ba501217..67fc6801f 100644 --- a/test-suite/tests/bytevectors.test +++ b/test-suite/tests/bytevectors.test @@ -1,6 +1,6 @@ ;;;; bytevectors.test --- R6RS bytevectors. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. ;;;; Ludovic Courtès ;;;; ;;;; This library is free software; you can redistribute it and/or @@ -589,42 +589,42 @@ (with-input-from-string "#vu8(0 256)" read))) -(with-test-prefix "Generalized Vectors" +(with-test-prefix "Arrays" - (pass-if "generalized-vector?" - (generalized-vector? #vu8(1 2 3))) + (pass-if "array?" + (array? #vu8(1 2 3))) - (pass-if "generalized-vector-length" + (pass-if "array-length" (equal? (iota 16) - (map generalized-vector-length + (map array-length (map make-bytevector (iota 16))))) - (pass-if "generalized-vector-ref" + (pass-if "array-ref" (let ((bv #vu8(255 127))) - (and (= 255 (generalized-vector-ref bv 0)) - (= 127 (generalized-vector-ref bv 1))))) + (and (= 255 (array-ref bv 0)) + (= 127 (array-ref bv 1))))) - (pass-if-exception "generalized-vector-ref [index out-of-range]" + (pass-if-exception "array-ref [index out-of-range]" exception:out-of-range (let ((bv #vu8(1 2))) - (generalized-vector-ref bv 2))) + (array-ref bv 2))) - (pass-if "generalized-vector-set!" + (pass-if "array-set!" (let ((bv (make-bytevector 2))) - (generalized-vector-set! bv 0 255) - (generalized-vector-set! bv 1 77) + (array-set! bv 255 0) + (array-set! bv 77 1) (equal? '(255 77) (bytevector->u8-list bv)))) - (pass-if-exception "generalized-vector-set! [index out-of-range]" + (pass-if-exception "array-set! [index out-of-range]" exception:out-of-range (let ((bv (make-bytevector 2))) - (generalized-vector-set! bv 2 0))) + (array-set! bv 0 2))) - (pass-if-exception "generalized-vector-set! [value out-of-range]" + (pass-if-exception "array-set! [value out-of-range]" exception:out-of-range (let ((bv (make-bytevector 2))) - (generalized-vector-set! bv 0 256))) + (array-set! bv 256 0))) (pass-if "array-type" (eq? 'vu8 (array-type #vu8()))) diff --git a/test-suite/tests/foreign.test b/test-suite/tests/foreign.test index 7c5ecd62f..204fde7c9 100644 --- a/test-suite/tests/foreign.test +++ b/test-suite/tests/foreign.test @@ -1,6 +1,6 @@ ;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; -;;;; 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 @@ -69,14 +69,19 @@ (pass-if "equal? modulo finalizer" (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))) - (equal? (make-pointer 123) - (make-pointer 123 finalizer)))) + (if (not finalizer) + (throw 'unresolved) ; probably Windows + (equal? (make-pointer 123) + (make-pointer 123 finalizer))))) (pass-if "equal? modulo finalizer (set-pointer-finalizer!)" (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))) (ptr (make-pointer 123))) - (set-pointer-finalizer! ptr finalizer) - (equal? (make-pointer 123) ptr))) + (if (not finalizer) + (throw 'unresolved) ; probably Windows + (begin + (set-pointer-finalizer! ptr finalizer) + (equal? (make-pointer 123) ptr))))) (pass-if "not equal?" (not (equal? (make-pointer 123) (make-pointer 456))))) diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test index bcdfe9110..72aa0c478 100644 --- a/test-suite/tests/hash.test +++ b/test-suite/tests/hash.test @@ -292,3 +292,19 @@ exception:wrong-type-arg (hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar)) ) + + +;;; +;;; hash-count +;;; + +(with-test-prefix "hash-count" + (let ((table (make-hash-table))) + (hashq-set! table 'foo "bar") + (hashq-set! table 'braz "zonk") + (hashq-create-handle! table 'frob #f) + + (pass-if (equal? 3 (hash-count (const #t) table))) + + (pass-if (equal? 2 (hash-count (lambda (k v) + (string? v)) table))))) diff --git a/test-suite/tests/peval.test b/test-suite/tests/peval.test index f3f3b41e3..ecc5dd187 100644 --- a/test-suite/tests/peval.test +++ b/test-suite/tests/peval.test @@ -1,7 +1,7 @@ ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; -;;;; Copyright (C) 2009, 2010, 2011, 2012 Free Software Foundation, Inc. +;;;; Copyright (C) 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 @@ -25,6 +25,7 @@ #:use-module (language tree-il) #:use-module (language tree-il primitives) #:use-module (language glil) + #:use-module (rnrs bytevectors) ;; for the bytevector primitives #:use-module (srfi srfi-13)) (define peval @@ -836,6 +837,153 @@ (call (toplevel top) (lexical x _))))))) (pass-if-peval + ;; The inliner sees through a `let'. + ((let ((a 10)) (lambda (b) (* b 2))) 30) + (const 60)) + + (pass-if-peval + ((lambda () + (define (const x) (lambda (_) x)) + (let ((v #f)) + ((const #t) v)))) + (const #t)) + + (pass-if-peval + ;; Applications of procedures with rest arguments can get inlined. + ((lambda (x y . z) + (list x y z)) + 1 2 3 4) + (let (z) (_) ((primcall list (const 3) (const 4))) + (primcall list (const 1) (const 2) (lexical z _)))) + + (pass-if-peval + ;; Unmutated lists can get inlined. + (let ((args (list 2 3))) + (apply (lambda (x y z w) + (list x y z w)) + 0 1 args)) + (primcall list (const 0) (const 1) (const 2) (const 3))) + + (pass-if-peval + ;; However if the list might have been mutated, it doesn't propagate. + (let ((args (list 2 3))) + (foo! args) + (apply (lambda (x y z w) + (list x y z w)) + 0 1 args)) + (let (args) (_) ((primcall list (const 2) (const 3))) + (seq + (call (toplevel foo!) (lexical args _)) + (primcall @apply + (lambda () + (lambda-case + (((x y z w) #f #f #f () (_ _ _ _)) + (primcall list + (lexical x _) (lexical y _) + (lexical z _) (lexical w _))))) + (const 0) + (const 1) + (lexical args _))))) + + (pass-if-peval + ;; Here the `args' that gets built by the application of the lambda + ;; takes more than effort "10" to visit. Test that we fall back to + ;; the source expression of the operand, which is still a call to + ;; `list', so the inlining still happens. + (lambda (bv offset n) + (let ((x (bytevector-ieee-single-native-ref + bv + (+ offset 0))) + (y (bytevector-ieee-single-native-ref + bv + (+ offset 4)))) + (let ((args (list x y))) + (@apply + (lambda (bv offset x y) + (bytevector-ieee-single-native-set! + bv + (+ offset 0) + x) + (bytevector-ieee-single-native-set! + bv + (+ offset 4) + y)) + bv + offset + args)))) + (lambda () + (lambda-case + (((bv offset n) #f #f #f () (_ _ _)) + (let (x y) (_ _) ((primcall bytevector-ieee-single-native-ref + (lexical bv _) + (primcall + + (lexical offset _) (const 0))) + (primcall bytevector-ieee-single-native-ref + (lexical bv _) + (primcall + + (lexical offset _) (const 4)))) + (seq + (primcall bytevector-ieee-single-native-set! + (lexical bv _) + (primcall + + (lexical offset _) (const 0)) + (lexical x _)) + (primcall bytevector-ieee-single-native-set! + (lexical bv _) + (primcall + + (lexical offset _) (const 4)) + (lexical y _)))))))) + + (pass-if-peval + ;; Here we ensure that non-constant expressions are not copied. + (lambda () + (let ((args (list (foo!)))) + (@apply + (lambda (z x) + (list z x)) + ;; This toplevel ref might raise an unbound variable exception. + ;; The effects of `(foo!)' must be visible before this effect. + z + args))) + (lambda () + (lambda-case + ((() #f #f #f () ()) + (let (_) (_) ((call (toplevel foo!))) + (let (z) (_) ((toplevel z)) + (primcall 'list + (lexical z _) + (lexical _ _)))))))) + + (pass-if-peval + ;; Rest args referenced more than once are not destructured. + (lambda () + (let ((args (list 'foo))) + (set-car! args 'bar) + (@apply + (lambda (z x) + (list z x)) + z + args))) + (lambda () + (lambda-case + ((() #f #f #f () ()) + (let (args) (_) + ((primcall list (const foo))) + (seq + (primcall set-car! (lexical args _) (const bar)) + (primcall @apply + (lambda . _) + (toplevel z) + (lexical args _)))))))) + + (pass-if-peval + ;; Let-values inlining, even with consumers with rest args. + (call-with-values (lambda () (values 1 2)) + (lambda args + (apply list args))) + (primcall list (const 1) (const 2))) + + (pass-if-peval ;; Constant folding: cons of #nil does not make list (cons 1 #nil) (primcall cons (const 1) (const '#nil))) diff --git a/test-suite/tests/srfi-4.test b/test-suite/tests/srfi-4.test index 033e39f47..9b76c7a4c 100644 --- a/test-suite/tests/srfi-4.test +++ b/test-suite/tests/srfi-4.test @@ -1,7 +1,7 @@ ;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*- ;;;; Martin Grabmueller, 2001-06-26 ;;;; -;;;; Copyright (C) 2001, 2006, 2010, 2011 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 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 @@ -438,24 +438,24 @@ (pass-if "+inf.0, -inf.0, +nan.0 in c32vector" (c32vector? #c32(+inf.0 -inf.0 +nan.0))) - (pass-if "generalized-vector-ref" + (pass-if "array-ref" (let ((v (c32vector 1+1i))) (= (c32vector-ref v 0) - (generalized-vector-ref v 0)))) + (array-ref v 0)))) - (pass-if "generalized-vector-set!" + (pass-if "array-set!" (let ((x 1+1i) (v (c32vector 0))) - (generalized-vector-set! v 0 x) - (= x (generalized-vector-ref v 0)))) + (array-set! v x 0) + (= x (array-ref v 0)))) - (pass-if-exception "generalized-vector-ref, out-of-range" + (pass-if-exception "array-ref, out-of-range" exception:out-of-range - (generalized-vector-ref (c32vector 1.0) 1)) + (array-ref (c32vector 1.0) 1)) - (pass-if-exception "generalized-vector-set!, out-of-range" + (pass-if-exception "array-set!, out-of-range" exception:out-of-range - (generalized-vector-set! (c32vector 1.0) 1 2.0))) + (array-set! (c32vector 1.0) 2.0 1))) (with-test-prefix "c64 vectors" @@ -497,24 +497,24 @@ (pass-if "+inf.0, -inf.0, +nan.0 in c64vector" (c64vector? #c64(+inf.0 -inf.0 +nan.0))) - (pass-if "generalized-vector-ref" + (pass-if "array-ref" (let ((v (c64vector 1+1i))) (= (c64vector-ref v 0) - (generalized-vector-ref v 0)))) + (array-ref v 0)))) - (pass-if "generalized-vector-set!" + (pass-if "array-set!" (let ((x 1+1i) (v (c64vector 0))) - (generalized-vector-set! v 0 x) - (= x (generalized-vector-ref v 0)))) + (array-set! v x 0) + (= x (array-ref v 0)))) - (pass-if-exception "generalized-vector-ref, out-of-range" + (pass-if-exception "array-ref, out-of-range" exception:out-of-range - (generalized-vector-ref (c64vector 1.0) 1)) + (array-ref (c64vector 1.0) 1)) - (pass-if-exception "generalized-vector-set!, out-of-range" + (pass-if-exception "array-set!, out-of-range" exception:out-of-range - (generalized-vector-set! (c64vector 1.0) 1 2.0))) + (array-set! (c64vector 1.0) 2.0 1))) (with-test-prefix "accessing uniform vectors of different types" |