X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstring.lisp;h=d38fdb0201c21e6d1996146fb5a3ea10c5bb43d2;hb=f409f90c5e8c4c87ed9fa6efdc0e5c1952d94602;hp=3ffae9072d3f68546e0f3b5bacdedc3bc24804de;hpb=79953929196409f21fe505b29b15d2a9281884b7;p=sbcl.git

diff --git a/src/code/string.lisp b/src/code/string.lisp
index 3ffae90..d38fdb0 100644
--- a/src/code/string.lisp
+++ b/src/code/string.lisp
@@ -27,15 +27,28 @@
 		:format-control "~S cannot be coerced to a string."
 		:format-arguments (list x)))))
 
+;;; %CHECK-VECTOR-SEQUENCE-BOUNDS is used to verify that the START and
+;;; END arguments are valid bounding indices.
+;;;
+;;; FIXME: This causes a certain amount of double checking that could
+;;; be avoided, as if the string passes this (more stringent) test it
+;;; will automatically pass the tests in WITH-ARRAY-DATA.  Fixing this
+;;; would necessitate rearranging the transforms (maybe converting to
+;;; strings in the unasterisked versions and using this in the
+;;; transforms conditional on SAFETY>SPEED,SPACE).
+(defun %check-vector-sequence-bounds (vector start end)
+  (%check-vector-sequence-bounds vector start end))
+
 (eval-when (:compile-toplevel)
 ;;; WITH-ONE-STRING is used to set up some string hacking things. The
 ;;; keywords are parsed, and the string is hacked into a
 ;;; simple-string.
 (sb!xc:defmacro with-one-string ((string start end) &body forms)
-  `(let ((,string (if (stringp ,string) ,string (string ,string))))
+  `(let* ((,string (if (stringp ,string) ,string (string ,string))))
      (with-array-data ((,string ,string)
-		       (,start ,start)
-		       (,end (or ,end (length (the vector ,string)))))
+	 	       (,start ,start)
+		       (,end
+		        (%check-vector-sequence-bounds ,string ,start ,end)))
        ,@forms)))
 ;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.
 (sb!xc:defmacro with-string (string &rest forms)
@@ -52,10 +65,12 @@
 	 (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
      (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
 		       (,start1 ,start1)
-		       (,end1 (or ,end1 (length (the vector ,string1)))))
+		       (,end1 (%check-vector-sequence-bounds
+			       ,string1 ,start1 ,end1)))
        (with-array-data ((,string2 ,string2)
 			 (,start2 ,start2)
-			 (,end2 (or ,end2 (length (the vector ,string2)))))
+			 (,end2 (%check-vector-sequence-bounds
+				 ,string2 ,start2 ,end2)))
 	 ,@forms))))
 ) ; EVAL-WHEN
 
