mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-15 16:20:17 +02:00
Code Activity

Make VM string literals immutable.

Browse source 
* 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.
This commit is contained in:
Ludovic Courtès 2011-03-20 23:34:42 +01:00
parent 95c1cfb550
commit 190d4b0d93
13 changed files with 83 additions and 56 deletions
Download patch file Download diff file Expand all files Collapse all files

2
libguile/deprecated.c
View file

@ -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,

2
libguile/goops.c
View file

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

2
libguile/i18n.c
View file

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

2
libguile/ports.c
View file

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

8
libguile/read.c
View file

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

2
libguile/socket.c
View file

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

26
libguile/srfi-13.c
View file

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

4
libguile/srfi-14.c
View file

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

48
libguile/strings.c
View file

@ -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_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"
}

7
libguile/strings.h
View file

@ -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_wide_string (size_t len, scm_t_wchar **datap);
SCM_INTERNAL SCM scm_i_make_string (size_t len, char **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);

2
libguile/strports.c
View file

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

4
libguile/vm-i-loader.c
View file

@ -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;

22
test-suite/tests/strings.test
View file

@ -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?
;;