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

Merge until e0bcda4ad9 from stable-2.2

Browse source
This commit is contained in:
Andy Wingo 2017-11-29 21:04:59 +01:00
commit f85d3c0bd8
21 changed files with 507 additions and 312 deletions
Download patch file Download diff file Expand all files Collapse all files

7
NEWS
View file

@ -940,6 +940,13 @@ All code deprecated in Guile 2.0 has been removed. See older NEWS, and
check that your programs can compile without linker warnings and run check that your programs can compile without linker warnings and run
without runtime warnings. See "Deprecation" in the manual. without runtime warnings. See "Deprecation" in the manual.
In particular, the following functions, which were deprecated in 2.0.10
but not specifically mentioned earlier in this file, have been removed:
*** `uniform-vector-read!' and `uniform-vector-write' have been
removed. Use `get-bytevector-n!' and `put-bytevector' from (rnrs io
ports) instead.
** Remove miscellaneous unused interfaces ** Remove miscellaneous unused interfaces
We have removed accidentally public, undocumented interfaces that we We have removed accidentally public, undocumented interfaces that we

2
benchmark-suite/Makefile.am
View file

@ -1,5 +1,6 @@
SCM_BENCHMARKS = benchmarks/0-reference.bm \ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/arithmetic.bm \ benchmarks/arithmetic.bm \
benchmarks/bytevector-io.bm \
benchmarks/bytevectors.bm \ benchmarks/bytevectors.bm \
benchmarks/chars.bm \ benchmarks/chars.bm \
benchmarks/continuations.bm \ benchmarks/continuations.bm \
@ -13,7 +14,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \
benchmarks/srfi-13.bm \ benchmarks/srfi-13.bm \
benchmarks/structs.bm \ benchmarks/structs.bm \
benchmarks/subr.bm \ benchmarks/subr.bm \
benchmarks/uniform-vector-read.bm \
benchmarks/vectors.bm \ benchmarks/vectors.bm \
benchmarks/vlists.bm \ benchmarks/vlists.bm \
benchmarks/write.bm \ benchmarks/write.bm \

29
benchmark-suite/benchmarks/uniform-vector-read.bm → benchmark-suite/benchmarks/bytevector-io.bm
View file

@ -1,6 +1,6 @@
;;; uniform-vector-read.bm --- Exercise binary I/O primitives. -*- Scheme -*- ;;; bytevector-io.bm --- Exercise bytevector I/O primitives. -*- Scheme -*-
;;; ;;;
;;; Copyright (C) 2008 Free Software Foundation, Inc. ;;; Copyright (C) 2008, 2017 Free Software Foundation, Inc.
;;; ;;;
;;; This program is free software; you can redistribute it and/or ;;; This program 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
@ -17,9 +17,10 @@
;;; not, write to the Free Software Foundation, Inc., 51 Franklin ;;; not, write to the Free Software Foundation, Inc., 51 Franklin
;;; Street, Fifth Floor, Boston, MA 02110-1301 USA ;;; Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (benchmarks uniform-vector-read) (define-module (benchmarks bytevector-io)
:use-module (benchmark-suite lib) :use-module (benchmark-suite lib)
:use-module (srfi srfi-4)) :use-module (rnrs io ports)
:use-module (rnrs bytevectors))
(define file-name (define file-name
(tmpnam)) (tmpnam))
@ -30,24 +31,22 @@
(define buf (define buf
(make-u8vector %buffer-size)) (make-u8vector %buffer-size))
(define str
(make-string %buffer-size))
(with-benchmark-prefix "uniform-vector-read!" (with-benchmark-prefix "bytevector i/o"
(benchmark "uniform-vector-write" 4000 (benchmark "put-bytevector" 4000
(let ((output (open-output-file file-name))) (let ((output (open-output-file file-name)))
(uniform-vector-write buf output) (put-bytevector output buf)
(close output))) (close output)))
(benchmark "uniform-vector-read!" 20000 (benchmark "get-bytevector-n!" 20000
(let ((input (open-input-file file-name))) (let ((input (open-input-file file-name)))
(setvbuf input 'none) (setvbuf input 'none)
(uniform-vector-read! buf input) (get-bytevector-n! input buf 0 (bytevector-length buf))
(close input))) (close input)))
(benchmark "string port" 5000 (benchmark "get-bytevector-n" 20000
(let ((input (open-input-string str))) (let ((input (open-input-file file-name)))
(uniform-vector-read! buf input) (setvbuf input 'none)
(get-bytevector-n input (bytevector-length buf))
(close input)))) (close input))))

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

@ -7498,10 +7498,6 @@ same type, and have corresponding elements which are either
@code{equal?} (@pxref{Equality}) in that all arguments must be arrays. @code{equal?} (@pxref{Equality}) in that all arguments must be arrays.
@end deffn @end deffn
@c FIXME: array-map! accepts no source arrays at all, and in that
@c case makes calls "(proc)". Is that meant to be a documented
@c feature?
@c
@c FIXME: array-for-each doesn't say what happens if the sources have @c FIXME: array-for-each doesn't say what happens if the sources have
@c different index ranges. The code currently iterates over the @c different index ranges. The code currently iterates over the
@c indices of the first and expects the others to cover those. That @c indices of the first and expects the others to cover those. That
@ -7509,14 +7505,15 @@ same type, and have corresponding elements which are either
@c documented feature? @c documented feature?
@deffn {Scheme Procedure} array-map! dst proc src @dots{} @deffn {Scheme Procedure} array-map! dst proc src @dots{}
@deffnx {Scheme Procedure} array-map-in-order! dst proc src1 @dots{} srcN @deffnx {Scheme Procedure} array-map-in-order! dst proc src @dots{}
@deffnx {C Function} scm_array_map_x (dst, proc, srclist) @deffnx {C Function} scm_array_map_x (dst, proc, srclist)
Set each element of the @var{dst} array to values obtained from calls Set each element of the @var{dst} array to values obtained from calls to
to @var{proc}. The value returned is unspecified. @var{proc}. The list of @var{src} arguments may be empty. The value
returned is unspecified.
Each call is @code{(@var{proc} @var{elem1} @dots{} @var{elemN})}, Each call is @code{(@var{proc} @var{elem} @dots{})}, where each
where each @var{elem} is from the corresponding @var{src} array, at @var{elem} is from the corresponding @var{src} array, at the
the @var{dst} index. @code{array-map-in-order!} makes the calls in @var{dst} index. @code{array-map-in-order!} makes the calls in
row-major order, @code{array-map!} makes them in an unspecified order. row-major order, @code{array-map!} makes them in an unspecified order.
The @var{src} arrays must have the same number of dimensions as The @var{src} arrays must have the same number of dimensions as
@ -7568,37 +7565,19 @@ $\left(\matrix{%
@end example @end example
@end deffn @end deffn
@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]] An additional array function is available in the module
@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end) @code{(ice-9 arrays)}. It can be used with:
Attempt to read all elements of array @var{ra}, in lexicographic order, as
binary objects from @var{port_or_fd}.
If an end of file is encountered,
the objects up to that point are put into @var{ra}
(starting at the beginning) and the remainder of the array is
unchanged.
The optional arguments @var{start} and @var{end} allow @example
a specified region of a vector (or linearized array) to be read, (use-modules (ice-9 arrays))
leaving the remainder of the vector unchanged. @end example
@code{uniform-array-read!} returns the number of objects read. @deffn {Scheme Procedure} array-copy src
@var{port_or_fd} may be omitted, in which case it defaults to the value Return a new array with the same elements, type and shape as
returned by @code{(current-input-port)}. @var{src}. However, the array increments may not be the same as those of
@end deffn @var{src}. In the current implementation, the returned array will be in
row-major order, but that might change in the future. Use
@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]] @code{array-copy!} on an array of known order if that is a concern.
@deffnx {C Function} scm_uniform_array_write (ra, port_or_fd, start, end)
Writes all elements of @var{ra} as binary objects to
@var{port_or_fd}.
The optional arguments @var{start}
and @var{end} allow
a specified region of a vector (or linearized array) to be written.
The number of objects actually written is returned.
@var{port_or_fd} may be
omitted, in which case it defaults to the value returned by
@code{(current-output-port)}.
@end deffn @end deffn
@node Shared Arrays @node Shared Arrays

