From bf060d2affbfea8e7b69d160b8214d791661f236 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Wed, 25 Oct 2017 10:46:25 -0700 Subject: [PATCH 1/8] 'frame-matcher' doesn't crash when the last IP is unknown. This fixes a bug when using ",break": system/vm/traps.scm:127:31: system/vm/traps.scm:127:31: In procedure <: Wrong type: #f * module/system/vm/traps.scm (frame-matcher): Check whether END is true. --- module/system/vm/traps.scm | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/module/system/vm/traps.scm b/module/system/vm/traps.scm index c4861c925..8bee10355 100644 --- a/module/system/vm/traps.scm +++ b/module/system/vm/traps.scm @@ -1,6 +1,6 @@ ;;; 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 ;;; modify it under the terms of the GNU Lesser General Public @@ -124,7 +124,8 @@ (end (program-last-ip proc))) (lambda (frame) (let ((ip (frame-instruction-pointer frame))) - (and (<= start ip) (< ip end)))))) + (and (<= start ip) + end (< ip end)))))) ((struct? proc) (frame-matcher (procedure proc))) (else From 1008ea315483d1fb41b2a8c10680e511238836d0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Thu, 12 Oct 2017 12:04:34 +0200 Subject: [PATCH 2/8] Allow garbage collection of revealed file ports. Reported at . Discussed at . * libguile/fports.c (revealed_ports, revealed_lock): Remove. (scm_revealed_count): Just return 'SCM_REVEALED (port)'. (scm_set_port_revealed_x, scm_adjust_port_revealed_x): Remove REVEALED_PORTS manipulation. (fport_close): Do nothing when SCM_REVEALED (port) > 0. * libguile/fports.h (scm_t_fport): Adjust comment; make 'revealed' unsigned. * libguile/ports.c (do_close): Call 'close_port' instead of 'scm_close_port'. (scm_close_port): Rename to... (close_port): ... this. Add 'explicit' parameter. Clear 'revealed' field when PORT is a file port and EXPLICIT is true. (scm_close_port): Call 'close_port'. * test-suite/tests/ports.test ("close-port & revealed port") ("revealed port fdes not closed"): New tests. --- libguile/fports.c | 41 ++++++------------------------- libguile/fports.h | 8 +++--- libguile/ports.c | 49 ++++++++++++++++++++++++------------- test-suite/tests/ports.test | 28 +++++++++++++++++++++ 4 files changed, 72 insertions(+), 54 deletions(-) diff --git a/libguile/fports.c b/libguile/fports.c index 94092b872..ee6ac0bf1 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,6 +1,6 @@ /* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, * 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 * 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) -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. Also used by the garbage collector. @@ -476,13 +474,7 @@ static scm_i_pthread_mutex_t revealed_lock = SCM_I_PTHREAD_MUTEX_INITIALIZER; int scm_revealed_count (SCM port) { - int ret; - - scm_i_pthread_mutex_lock (&revealed_lock); - ret = SCM_REVEALED (port); - scm_i_pthread_mutex_unlock (&revealed_lock); - - return ret; + return SCM_REVEALED (port); } 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.") #define FUNC_NAME s_scm_set_port_revealed_x { - int r, prev; + int r; port = SCM_COERCE_OUTPORT (port); SCM_VALIDATE_OPFPORT (1, port); r = scm_to_int (rcount); - - scm_i_pthread_mutex_lock (&revealed_lock); - - prev = SCM_REVEALED (port); 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; } #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); a = scm_to_int (addend); - if (!a) - return SCM_UNSPECIFIED; - - scm_i_pthread_mutex_lock (&revealed_lock); - 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; } @@ -668,6 +638,11 @@ fport_close (SCM 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); if (close (fp->fdes) != 0) /* It's not useful to retry after EINTR, as the file descriptor is diff --git a/libguile/fports.h b/libguile/fports.h index afb8ba771..e397fcc59 100644 --- a/libguile/fports.h +++ b/libguile/fports.h @@ -3,7 +3,8 @@ #ifndef 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 * modify it under the terms of the GNU Lesser General Public License @@ -33,9 +34,8 @@ typedef struct scm_t_fport { /* The file descriptor. */ int fdes; - /* Revealed count; 0 indicates not revealed, > 1 revealed. Revealed - ports do not get garbage-collected. */ - int revealed; + /* Revealed count; 0 indicates not revealed, > 1 revealed. */ + unsigned int revealed; /* Set of scm_fport_option flags. */ unsigned options; } scm_t_fport; diff --git a/libguile/ports.c b/libguile/ports.c index 2a25cd58e..72bb73a01 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995-2001, 2003-2004, 2006-2016 +/* Copyright (C) 1995-2001, 2003-2004, 2006-2017 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -680,10 +680,12 @@ SCM scm_i_port_weak_set; /* Port finalization. */ +static SCM close_port (SCM, int); + static SCM 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. */ @@ -859,6 +861,33 @@ SCM_DEFINE (scm_eof_object_p, "eof-object?", 1, 0, 0, /* 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 port), "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); SCM_VALIDATE_PORT (1, port); - if (SCM_CLOSEDP (port)) - 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; + return close_port (port, 1); } #undef FUNC_NAME diff --git a/test-suite/tests/ports.test b/test-suite/tests/ports.test index 3c8ae3050..6fe38d953 100644 --- a/test-suite/tests/ports.test +++ b/test-suite/tests/ports.test @@ -602,6 +602,34 @@ (pass-if "unread residue" (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) (let* ((p (pipe)) (r (car p)) From 4212f29655db2e9ddca19ebd590bca5521c1b97b Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Fri, 15 Sep 2017 12:36:57 +0200 Subject: [PATCH 3/8] Allow scm_XXX_writable_elements on empty vectors, even if immutable * libguile/array-handle.c (initialize_vector_handle): Set both element pointers to NULL if the vector is empty. * libguile/array-map.c (racp): Ignore immutability if destination is empty. * test-suite/tests/sort.test: Check empty/mutable/immutable vectors with sort!. * test-suite/tests/array-map.test: Check array-copy! with empty/immutable destination. --- libguile/array-handle.c | 6 ++++-- libguile/array-map.c | 2 +- test-suite/tests/array-map.test | 10 +++++++--- test-suite/tests/sort.test | 24 ++++++++++++++++++------ 4 files changed, 30 insertions(+), 12 deletions(-) diff --git a/libguile/array-handle.c b/libguile/array-handle.c index 3d81efc04..947462a59 100644 --- a/libguile/array-handle.c +++ b/libguile/array-handle.c @@ -149,8 +149,10 @@ initialize_vector_handle (scm_t_array_handle *h, size_t len, h->dim0.ubnd = (ssize_t) (len - 1U); h->dim0.inc = 1; h->element_type = element_type; - h->elements = elements; - h->writable_elements = mutable_p ? ((void *) elements) : NULL; + /* elements != writable_elements is used to check mutability later on. + 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->vref = vref; h->vset = vset; diff --git a/libguile/array-map.c b/libguile/array-map.c index 79383969d..651a1bfb9 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -263,7 +263,7 @@ racp (SCM src, SCM dst) { SCM const * el_s = h_s.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"); for (; n-- > 0; i_s += inc_s, i_d += inc_d) el_d[i_d] = el_s[i_s]; diff --git a/test-suite/tests/array-map.test b/test-suite/tests/array-map.test index 347184112..129469d4f 100644 --- a/test-suite/tests/array-map.test +++ b/test-suite/tests/array-map.test @@ -1,17 +1,17 @@ ;;;; array-map.test --- test array mapping functions -*- scheme -*- -;;;; +;;;; ;;;; Copyright (C) 2004, 2005, 2006, 2009, 2013 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public ;;;; License 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 @@ -92,6 +92,10 @@ (array-copy! #2:0:2() c) (array-equal? #2f64:0:2() c))) + (pass-if "empty/immutable vector" + (array-copy! #() (vector)) + #t) + ;; FIXME add empty, type 'b cases. ) diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index 249f890ec..fa1ffd0b6 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -74,7 +74,9 @@ (let* ((a (make-typed-array 'f64 0 99 3)) (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) (randomize-vector! v 99) - (sorted? (sort! v <) <))) + (sorted? (sort! v <) <)))) + +(with-test-prefix "stable-sort!" (pass-if "stable-sort!" (let ((v (randomize-vector! (make-vector 1000) 1000))) @@ -92,11 +94,6 @@ (randomize-vector! v 1000) (sorted? (stable-sort! v <) <)))) - -;;; -;;; stable-sort -;;; - (with-test-prefix "stable-sort" ;; in guile 1.8.0 and 1.8.1 this test failed, an empty list provoked a @@ -108,3 +105,18 @@ ;; behavior (integer underflow) leading to crashes. (pass-if "empty vector" (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)))) From bb7c7362c35843465fc6a2a03cd15381d8d41483 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 13 Feb 2017 12:11:50 +0100 Subject: [PATCH 4/8] Replace uniform-vector-read benchmark with bytevector-io benchmark * benchmark-suite/benchmarks/uniform-vector-read.bm: Remove; uniform-vector-read! and uniform-vector-write were deprecated in 2.0 and are have been removed in 2.1. * benchmark-suite/benchmarks/bytevector-io.bm: New benchmark. * benchmark-suite/Makefile.am: Run the new benchmark. --- benchmark-suite/Makefile.am | 2 +- ...niform-vector-read.bm => bytevector-io.bm} | 29 +++++++++---------- 2 files changed, 15 insertions(+), 16 deletions(-) rename benchmark-suite/benchmarks/{uniform-vector-read.bm => bytevector-io.bm} (64%) diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index 12221211e..47bd0365d 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,5 +1,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ benchmarks/arithmetic.bm \ + benchmarks/bytevector-io.bm \ benchmarks/bytevectors.bm \ benchmarks/chars.bm \ benchmarks/continuations.bm \ @@ -13,7 +14,6 @@ SCM_BENCHMARKS = benchmarks/0-reference.bm \ benchmarks/srfi-13.bm \ benchmarks/structs.bm \ benchmarks/subr.bm \ - benchmarks/uniform-vector-read.bm \ benchmarks/vectors.bm \ benchmarks/vlists.bm \ benchmarks/write.bm \ diff --git a/benchmark-suite/benchmarks/uniform-vector-read.bm b/benchmark-suite/benchmarks/bytevector-io.bm similarity index 64% rename from benchmark-suite/benchmarks/uniform-vector-read.bm rename to benchmark-suite/benchmarks/bytevector-io.bm index 01b747836..7ae7c0e02 100644 --- a/benchmark-suite/benchmarks/uniform-vector-read.bm +++ b/benchmark-suite/benchmarks/bytevector-io.bm @@ -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 ;;; 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 ;;; 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 (srfi srfi-4)) + :use-module (rnrs io ports) + :use-module (rnrs bytevectors)) (define file-name (tmpnam)) @@ -30,24 +31,22 @@ (define buf (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))) - (uniform-vector-write buf output) + (put-bytevector output buf) (close output))) - (benchmark "uniform-vector-read!" 20000 + (benchmark "get-bytevector-n!" 20000 (let ((input (open-input-file file-name))) (setvbuf input 'none) - (uniform-vector-read! buf input) + (get-bytevector-n! input buf 0 (bytevector-length buf)) (close input))) - (benchmark "string port" 5000 - (let ((input (open-input-string str))) - (uniform-vector-read! buf input) + (benchmark "get-bytevector-n" 20000 + (let ((input (open-input-file file-name))) + (setvbuf input 'none) + (get-bytevector-n input (bytevector-length buf)) (close input)))) From ffcdb7bddf9ff7f3b2479bf9ab58090b86bfcf72 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 13 Feb 2017 13:21:59 +0100 Subject: [PATCH 5/8] Remove documentation on uniform-vector-read!, uniform-vector-write * NEWS: Add specific removal notice. * doc/ref/api-data.texi: Remove documentation on uniform-vector-read!, uniform-vector-write. --- NEWS | 7 +++++++ doc/ref/api-data.texi | 33 --------------------------------- 2 files changed, 7 insertions(+), 33 deletions(-) diff --git a/NEWS b/NEWS index 06d4d383f..7620cfd55 100644 --- a/NEWS +++ b/NEWS @@ -884,6 +884,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 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 We have removed accidentally public, undocumented interfaces that we diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 677454bbe..05b70838a 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7568,39 +7568,6 @@ $\left(\matrix{% @end example @end deffn -@deffn {Scheme Procedure} uniform-array-read! ra [port_or_fd [start [end]]] -@deffnx {C Function} scm_uniform_array_read_x (ra, port_or_fd, start, end) -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 -a specified region of a vector (or linearized array) to be read, -leaving the remainder of the vector unchanged. - -@code{uniform-array-read!} returns the number of objects read. -@var{port_or_fd} may be omitted, in which case it defaults to the value -returned by @code{(current-input-port)}. -@end deffn - -@deffn {Scheme Procedure} uniform-array-write ra [port_or_fd [start [end]]] -@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 - @node Shared Arrays @subsubsection Shared Arrays From 3bfd4aaa6e080dc5b33875921b74d733ac16feb2 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 13 Feb 2017 12:58:34 +0100 Subject: [PATCH 6/8] Fix sort, sort! for arrays with nonzero lower bound * module/ice-9/arrays.scm (array-copy): New function, export. * module/Makefile.am: Install (ice-9 arrays). * doc/ref/api-data.texi: Add documentation for (ice-9 arrays). * libguile/quicksort.i.c: Use signed bounds throughout. * libguile/sort.c (scm_restricted_vector_sort_x): Fix error calls. Fix calls to quicksort. * test-suite/tests/sort.test: Actually test that the sorted results match the original data. Test cases for non-zero base index arrays for sort, sort!, and stable-sort!. --- doc/ref/api-data.texi | 32 ++++++--- libguile/quicksort.i.c | 48 ++++++------- libguile/sort.c | 68 ++++++++++-------- module/Makefile.am | 1 + module/ice-9/arrays.scm | 50 ++++++++------ test-suite/tests/sort.test | 137 +++++++++++++++++++++++-------------- 6 files changed, 202 insertions(+), 134 deletions(-) diff --git a/doc/ref/api-data.texi b/doc/ref/api-data.texi index 05b70838a..ac743ea1f 100644 --- a/doc/ref/api-data.texi +++ b/doc/ref/api-data.texi @@ -7498,10 +7498,6 @@ same type, and have corresponding elements which are either @code{equal?} (@pxref{Equality}) in that all arguments must be arrays. @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 different index ranges. The code currently iterates over the @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? @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) -Set each element of the @var{dst} array to values obtained from calls -to @var{proc}. The value returned is unspecified. +Set each element of the @var{dst} array to values obtained from calls to +@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})}, -where each @var{elem} is from the corresponding @var{src} array, at -the @var{dst} index. @code{array-map-in-order!} makes the calls in +Each call is @code{(@var{proc} @var{elem} @dots{})}, where each +@var{elem} is from the corresponding @var{src} array, at the +@var{dst} index. @code{array-map-in-order!} makes the calls in row-major order, @code{array-map!} makes them in an unspecified order. The @var{src} arrays must have the same number of dimensions as @@ -7568,6 +7565,21 @@ $\left(\matrix{% @end example @end deffn +An additional array function is available in the module +@code{(ice-9 arrays)}. It can be used with: + +@example +(use-modules (ice-9 arrays)) +@end example + +@deffn {Scheme Procedure} array-copy src +Return a new array with the same elements, type and shape as +@var{src}. However, the array increments may not be the same as those of +@var{src}. In the current implementation, the returned array will be in +row-major order, but that might change in the future. Use +@code{array-copy!} on an array of known order if that is a concern. +@end deffn + @node Shared Arrays @subsubsection Shared Arrays diff --git a/libguile/quicksort.i.c b/libguile/quicksort.i.c index cf1742efa..598267268 100644 --- a/libguile/quicksort.i.c +++ b/libguile/quicksort.i.c @@ -27,7 +27,7 @@ reduces the probability of selecting a bad pivot value and eliminates 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, since insertion sort is faster for small, mostly sorted array segments. @@ -54,33 +54,29 @@ #define STACK_NOT_EMPTY (stack < top) 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. */ typedef struct { - size_t lo; - size_t hi; + ssize_t lo; + ssize_t hi; } stack_node; static const char s_buggy_less[] = "buggy less predicate used when sorting"; - if (nr_elems == 0) - /* Avoid lossage with unsigned arithmetic below. */ - return; - - if (nr_elems > MAX_THRESH) + if (ubnd-lbnd+1 > MAX_THRESH) { - size_t lo = 0; - size_t hi = nr_elems-1; + ssize_t lo = lbnd; + ssize_t hi = ubnd; stack_node stack[STACK_SIZE]; stack_node *top = stack + 1; while (STACK_NOT_EMPTY) { - size_t left; - size_t right; - size_t mid = lo + (hi - lo) / 2; + ssize_t left; + ssize_t right; + ssize_t mid = lo + (hi - lo) / 2; SCM pivot; /* 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 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. */ POP (lo, hi); else /* Ignore small left partition. */ lo = left; } - else if ((size_t) (hi - left) <= MAX_THRESH) + else if ((hi - left) <= MAX_THRESH) /* Ignore small right partition. */ hi = right; else if ((right - lo) > (hi - left)) @@ -179,10 +175,10 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less) one beyond it!). */ { - size_t tmp = 0; - size_t end = nr_elems-1; - size_t thresh = min (end, MAX_THRESH); - size_t run; + ssize_t tmp = lbnd; + ssize_t end = ubnd; + ssize_t thresh = min (end, MAX_THRESH); + ssize_t run; /* Find smallest element in first threshold and place it at the 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)))) tmp = run; - if (tmp != 0) - SWAP (tmp, 0); + if (tmp != lbnd) + SWAP (tmp, lbnd); /* Insertion sort, running from left-hand-side up to right-hand-side. */ - run = 1; + run = lbnd + 1; while (++run <= end) { 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)))) { /* The comparison predicate may be buggy */ - if (tmp == 0) + if (tmp == lbnd) scm_misc_error (NULL, s_buggy_less, SCM_EOL); tmp -= 1; @@ -216,7 +212,7 @@ NAME (VEC_PARAM size_t nr_elems, INC_PARAM SCM less) if (tmp != run) { SCM to_insert = GET(run); - size_t hi, lo; + ssize_t hi, lo; for (hi = lo = run; --lo >= tmp; hi = lo) SET(hi, GET(lo)); diff --git a/libguile/sort.c b/libguile/sort.c index 81ef3ff27..ff7d6634d 100644 --- a/libguile/sort.c +++ b/libguile/sort.c @@ -69,7 +69,7 @@ #define SET(i, val) scm_array_handle_set (ra, scm_array_handle_pos_1 (ra, i), val) #include "libguile/quicksort.i.c" -SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, +SCM_DEFINE (scm_restricted_vector_sort_x, "restricted-vector-sort!", 4, 0, 0, (SCM vec, SCM less, SCM startpos, SCM endpos), "Sort the vector @var{vec}, using @var{less} for comparing\n" "the vector elements. @var{startpos} (inclusively) and\n" @@ -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 { 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_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) { 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) { scm_array_handle_release (&handle); - scm_error (scm_out_of_range_key, FUNC_NAME, "startpos out of range", - vec, scm_list_1(startpos)); + scm_error (scm_out_of_range_key, FUNC_NAME, "startpos ~s out of range of ~s", + 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_error (scm_out_of_range_key, FUNC_NAME, "endpos out of range", - vec, scm_list_1(endpos)); + scm_error (scm_out_of_range_key, FUNC_NAME, "endpos ~s out of range of ~s", + scm_list_2 (endpos, vec), scm_list_1 (endpos)); } - if (handle.element_type == SCM_ARRAY_ELEMENT_TYPE_SCM) - quicksort (scm_array_handle_writable_elements (&handle) + (spos-dims[0].lbnd) * dims[0].inc, - epos-spos, dims[0].inc, less); + quicksort (scm_array_handle_writable_elements (&handle) - dims[0].lbnd * dims[0].inc, + spos, epos, dims[0].inc, less); else - quicksorta (&handle, epos-spos, less); + quicksorta (&handle, spos, epos, less); scm_array_handle_release (&handle); return SCM_UNSPECIFIED; @@ -187,11 +186,11 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, } 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, - scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i)), - scm_array_handle_ref (&handle, scm_array_handle_pos_1 (&handle, i-1))))) + scm_array_handle_ref (&handle, i*dims[0].inc), + scm_array_handle_ref (&handle, (i-1)*dims[0].inc)))) { result = SCM_BOOL_F; break; @@ -211,7 +210,7 @@ SCM_DEFINE (scm_sorted_p, "sorted?", 2, 0, 0, and returns a new list in which the elements of a and b have been stably interleaved so that (sorted? (merge a b less?) less?). Note: this does _not_ accept vectors. */ -SCM_DEFINE (scm_merge, "merge", 3, 0, 0, +SCM_DEFINE (scm_merge, "merge", 3, 0, 0, (SCM alist, SCM blist, SCM less), "Merge two already sorted lists into one.\n" "Given two lists @var{alist} and @var{blist}, such that\n" @@ -275,7 +274,7 @@ SCM_DEFINE (scm_merge, "merge", 3, 0, 0, #undef FUNC_NAME -static SCM +static SCM scm_merge_list_x (SCM alist, SCM blist, long alen, long blen, SCM less) @@ -327,7 +326,7 @@ scm_merge_list_x (SCM alist, SCM blist, } /* scm_merge_list_x */ -SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, +SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, (SCM alist, SCM blist, SCM less), "Takes two lists @var{alist} and @var{blist} such that\n" "@code{(sorted? alist less?)} and @code{(sorted? blist less?)} and\n" @@ -358,7 +357,7 @@ SCM_DEFINE (scm_merge_x, "merge!", 3, 0, 0, scsh's merge-sort but that algorithm showed to not be stable, even though it claimed to be. */ -static SCM +static SCM scm_merge_list_step (SCM * seq, SCM less, long n) { SCM a, b; @@ -406,7 +405,7 @@ scm_merge_list_step (SCM * seq, SCM less, long n) } while (0) -SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, +SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, (SCM items, SCM less), "Sort the sequence @var{items}, which may be a list or a\n" "vector. @var{less} is used for comparing the sequence\n" @@ -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) { + 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, less, - scm_from_int (0), - scm_array_length (items)); + scm_from_ssize_t (dims[0].lbnd), + scm_from_ssize_t (dims[0].ubnd+1)); + + scm_array_handle_release (&handle); return items; } else @@ -439,7 +451,7 @@ SCM_DEFINE (scm_sort_x, "sort!", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_sort, "sort", 2, 0, 0, +SCM_DEFINE (scm_sort, "sort", 2, 0, 0, (SCM items, SCM less), "Sort the sequence @var{items}, which may be a list or a\n" "vector. @var{less} is used for comparing the sequence\n" @@ -525,7 +537,7 @@ scm_merge_vector_step (SCM *vec, } /* scm_merge_vector_step */ -SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, +SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, (SCM items, SCM less), "Sort the sequence @var{items}, which may be a list or a\n" "vector. @var{less} is used for comparing the sequence elements.\n" @@ -551,7 +563,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, SCM temp, *temp_elts, *vec_elts; size_t len; ssize_t inc; - + vec_elts = scm_vector_writable_elements (items, &vec_handle, &len, &inc); if (len == 0) @@ -559,7 +571,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, scm_array_handle_release (&vec_handle); return items; } - + temp = scm_c_make_vector (len, SCM_UNDEFINED); temp_elts = scm_vector_writable_elements (temp, &temp_handle, NULL, NULL); @@ -577,7 +589,7 @@ SCM_DEFINE (scm_stable_sort_x, "stable-sort!", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, +SCM_DEFINE (scm_stable_sort, "stable-sort", 2, 0, 0, (SCM items, SCM less), "Sort the sequence @var{items}, which may be a list or a\n" "vector. @var{less} is used for comparing the sequence elements.\n" @@ -613,7 +625,7 @@ SCM_DEFINE (scm_sort_list_x, "sort-list!", 2, 0, 0, #undef FUNC_NAME -SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, +SCM_DEFINE (scm_sort_list, "sort-list", 2, 0, 0, (SCM items, SCM less), "Sort the list @var{items}, using @var{less} for comparing the\n" "list elements. This is a stable sort.") diff --git a/module/Makefile.am b/module/Makefile.am index d5896bdd8..ec01b456e 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -44,6 +44,7 @@ ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm SOURCES = \ ice-9/and-let-star.scm \ + ice-9/arrays.scm \ ice-9/atomic.scm \ ice-9/binary-ports.scm \ ice-9/boot-9.scm \ diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm index f7f9e5eed..2c04b2ef8 100644 --- a/module/ice-9/arrays.scm +++ b/module/ice-9/arrays.scm @@ -1,22 +1,32 @@ -;;; 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. -;;;; -;;;; 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 -;;;; +(define-module (ice-9 arrays) + #:export (array-copy)) + +; This is actually defined in boot-9.scm, apparently for b.c. +;; (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)) -(define (array-shape a) - (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) - (array-dimensions a))) diff --git a/test-suite/tests/sort.test b/test-suite/tests/sort.test index fa1ffd0b6..dbb43c966 100644 --- a/test-suite/tests/sort.test +++ b/test-suite/tests/sort.test @@ -1,25 +1,57 @@ ;;;; 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 ;;;; 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 -(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" @@ -32,67 +64,72 @@ (sort '(1 2) (lambda (x y z) z))) (pass-if "sort of vector" - (let* ((v (randomize-vector! (make-vector 1000) 1000)) - (w (vector-copy v))) - (and (sorted? (sort v <) <) - (equal? w v)))) + (test-sort! (make-vector 100))) - (pass-if "sort of typed array" - (let* ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99)) - (w (make-typed-array 'f64 *unspecified* 99))) - (array-copy! v w) - (and (sorted? (sort v <) <) - (equal? w v)))) + (pass-if "sort of typed vector" + (test-sort! (make-f64vector 100)))) - (pass-if "sort! of vector" - (let ((v (randomize-vector! (make-vector 1000) 1000))) - (sorted? (sort! v <) <))) - (pass-if "sort! of typed array" - (let ((v (randomize-vector! (make-typed-array 'f64 *unspecified* 99) 99))) - (sorted? (sort! v <) <))) +(with-test-prefix "sort!" - (pass-if "sort! of non-contigous vector" - (let* ((a (make-array 0 1000 3)) - (v (make-shared-array a (lambda (i) (list i 0)) 1000))) - (randomize-vector! v 1000) - (sorted? (sort! v <) <))) + (pass-if "sort of empty vector" + (test-sort-inplace! (vector))) + + (pass-if "sort of vector" + (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" (let* ((a (make-typed-array 'f64 0 99 3)) (v (make-shared-array a (lambda (i) (list i 0)) 99))) - (randomize-vector! v 99) - (sorted? (sort! v <) <))) + (test-sort-inplace! v))) - (pass-if "sort! of negative-increment vector" - (let* ((a (make-array 0 1000 3)) - (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) - (randomize-vector! v 1000) - (sorted? (sort! v <) <))) + (pass-if "sort! of negative-increment array" + (let* ((a (make-array 0 100 3)) + (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100))) + (test-sort-inplace! 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" (let* ((a (make-typed-array 'f64 0 99 3)) (v (make-shared-array a (lambda (i) (list (- 98 i) 0)) 99))) - (randomize-vector! v 99) - (sorted? (sort! v <) <)))) + (test-sort-inplace! v)))) + (with-test-prefix "stable-sort!" (pass-if "stable-sort!" - (let ((v (randomize-vector! (make-vector 1000) 1000))) - (sorted? (stable-sort! v <) <))) + (let ((v (make-vector 100))) + (test-sort-inplace! v stable-sort!))) - (pass-if "stable-sort! of non-contigous vector" - (let* ((a (make-array 0 1000 3)) - (v (make-shared-array a (lambda (i) (list i 0)) 1000))) - (randomize-vector! v 1000) - (sorted? (stable-sort! v <) <))) + (pass-if "stable-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 stable-sort!))) + + (pass-if "stable-sort! of negative-increment array" + (let* ((a (make-array 0 100 3)) + (v (make-shared-array a (lambda (i) (list (- 99 i) 0)) 100))) + (test-sort-inplace! v stable-sort!))) + + (pass-if "stable-sort! of non-zero base index array" + (test-sort-inplace! (make-array 0 '(-99 0)) stable-sort!))) - (pass-if "stable-sort! of negative-increment vector" - (let* ((a (make-array 0 1000 3)) - (v (make-shared-array a (lambda (i) (list (- 999 i) 0)) 1000))) - (randomize-vector! v 1000) - (sorted? (stable-sort! v <) <)))) (with-test-prefix "stable-sort" From f52fc0566feabe4f1d3ba630287a418606ac30f9 Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Mon, 13 Feb 2017 13:49:35 +0100 Subject: [PATCH 7/8] Support non-zero lower bounds in array-slice-for-each * libguile/array-handle.c (scm_array_handle_writable_elements): Fix error message. * libguile/array-map.c (scm_array_slice_for_each): Support non-zero lower bounds. Fix error messages. * test-suite/tests/array-map.test: Test scm_array_slice_for_each with non-zero lower bound argument. --- libguile/array-map.c | 22 +++++++++------------- test-suite/tests/array-map.test | 8 ++++++++ 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/libguile/array-map.c b/libguile/array-map.c index 651a1bfb9..29e4aa785 100644 --- a/libguile/array-map.c +++ b/libguile/array-map.c @@ -679,6 +679,7 @@ SCM_DEFINE (scm_array_slice_for_each, "array-slice-for-each", 2, 0, 1, "@end lisp") #define FUNC_NAME s_scm_array_slice_for_each { + SCM xargs = args; int const N = scm_ilength (args); int const frank = scm_to_int (frame_rank); 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"); #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); as[n] = scm_array_handle_dims(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 */ msg = NULL; if (frank<0) - msg = "bad frame rank"; + msg = "bad frame rank ~S, ~S"; else { for (n=0; n!=N; ++n) { if (rank[n]typed-array 'f64 2 '((9 1) (7 8)))) From e0bcda4ad940c4e15679cc2b229838b33acdd36c Mon Sep 17 00:00:00 2001 From: Daniel Llorens Date: Tue, 21 Feb 2017 12:23:35 +0100 Subject: [PATCH 8/8] Fix bitvectors and non-zero lower bound arrays in truncated-print * module/ice-9/arrays.scm (array-print-prefix): New private function. * libguile/arrays.c (scm_i_print_array): Reuse (array-print-prefix) from (ice-9 arrays). Make sure to release the array handle. * module/ice-9/pretty-print.scm (truncated-print): Support bitvectors. Don't try to guess the array prefix but call array-print-prefix from (ice-9 arrays) instead. Fix call to print-sequence to support non-zero lower bound arrays. * test-suite/tests/arrays.test: Test that arrays print properly. * test-suite/tests/print.test: Test truncated-print with bitvectors, non-zero lower bound arrays. --- libguile/arrays.c | 48 ++++++----------------------- module/ice-9/arrays.scm | 40 +++++++++++++++++++++++- module/ice-9/pretty-print.scm | 24 ++++++++++----- test-suite/tests/arrays.test | 55 ++++++++++++++++++++++++++++++++- test-suite/tests/print.test | 58 ++++++++++++++++++++++++++++++----- 5 files changed, 169 insertions(+), 56 deletions(-) diff --git a/libguile/arrays.c b/libguile/arrays.c index 8b8bc48cd..682fbf6b2 100644 --- a/libguile/arrays.c +++ b/libguile/arrays.c @@ -908,50 +908,17 @@ scm_i_print_array_dimension (scm_t_array_handle *h, int dim, int pos, return 1; } -/* Print an array. -*/ - int scm_i_print_array (SCM array, SCM port, scm_print_state *pstate) { scm_t_array_handle h; - size_t i; - int print_lbnds = 0, zero_size = 0, print_lens = 0; + int d; + scm_call_2 (scm_c_private_ref ("ice-9 arrays", "array-print-prefix"), + array, port); + 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) { /* 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_i_print_array_dimension (&h, 0, 0, port, pstate); scm_putc (')', port); - return 1; + d = 1; } 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 diff --git a/module/ice-9/arrays.scm b/module/ice-9/arrays.scm index 2c04b2ef8..f03eb351b 100644 --- a/module/ice-9/arrays.scm +++ b/module/ice-9/arrays.scm @@ -17,9 +17,13 @@ ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA (define-module (ice-9 arrays) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) #:export (array-copy)) -; This is actually defined in boot-9.scm, apparently for b.c. +;; This is actually defined in boot-9.scm, apparently for backwards +;; compatibility. + ;; (define (array-shape a) ;; (map (lambda (ind) (if (number? ind) (list 0 (+ -1 ind)) ind)) ;; (array-dimensions a))) @@ -30,3 +34,37 @@ (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?)))))))) diff --git a/module/ice-9/pretty-print.scm b/module/ice-9/pretty-print.scm index d3d765202..f90e15d38 100644 --- a/module/ice-9/pretty-print.scm +++ b/module/ice-9/pretty-print.scm @@ -429,17 +429,25 @@ sub-expression, via the @var{breadth-first?} keyword argument." (display ")")) (else (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))) (let* ((type (array-type x)) (prefix (if inner? "" - (if (zero? (array-rank x)) - (string-append "#0" (if (eq? #t type) "" (symbol->string type))) - (let ((s (format #f "~a" - (apply make-typed-array type *unspecified* - (make-list (array-rank x) 0))))) - (substring s 0 (- (string-length s) 2)))))) + (call-with-output-string + (lambda (s) ((@@ (ice-9 arrays) array-print-prefix) x s))))) (width-prefix (string-length prefix))) (cond ((>= width (+ 2 width-prefix ellipsis-width)) @@ -447,7 +455,9 @@ sub-expression, via the @var{breadth-first?} keyword argument." (if (zero? (array-rank x)) (print (array-ref x) (- width width-prefix 2)) (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)))) (display ")")) (else diff --git a/test-suite/tests/arrays.test b/test-suite/tests/arrays.test index 1df77b1ba..e913e30a2 100644 --- a/test-suite/tests/arrays.test +++ b/test-suite/tests/arrays.test @@ -999,4 +999,57 @@ "#1(b c)" (format #f "~a" (make-shared-array #(a b c) (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))))) + diff --git a/test-suite/tests/print.test b/test-suite/tests/print.test index 82cc77603..f2e31451c 100644 --- a/test-suite/tests/print.test +++ b/test-suite/tests/print.test @@ -147,6 +147,35 @@ (pass-if-equal "#" (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(#)" (tprint (make-typed-array #t 9.0) 6 "UTF-8")) @@ -162,18 +191,31 @@ (pass-if-equal "#" (tprint (make-typed-array 's32 0 20 20) 7 "UTF-8")) - (pass-if-equal "#2s32(…)" - (tprint (make-typed-array 's32 0 20 20) 8 "UTF-8")) + ;; higher dimensional arrays - (pass-if-equal "#2s32(# …)" - (tprint (make-typed-array 's32 0 20 20) 10 "UTF-8")) + (let ((testa (make-typed-array 's32 0 20 20))) + (pass-if-equal "#2s32(…)" + (tprint testa 8 "UTF-8")) - (pass-if-equal "#2s32((…) …)" - (tprint (make-typed-array 's32 0 20 20) 12 "UTF-8")) + (pass-if-equal "#2s32(# …)" + (tprint testa 10 "UTF-8")) - (pass-if-equal "#2s32((0 …) …)" - (tprint (make-typed-array 's32 0 20 20) 14 "UTF-8")) + (pass-if-equal "#2s32((…) …)" + (tprint testa 12 "UTF-8")) + (pass-if-equal "#2s32((0 …) …)" + (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)))" (tprint (make-typed-array #t (make-typed-array #t 9 2) 2 2) 40 "UTF-8"))