mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

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

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

137
doc/ref/api-compound.texi
View file

@ -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"

28
doc/ref/api-data.texi
View file

@ -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

6
doc/ref/api-foreign.texi
View file

@ -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.

6
doc/ref/srfi-modules.texi
View file

@ -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

44
libguile/array-handle.c
View file

@ -1,4 +1,5 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005,
* 2006, 2009, 2011, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -97,6 +98,47 @@ scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
return pos;
}
static void
check_array_index_bounds (scm_t_array_dim *dim, ssize_t idx)
{
if (idx < dim->lbnd || idx > dim->ubnd)
scm_error (scm_out_of_range_key, NULL, "Value out of range ~S to ~S: ~S",
scm_list_3 (scm_from_ssize_t (dim->lbnd),
scm_from_ssize_t (dim->ubnd),
scm_from_ssize_t (idx)),
scm_list_1 (scm_from_ssize_t (idx)));
}
ssize_t
scm_array_handle_pos_1 (scm_t_array_handle *h, ssize_t idx0)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
if (scm_array_handle_rank (h) != 1)
scm_misc_error (NULL, "wrong number of indices, expecting ~A",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
check_array_index_bounds (&dim[0], idx0);
return (idx0 - dim[0].lbnd) * dim[0].inc;
}
ssize_t
scm_array_handle_pos_2 (scm_t_array_handle *h, ssize_t idx0, ssize_t idx1)
{
scm_t_array_dim *dim = scm_array_handle_dims (h);
if (scm_array_handle_rank (h) != 2)
scm_misc_error (NULL, "wrong number of indices, expecting ~A",
scm_list_1 (scm_from_size_t (scm_array_handle_rank (h))));
check_array_index_bounds (&dim[0], idx0);
check_array_index_bounds (&dim[1], idx1);
return ((idx0 - dim[0].lbnd) * dim[0].inc
+ (idx1 - dim[1].lbnd) * dim[1].inc);
}
SCM
scm_array_handle_element_type (scm_t_array_handle *h)
{

36
libguile/array-handle.h
View file

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

84
libguile/deprecated.c
View file

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

24
libguile/foreign.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2010, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -53,6 +53,8 @@ SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t");
SCM_SYMBOL (sym_ssize_t, "ssize_t");
SCM_SYMBOL (sym_ptrdiff_t, "ptrdiff_t");
/* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*");
@ -1279,6 +1281,26 @@ scm_init_foreign (void)
scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else
# error unsupported sizeof (size_t)
#endif
);
scm_define (sym_ssize_t,
#if SIZEOF_SIZE_T == 8
scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SIZEOF_SIZE_T == 4
scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (ssize_t)
#endif
);
scm_define (sym_ptrdiff_t,
#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
scm_from_uint8 (SCM_FOREIGN_TYPE_INT64)
#elif SCM_SIZEOF_SCM_T_PTRDIFF == 4
scm_from_uint8 (SCM_FOREIGN_TYPE_INT32)
#else
# error unsupported sizeof (scm_t_ptrdiff)
#endif
);

19
libguile/gen-scmconfig.c
View file

@ -1,3 +1,20 @@
/* Copyright (C) 2003-2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
* as published by the Free Software Foundation; either version 3 of
* the License, or (at your option) any later version.
*
* This library is distributed in the hope that it will be useful, but
* WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
* Lesser General Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public
* License along with this library; if not, write to the Free Software
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
* 02110-1301 USA
*/
/**********************************************************************
@ -268,7 +285,7 @@ main (int argc, char *argv[])
pf ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
pf ("\n");
pf ("/* scm_t_ptrdiff_t and size, always defined -- defined to long if\n"
pf ("/* scm_t_ptrdiff and size, always defined -- defined to long if\n"
" platform doesn't have ptrdiff_t. */\n");
pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
if (0 == strcmp ("long", SCM_I_GSC_T_PTRDIFF))

143
libguile/generalized-arrays.c
View file

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

11
libguile/generalized-arrays.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_ARRAYS_H
#define SCM_GENERALIZED_ARRAYS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -44,10 +44,19 @@ SCM_API SCM scm_typed_array_p (SCM v, SCM type);
SCM_API size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_array_rank (SCM ra);
SCM_API size_t scm_c_array_length (SCM ra);
SCM_API SCM scm_array_length (SCM ra);
SCM_API SCM scm_array_dimensions (SCM ra);
SCM_API SCM scm_array_type (SCM ra);
SCM_API SCM scm_array_in_bounds_p (SCM v, SCM args);
SCM_API SCM scm_c_array_ref_1 (SCM v, ssize_t idx0);
SCM_API SCM scm_c_array_ref_2 (SCM v, ssize_t idx0, ssize_t idx1);
SCM_API void scm_c_array_set_1_x (SCM v, SCM obj, ssize_t idx0);
SCM_API void scm_c_array_set_2_x (SCM v, SCM obj, ssize_t idx0, ssize_t idx1);
SCM_API SCM scm_array_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v);

68
libguile/generalized-vectors.c
View file

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

