0.6.11.37:

[sbcl.git] / src / code / string.lisp

diff --git a/src/code/string.lisp b/src/code/string.lisp
index ec9c7a0..28cb331 100644 (file)
--- a/src/code/string.lisp
+++ b/src/code/string.lisp
@@ -27,38 +27,25 @@
                :format-control "~S cannot be coerced to a string."
                :format-arguments (list x)))))
 
                :format-control "~S cannot be coerced to a string."
                :format-arguments (list x)))))
 

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

 (eval-when (:compile-toplevel)
 (eval-when (:compile-toplevel)

-
-(sb!xc:defmacro with-one-string (string start end cum-offset &rest forms)
+;;; 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 :offset-var ,cum-offset)
+     (with-array-data ((,string ,string)

                       (,start ,start)
                       (,end (or ,end (length (the vector ,string)))))
        ,@forms)))
                       (,start ,start)
                       (,end (or ,end (length (the vector ,string)))))
        ,@forms)))

-
-) ; EVAN-WHEN
-
-;;; With-String is like With-One-String, but doesn't parse keywords.
-
-(eval-when (:compile-toplevel)
-
+;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.

 (sb!xc:defmacro with-string (string &rest forms)
   `(let ((,string (if (stringp ,string) ,string (string ,string))))
      (with-array-data ((,string ,string)
                       (start)
                       (end (length (the vector ,string))))
        ,@forms)))
 (sb!xc:defmacro with-string (string &rest forms)
   `(let ((,string (if (stringp ,string) ,string (string ,string))))
      (with-array-data ((,string ,string)
                       (start)
                       (end (length (the vector ,string))))
        ,@forms)))

-
-) ; EVAL-WHEN
-
-;;; With-Two-Strings is used to set up string comparison operations. The
-;;; keywords are parsed, and the strings are hacked into simple-strings.
-
-(eval-when (:compile-toplevel)
-
+;;; WITH-TWO-STRINGS is used to set up string comparison operations. The
+;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs.

 (sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
                                            start2 end2 &rest forms)
   `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
 (sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
                                            start2 end2 &rest forms)
   `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))

@@ -70,7 +57,6 @@
                         (,start2 ,start2)
                         (,end2 (or ,end2 (length (the vector ,string2)))))
         ,@forms))))
                         (,start2 ,start2)
                         (,end2 (or ,end2 (length (the vector ,string2)))))
         ,@forms))))

-

 ) ; EVAL-WHEN
 
 (defun char (string index)
 ) ; EVAL-WHEN
 
 (defun char (string index)

@@ -97,7 +83,7 @@
   (setf (schar string index) new-el))
 
 (defun string=* (string1 string2 start1 end1 start2 end2)
   (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)
     (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
 
 (defun string/=* (string1 string2 start1 end1 start2 end2)

@@ -108,8 +94,8 @@
 
 (eval-when (:compile-toplevel :execute)
 
 
 (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
 (sb!xc:defmacro string<>=*-body (lessp equalp)
   (let ((offset1 (gensym)))
     `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2

@@ -130,8 +116,8 @@
                     (schar string2 (+ (the fixnum index) (- start2 start1))))
                    (- (the fixnum index) ,offset1))
                   (t nil))
                     (schar string2 (+ (the fixnum index) (- start2 start1))))
                    (- (the fixnum index) ,offset1))
                   (t nil))

-            ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
-) ; eval-when
+            ,(if equalp `(- (the fixnum end1) ,offset1) nil))))))
+) ; EVAL-WHEN

 
 (defun string<* (string1 string2 start1 end1 start2 end2)
   (declare (fixnum start1 start2))
 
 (defun string<* (string1 string2 start1 end1 start2 end2)
   (declare (fixnum start1 start2))

@@ -231,7 +217,7 @@
   start2, end1 and end2, compares characters in string1 to characters in
   string2 (using char-equal)."
   (declare (fixnum start1 start2))
   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))
     (let ((slen1 (- (the fixnum end1) start1))
          (slen2 (- (the fixnum end2) start2)))
       (declare (fixnum slen1 slen2))

@@ -252,7 +238,7 @@
          (slen2 (- end2 start2)))
       (declare (fixnum slen1 slen2))
       (if (or (minusp slen1) (minusp slen2))
          (slen2 (- end2 start2)))
       (declare (fixnum slen1 slen2))
       (if (or (minusp slen1) (minusp slen2))

-         ;;prevent endless looping later.
+         ;; Prevent endless looping later.

          (error "Improper bounds for string comparison."))
       (cond ((or (minusp slen1) (or (minusp slen2)))
             (error "Improper substring for comparison."))
          (error "Improper bounds for string comparison."))
       (cond ((or (minusp slen1) (or (minusp slen2)))
             (error "Improper substring for comparison."))

@@ -366,166 +352,64 @@
        (setf (schar string i) fill-char))
       (make-string count)))
 
        (setf (schar string i) fill-char))
       (make-string count)))
 

