diff options
-rw-r--r-- | NEWS | 3 | ||||
-rw-r--r-- | benchmark-suite/Makefile.am | 11 | ||||
-rw-r--r-- | benchmark-suite/benchmarks/uniform-vector-read.bm | 53 | ||||
-rw-r--r-- | doc/ref/posix.texi | 3 | ||||
-rw-r--r-- | libguile/numbers.c | 2 | ||||
-rw-r--r-- | libguile/ports.c | 87 | ||||
-rw-r--r-- | libguile/read.c | 2 | ||||
-rw-r--r-- | libguile/srfi-4.c | 35 | ||||
-rw-r--r-- | libguile/strings.c | 39 | ||||
-rw-r--r-- | libguile/strings.h | 1 | ||||
-rw-r--r-- | test-suite/tests/numbers.test | 5 | ||||
-rw-r--r-- | test-suite/tests/strings.test | 8 | ||||
-rw-r--r-- | test-suite/tests/symbols.test | 12 |
13 files changed, 182 insertions, 79 deletions
@@ -63,6 +63,8 @@ available: Guile is now always configured in "maintainer mode". * Bugs fixed +** `symbol->string' now returns a read-only string, as per R5RS +** Literal strings as returned by `read' are now read-only, as per R5RS ** `guile-config link' now prints `-L$libdir' before `-lguile' ** Fix memory corruption involving GOOPS' `class-redefinition' ** Fix possible deadlock in `mutex-lock' @@ -71,6 +73,7 @@ available: Guile is now always configured in "maintainer mode". ** Fix build issue on hppa2.0w-hp-hpux11.11 (`dirent64' and `readdir64_r') ** Fix misleading output from `(help rationalize)' ** Fix build failure on Debian hppa architecture (bad stack growth detection) +** Fix `gcd' when called with a single, negative argument. Changes in 1.8.5 (since 1.8.4) diff --git a/benchmark-suite/Makefile.am b/benchmark-suite/Makefile.am index afd1e77bd..5357cf050 100644 --- a/benchmark-suite/Makefile.am +++ b/benchmark-suite/Makefile.am @@ -1,8 +1,9 @@ -SCM_BENCHMARKS = benchmarks/0-reference.bm \ - benchmarks/continuations.bm \ - benchmarks/if.bm \ - benchmarks/logand.bm \ - benchmarks/read.bm +SCM_BENCHMARKS = benchmarks/0-reference.bm \ + benchmarks/continuations.bm \ + benchmarks/if.bm \ + benchmarks/logand.bm \ + benchmarks/read.bm \ + benchmarks/uniform-vector-read.bm EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS) \ ChangeLog-2008 diff --git a/benchmark-suite/benchmarks/uniform-vector-read.bm b/benchmark-suite/benchmarks/uniform-vector-read.bm new file mode 100644 index 000000000..d288f0b44 --- /dev/null +++ b/benchmark-suite/benchmarks/uniform-vector-read.bm @@ -0,0 +1,53 @@ +;;; uniform-vector-read.bm --- Exercise binary I/O primitives. -*- Scheme -*- +;;; +;;; Copyright (C) 2008 Free Software Foundation, Inc. +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 2, or (at your option) +;;; any later version. +;;; +;;; This program 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this software; see the file COPYING. If not, write to +;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, +;;; Boston, MA 02110-1301 USA + +(define-module (benchmarks uniform-vector-read) + :use-module (benchmark-suite lib) + :use-module (srfi srfi-4)) + +(define file-name + (tmpnam)) + +(define %buffer-size + 7777) + +(define buf + (make-u8vector %buffer-size)) + +(define str + (make-string %buffer-size)) + + +(with-benchmark-prefix "uniform-vector-read!" + + (benchmark "uniform-vector-write" 500 + (let ((output (open-output-file file-name))) + (uniform-vector-write buf output) + (close output))) + + (benchmark "uniform-vector-read!" 500 + (let ((input (open-input-file file-name))) + (setvbuf input _IONBF) + (uniform-vector-read! buf input) + (close input))) + + (benchmark "string port" 5000 + (let ((input (open-input-string str))) + (uniform-vector-read! buf input) + (close input)))) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index a91bdb969..cb19a7af8 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -1263,9 +1263,6 @@ formatting. If @code{setlocale} has been called (@pxref{Locales}), month and day names are from the current locale and in the locale character set. - -Note that @samp{%Z} always ignores the @code{tm:zone} in @var{tm}; -instead it prints just the current zone (@code{tzset} above). @end deffn @deffn {Scheme Procedure} strptime format string diff --git a/libguile/numbers.c b/libguile/numbers.c index 0452e435c..7006cccb6 100644 --- a/libguile/numbers.c +++ b/libguile/numbers.c @@ -1022,7 +1022,7 @@ SCM scm_gcd (SCM x, SCM y) { if (SCM_UNBNDP (y)) - return SCM_UNBNDP (x) ? SCM_INUM0 : x; + return SCM_UNBNDP (x) ? SCM_INUM0 : scm_abs (x); if (SCM_I_INUMP (x)) { diff --git a/libguile/ports.c b/libguile/ports.c index bd0e0a630..f5aba1b21 100644 --- a/libguile/ports.c +++ b/libguile/ports.c @@ -28,6 +28,7 @@ #include <stdio.h> #include <errno.h> #include <fcntl.h> /* for chsize on mingw */ +#include <assert.h> #include <assert.h> @@ -1012,6 +1013,8 @@ scm_fill_input (SCM port) { scm_t_port *pt = SCM_PTAB_ENTRY (port); + assert (pt->read_pos == pt->read_end); + if (pt->read_buf == pt->putback_buf) { /* finished reading put-back chars. */ @@ -1074,12 +1077,39 @@ scm_lfwrite (const char *ptr, size_t size, SCM port) * * Warning: Doesn't update port line and column counts! */ +/* This structure, and the following swap_buffer function, are used + for temporarily swapping a port's own read buffer, and the buffer + that the caller of scm_c_read provides. */ +struct port_and_swap_buffer +{ + scm_t_port *pt; + unsigned char *buffer; + size_t size; +}; + +static void +swap_buffer (void *data) +{ + struct port_and_swap_buffer *psb = (struct port_and_swap_buffer *) data; + unsigned char *old_buf = psb->pt->read_buf; + size_t old_size = psb->pt->read_buf_size; + + /* Make the port use (buffer, size) from the struct. */ + psb->pt->read_pos = psb->pt->read_buf = psb->pt->read_end = psb->buffer; + psb->pt->read_buf_size = psb->size; + + /* Save the port's old (buffer, size) in the struct. */ + psb->buffer = old_buf; + psb->size = old_size; +} + size_t scm_c_read (SCM port, void *buffer, size_t size) #define FUNC_NAME "scm_c_read" { scm_t_port *pt; size_t n_read = 0, n_available; + struct port_and_swap_buffer psb; SCM_VALIDATE_OPINPORT (1, port); @@ -1090,35 +1120,52 @@ scm_c_read (SCM port, void *buffer, size_t size) if (pt->rw_random) pt->rw_active = SCM_PORT_READ; - if (SCM_READ_BUFFER_EMPTY_P (pt)) - { - if (scm_fill_input (port) == EOF) - return 0; - } - - n_available = pt->read_end - pt->read_pos; - - while (n_available < size) + /* Take bytes first from the port's read buffer. */ + if (pt->read_pos < pt->read_end) { + n_available = min (size, pt->read_end - pt->read_pos); memcpy (buffer, pt->read_pos, n_available); buffer = (char *) buffer + n_available; pt->read_pos += n_available; n_read += n_available; - - if (SCM_READ_BUFFER_EMPTY_P (pt)) - { - if (scm_fill_input (port) == EOF) - return n_read; - } - size -= n_available; - n_available = pt->read_end - pt->read_pos; } - memcpy (buffer, pt->read_pos, size); - pt->read_pos += size; + /* Avoid the scm_dynwind_* costs if we now have enough data. */ + if (size == 0) + return n_read; + + /* Now we will call scm_fill_input repeatedly until we have read the + requested number of bytes. (Note that a single scm_fill_input + call does not guarantee to fill the whole of the port's read + buffer.) For these calls, since we already have a buffer here to + read into, we bypass the port's own read buffer (if it has one), + by saving it off and modifying the port structure to point to our + own buffer. + + We need to make sure that the port's normal buffer is reinstated + in case one of the scm_fill_input () calls throws an exception; + we use the scm_dynwind_* API to achieve that. */ + psb.pt = pt; + psb.buffer = buffer; + psb.size = size; + scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE); + scm_dynwind_rewind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY); + scm_dynwind_unwind_handler (swap_buffer, &psb, SCM_F_WIND_EXPLICITLY); + + /* Call scm_fill_input until we have all the bytes that we need, or + we hit EOF. */ + while (pt->read_buf_size && (scm_fill_input (port) != EOF)) + { + pt->read_buf_size -= (pt->read_end - pt->read_pos); + pt->read_pos = pt->read_buf = pt->read_end; + } + n_read += pt->read_buf - (unsigned char *) buffer; + + /* Reinstate the port's normal buffer. */ + scm_dynwind_end (); - return n_read + size; + return n_read; } #undef FUNC_NAME diff --git a/libguile/read.c b/libguile/read.c index 47b80041e..abe1cb9ad 100644 --- a/libguile/read.c +++ b/libguile/read.c @@ -484,7 +484,7 @@ scm_read_string (int chr, SCM port) else str = (str == SCM_BOOL_F) ? scm_nullstr : str; - return str; + return scm_i_make_read_only_string (str); } #undef FUNC_NAME diff --git a/libguile/srfi-4.c b/libguile/srfi-4.c index b00fdaf28..3e43a4985 100644 --- a/libguile/srfi-4.c +++ b/libguile/srfi-4.c @@ -858,38 +858,11 @@ SCM_DEFINE (scm_uniform_vector_read_x, "uniform-vector-read!", 1, 3, 0, if (SCM_NIMP (port_or_fd)) { - scm_t_port *pt = SCM_PTAB_ENTRY (port_or_fd); - - if (pt->rw_active == SCM_PORT_WRITE) - scm_flush (port_or_fd); - ans = cend - cstart; - while (remaining > 0) - { - if (pt->read_pos < pt->read_end) - { - size_t to_copy = min (pt->read_end - pt->read_pos, - remaining); - - memcpy (base + off, pt->read_pos, to_copy); - pt->read_pos += to_copy; - remaining -= to_copy; - off += to_copy; - } - else - { - if (scm_fill_input (port_or_fd) == EOF) - { - if (remaining % sz != 0) - SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); - ans -= remaining / sz; - break; - } - } - } - - if (pt->rw_random) - pt->rw_active = SCM_PORT_READ; + remaining -= scm_c_read (port_or_fd, base + off, remaining); + if (remaining % sz != 0) + SCM_MISC_ERROR ("unexpected EOF", SCM_EOL); + ans -= remaining / sz; } else /* file descriptor. */ { diff --git a/libguile/strings.c b/libguile/strings.c index 69e2cc481..47a5cfe62 100644 --- a/libguile/strings.c +++ b/libguile/strings.c @@ -205,6 +205,12 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start) } SCM +scm_i_make_read_only_string (SCM str) +{ + return scm_i_substring_read_only (str, 0, STRING_LENGTH (str)); +} + +SCM scm_i_substring (SCM str, size_t start, size_t end) { SCM buf; @@ -221,15 +227,28 @@ scm_i_substring (SCM str, size_t start, size_t end) SCM scm_i_substring_read_only (SCM str, size_t start, size_t end) { - SCM buf; - size_t str_start; - get_str_buf_start (&str, &buf, &str_start); - scm_i_pthread_mutex_lock (&stringbuf_write_mutex); - SET_STRINGBUF_SHARED (buf); - scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf), - (scm_t_bits)str_start + start, - (scm_t_bits) end - start); + SCM result; + + if (SCM_UNLIKELY (STRING_LENGTH (str) == 0)) + /* We want the empty string to be `eq?' with the read-only empty + string. */ + result = str; + else + { + SCM buf; + size_t str_start; + + get_str_buf_start (&str, &buf, &str_start); + scm_i_pthread_mutex_lock (&stringbuf_write_mutex); + SET_STRINGBUF_SHARED (buf); + scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); + + result = scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf), + (scm_t_bits) str_start + start, + (scm_t_bits) end - start); + } + + return result; } SCM @@ -457,7 +476,7 @@ scm_i_symbol_substring (SCM sym, size_t start, size_t end) scm_i_pthread_mutex_lock (&stringbuf_write_mutex); SET_STRINGBUF_SHARED (buf); scm_i_pthread_mutex_unlock (&stringbuf_write_mutex); - return scm_double_cell (STRING_TAG, SCM_UNPACK(buf), + return scm_double_cell (RO_STRING_TAG, SCM_UNPACK (buf), (scm_t_bits)start, (scm_t_bits) end - start); } diff --git a/libguile/strings.h b/libguile/strings.h index e81ee3d98..186a731bd 100644 --- a/libguile/strings.h +++ b/libguile/strings.h @@ -143,6 +143,7 @@ SCM_INTERNAL void scm_i_get_substring_spec (size_t len, SCM start, size_t *cstart, SCM end, size_t *cend); SCM_INTERNAL SCM scm_i_take_stringbufn (char *str, size_t len); +SCM_INTERNAL SCM scm_i_make_read_only_string (SCM str); /* deprecated stuff */ diff --git a/test-suite/tests/numbers.test b/test-suite/tests/numbers.test index b28b4ef97..32627ed8c 100644 --- a/test-suite/tests/numbers.test +++ b/test-suite/tests/numbers.test @@ -1059,6 +1059,11 @@ (expect-fail "documented?" (documented? gcd)) + (with-test-prefix "(n)" + + (pass-if "n = -2" + (eqv? 2 (gcd -2)))) + (with-test-prefix "(0 n)" (pass-if "n = 0" diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test index aa9196e68..735258a24 100644 --- a/test-suite/tests/strings.test +++ b/test-suite/tests/strings.test @@ -1,7 +1,7 @@ ;;;; strings.test --- test suite for Guile's string functions -*- scheme -*- ;;;; Jim Blandy <jimb@red-bean.com> --- August 1999 ;;;; -;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -168,7 +168,11 @@ (pass-if-exception "read-only string" exception:read-only-string - (string-set! (substring/read-only "abc" 0) 1 #\space))) + (string-set! (substring/read-only "abc" 0) 1 #\space)) + + (pass-if-exception "literal string" + exception:read-only-string + (string-set! "an immutable string" 0 #\a))) (with-test-prefix "string-split" diff --git a/test-suite/tests/symbols.test b/test-suite/tests/symbols.test index b57667f7f..3fe3402f8 100644 --- a/test-suite/tests/symbols.test +++ b/test-suite/tests/symbols.test @@ -1,6 +1,6 @@ ;;;; symbols.test --- test suite for Guile's symbols -*- scheme -*- ;;;; -;;;; Copyright (C) 2001, 2006 Free Software Foundation, Inc. +;;;; Copyright (C) 2001, 2006, 2008 Free Software Foundation, Inc. ;;;; ;;;; This program is free software; you can redistribute it and/or modify ;;;; it under the terms of the GNU General Public License as published by @@ -17,17 +17,17 @@ ;;;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;;;; Boston, MA 02110-1301 USA -(use-modules (ice-9 documentation)) +(define-module (test-suite test-symbols) + #:use-module (test-suite lib) + #:use-module (ice-9 documentation)) ;;; ;;; miscellaneous ;;; -;; FIXME: As soon as guile supports immutable strings, this has to be -;; replaced with the appropriate error type and message. (define exception:immutable-string - (cons 'some-error-type "^trying to modify an immutable string")) + (cons 'misc-error "^string is read-only")) (define (documented? object) (not (not (object-documentation object)))) @@ -55,7 +55,7 @@ (with-test-prefix "symbol->string" - (expect-fail-exception "result is an immutable string" + (pass-if-exception "result is an immutable string" exception:immutable-string (string-set! (symbol->string 'abc) 1 #\space))) |