summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--NEWS3
-rw-r--r--benchmark-suite/Makefile.am11
-rw-r--r--benchmark-suite/benchmarks/uniform-vector-read.bm53
-rw-r--r--doc/ref/posix.texi3
-rw-r--r--libguile/numbers.c2
-rw-r--r--libguile/ports.c87
-rw-r--r--libguile/read.c2
-rw-r--r--libguile/srfi-4.c35
-rw-r--r--libguile/strings.c39
-rw-r--r--libguile/strings.h1
-rw-r--r--test-suite/tests/numbers.test5
-rw-r--r--test-suite/tests/strings.test8
-rw-r--r--test-suite/tests/symbols.test12
13 files changed, 182 insertions, 79 deletions
diff --git a/NEWS b/NEWS
index c83e2d675..b55620075 100644
--- a/NEWS
+++ b/NEWS
@@ -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)))