From: Nikodemus Siivola Date: Tue, 24 Jun 2008 17:12:57 +0000 (+0000) Subject: 1.0.17.42: more string trimming fixes X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9135cb77fb7aa18a3131178b37a43bfac2112795;p=sbcl.git 1.0.17.42: more string trimming fixes * Return value in the no-op case for non-simple-strings must not be the underlying simple string object. * Correct return type (per spec) for STRING-TRIM &co is STRING-DESIGNATOR, but as long as we take care, we can make it STRING -- but the old SIMPLE-STRING is still wrong. * Instead of making WITH-STRING a full-blown Evil Macro, just use WITH-ARRAY-DATA at the call site. * Two more test-cases. patch by James Knight. --- diff --git a/NEWS b/NEWS index 7c8d8f5..71373b6 100644 --- a/NEWS +++ b/NEWS @@ -31,6 +31,9 @@ changes in sbcl-1.0.18 relative to 1.0.17: (reported by Yoshinori Tahara) * bug fix: more accurate disassembly annotations of foreign function calls. (thanks to Andy Hefner) + * bug fix: trimming non-simple strings and non-string string + designators when the there is nothing to trim works properly. + (thanks to James Knight) * new feature: SB-POSIX bindings for mlockall, munlockall, and setsid. (thanks to Travis Cross) * fixed some bugs revealed by Paul Dietz' test suite: diff --git a/src/code/string.lisp b/src/code/string.lisp index de97aa9..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 @@ -37,26 +40,18 @@ ;;; 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 ,end) :check-fill-pointer t) ,@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) - :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 ,end1) @@ -405,29 +400,33 @@ new string COUNT long filled with the fill character." ) ; FLET (defun generic-string-trim (char-bag string left-p right-p) - (with-string string - (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)) - string - (subseq (the simple-string string) left-end right-end))))) + (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) (generic-string-trim char-bag string t nil)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 5f8731d..a262483 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -913,7 +913,7 @@ simple-string (flushable)) (defknown (string-trim string-left-trim string-right-trim) - (sequence string-designator) simple-string (flushable)) + (sequence string-designator) string (flushable)) (defknown (string-upcase string-downcase string-capitalize) (string-designator &key (:start index) (:end sequence-end)) diff --git a/tests/string.pure.lisp b/tests/string.pure.lisp index 13da95d..89e9806 100644 --- a/tests/string.pure.lisp +++ b/tests/string.pure.lisp @@ -137,3 +137,11 @@ (assert (equal "bc" (string-right-trim "ab" s))) (assert (equal "bca" s)) (assert (equal "abcaeb" s0))) + +;;; Trimming non-simple-strings when there is nothing to do +(let ((a (make-array 10 :element-type 'character :initial-contents "abcde00000" :fill-pointer 5))) + (assert (equal "abcde" (string-right-trim "Z" a)))) + +;;; Trimming non-strings when there is nothing to do. +(string-right-trim " " #\a) + diff --git a/version.lisp-expr b/version.lisp-expr index d47865f..c60af46 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.17.41" +"1.0.17.42"