Make VM string literals immutable.

* libguile/strings.c (scm_i_make_string, scm_i_make_wide_string): Add
  `read_only_p' parameter.  All callers updated.

* libguile/vm-i-loader.c (load_string, load_wide_string): Push read-only
  strings.

* test-suite/tests/strings.test ("literals"): New test prefix.

libguile/deprecated.c

@@ -2281,7 +2281,7 @@ scm_allocate_string (size_t len)
 {
   scm_c_issue_deprecation_warning
     ("`scm_allocate_string' is deprecated. Use scm_c_make_string instead.");
-  return scm_i_make_string (len, NULL);
+  return scm_i_make_string (len, NULL, 0);
 }
 
 SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0, 

libguile/goops.c

@@ -670,7 +670,7 @@ SCM_DEFINE (scm_sys_prep_layout_x, "%prep-layout!", 1, 0, 0,
     SCM_MISC_ERROR ("class object doesn't have enough fields: ~S",
 		    scm_list_1 (nfields));
 
-  layout = scm_i_make_string (n, &s);
+  layout = scm_i_make_string (n, &s, 0);
   i = 0;
   while (scm_is_pair (getters_n_setters))
     {

libguile/i18n.c

@@ -1252,7 +1252,7 @@ str_to_case (SCM str, scm_t_locale c_locale,
       return NULL;
     }
 
-  convstr = scm_i_make_wide_string (convlen, &c_buf);
+  convstr = scm_i_make_wide_string (convlen, &c_buf, 0);
   memcpy (c_buf, c_convstr, convlen * sizeof (scm_t_wchar));
   free (c_convstr);
 

libguile/ports.c

@@ -352,7 +352,7 @@ SCM_DEFINE (scm_drain_input, "drain-input", 1, 0, 0,
 
   if (count)
     {
-      result = scm_i_make_string (count, &data);
+      result = scm_i_make_string (count, &data, 0);
       scm_take_from_input_buffers (port, data, count);
     }
   else

libguile/read.c

@@ -516,7 +516,7 @@ scm_read_string (int chr, SCM port)
   unsigned c_str_len = 0;
   scm_t_wchar c;
 
-  str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+  str = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
   while ('"' != (c = scm_getc (port)))
     {
       if (c == EOF)
@@ -528,7 +528,7 @@ scm_read_string (int chr, SCM port)
 
       if (c_str_len + 1 >= scm_i_string_length (str))
         {
-          SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL);
+          SCM addy = scm_i_make_string (READER_STRING_BUFFER_SIZE, NULL, 0);
 
           str = scm_string_append (scm_list_2 (str, addy));
         }
@@ -1232,7 +1232,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
      So here, CHR is expected to be `{'.  */
   int saw_brace = 0, finished = 0;
   size_t len = 0;
-  SCM buf = scm_i_make_string (1024, NULL);
+  SCM buf = scm_i_make_string (1024, NULL, 0);
 
   buf = scm_i_string_start_writing (buf);
 
@@ -1262,7 +1262,7 @@ scm_read_extended_symbol (scm_t_wchar chr, SCM port)
 	  SCM addy;
 
 	  scm_i_string_stop_writing ();
-	  addy = scm_i_make_string (1024, NULL);
+	  addy = scm_i_make_string (1024, NULL, 0);
 	  buf = scm_string_append (scm_list_2 (buf, addy));
 	  len = 0;
 	  buf = scm_i_string_start_writing (buf);

libguile/socket.c

@@ -1426,7 +1426,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
 	 "use a bytevector instead.");
 
       len = scm_i_string_length (buf);
-      msg = scm_i_make_string (len, &dest);
+      msg = scm_i_make_string (len, &dest, 0);
       SCM_SYSCALL (rv = recv (fd, dest, len, flg));
       scm_string_copy_x (buf, scm_from_int (0),
 			 msg, scm_from_int (0), scm_from_size_t (len));

libguile/srfi-13.c

@@ -251,14 +251,14 @@ SCM_DEFINE (scm_string_tabulate, "string-tabulate", 2, 0, 0,
     if (wide)
       {
         scm_t_wchar *wbuf = NULL;
-        res = scm_i_make_wide_string (clen, &wbuf);
+        res = scm_i_make_wide_string (clen, &wbuf, 0);
         memcpy (wbuf, buf, clen * sizeof (scm_t_wchar));
         free (buf);
       }
     else
       {
         char *nbuf = NULL;
-        res = scm_i_make_string (clen, &nbuf);
+        res = scm_i_make_string (clen, &nbuf, 0);
         for (i = 0; i < clen; i ++)
           nbuf[i] = (unsigned char) buf[i];
         free (buf);
@@ -336,7 +336,7 @@ SCM_DEFINE (scm_reverse_list_to_string, "reverse-list->string", 1, 0, 0,
 
   if (i < 0)
     SCM_WRONG_TYPE_ARG (1, chrs);
-  result = scm_i_make_string (i, &data);
+  result = scm_i_make_string (i, &data, 0);
 
   {
     SCM rest;
@@ -439,7 +439,7 @@ SCM_DEFINE (scm_string_join, "string-join", 1, 2, 0,
     SCM_MISC_ERROR ("strict-infix grammar requires non-empty list",
 		    SCM_EOL);
 
-  result = scm_i_make_string (0, NULL);
+  result = scm_i_make_string (0, NULL, 0);
 
   tmp = ls;
   switch (gram)
@@ -2486,7 +2486,7 @@ SCM_DEFINE (scm_string_map, "string-map", 2, 2, 0,
   MY_VALIDATE_SUBSTRING_SPEC (2, s,
 			      3, start, cstart,
 			      4, end, cend);
-  result = scm_i_make_string (cend - cstart, NULL);
+  result = scm_i_make_string (cend - cstart, NULL, 0);
   p = 0;
   while (cstart < cend)
     {
@@ -2624,7 +2624,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
       ans = base;
     }
   else
-    ans = scm_i_make_string (0, NULL);
+    ans = scm_i_make_string (0, NULL, 0);
   if (!SCM_UNBNDP (make_final))
     SCM_VALIDATE_PROC (6, make_final);
 
@@ -2636,7 +2636,7 @@ SCM_DEFINE (scm_string_unfold, "string-unfold", 4, 2, 0,
       SCM ch = scm_call_1 (f, seed);
       if (!SCM_CHARP (ch))
 	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
-      str = scm_i_make_string (1, NULL);
+      str = scm_i_make_string (1, NULL, 0);
       str = scm_i_string_start_writing (str);
       scm_i_string_set_x (str, i, SCM_CHAR (ch));
       scm_i_string_stop_writing ();
@@ -2690,7 +2690,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
       ans = base;
     }
   else
-    ans = scm_i_make_string (0, NULL);
+    ans = scm_i_make_string (0, NULL, 0);
   if (!SCM_UNBNDP (make_final))
     SCM_VALIDATE_PROC (6, make_final);
 
@@ -2702,7 +2702,7 @@ SCM_DEFINE (scm_string_unfold_right, "string-unfold-right", 4, 2, 0,
       SCM ch = scm_call_1 (f, seed);
       if (!SCM_CHARP (ch))
 	SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
-      str = scm_i_make_string (1, NULL);
+      str = scm_i_make_string (1, NULL, 0);
       str = scm_i_string_start_writing (str);
       scm_i_string_set_x (str, i, SCM_CHAR (ch));
       scm_i_string_stop_writing ();
@@ -2817,7 +2817,7 @@ SCM_DEFINE (scm_xsubstring, "xsubstring", 2, 3, 0,
   if (cstart == cend && cfrom != cto)
     SCM_MISC_ERROR ("start and end indices must not be equal", SCM_EOL);
 
-  result = scm_i_make_string (cto - cfrom, NULL);
+  result = scm_i_make_string (cto - cfrom, NULL, 0);
   result = scm_i_string_start_writing (result);
 
   p = 0;
@@ -3129,7 +3129,7 @@ SCM_DEFINE (scm_string_filter, "string-filter", 2, 2, 0,
       else
         {
           size_t dst = 0;
-          result = scm_i_make_string (count, NULL);
+          result = scm_i_make_string (count, NULL, 0);
 	  result = scm_i_string_start_writing (result);
 
           /* decrement "count" in this loop as well as using idx, so that if
@@ -3239,7 +3239,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
         {
 	  int i = 0;
           /* new string for retained portion */
-          result = scm_i_make_string (count, NULL); 
+          result = scm_i_make_string (count, NULL, 0); 
           result = scm_i_string_start_writing (result);
           /* decrement "count" in this loop as well as using idx, so that if
              another thread is simultaneously changing "s" there's no chance
@@ -3281,7 +3281,7 @@ SCM_DEFINE (scm_string_delete, "string-delete", 2, 2, 0,
         {
 	  size_t i = 0;
           /* new string for retained portion */
-          result = scm_i_make_string (count, NULL);
+          result = scm_i_make_string (count, NULL, 0);
 	  result = scm_i_string_start_writing (result);
 
           /* decrement "count" in this loop as well as using idx, so that if

libguile/srfi-14.c

@@ -1515,9 +1515,9 @@ SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
 
   count = scm_to_int (scm_char_set_size (cs));
   if (wide)
-    result = scm_i_make_wide_string (count, &wbuf);
+    result = scm_i_make_wide_string (count, &wbuf, 0);
   else
-    result = scm_i_make_string (count, &buf);
+    result = scm_i_make_string (count, &buf, 0);
 
   for (k = 0; k < cs_data->len; k++)
     for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)

libguile/strings.c

@@ -262,30 +262,34 @@ SCM scm_nullstr;
 
 /* Create a scheme string with space for LEN 8-bit Latin-1-encoded
    characters.  CHARSP, if not NULL, will be set to location of the
-   char array.  */
+   char array.  If READ_ONLY_P, the returned string is read-only;
+   otherwise it is writable.  */
 SCM
-scm_i_make_string (size_t len, char **charsp)
+scm_i_make_string (size_t len, char **charsp, int read_only_p)
 {
   SCM buf = make_stringbuf (len);
   SCM res;
   if (charsp)
     *charsp = (char *) STRINGBUF_CHARS (buf);
-  res = scm_double_cell (STRING_TAG, SCM_UNPACK(buf),
+  res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
-			 (scm_t_bits)0, (scm_t_bits) len);
+			 SCM_UNPACK (buf),
+			 (scm_t_bits) 0, (scm_t_bits) len);
   return res;
 }
 
 /* Create a scheme string with space for LEN 32-bit UCS-4-encoded
    characters.  CHARSP, if not NULL, will be set to location of the
-   character array.  */
+   character array.  If READ_ONLY_P, the returned string is read-only;
+   otherwise it is writable.  */
 SCM
-scm_i_make_wide_string (size_t len, scm_t_wchar **charsp)
+scm_i_make_wide_string (size_t len, scm_t_wchar **charsp, int read_only_p)
 {
   SCM buf = make_wide_stringbuf (len);
   SCM res;
   if (charsp)
     *charsp = STRINGBUF_WIDE_CHARS (buf);
-  res = scm_double_cell (STRING_TAG, SCM_UNPACK (buf),
+  res = scm_double_cell (read_only_p ? RO_STRING_TAG : STRING_TAG,
+			 SCM_UNPACK (buf),
                          (scm_t_bits) 0, (scm_t_bits) len);
   return res;
 }
@@ -889,7 +893,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       char *cbuf;
-      SCM sbc = scm_i_make_string (len, &cbuf);
+      SCM sbc = scm_i_make_string (len, &cbuf, 0);
       memcpy (cbuf, STRINGBUF_CHARS (buf), len);
       e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
                      sbc);
@@ -898,7 +902,7 @@ SCM_DEFINE (scm_sys_string_dump, "%string-dump", 1, 0, 0, (SCM str),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       scm_t_wchar *cbuf;
-      SCM sbc = scm_i_make_wide_string (len, &cbuf);
+      SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
       u32_cpy ((scm_t_uint32 *) cbuf, 
                (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
       e6 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
@@ -962,7 +966,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       char *cbuf;
-      SCM sbc = scm_i_make_string (len, &cbuf);
+      SCM sbc = scm_i_make_string (len, &cbuf, 0);
       memcpy (cbuf, STRINGBUF_CHARS (buf), len);
       e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
                      sbc);
@@ -971,7 +975,7 @@ SCM_DEFINE (scm_sys_symbol_dump, "%symbol-dump", 1, 0, 0, (SCM sym),
     {
       size_t len = STRINGBUF_LENGTH (buf);
       scm_t_wchar *cbuf;
-      SCM sbc = scm_i_make_wide_string (len, &cbuf);
+      SCM sbc = scm_i_make_wide_string (len, &cbuf, 0);
       u32_cpy ((scm_t_uint32 *) cbuf, 
                (scm_t_uint32 *) STRINGBUF_WIDE_CHARS (buf), len);
       e4 = scm_cons (scm_from_latin1_symbol ("stringbuf-chars"),
@@ -1066,7 +1070,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
     {
       char *buf;
 
-      result = scm_i_make_string (len, NULL);
+      result = scm_i_make_string (len, NULL, 0);
       result = scm_i_string_start_writing (result);
       buf = scm_i_string_writable_chars (result);
       while (len > 0 && scm_is_pair (rest))
@@ -1083,7 +1087,7 @@ SCM_DEFINE (scm_string, "string", 0, 0, 1,
     {
       scm_t_wchar *buf;
 
-      result = scm_i_make_wide_string (len, NULL);
+      result = scm_i_make_wide_string (len, NULL, 0);
       result = scm_i_string_start_writing (result);
       buf = scm_i_string_writable_wide_chars (result);
       while (len > 0 && scm_is_pair (rest))
@@ -1125,7 +1129,7 @@ scm_c_make_string (size_t len, SCM chr)
 {
   size_t p;
   char *contents = NULL;
-  SCM res = scm_i_make_string (len, &contents);
+  SCM res = scm_i_make_string (len, &contents, 0);
 
   /* If no char is given, initialize string contents to NULL.  */
   if (SCM_UNBNDP (chr))
@@ -1372,9 +1376,9 @@ SCM_DEFINE (scm_string_append, "string-append", 0, 0, 1,
     }
   data.narrow = NULL;
   if (!wide)
-    res = scm_i_make_string (len, &data.narrow);
+    res = scm_i_make_string (len, &data.narrow, 0);
   else
-    res = scm_i_make_wide_string (len, &data.wide);
+    res = scm_i_make_wide_string (len, &data.wide, 0);
 
   for (l = args; !scm_is_null (l); l = SCM_CDR (l))
     {
@@ -1463,7 +1467,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
     {
       /* If encoding is null, use Latin-1.  */
       char *buf;
-      res = scm_i_make_string (len, &buf);
+      res = scm_i_make_string (len, &buf, 0);
       memcpy (buf, str, len);
       return res;
     }
@@ -1502,7 +1506,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
   if (!wide)
     {
       char *dst;
-      res = scm_i_make_string (u32len, &dst);
+      res = scm_i_make_string (u32len, &dst, 0);
       for (i = 0; i < u32len; i ++)
         dst[i] = (unsigned char) u32[i];
       dst[u32len] = '\0';
@@ -1510,7 +1514,7 @@ scm_from_stringn (const char *str, size_t len, const char *encoding,
   else
     {
       scm_t_wchar *wdst;
-      res = scm_i_make_wide_string (u32len, &wdst);
+      res = scm_i_make_wide_string (u32len, &wdst, 0);
       u32_cpy ((scm_t_uint32 *) wdst, (scm_t_uint32 *) u32, u32len);
       wdst[u32len] = 0;
     }
@@ -1548,7 +1552,7 @@ scm_from_latin1_stringn (const char *str, size_t len)
     len = strlen (str);
 
   /* Make a narrow string and copy STR as is.  */
-  result = scm_i_make_string (len, &buf);
+  result = scm_i_make_string (len, &buf, 0);
   memcpy (buf, str, len);
 
   return result;
@@ -1581,7 +1585,7 @@ scm_from_utf32_stringn (const scm_t_wchar *str, size_t len)
   if (len == (size_t) -1)
     len = u32_strlen ((uint32_t *) str);
 
-  result = scm_i_make_wide_string (len, &buf);
+  result = scm_i_make_wide_string (len, &buf, 0);
   memcpy (buf, str, len * sizeof (scm_t_wchar));
   scm_i_try_narrow_string (result);
 
@@ -1999,7 +2003,7 @@ normalize_str (SCM string, uninorm_t form)
 
   w_str = u32_normalize (form, w_str, len, NULL, &rlen);  
   
-  ret = scm_i_make_wide_string (rlen, &cbuf);
+  ret = scm_i_make_wide_string (rlen, &cbuf, 0);
   u32_cpy ((scm_t_uint32 *) cbuf, w_str, rlen);
   free (w_str);
 
@@ -2211,7 +2215,7 @@ SCM_VECTOR_IMPLEMENTATION (SCM_ARRAY_ELEMENT_TYPE_CHAR, scm_make_string)
 void
 scm_init_strings ()
 {
-  scm_nullstr = scm_i_make_string (0, NULL);
+  scm_nullstr = scm_i_make_string (0, NULL, 1);
 
 #include "libguile/strings.x"
 }

libguile/strings.h

@@ -177,8 +177,11 @@ SCM_API SCM scm_makfromstrs (int argc, char **argv);
 
 /* internal accessor functions.  Arguments must be valid. */
 
-SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap);
+SCM_INTERNAL SCM scm_i_make_string (size_t len, char **datap,
-SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap);
+				    int read_only_p);
+SCM_INTERNAL SCM scm_i_make_wide_string (size_t len, scm_t_wchar **datap,
+					 int read_only_p);
+SCM_INTERNAL SCM scm_i_set_string_read_only_x (SCM str);
 SCM_INTERNAL SCM scm_i_substring (SCM str, size_t start, size_t end);
 SCM_INTERNAL SCM scm_i_substring_read_only (SCM str, size_t start, size_t end);
 SCM_INTERNAL SCM scm_i_substring_shared (SCM str, size_t start, size_t end);

libguile/strports.c

@@ -357,7 +357,7 @@ scm_strport_to_string (SCM port)
   if (pt->encoding == NULL)
     {
       char *buf;
-      str = scm_i_make_string (pt->read_buf_size, &buf);
+      str = scm_i_make_string (pt->read_buf_size, &buf, 0);
       memcpy (buf, pt->read_buf, pt->read_buf_size);
     }
   else

libguile/vm-i-loader.c

@@ -40,7 +40,7 @@ VM_DEFINE_LOADER (102, load_string, "load-string")
 
   FETCH_LENGTH (len);
   SYNC_REGISTER ();
-  PUSH (scm_i_make_string (len, &buf));
+  PUSH (scm_i_make_string (len, &buf, 1));
   memcpy (buf, (char *) ip, len);
   ip += len;
   NEXT;
@@ -113,7 +113,7 @@ VM_DEFINE_LOADER (107, load_wide_string, "load-wide-string")
     }
 
   SYNC_REGISTER ();
-  PUSH (scm_i_make_wide_string (len / 4, &wbuf));
+  PUSH (scm_i_make_wide_string (len / 4, &wbuf, 1));
   memcpy ((char *) wbuf, (char *) ip, len);
   ip += len;
   NEXT;

test-suite/tests/strings.test

@@ -1,7 +1,8 @@
 ;;;; 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, 2008, 2009, 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 1999, 2001, 2004, 2005, 2006, 2008, 2009, 2010,
+;;;;   2011 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
@@ -18,6 +19,7 @@
 ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
 (define-module (test-strings)
+  #:use-module ((system base compile) #:select (compile))
   #:use-module (test-suite lib))
 
 (define exception:read-only-string
@@ -240,6 +242,24 @@
   (pass-if "symbol"
     (not (string? 'abc))))
 
+;;
+;; literals
+;;
+
+(with-test-prefix "literals"
+
+  ;; The "Storage Model" section of R5RS reads: "In such systems literal
+  ;; constants and the strings returned by `symbol->string' are
+  ;; immutable objects".  `eval' doesn't support it yet, but it doesn't
+  ;; really matter because `eval' doesn't coalesce repeated constants,
+  ;; unlike the bytecode compiler.
+
+  (pass-if-exception "literals are constant"
+    exception:read-only-string
+    (compile '(string-set! "literal string" 0 #\x)
+             #:from 'scheme
+             #:to 'value)))
+
 ;;
 ;; string-null?
 ;;