8
libguile/generalized-vectors.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_VECTORS_H
#define SCM_GENERALIZED_VECTORS_H
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1999,2000,2001, 2004, 2006, 2008, 2009, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -30,12 +30,6 @@
/* Generalized vectors */
SCM_API SCM scm_generalized_vector_p (SCM v);
SCM_API SCM scm_generalized_vector_length (SCM v);
SCM_API SCM scm_generalized_vector_ref (SCM v, SCM idx);
SCM_API SCM scm_generalized_vector_set_x (SCM v, SCM idx, SCM val);
SCM_API SCM scm_generalized_vector_to_list (SCM v);
SCM_API int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v);
SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx);

28
libguile/hashtab.c
View file

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

1
libguile/hashtab.h
View file

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

3
libguile/inline.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 2001, 2006, 2008, 2011, 2012 Free Software Foundation, Inc.
/* Copyright (C) 2001, 2006, 2008, 2011, 2012, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -23,6 +23,7 @@
#define SCM_IMPLEMENT_INLINES 1
#define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h"
#include "libguile/array-handle.h"
#include "libguile/gc.h"
#include "libguile/smob.h"
#include "libguile/pairs.h"

25
libguile/inline.h
View file

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

15
libguile/numbers.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_NUMBERS_H
#define SCM_NUMBERS_H
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006, 2008, 2009, 2010, 2011 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1998,2000,2001,2002,2003,2004,2005, 2006,
* 2008, 2009, 2010, 2011, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -500,6 +501,18 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif
#endif
#if SCM_SIZEOF_SCM_T_PTRDIFF == 4
#define scm_to_ptrdiff_t scm_to_int32
#define scm_from_ptrdiff_t scm_from_int32
#else
#if SCM_SIZEOF_SCM_T_PTRDIFF == 8
#define scm_to_ptrdiff_t scm_to_int64
#define scm_from_ptrdiff_t scm_from_int64
#else
#error sizeof(scm_t_ptrdiff) is not 4 or 8.
#endif
#endif
/* conversion functions for double */
SCM_API int scm_is_real (SCM val);

4
libguile/posix.c
View file

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

4
libguile/uniform.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010 Free Software Foundation, Inc.
/* Copyright (C) 1995,1996,1997,1998,2000,2001,2002,2003,2004, 2005, 2006, 2009, 2010, 2013 Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License
@ -193,7 +193,7 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
{
if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector");
return scm_generalized_vector_to_list (uvec);
return scm_array_to_list (uvec);
}
#undef FUNC_NAME

8
meta/guild.in
View file

@ -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)
(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))

8
module/ice-9/boot-9.scm
View file

@ -627,11 +627,9 @@ file with the given name already exists, the effect is unspecified."
datum
(syntax->datum clause)
(syntax->datum whole-expr)))
(if (memv datum seen)
(when (memv datum seen)
(warn-datum 'duplicate-case-datum))
(if (or (pair? datum)
(array? datum)
(generalized-vector? datum))
(when (or (pair? datum) (array? datum))
(warn-datum 'bad-case-datum))
(cons datum seen))
seen
@ -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)))

222
module/language/tree-il/peval.scm
View file

@ -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)
(($ <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 producer src req gensyms body)
((inline-values lv-src producer nmin nmax consumer)
=> for-tail)
(else #f)))
(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)
(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 (lambda (x) (make-const #f x)) args*)))
(let ((args* (map (cut make-const #f <>) args*)))
(for-tail (make-call src proc (append args args*)))))
(($ <primcall> _ 'list 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
(let ((args (append (map for-value args) (list tail))))
(make-primcall src '@apply (cons (for-value proc) 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)))

8
module/srfi/srfi-4/gnu.scm
View file

@ -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))))))

4
module/system/foreign.scm
View file

@ -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

3
module/texinfo.scm
View file

@ -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)

2
module/texinfo/docbook.scm
View file

@ -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*)))

3
module/texinfo/plain-text.scm
View file

@ -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)

5
module/texinfo/serialize.scm
View file

@ -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"

26
test-suite/tests/arrays.test
View file

@ -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
@ -227,26 +227,6 @@
(b (make-shared-array a (lambda (i) (list i 1)) 2)))
(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))))

3
test-suite/tests/bitvectors.test
View file

@ -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)))

36
test-suite/tests/bytevectors.test
View file

@ -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())))

11
test-suite/tests/foreign.test
View file

@ -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))))
(if (not finalizer)
(throw 'unresolved) ; probably Windows
(equal? (make-pointer 123)
(make-pointer 123 finalizer))))
(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)))
(if (not finalizer)
(throw 'unresolved) ; probably Windows
(begin
(set-pointer-finalizer! ptr finalizer)
(equal? (make-pointer 123) ptr)))
(equal? (make-pointer 123) ptr)))))
(pass-if "not equal?"
(not (equal? (make-pointer 123) (make-pointer 456)))))

16
test-suite/tests/hash.test
View file

@ -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)))))

150
test-suite/tests/peval.test
View file

@ -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
@ -835,6 +836,153 @@
(((x) #f #f #f () (_))
(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)

38
test-suite/tests/srfi-4.test
View file

@ -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"