@@ -83,7 +98,7 @@
   (setf (schar string index) new-el))
 
 (defun string=* (string1 string2 start1 end1 start2 end2)
-  (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+  (with-two-strings string1 string2 start1 end1 nil start2 end2
     (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
 
 (defun string/=* (string1 string2 start1 end1 start2 end2)
@@ -94,8 +109,8 @@
 
 (eval-when (:compile-toplevel :execute)
 
-;;; Lessp is true if the desired expansion is for string<* or string<=*.
-;;; Equalp is true if the desired expansion is for string<=* or string>=*.
+;;; LESSP is true if the desired expansion is for STRING<* or STRING<=*.
+;;; EQUALP is true if the desired expansion is for STRING<=* or STRING>=*.
 (sb!xc:defmacro string<>=*-body (lessp equalp)
   (let ((offset1 (gensym)))
     `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
@@ -116,7 +131,7 @@
 		     (schar string2 (+ (the fixnum index) (- start2 start1))))
 		    (- (the fixnum index) ,offset1))
 		   (t nil))
-	     ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
+	     ,(if equalp `(- (the fixnum end1) ,offset1) nil))))))
 ) ; EVAL-WHEN
 
 (defun string<* (string1 string2 start1 end1 start2 end2)
@@ -217,13 +232,10 @@
   start2, end1 and end2, compares characters in string1 to characters in
   string2 (using char-equal)."
   (declare (fixnum start1 start2))
-  (with-two-strings string1 string2 start1 end1 offset1 start2 end2
+  (with-two-strings string1 string2 start1 end1 nil start2 end2
     (let ((slen1 (- (the fixnum end1) start1))
 	  (slen2 (- (the fixnum end2) start2)))
       (declare (fixnum slen1 slen2))
-      (if (or (minusp slen1) (minusp slen2))
-	  ;;prevent endless looping later.
-	  (error "Improper bounds for string comparison."))
       (if (= slen1 slen2)
 	  ;;return () immediately if lengths aren't equal.
 	  (string-not-equal-loop 1 t nil)))))
@@ -237,12 +249,7 @@
     (let ((slen1 (- end1 start1))
 	  (slen2 (- end2 start2)))
       (declare (fixnum slen1 slen2))
-      (if (or (minusp slen1) (minusp slen2))
-	  ;; Prevent endless looping later.
-	  (error "Improper bounds for string comparison."))
-      (cond ((or (minusp slen1) (or (minusp slen2)))
-	     (error "Improper substring for comparison."))
-	    ((= slen1 slen2)
+      (cond ((= slen1 slen2)
 	     (string-not-equal-loop 1 nil (- index1 offset1)))
 	    ((< slen1 slen2)
 	     (string-not-equal-loop 1 (- index1 offset1)))
@@ -274,9 +281,6 @@
        (let ((slen1 (- (the fixnum end1) start1))
 	     (slen2 (- (the fixnum end2) start2)))
 	 (declare (fixnum slen1 slen2))
-	 (if (or (minusp slen1) (minusp slen2))
-	     ;;prevent endless looping later.
-	     (error "Improper bounds for string comparison."))
 	 (do ((index1 start1 (1+ index1))
 	      (index2 start2 (1+ index2))
 	      (char1)
@@ -352,61 +356,61 @@
 	(setf (schar string i) fill-char))
       (make-string count)))
 
-(flet ((frob (string start end)
-	 (declare (string string) (index start) (type (or index null end)))
-	 (let ((save-header string))
+(flet ((%upcase (string start end)
+	 (declare (string string) (index start) (type sequence-end end))
+	 (let ((saved-header string))
 	   (with-one-string (string start end)
 	     (do ((index start (1+ index)))
 		 ((= index (the fixnum end)))
 	       (declare (fixnum index))
 	       (setf (schar string index) (char-upcase (schar string index)))))
-	   save-header)))
+	   saved-header)))
 (defun string-upcase (string &key (start 0) end)
-  (frob (copy-seq string) start end))
+  (%upcase (copy-seq (string string)) start end))
 (defun nstring-upcase (string &key (start 0) end)
-  (frob string start end))
+  (%upcase string start end))
 ) ; FLET
 
-(flet ((frob (string start end)
-	 (declare (string string) (index start) (type (or index null end)))
-	 (let ((save-header string))
+(flet ((%downcase (string start end)
+	 (declare (string string) (index start) (type sequence-end end))
+	 (let ((saved-header string))
 	   (with-one-string (string start end)
 	     (do ((index start (1+ index)))
 		 ((= index (the fixnum end)))
 	       (declare (fixnum index))
 	       (setf (schar string index)
 		     (char-downcase (schar string index)))))
-	   save-header)))
+	   saved-header)))
 (defun string-downcase (string &key (start 0) end)
-  (frob (copy-seq string) start end))
+  (%downcase (copy-seq (string string)) start end))
 (defun nstring-downcase (string &key (start 0) end)
-  (frob string start end))
+  (%downcase string start end))
 ) ; FLET
 
-(flet ((frob (string start end)
-	 (declare (string string) (index start) (type (or index null end)))
-	 (let ((save-header string))
+(flet ((%capitalize (string start end)
+	 (declare (string string) (index start) (type sequence-end end))
+	 (let ((saved-header string))
            (with-one-string (string start end)
              (do ((index start (1+ index))
-		  (newword t)
-		  (char ()))
+		  (new-word? t)
+		  (char nil))
 		 ((= index (the fixnum end)))
 	       (declare (fixnum index))
 	       (setq char (schar string index))
 	       (cond ((not (alphanumericp char))
-		      (setq newword t))
-	       (newword
-		;; CHAR is the first case-modifiable character after
-		;; a sequence of non-case-modifiable characters.
-		(setf (schar string index) (char-upcase char))
-		(setq newword ()))
-	       (t
-		(setf (schar string index) (char-downcase char))))))
-	   save-header)))
+		      (setq new-word? t))
+		     (new-word?
+		      ;; CHAR is the first case-modifiable character after
+		      ;; a sequence of non-case-modifiable characters.
+		      (setf (schar string index) (char-upcase char))
+		      (setq new-word? nil))
+		     (t
+		      (setf (schar string index) (char-downcase char))))))
+	   saved-header)))
 (defun string-capitalize (string &key (start 0) end)
-  (frob (copy-seq string) start end))
+  (%capitalize (copy-seq (string string)) start end))
 (defun nstring-capitalize (string &key (start 0) end)
-  (frob string start end))
+  (%capitalize string start end))
 ) ; FLET
 
 (defun string-left-trim (char-bag string)