X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstring.lisp;h=72df091f15653f817c09968df8502e6cb0619faf;hb=5f0cfcf9095f2d8dbca4ddf703c580a36d5c3709;hp=da9a068d1dae2f13c3231b7ca7cd0f55dab6fa1a;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/string.lisp b/src/code/string.lisp
index da9a068..72df091 100644
--- a/src/code/string.lisp
+++ b/src/code/string.lisp
@@ -9,6 +9,9 @@
 
 (in-package "SB!IMPL")
 
+(eval-when (:compile-toplevel)
+  (sb!xc:defmacro %string (x) `(if (stringp ,x) ,x (string ,x))))
+
 (defun string (x)
   #!+sb-doc
   "Coerces X into a string. If X is a string, X is returned. If X is a
@@ -29,13 +32,6 @@
 
 ;;; %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))
 
@@ -44,33 +40,26 @@
 ;;; 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 (%string ,string)))
      (with-array-data ((,string ,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)
-  `(let ((,string (if (stringp ,string) ,string (string ,string))))
-     (with-array-data ((,string ,string)
-                       (start)
-                       (end (length (the vector ,string))))
+                       (,end ,end)
+                       :check-fill-pointer t)
        ,@forms)))
 ;;; 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)))
-         (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
+  `(let ((,string1 (%string ,string1))
+         (,string2 (%string ,string2)))
      (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
                        (,start1 ,start1)
-                       (,end1 (%check-vector-sequence-bounds
-                               ,string1 ,start1 ,end1)))
+                       (,end1 ,end1)
+                       :check-fill-pointer t)
        (with-array-data ((,string2 ,string2)
                          (,start2 ,start2)
-                         (,end2 (%check-vector-sequence-bounds
-                                 ,string2 ,start2 ,end2)))
+                         (,end2 ,end2)
+                         :check-fill-pointer t)
          ,@forms))))
 ) ; EVAL-WHEN
 
@@ -346,8 +335,8 @@
                     (element-type 'character)
                     ((:initial-element fill-char)))
   #!+sb-doc
-  "Given a character count and an optional fill character, makes and returns
-   a new string COUNT long filled with the fill character."
+  "Given a character count and an optional fill character, makes and returns a
+new string COUNT long filled with the fill character."
   (declare (fixnum count))
   (if fill-char
       (make-string count :element-type element-type :initial-element fill-char)
@@ -410,36 +399,40 @@
   (%capitalize string start end))
 ) ; FLET
 
+(defun generic-string-trim (char-bag string left-p right-p)
+  (let ((header (%string string)))
+    (with-array-data ((string header)
+                      (start)
+                      (end)
+                      :check-fill-pointer t)
+      (let* ((left-end (if left-p
+                           (do ((index start (1+ index)))
+                               ((or (= index (the fixnum end))
+                                    (not (find (schar string index)
+                                               char-bag
+                                               :test #'char=)))
+                                index)
+                             (declare (fixnum index)))
+                           start))
+             (right-end (if right-p
+                            (do ((index (1- (the fixnum end)) (1- index)))
+                                ((or (< index left-end)
+                                     (not (find (schar string index)
+                                                char-bag
+                                                :test #'char=)))
+                                 (1+ index))
+                              (declare (fixnum index)))
+                            end)))
+        (if (and (eql left-end start)
+                 (eql right-end end))
+            header
+            (subseq (the simple-string string) left-end right-end))))))
+
 (defun string-left-trim (char-bag string)
-  (with-string string
-    (do ((index start (1+ index)))
-        ((or (= index (the fixnum end))
-             (not (find (schar string index) char-bag :test #'char=)))
-         (subseq (the simple-string string) index end))
-      (declare (fixnum index)))))
+  (generic-string-trim char-bag string t nil))
 
 (defun string-right-trim (char-bag string)
-  (with-string string
-    (do ((index (1- (the fixnum end)) (1- index)))
-        ((or (< index start)
-             (not (find (schar string index) char-bag :test #'char=)))
-         (subseq (the simple-string string) start (1+ index)))
-      (declare (fixnum index)))))
+  (generic-string-trim char-bag string nil t))
 
 (defun string-trim (char-bag string)
-  (with-string string
-    (let* ((left-end (do ((index start (1+ index)))
-                         ((or (= index (the fixnum end))
-                              (not (find (schar string index)
-                                         char-bag
-                                         :test #'char=)))
-                          index)
-                       (declare (fixnum index))))
-           (right-end (do ((index (1- (the fixnum end)) (1- index)))
-                          ((or (< index left-end)
-                               (not (find (schar string index)
-                                          char-bag
-                                          :test #'char=)))
-                           (1+ index))
-                        (declare (fixnum index)))))
-      (subseq (the simple-string string) left-end right-end))))
+  (generic-string-trim char-bag string t t))