Merge branch 'master' into boehm-demers-weiser-gc

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)

benchmark-suite/Makefile.am

@@ -1,8 +1,9 @@
-SCM_BENCHMARKS = benchmarks/0-reference.bm	\
+SCM_BENCHMARKS = benchmarks/0-reference.bm		\
-	         benchmarks/continuations.bm	\
+	         benchmarks/continuations.bm		\
-                 benchmarks/if.bm		\
+                 benchmarks/if.bm			\
-                 benchmarks/logand.bm		\
+                 benchmarks/logand.bm			\
-		 benchmarks/read.bm
+		 benchmarks/read.bm			\
+		 benchmarks/uniform-vector-read.bm
 
 EXTRA_DIST = guile-benchmark lib.scm $(SCM_BENCHMARKS)	\
 	     ChangeLog-2008

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))))

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

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))
     {

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))
+  /* Take bytes first from the port's read buffer. */
-    {
+  if (pt->read_pos < pt->read_end)
-      if (scm_fill_input (port) == EOF)
-	return 0;
-    }
-  
-  n_available = pt->read_end - pt->read_pos;
-  
-  while (n_available < size)
     {
+      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);
+  /* Avoid the scm_dynwind_* costs if we now have enough data. */
-  pt->read_pos += size;
+  if (size == 0)
+    return n_read;
 
-  return n_read + size;
+  /* 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;
 }
 #undef FUNC_NAME
 

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
 

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)
+      remaining -= scm_c_read (port_or_fd, base + off, remaining);
-	{
+      if (remaining % sz != 0)
-	  if (pt->read_pos < pt->read_end)
+        SCM_MISC_ERROR ("unexpected EOF", SCM_EOL);
-	    {
+      ans -= remaining / sz;
-	      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;
     }
   else /* file descriptor.  */
     {

libguile/strings.c

@@ -204,6 +204,12 @@ get_str_buf_start (SCM *str, SCM *buf, size_t *start)
   *buf = STRING_STRINGBUF (*str);
 }
 
+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)
 {
@@ -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;
+  SCM result;
-  size_t str_start;
+
-  get_str_buf_start (&str, &buf, &str_start);
+  if (SCM_UNLIKELY (STRING_LENGTH (str) == 0))
-  scm_i_pthread_mutex_lock (&stringbuf_write_mutex);
+    /* We want the empty string to be `eq?' with the read-only empty
-  SET_STRINGBUF_SHARED (buf);
+       string.  */
-  scm_i_pthread_mutex_unlock (&stringbuf_write_mutex);
+    result = str;
-  return scm_double_cell (RO_STRING_TAG, SCM_UNPACK(buf),
+  else
-			  (scm_t_bits)str_start + start,
+    {
-			  (scm_t_bits) end - start);
+      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);
 }
 

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 */
 

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"

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"
 

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)))