mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 20:00:19 +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 -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2005, 2006, @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. @c See the file guile.texi for copying conditions.
@node Compound Data Types @node Compound Data Types
@ -22,7 +22,6 @@ values can be looked up within them.
* Lists:: Special list functions supported by Guile. * Lists:: Special list functions supported by Guile.
* Vectors:: One-dimensional arrays of Scheme objects. * Vectors:: One-dimensional arrays of Scheme objects.
* Bit Vectors:: Vectors of bits. * Bit Vectors:: Vectors of bits.
* Generalized Vectors:: Treating all vector-like things uniformly.
* Arrays:: Matrices, etc. * Arrays:: Matrices, etc.
* VLists:: Vector-like lists. * VLists:: Vector-like lists.
* Record Overview:: Walking through the maze of record APIs. * 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 #*00000000
@end example @end example
Bit vectors are also generalized vectors, @xref{Generalized Bit vectors are the special case of one dimensional bit arrays, and can
Vectors}, and can thus be used with the array procedures, @xref{Arrays}. thus be used with the array procedures, @xref{Arrays}.
Bit vectors are the special case of one dimensional bit arrays.
@deffn {Scheme Procedure} bitvector? obj @deffn {Scheme Procedure} bitvector? obj
@deffnx {C Function} scm_bitvector_p (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. and writing.
@end deftypefn @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 @node Arrays
@subsection Arrays @subsection Arrays
@tpindex 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 number of dimensions. Each cell can be accessed in constant time by
supplying an index for each dimension. supplying an index for each dimension.
In the current implementation, an array uses a generalized vector for In the current implementation, an array uses a vector of some kind for
the actual storage of its elements. Any kind of generalized vector the actual storage of its elements. Any kind of vector will do, so you
will do, so you can have arrays of uniform numeric values, arrays of can have arrays of uniform numeric values, arrays of characters, arrays
characters, arrays of bits, and of course, arrays of arbitrary Scheme of bits, and of course, arrays of arbitrary Scheme values. For example,
values. For example, arrays with an underlying @code{c64vector} might arrays with an underlying @code{c64vector} might be nice for digital
be nice for digital signal processing, while arrays made from a signal processing, while arrays made from a @code{u8vector} might be
@code{u8vector} might be used to hold gray-scale images. used to hold gray-scale images.
The number of dimensions of an array is called its @dfn{rank}. Thus, 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 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 columns and zero rows, which again is different from a vector of
length zero. length zero.
Generalized vectors, such as strings, uniform numeric vectors, The array procedures are all polymorphic, treating strings, uniform
bytevectors, bit vectors and ordinary vectors, are the special case of numeric vectors, bytevectors, bit vectors and ordinary vectors as one
one dimensional arrays. dimensional arrays.
@menu @menu
* Array Syntax:: * Array Syntax::
@ -1462,6 +1392,7 @@ as elements in the list.
@end deffn @end deffn
@deffn {Scheme Procedure} array-type array @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 Return the type of @var{array}. This is the `vectag' used for
printing @var{array} (or @code{#t} for ordinary arrays) and can be 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 used with @code{make-typed-array} to create an array of the same kind
@ -1469,6 +1400,7 @@ as @var{array}.
@end deffn @end deffn
@deffn {Scheme Procedure} array-ref array idx @dots{} @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}. Return the element at @code{(idx @dots{})} in @var{array}.
@example @example
@ -1479,7 +1411,7 @@ Return the element at @code{(idx @dots{})} in @var{array}.
@deffn {Scheme Procedure} array-in-bounds? array idx @dots{} @deffn {Scheme Procedure} array-in-bounds? array idx @dots{}
@deffnx {C Function} scm_array_in_bounds_p (array, idxlist) @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}. @code{array-ref}.
@example @example
@ -1520,6 +1452,13 @@ For example,
@end example @end example
@end deffn @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 @deffn {Scheme Procedure} array-rank array
@deffnx {C Function} scm_array_rank (array) @deffnx {C Function} scm_array_rank (array)
Return the rank of @var{array}. Return the rank of @var{array}.
@ -3796,8 +3735,9 @@ key is not found.
#f #f
@end lisp @end lisp
There is no procedure for calculating the number of key/value-pairs in Interesting results can be computed by using @code{hash-fold} to work
a hash table, but @code{hash-fold} can be used for doing exactly that. through each element. This example will count the total number of
elements:
@lisp @lisp
(hash-fold (lambda (key value seed) (+ 1 seed)) 0 h) (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 3
@end lisp @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 @node Hash Table Reference
@subsubsection 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 example
@end deffn @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 Local Variables:
@c TeX-master: "guile.texi" @c TeX-master: "guile.texi"

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

@ -1,7 +1,7 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @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 Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
@c Free Software Foundation, Inc. @c 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @c See the file guile.texi for copying conditions.
@node Simple Data Types @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} {unsigned long long} scm_to_ulong_long (SCM x)
@deftypefnx {C Function} size_t scm_to_size_t (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} 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_int8 scm_to_int8 (SCM x)
@deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x) @deftypefnx {C Function} scm_t_uint8 scm_to_uint8 (SCM x)
@deftypefnx {C Function} scm_t_int16 scm_to_int16 (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_ulong_long (unsigned long long x)
@deftypefnx {C Function} SCM scm_from_size_t (size_t 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_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_int8 (scm_t_int8 x)
@deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x) @deftypefnx {C Function} SCM scm_from_uint8 (scm_t_uint8 x)
@deftypefnx {C Function} SCM scm_from_int16 (scm_t_int16 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 and Integer Lists:: Converting to/from an integer list.
* Bytevectors as Floats:: Interpreting bytes as real numbers. * Bytevectors as Floats:: Interpreting bytes as real numbers.
* Bytevectors as Strings:: Interpreting bytes as Unicode strings. * 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. * Bytevectors as Uniform Vectors:: Bytevectors and SRFI-4.
@end menu @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. it defaults to big endian.
@end deffn @end deffn
@node Bytevectors as Generalized Vectors @node Bytevectors as Arrays
@subsubsection Accessing Bytevectors with the Generalized Vector API @subsubsection Accessing Bytevectors with the Array API
As an extension to the R6RS, Guile allows bytevectors to be manipulated As an extension to the R6RS, Guile allows bytevectors to be manipulated
with the @dfn{generalized vector} procedures (@pxref{Generalized with the @dfn{array} procedures (@pxref{Arrays}). When using these
Vectors}). This also allows bytevectors to be accessed using the APIs, bytes are accessed one at a time as 8-bit unsigned integers:
generic @dfn{array} procedures (@pxref{Array Procedures}). When using
these APIs, bytes are accessed one at a time as 8-bit unsigned integers:
@example @example
(define bv #vu8(0 1 2 3)) (define bv #vu8(0 1 2 3))
(generalized-vector? bv) (array? bv)
@result{} #t @result{} #t
(generalized-vector-ref bv 2) (array-rank bv)
@result{} 1
(array-ref bv 2)
@result{} 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) (array-ref bv 2)
@result{} 77 @result{} 77

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

@ -489,6 +489,8 @@ platform-dependent size:
@defvrx {Scheme Variable} long @defvrx {Scheme Variable} long
@defvrx {Scheme Variable} unsigned-long @defvrx {Scheme Variable} unsigned-long
@defvrx {Scheme Variable} size_t @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 Values exported by the @code{(system foreign)} module, representing C
numeric types. For example, @code{long} may be @code{equal?} to numeric types. For example, @code{long} may be @code{equal?} to
@code{int64} on a 64-bit platform. @code{int64} on a 64-bit platform.
@ -801,8 +803,8 @@ int64_t a; uint8_t b; @}}:
@end example @end example
As yet, Guile only has convenience routines to support As yet, Guile only has convenience routines to support
conventionally-packed structs. But given the @code{bytevector->foreign} conventionally-packed structs. But given the @code{bytevector->pointer}
and @code{foreign->bytevector} routines, one can create and parse and @code{pointer->bytevector} routines, one can create and parse
tightly packed structs and unions by hand. See the code for tightly packed structs and unions by hand. See the code for
@code{(system foreign)} for details. @code{(system foreign)} for details.

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

@ -1,6 +1,6 @@
@c -*-texinfo-*- @c -*-texinfo-*-
@c This is part of the GNU Guile Reference Manual. @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 Free Software Foundation, Inc.
@c See the file guile.texi for copying conditions. @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. C}), but returns a pointer to the elements of a uniform numeric vector.
@end deftypefn @end deftypefn
Unless you really need to the limited generality of these functions, it is best Unless you really need to the limited generality of these functions, it
to use the type-specific functions, or the generalized vector accessors. is best to use the type-specific functions, or the array accessors.
@node SRFI-4 and Bytevectors @node SRFI-4 and Bytevectors
@subsubsection SRFI-4 - Relation to 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -97,6 +98,47 @@ scm_array_handle_pos (scm_t_array_handle *h, SCM indices)
return pos; 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
scm_array_handle_element_type (scm_t_array_handle *h) 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 #define SCM_ARRAY_HANDLE_H
/* Copyright (C) 1995, 1996, 1997, 1999, 2000, 2001, 2004, 2006, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -25,6 +25,8 @@
#include "libguile/__scm.h" #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 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 (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 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 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 const SCM* scm_array_handle_elements (scm_t_array_handle *h);
SCM_API SCM* scm_array_handle_writable_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); 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. 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -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 void
scm_i_init_deprecated () 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -53,6 +53,8 @@ SCM_SYMBOL (sym_unsigned_short, "unsigned-short");
SCM_SYMBOL (sym_unsigned_int, "unsigned-int"); SCM_SYMBOL (sym_unsigned_int, "unsigned-int");
SCM_SYMBOL (sym_unsigned_long, "unsigned-long"); SCM_SYMBOL (sym_unsigned_long, "unsigned-long");
SCM_SYMBOL (sym_size_t, "size_t"); 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. */ /* that's for pointers, you know. */
SCM_SYMBOL (sym_asterisk, "*"); SCM_SYMBOL (sym_asterisk, "*");
@ -1279,6 +1281,26 @@ scm_init_foreign (void)
scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32) scm_from_uint8 (SCM_FOREIGN_TYPE_UINT32)
#else #else
# error unsupported sizeof (size_t) # 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 #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 ("typedef %s scm_t_uint64;\n", SCM_I_GSC_T_UINT64);
pf ("\n"); 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"); " platform doesn't have ptrdiff_t. */\n");
pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF); pf ("typedef %s scm_t_ptrdiff;\n", SCM_I_GSC_T_PTRDIFF);
if (0 == strcmp ("long", 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -33,6 +33,12 @@
#include "libguile/generalized-arrays.h" #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 int
scm_is_array (SCM obj) scm_is_array (SCM obj)
{ {
@ -107,6 +113,35 @@ SCM_DEFINE (scm_array_rank, "array-rank", 1, 0, 0,
#undef FUNC_NAME #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_DEFINE (scm_array_dimensions, "array-dimensions", 1, 0, 0,
(SCM ra), (SCM ra),
"@code{array-dimensions} is similar to @code{array-shape} but replaces\n" "@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 #undef FUNC_NAME
SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
(SCM v, SCM args), SCM
"Return the element at the @code{(index1, index2)} element in\n" scm_c_array_ref_1 (SCM array, ssize_t idx0)
"array @var{v}.") {
#define FUNC_NAME s_scm_array_ref 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_t_array_handle handle;
SCM res; SCM res;
@ -209,15 +268,34 @@ SCM_DEFINE (scm_array_ref, "array-ref", 1, 0, 1,
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
return res; return res;
} }
#undef FUNC_NAME
SCM_DEFINE (scm_array_set_x, "array-set!", 2, 0, 1, void
(SCM v, SCM obj, SCM args), scm_c_array_set_1_x (SCM array, SCM obj, ssize_t idx0)
"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" scm_t_array_handle handle;
"is unspecified.")
#define FUNC_NAME s_scm_array_set_x 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; 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); scm_array_handle_release (&handle);
return SCM_UNSPECIFIED; 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 #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 static SCM
array_to_list (scm_t_array_handle *h, size_t dim, unsigned long pos) 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 #ifndef SCM_GENERALIZED_ARRAYS_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -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 size_t scm_c_array_rank (SCM ra);
SCM_API SCM scm_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_dimensions (SCM ra);
SCM_API SCM scm_array_type (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_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_ref (SCM v, SCM args);
SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args); SCM_API SCM scm_array_set_x (SCM v, SCM obj, SCM args);
SCM_API SCM scm_array_to_list (SCM v); 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, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -83,16 +83,6 @@ scm_is_generalized_vector (SCM obj)
return ret; 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) \ #define SCM_VALIDATE_VECTOR_WITH_HANDLE(pos, val, handle) \
scm_generalized_vector_get_handle (val, handle) scm_generalized_vector_get_handle (val, handle)
@ -119,15 +109,6 @@ scm_c_generalized_vector_length (SCM v)
return ret; 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
scm_c_generalized_vector_ref (SCM v, size_t idx) 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; 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 void
scm_c_generalized_vector_set_x (SCM v, size_t idx, SCM val) 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_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 void
scm_init_generalized_vectors () scm_init_generalized_vectors ()
{ {

8
libguile/generalized-vectors.h
View file

@ -3,7 +3,7 @@
#ifndef SCM_GENERALIZED_VECTORS_H #ifndef SCM_GENERALIZED_VECTORS_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -30,12 +30,6 @@
/* Generalized vectors */ /* 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 int scm_is_generalized_vector (SCM obj);
SCM_API size_t scm_c_generalized_vector_length (SCM v); SCM_API size_t scm_c_generalized_vector_length (SCM v);
SCM_API SCM scm_c_generalized_vector_ref (SCM v, size_t idx); 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 #undef FUNC_NAME
/* Accessing hash table entries. */ /* Accessing hash table entries. */
@ -966,6 +967,33 @@ SCM_DEFINE (scm_hash_map_to_list, "hash-map->list", 2, 0, 0,
} }
#undef FUNC_NAME #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 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 (SCM proc, SCM hash);
SCM_API SCM scm_hash_for_each_handle (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_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_i_hashtable_print (SCM exp, SCM port, scm_print_state *pstate);
SCM_INTERNAL void scm_init_hashtab (void); 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -23,6 +23,7 @@
#define SCM_IMPLEMENT_INLINES 1 #define SCM_IMPLEMENT_INLINES 1
#define SCM_INLINE_C_IMPLEMENTING_INLINES 1 #define SCM_INLINE_C_IMPLEMENTING_INLINES 1
#include "libguile/inline.h" #include "libguile/inline.h"
#include "libguile/array-handle.h"
#include "libguile/gc.h" #include "libguile/gc.h"
#include "libguile/smob.h" #include "libguile/smob.h"
#include "libguile/pairs.h" #include "libguile/pairs.h"

25
libguile/inline.h
View file

@ -4,7 +4,7 @@
#define SCM_INLINE_H #define SCM_INLINE_H
/* Copyright (C) 2001, 2002, 2003, 2004, 2006, 2008, 2009, 2010, /* 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -37,9 +37,6 @@
#include "libguile/error.h" #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 int scm_is_string (SCM x);
SCM_INLINE SCM scm_cell (scm_t_bits car, scm_t_bits cdr); 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 #if SCM_CAN_INLINE || defined SCM_INLINE_C_IMPLEMENTING_INLINES
/* Either inlining, or being included from inline.c. */ /* 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_INLINE_IMPLEMENTATION int
scm_is_string (SCM x) scm_is_string (SCM x)
{ {

15
libguile/numbers.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_NUMBERS_H #ifndef SCM_NUMBERS_H
#define 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -500,6 +501,18 @@ SCM_API SCM scm_from_mpz (mpz_t rop);
#endif #endif
#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 */ /* conversion functions for double */
SCM_API int scm_is_real (SCM val); 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; GETGROUPS_T *groups;
ngroups = getgroups (0, NULL); ngroups = getgroups (0, NULL);
if (ngroups <= 0) if (ngroups < 0)
SCM_SYSERROR; SCM_SYSERROR;
else if (ngroups == 0)
return scm_c_make_vector (0, SCM_BOOL_F);
size = ngroups * sizeof (GETGROUPS_T); size = ngroups * sizeof (GETGROUPS_T);
groups = scm_malloc (size); 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 * This library is free software; you can redistribute it and/or
* modify it under the terms of the GNU Lesser General Public License * modify it under the terms of the GNU Lesser General Public License
@ -193,7 +193,7 @@ SCM_DEFINE (scm_uniform_vector_to_list, "uniform-vector->list", 1, 0, 0,
{ {
if (!scm_is_uniform_vector (uvec)) if (!scm_is_uniform_vector (uvec))
scm_wrong_type_arg_msg (FUNC_NAME, SCM_ARG1, uvec, "uniform vector"); 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 #undef FUNC_NAME

10
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 ;;;; guild --- running scripts bundled with Guile
;;;; Andy Wingo <wingo@pobox.com> --- April 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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) (define (main args)
(if (defined? 'setlocale) (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* (let* ((options (getopt-long args *option-grammar*
#:stop-at-first-non-option #t)) #:stop-at-first-non-option #t))

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

@ -627,12 +627,10 @@ file with the given name already exists, the effect is unspecified."
datum datum
(syntax->datum clause) (syntax->datum clause)
(syntax->datum whole-expr))) (syntax->datum whole-expr)))
(if (memv datum seen) (when (memv datum seen)
(warn-datum 'duplicate-case-datum)) (warn-datum 'duplicate-case-datum))
(if (or (pair? datum) (when (or (pair? datum) (array? datum))
(array? datum) (warn-datum 'bad-case-datum))
(generalized-vector? datum))
(warn-datum 'bad-case-datum))
(cons datum seen)) (cons datum seen))
seen seen
(map syntax->datum #'(datums ...))))) (map syntax->datum #'(datums ...)))))
@ -966,6 +964,8 @@ information is unavailable."
#'(define-macro macro doc (lambda args body1 body ...))) #'(define-macro macro doc (lambda args body1 body ...)))
((_ (macro . args) body ...) ((_ (macro . args) body ...)
#'(define-macro macro #f (lambda args body ...))) #'(define-macro macro #f (lambda args body ...)))
((_ macro transformer)
#'(define-macro macro #f transformer))
((_ macro doc transformer) ((_ macro doc transformer)
(or (string? (syntax->datum #'doc)) (or (string? (syntax->datum #'doc))
(not (syntax->datum #'doc))) (not (syntax->datum #'doc)))

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

@ -431,6 +431,13 @@ top-level bindings from ENV and return the resulting expression."
new)) new))
vars)) vars))
(define (fresh-temporaries ls)
(map (lambda (elt)
(let ((new (gensym "tmp ")))
(record-new-temporary! 'tmp new 1)
new))
ls))
(define (assigned-lexical? sym) (define (assigned-lexical? sym)
(var-set? (lookup-var sym))) (var-set? (lookup-var sym)))
@ -508,7 +515,7 @@ top-level bindings from ENV and return the resulting expression."
(else (else
(residualize-call)))) (residualize-call))))
(define (inline-values exp src names gensyms body) (define (inline-values src exp nmin nmax consumer)
(let loop ((exp exp)) (let loop ((exp exp))
(match exp (match exp
;; Some expression types are always singly-valued. ;; 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-set>) ; could return zero values in
($ <toplevel-define>) ; the future ($ <toplevel-define>) ; the future
($ <module-set>) ; ($ <module-set>) ;
($ <dynset>)) ; ($ <dynset>) ;
(and (= (length names) 1) ($ <primcall> src (? singly-valued-primitive?)))
(make-let src names gensyms (list exp) body))) (and (<= nmin 1) (or (not nmax) (>= nmax 1))
(($ <primcall> src (? singly-valued-primitive? name)) (make-call src (make-lambda #f '() consumer) (list exp))))
(and (= (length names) 1)
(make-let src names gensyms (list exp) body)))
;; Statically-known number of values. ;; Statically-known number of values.
(($ <primcall> src 'values vals) (($ <primcall> src 'values vals)
(and (= (length names) (length vals)) (and (<= nmin (length vals)) (or (not nmax) (>= nmax (length vals)))
(make-let src names gensyms vals body))) (make-call src (make-lambda #f '() consumer) vals)))
;; Not going to copy code into both branches. ;; Not going to copy code into both branches.
(($ <conditional>) #f) (($ <conditional>) #f)
@ -692,6 +697,49 @@ top-level bindings from ENV and return the resulting expression."
((vhash-assq var env) => cdr) ((vhash-assq var env) => cdr)
(else (error "unbound var" var)))) (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) (define (visit exp ctx)
(loop exp env counter ctx)) (loop exp env counter ctx))
@ -820,6 +868,30 @@ top-level bindings from ENV and return the resulting expression."
(begin (begin
(record-operand-use op) (record-operand-use op)
(make-lexical-set src name (operand-sym op) (for-value exp)))))) (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) (($ <let> src names gensyms vals body)
(define (compute-alias exp) (define (compute-alias exp)
;; It's very common for macros to introduce something like: ;; 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. ;; reconstruct the let-values, pevaling the consumer.
(let ((producer (for-values producer))) (let ((producer (for-values producer)))
(or (match consumer (or (match consumer
(($ <lambda-case> src req #f #f #f () gensyms body #f) (($ <lambda-case> src req opt rest #f inits gensyms body #f)
(cond (let* ((nmin (length req))
((inline-values producer src req gensyms body) (nmax (and (not rest) (+ nmin (if opt (length opt) 0)))))
=> for-tail) (cond
(else #f))) ((inline-values lv-src producer nmin nmax consumer)
=> for-tail)
(else #f))))
(_ #f)) (_ #f))
(make-let-values lv-src producer (for-tail consumer))))) (make-let-values lv-src producer (for-tail consumer)))))
(($ <dynwind> src winder pre body post unwinder) (($ <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)))))) (make-primcall src 'values vals))))))
(($ <primcall> src (or 'apply '@apply) (proc args ... tail)) (($ <primcall> src (or 'apply '@apply) (proc args ... tail))
(match (for-value tail) (let lp ((tail* (find-definition tail 1)) (speculative? #t))
(($ <const> _ (args* ...)) (define (copyable? x)
(let ((args* (map (lambda (x) (make-const #f x)) args*))) ;; Inlining a result from find-definition effectively copies it,
(for-tail (make-call src proc (append args args*))))) ;; relying on the let-pruning to remove its original binding. We
(($ <primcall> _ 'list args*) ;; shouldn't copy non-constant expressions.
(for-tail (make-call src proc (append args args*)))) (or (not speculative?) (constant-expression? x)))
(tail (match tail*
(let ((args (append (map for-value args) (list tail)))) (($ <const> _ (args* ...))
(make-primcall src '@apply (cons (for-value proc) 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) (($ <primcall> src (? constructor-primitive? name) args)
(cond (cond
@ -1219,20 +1308,39 @@ top-level bindings from ENV and return the resulting expression."
(($ <call> src orig-proc orig-args) (($ <call> src orig-proc orig-args)
;; todo: augment the global env with specialized functions ;; todo: augment the global env with specialized functions
(let ((proc (visit orig-proc 'operator))) (let revisit-proc ((proc (visit orig-proc 'operator)))
(match proc (match proc
(($ <primitive-ref> _ name) (($ <primitive-ref> _ name)
(for-tail (make-primcall src name orig-args))) (for-tail (make-primcall src name orig-args)))
(($ <lambda> _ _ (($ <lambda> _ _
($ <lambda-case> _ req opt #f #f inits gensyms body #f)) ($ <lambda-case> _ req opt rest #f inits gensyms body #f))
;; Simple case: no rest, no keyword arguments. ;; Simple case: no keyword arguments.
;; todo: handle the more complex cases ;; todo: handle the more complex cases
(let* ((nargs (length orig-args)) (let* ((nargs (length orig-args))
(nreq (length req)) (nreq (length req))
(nopt (if opt (length opt) 0)) (nopt (if opt (length opt) 0))
(key (source-expression proc))) (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 (cond
((or (< nargs nreq) (> nargs (+ nreq nopt))) ((or (< nargs nreq) (and (not rest) (> nargs (+ nreq nopt))))
;; An error, or effecting arguments. ;; An error, or effecting arguments.
(make-call src (for-call orig-proc) (map for-value orig-args))) (make-call src (for-call orig-proc) (map for-value orig-args)))
((or (and=> (find-counter key counter) counter-recursive?) ((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))))))) (lp (counter-prev counter)))))))
(log 'inline-recurse key) (log 'inline-recurse key)
(loop (make-let src (append req (or opt '())) (loop (inlined-call) env counter ctx))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env counter ctx))
(else (else
;; An integration at the top-level, the first ;; An integration at the top-level, the first
;; recursion of a recursive procedure, or a nested ;; 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 (make-top-counter effort-limit operand-size-limit
abort key)))) abort key))))
(define result (define result
(loop (make-let src (append req (or opt '())) (loop (inlined-call) env new-counter ctx))
gensyms
(append orig-args
(drop inits (- nargs nreq)))
body)
env new-counter ctx))
(if counter (if counter
;; The nested inlining attempt succeeded. ;; The nested inlining attempt succeeded.
@ -1307,6 +1405,31 @@ top-level bindings from ENV and return the resulting expression."
(log 'inline-end result exp) (log 'inline-end result exp)
result))))) 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)))))) (make-call src (for-call orig-proc) (map for-value orig-args))))))
(($ <lambda> src meta body) (($ <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?)))) (($ <primcall> _ 'make-prompt-tag (or () ((? constant-expression?))))
#t) #t)
(_ #f))) (_ #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)) (let ((tag (for-value tag))
(body (for-tail body))) (body (for-tail body)))

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

@ -1,6 +1,6 @@
;;; Extensions to SRFI-4 ;;; 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 ;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public ;; modify it under the terms of the GNU Lesser General Public
@ -101,14 +101,14 @@
`(define (,(symbol-append 'any-> tag 'vector) obj) `(define (,(symbol-append 'any-> tag 'vector) obj)
(cond ((,(symbol-append tag 'vector?) obj) obj) (cond ((,(symbol-append tag 'vector?) obj) obj)
((pair? obj) (,(symbol-append 'list-> tag 'vector) obj)) ((pair? obj) (,(symbol-append 'list-> tag 'vector) obj))
((generalized-vector? obj) ((and (array? obj) (eqv? 1 (array-rank obj)))
(let* ((len (generalized-vector-length obj)) (let* ((len (array-length obj))
(v (,(symbol-append 'make- tag 'vector) len))) (v (,(symbol-append 'make- tag 'vector) len)))
(let lp ((i 0)) (let lp ((i 0))
(if (< i len) (if (< i len)
(begin (begin
(,(symbol-append tag 'vector-set!) (,(symbol-append tag 'vector-set!)
v i (generalized-vector-ref obj i)) v i (array-ref obj i))
(lp (1+ i))) (lp (1+ i)))
v)))) v))))
(else (scm-error 'wrong-type-arg #f "" '() (list obj)))))) (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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -25,7 +25,7 @@
float double float double
short short
unsigned-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 int8 uint8
uint16 int16 uint16 int16
uint32 int32 uint32 int32

3
module/texinfo.scm
View file

@ -1,6 +1,6 @@
;;;; (texinfo) -- parsing of texinfo into SXML ;;;; (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) 2004, 2009 Andy Wingo <wingo at pobox dot com>
;;;; Copyright (C) 2001,2002 Oleg Kiselyov <oleg 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) (sample INLINE-TEXT)
(samp INLINE-TEXT) (samp INLINE-TEXT)
(code INLINE-TEXT) (code INLINE-TEXT)
(math INLINE-TEXT)
(kbd INLINE-TEXT) (kbd INLINE-TEXT)
(key INLINE-TEXT) (key INLINE-TEXT)
(var 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." for more information."
'(para programlisting informalexample indexterm variablelist '(para programlisting informalexample indexterm variablelist
orderedlist refsect1 refsect2 refsect3 refsect4 title example orderedlist refsect1 refsect2 refsect3 refsect4 title example
note itemizedlist)) note itemizedlist informaltable))
(define (inline-command? command) (define (inline-command? command)
(not (memq command *sdocbook-block-commands*))) (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 ;;;; (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> ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -238,6 +238,7 @@
(sample ,code) (sample ,code)
(samp ,code) (samp ,code)
(code ,code) (code ,code)
(math ,passthrough)
(kbd ,code) (kbd ,code)
(key ,key) (key ,key)
(var ,var) (var ,var)

5
module/texinfo/serialize.scm
View file

@ -1,6 +1,6 @@
;;;; (texinfo serialize) -- rendering stexinfo as texinfo ;;;; (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> ;;;; Copyright (C) 2003,2004,2009 Andy Wingo <wingo at pobox dot com>
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -185,7 +185,8 @@
(define (wrap strings) (define (wrap strings)
(fill-string (string-concatenate 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) (define (paragraph exp lp command type formals args accum)
(list* "\n\n" (list* "\n\n"

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

@ -1,6 +1,6 @@
;;;; unif.test --- tests guile's uniform arrays -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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))) (b (make-shared-array a (lambda (i) (list i 1)) 2)))
(array->list b)))) (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! ;;; array-fill!
;;; ;;;
@ -451,7 +431,7 @@
(array-set! a 'y 2)) (array-set! a 'y 2))
(pass-if-exception "end+1" exception:out-of-range (pass-if-exception "end+1" exception:out-of-range
(array-set! a 'y 6)) (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)))) (array-set! a 'y 6 7))))
(with-test-prefix "two dim" (with-test-prefix "two dim"
@ -649,6 +629,4 @@
(pass-if (equal? (array-row array 1) (pass-if (equal? (array-row array 1)
#u32(2 3))) #u32(2 3)))
(pass-if (equal? (array-ref (array-row array 1) 0) (pass-if (equal? (array-ref (array-row array 1) 0)
2))
(pass-if (equal? (generalized-vector-ref (array-row array 1) 0)
2)))) 2))))

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

@ -1,6 +1,6 @@
;;;; bitvectors.test --- tests guile's bitvectors -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -22,7 +22,6 @@
(with-test-prefix "predicates" (with-test-prefix "predicates"
(pass-if (bitvector? #*1010101010)) (pass-if (bitvector? #*1010101010))
(pass-if (generalized-vector? #*1010101010))
(pass-if (uniform-vector? #*1010101010)) (pass-if (uniform-vector? #*1010101010))
(pass-if (array? #*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; -*- ;;;; 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 ;;;; Ludovic Courtès
;;;; ;;;;
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
@ -589,42 +589,42 @@
(with-input-from-string "#vu8(0 256)" read))) (with-input-from-string "#vu8(0 256)" read)))
(with-test-prefix "Generalized Vectors" (with-test-prefix "Arrays"
(pass-if "generalized-vector?" (pass-if "array?"
(generalized-vector? #vu8(1 2 3))) (array? #vu8(1 2 3)))
(pass-if "generalized-vector-length" (pass-if "array-length"
(equal? (iota 16) (equal? (iota 16)
(map generalized-vector-length (map array-length
(map make-bytevector (iota 16))))) (map make-bytevector (iota 16)))))
(pass-if "generalized-vector-ref" (pass-if "array-ref"
(let ((bv #vu8(255 127))) (let ((bv #vu8(255 127)))
(and (= 255 (generalized-vector-ref bv 0)) (and (= 255 (array-ref bv 0))
(= 127 (generalized-vector-ref bv 1))))) (= 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 exception:out-of-range
(let ((bv #vu8(1 2))) (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))) (let ((bv (make-bytevector 2)))
(generalized-vector-set! bv 0 255) (array-set! bv 255 0)
(generalized-vector-set! bv 1 77) (array-set! bv 77 1)
(equal? '(255 77) (equal? '(255 77)
(bytevector->u8-list bv)))) (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 exception:out-of-range
(let ((bv (make-bytevector 2))) (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 exception:out-of-range
(let ((bv (make-bytevector 2))) (let ((bv (make-bytevector 2)))
(generalized-vector-set! bv 0 256))) (array-set! bv 256 0)))
(pass-if "array-type" (pass-if "array-type"
(eq? 'vu8 (array-type #vu8()))) (eq? 'vu8 (array-type #vu8())))

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

@ -1,6 +1,6 @@
;;;; foreign.test --- FFI. -*- mode: scheme; coding: utf-8; -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -69,14 +69,19 @@
(pass-if "equal? modulo finalizer" (pass-if "equal? modulo finalizer"
(let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))) (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))))
(equal? (make-pointer 123) (if (not finalizer)
(make-pointer 123 finalizer)))) (throw 'unresolved) ; probably Windows
(equal? (make-pointer 123)
(make-pointer 123 finalizer)))))
(pass-if "equal? modulo finalizer (set-pointer-finalizer!)" (pass-if "equal? modulo finalizer (set-pointer-finalizer!)"
(let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link))) (let ((finalizer (dynamic-func "scm_is_pair" (dynamic-link)))
(ptr (make-pointer 123))) (ptr (make-pointer 123)))
(set-pointer-finalizer! ptr finalizer) (if (not finalizer)
(equal? (make-pointer 123) ptr))) (throw 'unresolved) ; probably Windows
(begin
(set-pointer-finalizer! ptr finalizer)
(equal? (make-pointer 123) ptr)))))
(pass-if "not equal?" (pass-if "not equal?"
(not (equal? (make-pointer 123) (make-pointer 456))))) (not (equal? (make-pointer 123) (make-pointer 456)))))

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

@ -292,3 +292,19 @@
exception:wrong-type-arg exception:wrong-type-arg
(hashx-set! (lambda (k s) 1) (lambda (k al) #t) (make-hash-table) 'foo 'bar)) (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 -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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)
#:use-module (language tree-il primitives) #:use-module (language tree-il primitives)
#:use-module (language glil) #:use-module (language glil)
#:use-module (rnrs bytevectors) ;; for the bytevector primitives
#:use-module (srfi srfi-13)) #:use-module (srfi srfi-13))
(define peval (define peval
@ -835,6 +836,153 @@
(((x) #f #f #f () (_)) (((x) #f #f #f () (_))
(call (toplevel top) (lexical x _))))))) (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 (pass-if-peval
;; Constant folding: cons of #nil does not make list ;; Constant folding: cons of #nil does not make list
(cons 1 #nil) (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 -*- ;;;; srfi-4.test --- Test suite for Guile's SRFI-4 functions. -*- scheme -*-
;;;; Martin Grabmueller, 2001-06-26 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; 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" (pass-if "+inf.0, -inf.0, +nan.0 in c32vector"
(c32vector? #c32(+inf.0 -inf.0 +nan.0))) (c32vector? #c32(+inf.0 -inf.0 +nan.0)))
(pass-if "generalized-vector-ref" (pass-if "array-ref"
(let ((v (c32vector 1+1i))) (let ((v (c32vector 1+1i)))
(= (c32vector-ref v 0) (= (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) (let ((x 1+1i)
(v (c32vector 0))) (v (c32vector 0)))
(generalized-vector-set! v 0 x) (array-set! v x 0)
(= x (generalized-vector-ref v 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 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 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" (with-test-prefix "c64 vectors"
@ -497,24 +497,24 @@
(pass-if "+inf.0, -inf.0, +nan.0 in c64vector" (pass-if "+inf.0, -inf.0, +nan.0 in c64vector"
(c64vector? #c64(+inf.0 -inf.0 +nan.0))) (c64vector? #c64(+inf.0 -inf.0 +nan.0)))
(pass-if "generalized-vector-ref" (pass-if "array-ref"
(let ((v (c64vector 1+1i))) (let ((v (c64vector 1+1i)))
(= (c64vector-ref v 0) (= (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) (let ((x 1+1i)
(v (c64vector 0))) (v (c64vector 0)))
(generalized-vector-set! v 0 x) (array-set! v x 0)
(= x (generalized-vector-ref v 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 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 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" (with-test-prefix "accessing uniform vectors of different types"