From 3ae3166b2307ee8588aa9b422764b486ed02ad09 Mon Sep 17 00:00:00 2001
From: =?utf8?q?Ludovic=20Court=C3=A8s?= <ludo@gnu.org>
Date: Tue, 2 Dec 2008 19:42:39 +0100
Subject: [PATCH] Fix sloppy bound checking in `string-{ref,set!}' with the
 empty string.

* libguile/strings.c (scm_string_ref): Add proper range checking for the
  empty string.
  (scm_string_set_x): Likewise.
  Reported by Bill Schottstaedt <bil@ccrma.Stanford.EDU>.

* test-suite/tests/strings.test ("string-ref"): New test prefix.
  ("string-set!")["empty string", "empty string and non-zero index",
  "out of range", "negative index", "regular string"]: New tests.

* NEWS: Update.
---
 NEWS                          |  1 +
 libguile/strings.c            | 18 +++++++++++--
 test-suite/tests/strings.test | 51 +++++++++++++++++++++++++++++++++--
 3 files changed, 66 insertions(+), 4 deletions(-)

diff --git a/NEWS b/NEWS
index 7fc29c2ce..179126ff2 100644
--- a/NEWS
+++ b/NEWS
@@ -86,6 +86,7 @@ available: Guile is now always configured in "maintainer mode".
    dynamic environment of the call to `raise'
 ** Fix potential deadlock in `make-struct'
 ** Fix compilation problem with libltdl from Libtool 2.2.x
+** Fix sloppy bound checking in `string-{ref,set!}' with the empty string
 
 
 Changes in 1.8.5 (since 1.8.4)
diff --git a/libguile/strings.c b/libguile/strings.c
index 7399d8831..c13802664 100644
--- a/libguile/strings.c
+++ b/libguile/strings.c
@@ -670,10 +670,17 @@ SCM_DEFINE (scm_string_ref, "string-ref", 2, 0, 0,
 	    "indexing. @var{k} must be a valid index of @var{str}.")
 #define FUNC_NAME s_scm_string_ref
 {
+  size_t len;
   unsigned long idx;
 
   SCM_VALIDATE_STRING (1, str);
-  idx = scm_to_unsigned_integer (k, 0, scm_i_string_length (str)-1);
+
+  len = scm_i_string_length (str);
+  if (SCM_LIKELY (len > 0))
+    idx = scm_to_unsigned_integer (k, 0, len - 1);
+  else
+    scm_out_of_range (NULL, k);
+
   return SCM_MAKE_CHAR (scm_i_string_chars (str)[idx]);
 }
 #undef FUNC_NAME
@@ -693,10 +700,17 @@ SCM_DEFINE (scm_string_set_x, "string-set!", 3, 0, 0,
 	    "@var{str}.")
 #define FUNC_NAME s_scm_string_set_x
 {
+  size_t len;
   unsigned long idx;
 
   SCM_VALIDATE_STRING (1, str);
-  idx = scm_to_unsigned_integer (k, 0, scm_i_string_length(str)-1);
+
+  len = scm_i_string_length (str);
+  if (SCM_LIKELY (len > 0))
+    idx = scm_to_unsigned_integer (k, 0, len - 1);
+  else
+    scm_out_of_range (NULL, k);
+
   SCM_VALIDATE_CHAR (3, chr);
   {
     char *dst = scm_i_string_writable_chars (str);
diff --git a/test-suite/tests/strings.test b/test-suite/tests/strings.test
index aa9196e68..51f163254 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
@@ -160,15 +160,62 @@
     (eq? (char-ci>=? (integer->char 0) (integer->char 255))
 	 (string-ci>=? (string-ints 0) (string-ints 255)))))
 
+;;
+;; string-ref
+;;
+
+(with-test-prefix "string-ref"
+
+  (pass-if-exception "empty string"
+    exception:out-of-range
+    (string-ref "" 0))
+
+  (pass-if-exception "empty string and non-zero index"
+    exception:out-of-range
+    (string-ref "" 123))
+
+  (pass-if-exception "out of range"
+    exception:out-of-range
+    (string-ref "hello" 123))
+
+  (pass-if-exception "negative index"
+    exception:out-of-range
+    (string-ref "hello" -1))
+
+  (pass-if "regular string"
+    (char=? (string-ref "GNU Guile" 4) #\G)))
+
 ;;
 ;; string-set!
 ;;
 
 (with-test-prefix "string-set!"
 
+  (pass-if-exception "empty string"
+    exception:out-of-range
+    (string-set! (string-copy "") 0 #\x))
+
+  (pass-if-exception "empty string and non-zero index"
+    exception:out-of-range
+    (string-set! (string-copy "") 123 #\x))
+
+  (pass-if-exception "out of range"
+    exception:out-of-range
+    (string-set! (string-copy "hello") 123 #\x))
+
+  (pass-if-exception "negative index"
+    exception:out-of-range
+    (string-set! (string-copy "hello") -1 #\x))
+
   (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 "regular string"
+    (let ((s (string-copy "GNU guile")))
+      (string-set! s 4 #\G)
+      (char=? (string-ref s 4) #\G))))
+
 
 (with-test-prefix "string-split"
 
-- 
2.20.1