From be5c4a82abb13eb8e00368fe871bcc890a40e97b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Mon, 22 Sep 2008 23:03:20 +0200
Subject: [PATCH] Make literal strings (i.e., returned by `read') read-only.

* libguile/read.c (scm_read_string): Use `scm_i_make_read_only_string ()' to
  return a read-only string, as mandated by R5RS.  Reported by Bill
  Schottstaedt <bil@ccrma.Stanford.EDU>.

* libguile/strings.c (scm_i_make_read_only_string): New function.
  (scm_i_shared_substring_read_only): Special-case the empty string
  so that the read-only and read-write empty strings are `eq?'.  This
  optimization is relied on by the `substring/shared' `empty string'
  test case in `srfi-13.test'.

* libguile/strings.h (scm_i_make_read_only_string): New declaration.

* test-suite/tests/strings.test ("string-set!")["literal string"]: New test.

* NEWS: Update.
---
 NEWS                          |  1 +
 libguile/read.c               |  2 +-
 libguile/strings.c            | 37 ++++++++++++++++++++++++++---------
 libguile/strings.h            |  3 ++-
 test-suite/tests/strings.test |  8 ++++++--
 5 files changed, 38 insertions(+), 13 deletions(-)

diff --git a/NEWS b/NEWS
index 9f6e0eda0..796da625d 100644
--- a/NEWS
+++ b/NEWS
@@ -27,6 +27,7 @@ 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'
diff --git a/libguile/read.c b/libguile/read.c
index ff507354d..9600ecc49 100644
--- a/libguile/read.c
+++ b/libguile/read.c
@@ -514,7 +514,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/strings.c b/libguile/strings.c
index 7399d8831..ffc1eb312 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -217,6 +217,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)
 {
@@ -234,15 +240,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
diff --git a/libguile/strings.h b/libguile/strings.h
index dcc1f114f..a7427db45 100644
--- a/libguile/strings.h
+++ b/libguile/strings.h
@@ -3,7 +3,7 @@
 #ifndef SCM_STRINGS_H
 #define SCM_STRINGS_H
 
-/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006 Free Software Foundation, Inc.
+/* Copyright (C) 1995,1996,1997,1998,2000,2001, 2004, 2005, 2006, 2008 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
@@ -152,6 +152,7 @@ SCM_API void scm_i_get_substring_spec (size_t len,
 				       SCM start, size_t *cstart,
 				       SCM end, size_t *cend);
 SCM_API SCM scm_i_take_stringbufn (char *str, size_t len);
+SCM_API SCM scm_i_make_read_only_string (SCM str);
 
 /* deprecated stuff */
 
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"