diff --git a/code/string.lisp b/code/string.lisp
index cbea623eced68995ffdd3f16526ac8aa116c56dd..f84ae5a89bccaf18ec59df270b7cae27e2640f64 100644
--- a/code/string.lisp
+++ b/code/string.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.26 2010/09/15 21:06:38 rtoy Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/string.lisp,v 1.27 2010/09/20 23:01:15 rtoy Rel $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -40,7 +40,9 @@
   for.  :High means to test for the high (leading) surrogate; :Low
   tests for the low (trailing surrogate).  A value of :Any or Nil
   tests for any surrogate value (high or low)."
-  (declare (type (or character codepoint) char-or-code))
+  (declare (type (or character codepoint) char-or-code)
+	   (type (or null (member :high :leading :low :trailing :any)) surrogate-type)
+	   (optimize (inhibit-warnings 3)))
   (let ((code (if (characterp char-or-code)
 		  (char-code char-or-code)
 		  char-or-code)))
@@ -74,14 +76,16 @@
     (cond ((and (surrogatep code :high) (< (1+ i) end))
 	   (let ((tmp (char-code (schar string (1+ i)))))
 	     (if (surrogatep tmp :low)
-		 (values (+ (ash (- code #xD800) 10) tmp #x2400) +1)
-		 (values code nil))))
+		 (values (truly-the codepoint (+ (ash (- code #xD800) 10) tmp #x2400))
+			 +1)
+		 (values (truly-the codepoint code) nil))))
 	  ((and (surrogatep code :low) (> i 0))
 	   (let ((tmp (char-code (schar string (1- i)))))
 	     (if (surrogatep tmp :high)
-		 (values (+ (ash (- tmp #xD800) 10) code #x2400) -1)
-		 (values code nil))))
-	  (t (values code nil)))))
+		 (values (truly-the codepoint (+ (ash (- tmp #xD800) 10) code #x2400))
+			 -1)
+		 (values (truly-the codepoint code) nil))))
+	  (t (values (truly-the codepoint code) nil)))))
 
 (defun surrogates (codepoint)
   "Return the high and low surrogate characters for Codepoint.  If