+(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)))))
+          saved-header)))

 (defun string-upcase (string &key (start 0) end)
 (defun string-upcase (string &key (start 0) end)

-  #!+sb-doc
-  "Given a string, returns a new string that is a copy of it with
-  all lower case alphabetic characters converted to uppercase."
-  (declare (fixnum start))
-  (let* ((string (if (stringp string) string (string string)))
-        (slen (length string)))
-    (declare (fixnum slen))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-           (newstring (make-string slen)))
-       (declare (fixnum offset-slen))
-       (do ((index offset (1+ index))
-            (new-index 0 (1+ new-index)))
-           ((= index start))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       (do ((index start (1+ index))
-            (new-index (- start offset) (1+ new-index)))
-           ((= index (the fixnum end)))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index)
-               (char-upcase (schar string index))))
-       (do ((index end (1+ index))
-            (new-index (- (the fixnum end) offset) (1+ new-index)))
-           ((= index offset-slen))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       newstring))))
-
-(defun string-downcase (string &key (start 0) end)
-  #!+sb-doc
-  "Given a string, returns a new string that is a copy of it with
-  all upper case alphabetic characters converted to lowercase."
-  (declare (fixnum start))
-  (let* ((string (if (stringp string) string (string string)))
-        (slen (length string)))
-    (declare (fixnum slen))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-           (newstring (make-string slen)))
-       (declare (fixnum offset-slen))
-       (do ((index offset (1+ index))
-            (new-index 0 (1+ new-index)))
-           ((= index start))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       (do ((index start (1+ index))
-            (new-index (- start offset) (1+ new-index)))
-           ((= index (the fixnum end)))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index)
-               (char-downcase (schar string index))))
-       (do ((index end (1+ index))
-            (new-index (- (the fixnum end) offset) (1+ new-index)))
-           ((= index offset-slen))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       newstring))))
-
-(defun string-capitalize (string &key (start 0) end)
-  #!+sb-doc
-  "Given a string, returns a copy of the string with the first
-  character of each ``word'' converted to upper-case, and remaining
-  chars in the word converted to lower case. A ``word'' is defined
-  to be a string of case-modifiable characters delimited by
-  non-case-modifiable chars."
-  (declare (fixnum start))
-  (let* ((string (if (stringp string) string (string string)))
-        (slen (length string)))
-    (declare (fixnum slen))
-    (with-one-string string start end offset
-      (let ((offset-slen (+ slen offset))
-           (newstring (make-string slen)))
-       (declare (fixnum offset-slen))
-       (do ((index offset (1+ index))
-            (new-index 0 (1+ new-index)))
-           ((= index start))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       (do ((index start (1+ index))
-            (new-index (- start offset) (1+ new-index))
-            (newword t)
-            (char ()))
-           ((= index (the fixnum end)))
-         (declare (fixnum index new-index))
-         (setq char (schar string index))
-         (cond ((not (alphanumericp char))
-                (setq newword t))
-               (newword
-                ;;char is first case-modifiable after non-case-modifiable
-                (setq char (char-upcase char))
-                (setq newword ()))
-               ;;char is case-modifiable, but not first
-               (t (setq char (char-downcase char))))
-         (setf (schar newstring new-index) char))
-       (do ((index end (1+ index))
-            (new-index (- (the fixnum end) offset) (1+ new-index)))
-           ((= index offset-slen))
-         (declare (fixnum index new-index))
-         (setf (schar newstring new-index) (schar string index)))
-       newstring))))
-
+  (%upcase (copy-seq (string string)) start end))

 (defun nstring-upcase (string &key (start 0) end)
 (defun nstring-upcase (string &key (start 0) end)

-  #!+sb-doc
-  "Given a string, returns that string with all lower case alphabetic
-  characters converted to uppercase."
-  (declare (fixnum start))
-  (let ((save-header string))
-    (with-one-string string start end offset
-      (do ((index start (1+ index)))
-         ((= index (the fixnum end)))
-       (declare (fixnum index))
-       (setf (schar string index) (char-upcase (schar string index)))))
-    save-header))
-
+  (%upcase string start end))
+) ; FLET
+
+(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)))))
+          saved-header)))
+(defun string-downcase (string &key (start 0) end)
+  (%downcase (copy-seq (string string)) start end))

 (defun nstring-downcase (string &key (start 0) end)
 (defun nstring-downcase (string &key (start 0) end)

-  #!+sb-doc
-  "Given a string, returns that string with all upper case alphabetic
-  characters converted to lowercase."
-  (declare (fixnum start))
-  (let ((save-header string))
-    (with-one-string string start end offset
-      (do ((index start (1+ index)))
-         ((= index (the fixnum end)))
-       (declare (fixnum index))
-       (setf (schar string index) (char-downcase (schar string index)))))
-    save-header))
-
+  (%downcase string start end))
+) ; FLET
+
+(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))
+                 (new-word? t)
+                 (char nil))
+                ((= index (the fixnum end)))
+              (declare (fixnum index))
+              (setq char (schar string index))
+              (cond ((not (alphanumericp char))
+                     (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)
+  (%capitalize (copy-seq (string string)) start end))

 (defun nstring-capitalize (string &key (start 0) end)
 (defun nstring-capitalize (string &key (start 0) end)

-  #!+sb-doc
-  "Given a string, returns that string with the first
-  character of each ``word'' converted to upper-case, and remaining
-  chars in the word converted to lower case. A ``word'' is defined
-  to be a string of case-modifiable characters delimited by
-  non-case-modifiable chars."
-  (declare (fixnum start))
-  (let ((save-header string))
-    (with-one-string string start end offset
-      (do ((index start (1+ index))
-          (newword t)
-          (char ()))
-         ((= index (the fixnum end)))
-       (declare (fixnum index))
-       (setq char (schar string index))
-       (cond ((not (alphanumericp char))
-              (setq newword t))
-             (newword
-              ;;char is first case-modifiable after non-case-modifiable
-              (setf (schar string index) (char-upcase char))
-              (setq newword ()))
-             (t
-              (setf (schar string index) (char-downcase char))))))
-    save-header))
+  (%capitalize string start end))
+) ; FLET

 
 (defun string-left-trim (char-bag string)
 
 (defun string-left-trim (char-bag string)

-  #!+sb-doc
-  "Given a set of characters (a list or string) and a string, returns
-  a copy of the string with the characters in the set removed from the
-  left end."

   (with-string string
     (do ((index start (1+ index)))
        ((or (= index (the fixnum end))
   (with-string string
     (do ((index start (1+ index)))
        ((or (= index (the fixnum end))

@@ -534,10 +418,6 @@
       (declare (fixnum index)))))
 
 (defun string-right-trim (char-bag string)
       (declare (fixnum index)))))
 
 (defun string-right-trim (char-bag string)

-  #!+sb-doc
-  "Given a set of characters (a list or string) and a string, returns
-  a copy of the string with the characters in the set removed from the
-  right end."

   (with-string string
     (do ((index (1- (the fixnum end)) (1- index)))
        ((or (< index start)
   (with-string string
     (do ((index (1- (the fixnum end)) (1- index)))
        ((or (< index start)

@@ -546,10 +426,6 @@
       (declare (fixnum index)))))
 
 (defun string-trim (char-bag string)
       (declare (fixnum index)))))
 
 (defun string-trim (char-bag string)

-  #!+sb-doc
-  "Given a set of characters (a list or string) and a string, returns a
-  copy of the string with the characters in the set removed from both
-  ends."

   (with-string string
     (let* ((left-end (do ((index start (1+ index)))
                         ((or (= index (the fixnum end))
   (with-string string
     (let* ((left-end (do ((index start (1+ index)))
                         ((or (= index (the fixnum end))