summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-02-18 17:59:38 +0100
committerAndy Wingo <wingo@pobox.com>2013-02-18 17:59:38 +0100
commit9b977c836bf147d386944c401113aba32776fa68 (patch)
treed097e1a2376e26bc6b03447445ae239d5514a7a8
parent180ac9d7b0bac97bdead2813a1b0b23d19002c3e (diff)
parent739941679c2c7dc36c29c30aff7d4c1b436ba773 (diff)
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
-rw-r--r--doc/ref/api-compound.texi137
-rw-r--r--doc/ref/api-data.texi28
-rw-r--r--doc/ref/api-foreign.texi6
-rw-r--r--doc/ref/srfi-modules.texi6
-rw-r--r--libguile/array-handle.c44
-rw-r--r--libguile/array-handle.h36
-rw-r--r--libguile/deprecated.c84
-rw-r--r--libguile/foreign.c24
-rw-r--r--libguile/gen-scmconfig.c19
-rw-r--r--libguile/generalized-arrays.c143
-rw-r--r--libguile/generalized-arrays.h11
-rw-r--r--libguile/generalized-vectors.c68
-rw-r--r--libguile/generalized-vectors.h8
-rw-r--r--libguile/hashtab.c28
-rw-r--r--libguile/hashtab.h1
-rw-r--r--libguile/inline.c3
-rw-r--r--libguile/inline.h25
-rw-r--r--libguile/numbers.h15
-rw-r--r--libguile/posix.c4
-rw-r--r--libguile/uniform.c4
-rwxr-xr-xmeta/guild.in10
-rw-r--r--module/ice-9/boot-9.scm12
-rw-r--r--module/language/tree-il/peval.scm232
-rw-r--r--module/srfi/srfi-4/gnu.scm8
-rw-r--r--module/system/foreign.scm4
-rw-r--r--module/texinfo.scm3
-rw-r--r--module/texinfo/docbook.scm2
-rw-r--r--module/texinfo/plain-text.scm3
-rw-r--r--module/texinfo/serialize.scm5
-rw-r--r--test-suite/tests/arrays.test26
-rw-r--r--test-suite/tests/bitvectors.test3
-rw-r--r--test-suite/tests/bytevectors.test36
-rw-r--r--test-suite/tests/foreign.test15
-rw-r--r--test-suite/tests/hash.test16
-rw-r--r--test-suite/tests/peval.test150
-rw-r--r--test-suite/tests/srfi-4.test38
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"