6
libguile/array-handle.c
View file

@ -149,8 +149,10 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len,
h->dim0.ubnd = (ssize_t) (len - 1U); h->dim0.ubnd = (ssize_t) (len - 1U);
h->dim0.inc = 1; h->dim0.inc = 1;
h->element_type = element_type; h->element_type = element_type;
h->elements = elements; /* elements != writable_elements is used to check mutability later on.
h->writable_elements = mutable_p ? ((void *) elements) : NULL; Ignore it if the array is empty. */
h->elements = len==0 ? NULL : elements;
h->writable_elements = mutable_p ? ((void *) h->elements) : NULL;
h->vector = h->array; h->vector = h->array;
h->vref = vref; h->vref = vref;
h->vset = vset; h->vset = vset;

24
libguile/array-map.c
View file

@ -263,7 +263,7 @@ racp (SCM src, SCM dst)
{ {
SCM const * el_s = h_s.elements; SCM const * el_s = h_s.elements;
SCM * el_d = h_d.writable_elements; SCM * el_d = h_d.writable_elements;
if (!el_d) if (!el_d && n>0)
scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array"); scm_wrong_type_arg_msg ("array-copy!", SCM_ARG2, dst, "mutable array");
for (; n-- > 0; i_s += inc_s, i_d += inc_d) for (; n-- > 0; i_s += inc_s, i_d += inc_d)
el_d[i_d] = el_s[i_s]; el_d[i_d] = el_s[i_s];
@ -679,6 +679,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
"@end lisp") "@end lisp")
#define FUNC_NAME s_scm_array_slice_for_each #define FUNC_NAME s_scm_array_slice_for_each
{ {
SCM xargs = args;
int const N = scm_ilength (args); int const N = scm_ilength (args);
int const frank = scm_to_int (frame_rank); int const frank = scm_to_int (frame_rank);
int ocd; int ocd;
@ -742,9 +743,9 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
assert((pool0+pool_size==pool) && "internal error"); assert((pool0+pool_size==pool) && "internal error");
#undef AFIC_ALLOC_ADVANCE #undef AFIC_ALLOC_ADVANCE
for (n=0; scm_is_pair(args); args=scm_cdr(args), ++n) for (n=0, xargs=args; scm_is_pair(xargs); xargs=scm_cdr(xargs), ++n)
{ {
args_[n] = scm_car(args); args_[n] = scm_car(xargs);
scm_array_get_handle(args_[n], ah+n); scm_array_get_handle(args_[n], ah+n);
as[n] = scm_array_handle_dims(ah+n); as[n] = scm_array_handle_dims(ah+n);
rank[n] = scm_array_handle_rank(ah+n); rank[n] = scm_array_handle_rank(ah+n);
@ -752,29 +753,24 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
/* checks */ /* checks */
msg = NULL; msg = NULL;
if (frank<0) if (frank<0)
msg = "bad frame rank"; msg = "bad frame rank ~S, ~S";
else else
{ {
for (n=0; n!=N; ++n) for (n=0; n!=N; ++n)
{ {
if (rank[n]<frank) if (rank[n]<frank)
{ {
msg = "frame too large for arguments"; msg = "frame too large for arguments: ~S, ~S";
goto check_msg; goto check_msg;
} }
for (k=0; k!=frank; ++k) for (k=0; k!=frank; ++k)
{ {
if (as[n][k].lbnd!=0) if (as[0][k].lbnd!=as[n][k].lbnd || as[0][k].ubnd!=as[n][k].ubnd)
{ {
msg = "non-zero base index is not supported"; msg = "mismatched frames: ~S, ~S";
goto check_msg; goto check_msg;
} }
if (as[0][k].ubnd!=as[n][k].ubnd) s[k] = as[n][k].ubnd - as[n][k].lbnd + 1;
{
msg = "mismatched frames";
goto check_msg;
}
s[k] = as[n][k].ubnd + 1;
/* this check is needed if the array cannot be entirely */ /* this check is needed if the array cannot be entirely */
/* unrolled, because the unrolled subloop will be run before */ /* unrolled, because the unrolled subloop will be run before */
@ -789,7 +785,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1,
{ {
for (n=0; n!=N; ++n) for (n=0; n!=N; ++n)
scm_array_handle_release(ah+n); scm_array_handle_release(ah+n);
scm_misc_error("array-slice-for-each", msg, scm_cons_star(frame_rank, args)); scm_misc_error("array-slice-for-each", msg, scm_cons(frame_rank, args));
} }
/* prepare moving cells. */ /* prepare moving cells. */
for (n=0; n!=N; ++n) for (n=0; n!=N; ++n)

48
libguile/arrays.c
View file

@ -908,50 +908,17 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos,
return 1; return 1;
} }
/* Print an array.
*/
int int
scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
{ {
scm_t_array_handle h; scm_t_array_handle h;
size_t i; int d;
int print_lbnds = 0, zero_size = 0, print_lens = 0;
scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"),
array, port);
scm_array_get_handle (array, &h); scm_array_get_handle (array, &h);
scm_putc ('#', port);
if (SCM_I_ARRAYP (array))
scm_intprint (h.ndims, 10, port);
if (h.element_type != SCM_ARRAY_ELEMENT_TYPE_SCM)
scm_write (scm_array_handle_element_type (&h), port);
for (i = 0; i < h.ndims; i++)
{
if (h.dims[i].lbnd != 0)
print_lbnds = 1;
if (h.dims[i].ubnd - h.dims[i].lbnd + 1 == 0)
zero_size = 1;
else if (zero_size)
print_lens = 1;
}
if (print_lbnds || print_lens)
for (i = 0; i < h.ndims; i++)
{
if (print_lbnds)
{
scm_putc ('@', port);
scm_intprint (h.dims[i].lbnd, 10, port);
}
if (print_lens)
{
scm_putc (':', port);
scm_intprint (h.dims[i].ubnd - h.dims[i].lbnd + 1,
10, port);
}
}
if (h.ndims == 0) if (h.ndims == 0)
{ {
/* Rank zero arrays, which are really just scalars, are printed /* Rank zero arrays, which are really just scalars, are printed
@ -977,10 +944,13 @@ scm_i_print_array (SCM array, SCM port, scm_print_state *pstate)
scm_putc ('(', port); scm_putc ('(', port);
scm_i_print_array_dimension (&h, 0, 0, port, pstate); scm_i_print_array_dimension (&h, 0, 0, port, pstate);
scm_putc (')', port); scm_putc (')', port);
return 1; d = 1;
} }
else else
return scm_i_print_array_dimension (&h, 0, 0, port, pstate); d = scm_i_print_array_dimension (&h, 0, 0, port, pstate);
scm_array_handle_release (&h);
return d;
} }
void void

41
libguile/fports.c
View file

@ -1,6 +1,6 @@
/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
* 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, * 2004, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013,
* 2014, 2015 Free Software Foundation, Inc. * 2014, 2015, 2017 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
@ -467,8 +467,6 @@ fport_input_waiting (SCM port)
#define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed) #define SCM_REVEALED(x) (SCM_FSTREAM(x)->revealed)
static SCM revealed_ports = SCM_EOL;
static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
/* Find a port in the table and return its revealed count. /* Find a port in the table and return its revealed count.
Also used by the garbage collector. Also used by the garbage collector.
@ -476,13 +474,7 @@ static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER;
int int
scm_revealed_count (SCM port) scm_revealed_count (SCM port)
{ {
int ret; return SCM_REVEALED (port);
scm_i_pthread_mutex_lock (&revealed_lock);
ret = SCM_REVEALED (port);
scm_i_pthread_mutex_unlock (&revealed_lock);
return ret;
} }
SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0, SCM_DEFINE (scm_port_revealed, "port-revealed", 1, 0, 0,
@ -503,25 +495,14 @@ SCM_DEFINE (scm_set_port_revealed_x, "set-port-revealed!", 2, 0, 0,
"The return value is unspecified.") "The return value is unspecified.")
#define FUNC_NAME s_scm_set_port_revealed_x #define FUNC_NAME s_scm_set_port_revealed_x
{ {
int r, prev; int r;
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
r = scm_to_int (rcount); r = scm_to_int (rcount);
scm_i_pthread_mutex_lock (&revealed_lock);
prev = SCM_REVEALED (port);
SCM_REVEALED (port) = r; SCM_REVEALED (port) = r;
if (r && !prev)
revealed_ports = scm_cons (port, revealed_ports);
else if (prev && !r)
revealed_ports = scm_delq_x (port, revealed_ports);
scm_i_pthread_mutex_unlock (&revealed_lock);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
#undef FUNC_NAME #undef FUNC_NAME
@ -539,18 +520,7 @@ SCM_DEFINE (scm_adjust_port_revealed_x, "adjust-port-revealed!", 2, 0, 0,
SCM_VALIDATE_OPFPORT (1, port); SCM_VALIDATE_OPFPORT (1, port);
a = scm_to_int (addend); a = scm_to_int (addend);
if (!a)
return SCM_UNSPECIFIED;
scm_i_pthread_mutex_lock (&revealed_lock);
SCM_REVEALED (port) += a; SCM_REVEALED (port) += a;
if (SCM_REVEALED (port) == a)
revealed_ports = scm_cons (port, revealed_ports);
else if (!SCM_REVEALED (port))
revealed_ports = scm_delq_x (port, revealed_ports);
scm_i_pthread_mutex_unlock (&revealed_lock);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
@ -668,6 +638,11 @@ fport_close (SCM port)
{ {
scm_t_fport *fp = SCM_FSTREAM (port); scm_t_fport *fp = SCM_FSTREAM (port);
if (SCM_REVEALED (port) > 0)
/* The port has a non-zero revealed count, so don't close the
underlying file descriptor. */
return;
scm_run_fdes_finalizers (fp->fdes); scm_run_fdes_finalizers (fp->fdes);
if (close (fp->fdes) != 0) if (close (fp->fdes) != 0)
/* It's not useful to retry after EINTR, as the file descriptor is /* It's not useful to retry after EINTR, as the file descriptor is

8
libguile/fports.h
View file

@ -3,7 +3,8 @@
#ifndef SCM_FPORTS_H #ifndef SCM_FPORTS_H
#define SCM_FPORTS_H #define SCM_FPORTS_H
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009, 2011, 2012 Free Software Foundation, Inc. /* Copyright (C) 1995-2001, 2006, 2008, 2009, 2011, 2012,
* 2017 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,9 +34,8 @@
typedef struct scm_t_fport { typedef struct scm_t_fport {
/* The file descriptor. */ /* The file descriptor. */
int fdes; int fdes;
/* Revealed count; 0 indicates not revealed, > 1 revealed. Revealed /* Revealed count; 0 indicates not revealed, > 1 revealed. */
ports do not get garbage-collected. */ unsigned int revealed;
int revealed;
/* Set of scm_fport_option flags. */ /* Set of scm_fport_option flags. */
unsigned options; unsigned options;
} scm_t_fport; } scm_t_fport;

49
libguile/ports.c
View file

@ -1,4 +1,4 @@
/* Copyright (C) 1995-2001, 2003-2004, 2006-2016 /* Copyright (C) 1995-2001, 2003-2004, 2006-2017
* Free Software Foundation, Inc. * 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
@ -680,10 +680,12 @@ SCM scm_i_port_weak_set;
/* Port finalization. */ /* Port finalization. */
static SCM close_port (SCM, int);
static SCM static SCM
do_close (void *data) do_close (void *data)
{ {
return scm_close_port (SCM_PACK_POINTER (data)); return close_port (SCM_PACK_POINTER (data), 0);
} }
/* Finalize the object (a port) pointed to by PTR. */ /* Finalize the object (a port) pointed to by PTR. */
@ -859,6 +861,33 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0,
/* Closing ports. */ /* Closing ports. */
/* Close PORT. If EXPLICIT is true, then we are explicitly closing PORT
with 'close-port'; otherwise PORT is just being GC'd. */
static SCM
close_port (SCM port, int explicit)
{
if (SCM_CLOSEDP (port))
return SCM_BOOL_F;
/* May throw an exception. */
if (SCM_OUTPUT_PORT_P (port))
scm_flush (port);
if (explicit && SCM_FPORTP (port))
/* We're closing PORT explicitly so clear its revealed count so that
it really gets closed. */
SCM_FSTREAM (port)->revealed = 0;
SCM_CLR_PORT_OPEN_FLAG (port);
if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
scm_weak_set_remove_x (scm_i_port_weak_set, port);
release_port (port);
return SCM_BOOL_T;
}
SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0, SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
(SCM port), (SCM port),
"Close the specified port object. Return @code{#t} if it\n" "Close the specified port object. Return @code{#t} if it\n"
@ -872,21 +901,7 @@ SCM_DEFINE (scm_close_port, "close-port", 1, 0, 0,
port = SCM_COERCE_OUTPORT (port); port = SCM_COERCE_OUTPORT (port);
SCM_VALIDATE_PORT (1, port); SCM_VALIDATE_PORT (1, port);
if (SCM_CLOSEDP (port)) return close_port (port, 1);
return SCM_BOOL_F;
/* May throw an exception. */
if (SCM_OUTPUT_PORT_P (port))
scm_flush (port);
SCM_CLR_PORT_OPEN_FLAG (port);
if (SCM_PORT_TYPE (port)->flags & SCM_PORT_TYPE_NEEDS_CLOSE_ON_GC)
scm_weak_set_remove_x (scm_i_port_weak_set, port);
release_port (port);
return SCM_BOOL_T;
} }
#undef FUNC_NAME #undef FUNC_NAME

48
libguile/quicksort.i.c
View file

@ -27,7 +27,7 @@
reduces the probability of selecting a bad pivot value and eliminates reduces the probability of selecting a bad pivot value and eliminates
certain extraneous comparisons. certain extraneous comparisons.
3. Only quicksorts NR_ELEMS / MAX_THRESH partitions, leaving insertion sort 3. Only quicksorts (UBND-LBND+1) / MAX_THRESH partitions, leaving insertion sort
to order the MAX_THRESH items within each partition. This is a big win, to order the MAX_THRESH items within each partition. This is a big win,
since insertion sort is faster for small, mostly sorted array segments. since insertion sort is faster for small, mostly sorted array segments.
@ -54,33 +54,29 @@
#define STACK_NOT_EMPTY (stack < top) #define STACK_NOT_EMPTY (stack < top)
static void static void
NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less) NAME (VEC_PARAM ssize_t lbnd, ssize_t ubnd, INC_PARAM SCM less)
{ {
/* Stack node declarations used to store unfulfilled partition obligations. */ /* Stack node declarations used to store unfulfilled partition obligations. */
typedef struct { typedef struct {
size_t lo; ssize_t lo;
size_t hi; ssize_t hi;
} stack_node; } stack_node;
static const char s_buggy_less[] = "buggy less predicate used when sorting"; static const char s_buggy_less[] = "buggy less predicate used when sorting";
if (nr_elems == 0) if (ubnd-lbnd+1 > MAX_THRESH)
/* Avoid lossage with unsigned arithmetic below. */
return;
if (nr_elems > MAX_THRESH)
{ {
size_t lo = 0; ssize_t lo = lbnd;
size_t hi = nr_elems-1; ssize_t hi = ubnd;
stack_node stack[STACK_SIZE]; stack_node stack[STACK_SIZE];
stack_node *top = stack + 1; stack_node *top = stack + 1;
while (STACK_NOT_EMPTY) while (STACK_NOT_EMPTY)
{ {
size_t left; ssize_t left;
size_t right; ssize_t right;
size_t mid = lo + (hi - lo) / 2; ssize_t mid = lo + (hi - lo) / 2;
SCM pivot; SCM pivot;
/* Select median value from among LO, MID, and HI. Rearrange /* Select median value from among LO, MID, and HI. Rearrange
@ -145,16 +141,16 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
ignore one or both. Otherwise, push the larger partition's ignore one or both. Otherwise, push the larger partition's
bounds on the stack and continue sorting the smaller one. */ bounds on the stack and continue sorting the smaller one. */
if ((size_t) (right - lo) <= MAX_THRESH) if ((right - lo) <= MAX_THRESH)
{ {
if ((size_t) (hi - left) <= MAX_THRESH) if ((hi - left) <= MAX_THRESH)
/* Ignore both small partitions. */ /* Ignore both small partitions. */
POP (lo, hi); POP (lo, hi);
else else
/* Ignore small left partition. */ /* Ignore small left partition. */
lo = left; lo = left;
} }
else if ((size_t) (hi - left) <= MAX_THRESH) else if ((hi - left) <= MAX_THRESH)
/* Ignore small right partition. */ /* Ignore small right partition. */
hi = right; hi = right;
else if ((right - lo) > (hi - left)) else if ((right - lo) > (hi - left))
@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
one beyond it!). */ one beyond it!). */
{ {
size_t tmp = 0; ssize_t tmp = lbnd;
size_t end = nr_elems-1; ssize_t end = ubnd;
size_t thresh = min (end, MAX_THRESH); ssize_t thresh = min (end, MAX_THRESH);
size_t run; ssize_t run;
/* Find smallest element in first threshold and place it at the /* Find smallest element in first threshold and place it at the
array's beginning. This is the smallest array element, array's beginning. This is the smallest array element,
@ -192,12 +188,12 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) if (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
tmp = run; tmp = run;
if (tmp != 0) if (tmp != lbnd)
SWAP (tmp, 0); SWAP (tmp, lbnd);
/* Insertion sort, running from left-hand-side up to right-hand-side. */ /* Insertion sort, running from left-hand-side up to right-hand-side. */
run = 1; run = lbnd + 1;
while (++run <= end) while (++run <= end)
{ {
SCM_TICK; SCM_TICK;
@ -206,7 +202,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp)))) while (scm_is_true (scm_call_2 (less, GET(run), GET(tmp))))
{ {
/* The comparison predicate may be buggy */ /* The comparison predicate may be buggy */
if (tmp == 0) if (tmp == lbnd)
scm_misc_error (NULL, s_buggy_less, SCM_EOL); scm_misc_error (NULL, s_buggy_less, SCM_EOL);
tmp -= 1; tmp -= 1;
@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less)
if (tmp != run) if (tmp != run)
{ {
SCM to_insert = GET(run); SCM to_insert = GET(run);
size_t hi, lo; ssize_t hi, lo;
for (hi = lo = run; --lo >= tmp; hi = lo) for (hi = lo = run; --lo >= tmp; hi = lo)
SET(hi, GET(lo)); SET(hi, GET(lo));

44
libguile/sort.c
View file

@ -79,7 +79,7 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
#define FUNC_NAME s_scm_restricted_vector_sort_x #define FUNC_NAME s_scm_restricted_vector_sort_x
{ {
ssize_t spos = scm_to_ssize_t (startpos); ssize_t spos = scm_to_ssize_t (startpos);
size_t epos = scm_to_ssize_t (endpos); ssize_t epos = scm_to_ssize_t (endpos)-1;
scm_t_array_handle handle; scm_t_array_handle handle;
scm_t_array_dim const * dims; scm_t_array_dim const * dims;
@ -89,26 +89,25 @@ SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0,
if (scm_array_handle_rank(&handle) != 1) if (scm_array_handle_rank(&handle) != 1)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_misc_error_key, FUNC_NAME, "rank must be 1", vec, SCM_EOL); scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (vec));
} }
if (spos < dims[0].lbnd) if (spos < dims[0].lbnd)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range", scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s",
vec, scm_list_1(startpos)); scm_list_2 (startpos, vec), scm_list_1 (startpos));
} }
if (epos > dims[0].ubnd+1) if (epos > dims[0].ubnd)
{ {
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
scm_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range", scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s",
vec, scm_list_1(endpos)); scm_list_2 (endpos, vec), scm_list_1 (endpos));
} }
if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM)
quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc, quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc,
epos-spos, dims[0].inc, less); spos, epos, dims[0].inc, less);
else else
quicksorta (&handle, epos-spos, less); quicksorta (&handle, spos, epos, less);
scm_array_handle_release (&handle); scm_array_handle_release (&handle);
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
@ -187,11 +186,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0,
} }
else else
{ {
for (i = dims[0].lbnd+1, end = dims[0].ubnd+1; i < end; ++i) for (i = 1, end = dims[0].ubnd-dims[0].lbnd+1; i < end; ++i)
{ {
if (scm_is_true (scm_call_2 (less, if (scm_is_true (scm_call_2 (less,
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)), scm_array_handle_ref (&handle, i*dims[0].inc),
scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1))))) scm_array_handle_ref (&handle, (i-1)*dims[0].inc))))
{ {
result = SCM_BOOL_F; result = SCM_BOOL_F;
break; break;
@ -427,10 +426,23 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0,
} }
else if (scm_is_array (items) && scm_c_array_rank (items) == 1) else if (scm_is_array (items) && scm_c_array_rank (items) == 1)
{ {
scm_t_array_handle handle;
scm_t_array_dim const * dims;
scm_array_get_handle (items, &handle);
dims = scm_array_handle_dims (&handle);
if (scm_array_handle_rank (&handle) != 1)
{
scm_array_handle_release (&handle);
scm_misc_error (FUNC_NAME, "rank must be 1", scm_list_1 (items));
}
scm_restricted_vector_sort_x (items, scm_restricted_vector_sort_x (items,
less, less,
scm_from_int (0), scm_from_ssize_t (dims[0].lbnd),
scm_array_length (items)); scm_from_ssize_t (dims[0].ubnd+1));
scm_array_handle_release (&handle);
return items; return items;
} }
else else

1
module/Makefile.am
View file

@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm
SOURCES = \ SOURCES = \
ice-9/and-let-star.scm \ ice-9/and-let-star.scm \
ice-9/arrays.scm \
ice-9/atomic.scm \ ice-9/atomic.scm \
ice-9/binary-ports.scm \ ice-9/binary-ports.scm \
ice-9/boot-9.scm \ ice-9/boot-9.scm \

88
module/ice-9/arrays.scm
View file

@ -1,22 +1,70 @@
;;; installed-scm-file ;;; -*- mode: scheme; coding: utf-8; -*-
;;;
;;; Copyright (C) 1999, 2001, 2004, 2006, 2017 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
;;;; Copyright (C) 1999, 2001, 2004, 2006 Free Software Foundation, Inc. (define-module (ice-9 arrays)
;;;; #:use-module (rnrs io ports)
;;;; This library is free software; you can redistribute it and/or #:use-module (srfi srfi-1)
;;;; modify it under the terms of the GNU Lesser General Public #:export (array-copy))
;;;; 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
;;;;
(define (array-shape a) ;; This is actually defined in boot-9.scm, apparently for backwards
(map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) ;; compatibility.
(array-dimensions a)))
;; (define (array-shape a)
;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind))
;; (array-dimensions a)))
; FIXME writes over the array twice if (array-type) is #t
(define (array-copy a)
(let ((b (apply make-typed-array (array-type a) *unspecified* (array-shape a))))
(array-copy! a b)
b))
;; Printing arrays
;; The dimensions aren't printed out unless they cannot be deduced from
;; the content, which happens only when certain axes are empty. #:dims?
;; can be used to force this printing. An array with all the dimensions
;; printed out is still readable syntax, this can be useful for
;; truncated-print.
(define* (array-print-prefix a port #:key dims?)
(put-char port #\#)
(display (array-rank a) port)
(let ((t (array-type a)))
(unless (eq? #t t)
(display t port)))
(let ((ss (array-shape a)))
(let loop ((s ss) (slos? #f) (szero? #f) (slens? dims?))
(define lo caar)
(define hi cadar)
(if (null? s)
(when (or slos? slens?)
(pair-for-each (lambda (s)
(when slos?
(put-char port #\@)
(display (lo s) port))
(when slens?
(put-char port #\:)
(display (- (hi s) (lo s) -1) port)))
ss))
(let ((zero-size? (zero? (- (hi s) (lo s) -1))))
(loop (cdr s)
(or slos? (not (zero? (lo s))))
(or szero? zero-size?)
(or slens? (and (not zero-size?) szero?))))))))

24
module/ice-9/pretty-print.scm
View file

@ -429,17 +429,25 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(display ")")) (display ")"))
(else (else
(display "#")))) (display "#"))))
((bitvector? x)
(cond
((>= width (+ 2 (array-length x)))
(format #t "~a" x))
;; the truncated bitvector would print as #1b(...), so we print by hand.
((>= width (+ 2 ellipsis-width))
(format #t "#*")
(array-for-each (lambda (xi) (format #t (if xi "1" "0")))
(make-shared-array x list (- width 2 ellipsis-width)))
(format #t ellipsis))
(else
(display "#"))))
((and (array? x) (not (string? x))) ((and (array? x) (not (string? x)))
(let* ((type (array-type x)) (let* ((type (array-type x))
(prefix (prefix
(if inner? (if inner?
"" ""
(if (zero? (array-rank x)) (call-with-output-string
(string-append "#0" (if (eq? #t type) "" (symbol->string type))) (lambda (s) ((@@ (ice-9 arrays) array-print-prefix) x s)))))
(let ((s (format #f "~a"
(apply make-typed-array type *unspecified*
(make-list (array-rank x) 0)))))
(substring s 0 (- (string-length s) 2))))))
(width-prefix (string-length prefix))) (width-prefix (string-length prefix)))
(cond (cond
((>= width (+ 2 width-prefix ellipsis-width)) ((>= width (+ 2 width-prefix ellipsis-width))
@ -447,7 +455,9 @@ sub-expression, via the @var{breadth-first?} keyword argument."
(if (zero? (array-rank x)) (if (zero? (array-rank x))
(print (array-ref x) (- width width-prefix 2)) (print (array-ref x) (- width width-prefix 2))
(print-sequence x (- width width-prefix 2) (array-length x) (print-sequence x (- width width-prefix 2) (array-length x)
array-cell-ref identity (let ((base (caar (array-shape x))))
(lambda (x i) (array-cell-ref x (+ base i))))
identity
#:inner? (< 1 (array-rank x)))) #:inner? (< 1 (array-rank x))))
(display ")")) (display ")"))
(else (else

5
module/system/vm/traps.scm
View file

@ -1,6 +1,6 @@
;;; Traps: stepping, breakpoints, and such. ;;; Traps: stepping, breakpoints, and such.
;; Copyright (C) 2010, 2012, 2013, 2014 Free Software Foundation, Inc. ;; Copyright (C) 2010, 2012, 2013, 2014, 2017 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
@ -124,7 +124,8 @@
(end (program-last-ip proc))) (end (program-last-ip proc)))
(lambda (frame) (lambda (frame)
(let ((ip (frame-instruction-pointer frame))) (let ((ip (frame-instruction-pointer frame)))
(and (<= start ip) (< ip end)))))) (and (<= start ip)
end (< ip end))))))
((struct? proc) ((struct? proc)
(frame-matcher (procedure proc))) (frame-matcher (procedure proc)))
(else (else

12
test-suite/tests/array-map.test
View file

@ -92,6 +92,10 @@
(array-copy! #2:0:2() c) (array-copy! #2:0:2() c)
(array-equal? #2f64:0:2() c))) (array-equal? #2f64:0:2() c)))
(pass-if "empty/immutable vector"
(array-copy! #() (vector))
#t)
;; FIXME add empty, type 'b cases. ;; FIXME add empty, type 'b cases.
) )
@ -520,6 +524,14 @@
(array-slice-for-each 1 (lambda (a) (sort! a <)) a) (array-slice-for-each 1 (lambda (a) (sort! a <)) a)
a)) a))
(pass-if-equal "1 argument frame rank 1, non-zero base indices"
#2@1@1((1 3 9) (2 7 8))
(let* ((a (make-array *unspecified* '(1 2) '(1 3)))
(b #2@1@1((9 1 3) (7 8 2))))
(array-copy! b a)
(array-slice-for-each 1 (lambda (a) (sort! a <)) a)
a))
(pass-if-equal "2 arguments frame rank 1" (pass-if-equal "2 arguments frame rank 1"
#f64(8 -1) #f64(8 -1)
(let* ((x (list->typed-array 'f64 2 '((9 1) (7 8)))) (let* ((x (list->typed-array 'f64 2 '((9 1) (7 8))))

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

@ -999,4 +999,57 @@
"#1(b c)" "#1(b c)"
(format #f "~a" (make-shared-array #(a b c) (format #f "~a" (make-shared-array #(a b c)
(lambda (i) (list (+ i 1))) (lambda (i) (list (+ i 1)))
2)))) 2)))
(pass-if-equal "0-array"
"#0(9)"
(format #f "~a" (make-array 9)))
(pass-if-equal "2-array"
"#2f64((0.0 1.0) (2.0 3.0))"
(format #f "~a" #2f64((0 1) (2 3))))
(pass-if-equal "empty 3-array"
"#3()"
(format #f "~a" (make-array 1 0 0 0)))
(pass-if-equal "empty 3-array with last nonempty dim."
"#3:0:0:1()"
(format #f "~a" (make-array 1 0 0 1)))
(pass-if-equal "empty 3-array with middle nonempty dim."
"#3:0:1:0()"
(format #f "~a" (make-array 1 0 1 0)))
(pass-if-equal "empty 3-array with first nonempty dim."
"#3(())"
(format #f "~a" (make-array 1 1 0 0)))
(pass-if-equal "3-array with non-zero lower bounds"
"#3@1@0@1(((1 1 1) (1 1 1)) ((1 1 1) (1 1 1)))"
(format #f "~a" (make-array 1 '(1 2) '(0 1) '(1 3))))
(pass-if-equal "3-array with non-zero-lower bounds and last nonempty dim."
"#3@0:0@0:0@1:3()"
(format #f "~a" (make-array 1 0 0 '(1 3))))
(pass-if-equal "3-array with non-zero-lower bounds and middle nonempty dim."
"#3@0:0@1:3@0:0()"
(format #f "~a" (make-array 1 0 '(1 3) 0)))
(pass-if-equal "3-array with non-zero-lower bounds and first nonempty dim."
"#3@1@0@0(() () ())"
(format #f "~a" (make-array 1 '(1 3) 0 0)))
(pass-if-equal "3-array with singleton dim case I"
"#3@1@1@-1(((1 1 1)))"
(format #f "~a" (make-array 1 '(1 1) '(1 1) '(-1 1))))
(pass-if-equal "3-array with singleton dim case II"
"#3@-1@1@1(((1) (1) (1)))"
(format #f "~a" (make-array 1 '(-1 -1) '(1 3) '(1 1))))
(pass-if-equal "3-array with singleton dim case III"
"#3@1@-1@1(((1)) ((1)) ((1)))"
(format #f "~a" (make-array 1 '(1 3) '(-1 -1) '(1 1)))))

28
test-suite/tests/ports.test
View file

@ -602,6 +602,34 @@
(pass-if "unread residue" (pass-if "unread residue"
(string=? (read-line) "moon")))) (string=? (read-line) "moon"))))
(pass-if-equal "close-port & revealed port"
EBADF
(let* ((port (open-file "/dev/null" "r0"))
(fdes (port->fdes port))) ;increments revealed count of PORT
(close-port port) ;closes FDES as a side-effect
(catch 'system-error
(lambda ()
(seek fdes 0 SEEK_CUR)
#f)
(lambda args
(system-error-errno args)))))
(pass-if "revealed port fdes not closed"
(let* ((port (open-file "/dev/null" "r0"))
(fdes (port->fdes port)) ;increments revealed count of PORT
(guardian (make-guardian)))
(guardian port)
(set! port #f)
(gc)
(if (port? (guardian))
(and (zero? (seek fdes 0 SEEK_CUR))
(begin
(close-fdes fdes)
#t))
(begin
(close-fdes fdes)
(throw 'unresolved)))))
(when (provided? 'threads) (when (provided? 'threads)
(let* ((p (pipe)) (let* ((p (pipe))
(r (car p)) (r (car p))

50
test-suite/tests/print.test
View file

@ -147,6 +147,35 @@
(pass-if-equal "#<directory (test-…>" (pass-if-equal "#<directory (test-…>"
(tprint (current-module) 20 "UTF-8")) (tprint (current-module) 20 "UTF-8"))
;; bitvectors
(let ((testv (bitvector #t #f #f #t #t #f #t #t)))
(pass-if-equal "#*10011011"
(tprint testv 11 "UTF-8"))
(pass-if-equal "#*10011011"
(tprint testv 11 "ISO-8859-1"))
(pass-if-equal "#*10011…"
(tprint testv 8 "UTF-8"))
(pass-if-equal "#*100..."
(tprint testv 8 "ISO-8859-1"))
(pass-if-equal "#*10…"
(tprint testv 5 "UTF-8"))
(pass-if-equal "#*..."
(tprint testv 5 "ISO-8859-1"))
(pass-if-equal "#*1…"
(tprint testv 4 "UTF-8"))
(pass-if-equal "#"
(tprint testv 4 "ISO-8859-1")))
;; rank 0 arrays
(pass-if-equal "#0(#)" (pass-if-equal "#0(#)"
(tprint (make-typed-array #t 9.0) 6 "UTF-8")) (tprint (make-typed-array #t 9.0) 6 "UTF-8"))
@ -162,17 +191,30 @@
(pass-if-equal "#" (pass-if-equal "#"
(tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8"))
;; higher dimensional arrays
(let ((testa (make-typed-array 's32 0 20 20)))
(pass-if-equal "#2s32(…)" (pass-if-equal "#2s32(…)"
(tprint (make-typed-array 's32 0 20 20) 8 "UTF-8")) (tprint testa 8 "UTF-8"))
(pass-if-equal "#2s32(# …)" (pass-if-equal "#2s32(# …)"
(tprint (make-typed-array 's32 0 20 20) 10 "UTF-8")) (tprint testa 10 "UTF-8"))
(pass-if-equal "#2s32((…) …)" (pass-if-equal "#2s32((…) …)"
(tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) (tprint testa 12 "UTF-8"))
(pass-if-equal "#2s32((0 …) …)" (pass-if-equal "#2s32((0 …) …)"
(tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")) (tprint testa 14 "UTF-8")))
;; check that bounds are printed correctly
(pass-if-equal "#2@-1@0((foo foo foo foo …) …)"
(tprint (make-array 'foo '(-1 3) 5) 30 "UTF-8"))
(pass-if-equal "#3@-1:5@0:0@0:5(() () () # #)"
(tprint (make-array 'foo '(-1 3) 0 5) 30 "UTF-8"))
;; nested objects including arrays
(pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))" (pass-if-equal "#2((#(9 9) #(9 9)) (#(9 9) #(9 9)))"
(tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8")) (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8"))

149
test-suite/tests/sort.test
View file

@ -1,5 +1,6 @@
;;;; sort.test --- tests Guile's sort functions -*- scheme -*- ;;;; sort.test --- tests Guile's sort functions -*- scheme -*-
;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011 Free Software Foundation, Inc. ;;;; Copyright (C) 2003, 2006, 2007, 2009, 2011, 2017
;;;; 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
@ -15,11 +16,42 @@
;;;; License along with this library; if not, write to the Free Software ;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (test-suite lib)) (use-modules (test-suite lib)
(ice-9 arrays))
(set! *random-state* (seed->random-state 2017))
; Randomly shuffle u in place, using Fisher-Yates algorithm.
(define (array-shuffle! v)
(unless (= 1 (array-rank v)) (throw 'bad-rank (array-rank v)))
(let* ((dims (car (array-shape v)))
(lo (car dims)))
(let loop ((i (cadr dims)))
(if (> i lo)
(let* ((j (+ lo (random (- (1+ i) lo))))
(t (array-ref v j)))
(array-set! v (array-ref v i) j)
(array-set! v t i)
(loop (- i 1)))
v))))
(define* (test-sort! v #:optional (sort sort))
(array-index-map! v (lambda (i) i))
(let ((before (array-copy v)))
(array-shuffle! v)
(let ((after (array-copy v)))
(and
(equal? before (sort v <))
(equal? after v)))))
(define* (test-sort-inplace! v #:optional (sort! sort!))
(array-index-map! v (lambda (i) i))
(let ((before (array-copy v)))
(array-shuffle! v)
(and (equal? before (sort! v <))
(equal? before v)
(sorted? v <))))
(define (randomize-vector! v n)
(array-index-map! v (lambda (i) (random n)))
v)
(with-test-prefix "sort" (with-test-prefix "sort"
@ -32,70 +64,72 @@
(sort '(1 2) (lambda (x y z) z))) (sort '(1 2) (lambda (x y z) z)))
(pass-if "sort of vector" (pass-if "sort of vector"
(let* ((v (randomize-vector! (make-vector 1000) 1000)) (test-sort! (make-vector 100)))
(w (vector-copy v)))
(and (sorted? (sort v <) <)
(equal? w v))))
(pass-if "sort of typed array" (pass-if "sort of typed vector"
(let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)) (test-sort! (make-f64vector 100))))
(w (make-typed-array 'f64 *unspecified* 99)))
(array-copy! v w)
(and (sorted? (sort v <) <)
(equal? w v))))
(pass-if "sort! of vector"
(let ((v (randomize-vector! (make-vector 1000) 1000)))
(sorted? (sort! v <) <)))
(pass-if "sort! of typed array" (with-test-prefix "sort!"
(let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)))
(sorted? (sort! v <) <)))
(pass-if "sort! of non-contigous vector" (pass-if "sort of empty vector"
(let* ((a (make-array 0 1000 3)) (test-sort-inplace! (vector)))
(v (make-shared-array a (lambda (i) (list i 0)) 1000)))
(randomize-vector! v 1000) (pass-if "sort of vector"
(sorted? (sort! v <) <))) (test-sort-inplace! (make-vector 100)))
(pass-if "sort of empty typed vector"
(test-sort-inplace! (f64vector)))
(pass-if "sort! of typed vector"
(test-sort-inplace! (make-f64vector 100)))
(pass-if "sort! of non-contigous array"
(let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list i 0)) 100)))
(test-sort-inplace! v)))
(pass-if "sort! of non-contigous typed array" (pass-if "sort! of non-contigous typed array"
(let* ((a (make-typed-array 'f64 0 99 3)) (let* ((a (make-typed-array 'f64 0 99 3))
(v (make-shared-array a (lambda (i) (list i 0)) 99))) (v (make-shared-array a (lambda (i) (list i 0)) 99)))
(randomize-vector! v 99) (test-sort-inplace! v)))
(sorted? (sort! v <) <)))
(pass-if "sort! of negative-increment vector" (pass-if "sort! of negative-increment array"
(let* ((a (make-array 0 1000 3)) (let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
(randomize-vector! v 1000) (test-sort-inplace! v)))
(sorted? (sort! v <) <)))
(pass-if "sort! of non-zero base index array"
(test-sort-inplace! (make-array 0 '(-99 0))))
(pass-if "sort! of non-zero base index typed array"
(test-sort-inplace! (make-typed-array 'f64 0 '(-99 0))))
(pass-if "sort! of negative-increment typed array" (pass-if "sort! of negative-increment typed array"
(let* ((a (make-typed-array 'f64 0 99 3)) (let* ((a (make-typed-array 'f64 0 99 3))
(v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99)))
(randomize-vector! v 99) (test-sort-inplace! v))))
(sorted? (sort! v <) <)))
(with-test-prefix "stable-sort!"
(pass-if "stable-sort!" (pass-if "stable-sort!"
(let ((v (randomize-vector! (make-vector 1000) 1000))) (let ((v (make-vector 100)))
(sorted? (stable-sort! v <) <))) (test-sort-inplace! v stable-sort!)))
(pass-if "stable-sort! of non-contigous vector" (pass-if "stable-sort! of non-contigous array"
(let* ((a (make-array 0 1000 3)) (let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list i 0)) 1000))) (v (make-shared-array a (lambda (i) (list i 0)) 100)))
(randomize-vector! v 1000) (test-sort-inplace! v stable-sort!)))
(sorted? (stable-sort! v <) <)))
(pass-if "stable-sort! of negative-increment vector" (pass-if "stable-sort! of negative-increment array"
(let* ((a (make-array 0 1000 3)) (let* ((a (make-array 0 100 3))
(v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100)))
(randomize-vector! v 1000) (test-sort-inplace! v stable-sort!)))
(sorted? (stable-sort! v <) <))))
(pass-if "stable-sort! of non-zero base index array"
(test-sort-inplace! (make-array 0 '(-99 0)) stable-sort!)))
;;;
;;; stable-sort
;;;
(with-test-prefix "stable-sort" (with-test-prefix "stable-sort"
@ -108,3 +142,18 @@
;; behavior (integer underflow) leading to crashes. ;; behavior (integer underflow) leading to crashes.
(pass-if "empty vector" (pass-if "empty vector"
(equal? '#() (stable-sort '#() <)))) (equal? '#() (stable-sort '#() <))))
(with-test-prefix "mutable/immutable arguments"
(with-test-prefix/c&e "immutable arguments"
(pass-if "sort! of empty vector"
(equal? #() (sort! (vector) <)))
(pass-if "sort of immutable vector"
(equal? #(0 1) (sort #(1 0) <))))
(pass-if-exception "sort! of mutable vector (compile)"
exception:wrong-type-arg
(compile '(sort! #(0) <) #:to 'value #:env (current-module))))