X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstring.lisp;h=b7c0035aa64037e6843c72ccd44422356027c89d;hb=0c3bbfaa2286626a2d915c8810f690aefc702661;hp=d38fdb0201c21e6d1996146fb5a3ea10c5bb43d2;hpb=0ae2550b2edc90fcce6318080bc33586db675f50;p=sbcl.git diff --git a/src/code/string.lisp b/src/code/string.lisp index d38fdb0..b7c0035 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -9,33 +9,29 @@ (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 - symbol, X's pname is returned. If X is a character then a one element + symbol, its name is returned. If X is a character then a one element string containing that character is returned. If X cannot be coerced into a string, an error occurs." (cond ((stringp x) x) - ((symbolp x) (symbol-name x)) - ((characterp x) - (let ((res (make-string 1))) - (setf (schar res 0) x) res)) - (t - (error 'simple-type-error - :datum x - :expected-type 'stringable - :format-control "~S cannot be coerced to a string." - :format-arguments (list x))))) + ((symbolp x) (symbol-name x)) + ((characterp x) + (let ((res (make-string 1))) + (setf (schar res 0) x) res)) + (t + (error 'simple-type-error + :datum x + :expected-type 'string-designator + :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)) @@ -44,34 +40,27 @@ ;;; 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)))) - (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)))) + `(let ((,string (%string ,string))) (with-array-data ((,string ,string) - (start) - (end (length (the vector ,string)))) + (,start ,start) + (,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)))) + start2 end2 &rest forms) + `(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))) + (,start1 ,start1) + (,end1 ,end1) + :check-fill-pointer t) (with-array-data ((,string2 ,string2) - (,start2 ,start2) - (,end2 (%check-vector-sequence-bounds - ,string2 ,start2 ,end2))) - ,@forms)))) + (,start2 ,start2) + (,end2 ,end2) + :check-fill-pointer t) + ,@forms)))) ) ; EVAL-WHEN (defun char (string index) @@ -104,7 +93,7 @@ (defun string/=* (string1 string2 start1 end1 start2 end2) (with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((comparison (%sp-string-compare string1 start1 end1 - string2 start2 end2))) + string2 start2 end2))) (if comparison (- (the fixnum comparison) offset1))))) (eval-when (:compile-toplevel :execute) @@ -115,23 +104,23 @@ (let ((offset1 (gensym))) `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2 (let ((index (%sp-string-compare string1 start1 end1 - string2 start2 end2))) - (if index - (cond ((= (the fixnum index) (the fixnum end1)) - ,(if lessp - `(- (the fixnum index) ,offset1) - `nil)) - ((= (+ (the fixnum index) (- start2 start1)) - (the fixnum end2)) - ,(if lessp - `nil - `(- (the fixnum index) ,offset1))) - ((,(if lessp 'char< 'char>) - (schar string1 index) - (schar string2 (+ (the fixnum index) (- start2 start1)))) - (- (the fixnum index) ,offset1)) - (t nil)) - ,(if equalp `(- (the fixnum end1) ,offset1) nil)))))) + string2 start2 end2))) + (if index + (cond ((= (the fixnum index) (the fixnum end1)) + ,(if lessp + `(- (the fixnum index) ,offset1) + `nil)) + ((= (+ (the fixnum index) (- start2 start1)) + (the fixnum end2)) + ,(if lessp + `nil + `(- (the fixnum index) ,offset1))) + ((,(if lessp 'char< 'char>) + (schar string1 index) + (schar string2 (+ (the fixnum index) (- start2 start1)))) + (- (the fixnum index) ,offset1)) + (t nil)) + ,(if equalp `(- (the fixnum end1) ,offset1) nil)))))) ) ; EVAL-WHEN (defun string<* (string1 string2 start1 end1 start2 end2) @@ -204,25 +193,25 @@ ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for ;;; STRING-EQUAL and STRING-NOT-EQUAL. (sb!xc:defmacro string-not-equal-loop (end - end-value - &optional (abort-value nil abortp)) + end-value + &optional (abort-value nil abortp)) (declare (fixnum end)) (let ((end-test (if (= end 1) - `(= index1 (the fixnum end1)) - `(= index2 (the fixnum end2))))) + `(= index1 (the fixnum end1)) + `(= index2 (the fixnum end2))))) `(do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2))) - (,(if abortp - end-test - `(or ,end-test - (not (char-equal (schar string1 index1) - (schar string2 index2))))) - ,end-value) + (index2 start2 (1+ index2))) + (,(if abortp + end-test + `(or ,end-test + (not (char-equal (schar string1 index1) + (schar string2 index2))))) + ,end-value) (declare (fixnum index1 index2)) ,@(if abortp - `((if (not (char-equal (schar string1 index1) - (schar string2 index2))) - (return ,abort-value))))))) + `((if (not (char-equal (schar string1 index1) + (schar string2 index2))) + (return ,abort-value))))))) ) ; EVAL-WHEN @@ -234,11 +223,11 @@ (declare (fixnum start1 start2)) (with-two-strings string1 string2 start1 end1 nil start2 end2 (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) + (slen2 (- (the fixnum end2) start2))) (declare (fixnum slen1 slen2)) (if (= slen1 slen2) - ;;return () immediately if lengths aren't equal. - (string-not-equal-loop 1 t nil))))) + ;;return () immediately if lengths aren't equal. + (string-not-equal-loop 1 t nil))))) (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2) #!+sb-doc @@ -247,14 +236,14 @@ of the two strings. Otherwise, returns ()." (with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((slen1 (- end1 start1)) - (slen2 (- end2 start2))) + (slen2 (- end2 start2))) (declare (fixnum slen1 slen2)) (cond ((= slen1 slen2) - (string-not-equal-loop 1 nil (- index1 offset1))) - ((< slen1 slen2) - (string-not-equal-loop 1 (- index1 offset1))) - (t - (string-not-equal-loop 2 (- index1 offset1))))))) + (string-not-equal-loop 1 nil (- index1 offset1))) + ((< slen1 slen2) + (string-not-equal-loop 1 (- index1 offset1))) + (t + (string-not-equal-loop 2 (- index1 offset1))))))) (eval-when (:compile-toplevel :execute) @@ -264,36 +253,36 @@ (defun string-less-greater-equal-tests (lessp equalp) (if lessp (if equalp - ;; STRING-NOT-GREATERP - (values '<= `(not (char-greaterp char1 char2))) - ;; STRING-LESSP - (values '< `(char-lessp char1 char2))) + ;; STRING-NOT-GREATERP + (values '<= `(not (char-greaterp char1 char2))) + ;; STRING-LESSP + (values '< `(char-lessp char1 char2))) (if equalp - ;; STRING-NOT-LESSP - (values '>= `(not (char-lessp char1 char2))) - ;; STRING-GREATERP - (values '> `(char-greaterp char1 char2))))) + ;; STRING-NOT-LESSP + (values '>= `(not (char-lessp char1 char2))) + ;; STRING-GREATERP + (values '> `(char-greaterp char1 char2))))) (sb!xc:defmacro string-less-greater-equal (lessp equalp) (multiple-value-bind (length-test character-test) (string-less-greater-equal-tests lessp equalp) `(with-two-strings string1 string2 start1 end1 offset1 start2 end2 (let ((slen1 (- (the fixnum end1) start1)) - (slen2 (- (the fixnum end2) start2))) - (declare (fixnum slen1 slen2)) - (do ((index1 start1 (1+ index1)) - (index2 start2 (1+ index2)) - (char1) - (char2)) - ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) - (if (,length-test slen1 slen2) (- index1 offset1))) - (declare (fixnum index1 index2)) - (setq char1 (schar string1 index1)) - (setq char2 (schar string2 index2)) - (if (not (char-equal char1 char2)) - (if ,character-test - (return (- index1 offset1)) - (return ())))))))) + (slen2 (- (the fixnum end2) start2))) + (declare (fixnum slen1 slen2)) + (do ((index1 start1 (1+ index1)) + (index2 start2 (1+ index2)) + (char1) + (char2)) + ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2))) + (if (,length-test slen1 slen2) (- index1 offset1))) + (declare (fixnum index1 index2)) + (setq char1 (schar string1 index1)) + (setq char2 (schar string2 index2)) + (if (not (char-equal char1 char2)) + (if ,character-test + (return (- index1 offset1)) + (return ())))))))) ) ; EVAL-WHEN @@ -335,36 +324,33 @@ (string-not-lessp* string1 string2 start1 end1 start2 end2)) (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0) - end2) + end2) #!+sb-doc "Given two strings, if the first string is lexicographically less than or equal to the second string, returns the longest common prefix (using char-equal) of the two strings. Otherwise, returns ()." (string-not-greaterp* string1 string2 start1 end1 start2 end2)) -(defun make-string (count &key element-type ((:initial-element fill-char))) +(defun make-string (count &key + (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." - (declare (fixnum count) - (ignore element-type)) + "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 - (do ((i 0 (1+ i)) - (string (make-string count))) - ((= i count) string) - (declare (fixnum i)) - (setf (schar string i) fill-char)) - (make-string count))) + (make-string count :element-type element-type :initial-element fill-char) + (make-string count :element-type element-type))) (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))) + (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) (%upcase (copy-seq (string string)) start end)) (defun nstring-upcase (string &key (start 0) end) @@ -372,15 +358,15 @@ ) ; 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))) + (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) @@ -388,61 +374,65 @@ ) ; FLET (flet ((%capitalize (string start end) - (declare (string string) (index start) (type sequence-end end)) - (let ((saved-header string)) + (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))) + (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) (%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))