X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fstring.lisp;h=da9a068d1dae2f13c3231b7ca7cd0f55dab6fa1a;hb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;hp=b1fe4875422e62b715120c47153d585826fc772b;hpb=79cc569a97e444389350ea3f5b1017374fe16bec;p=sbcl.git diff --git a/src/code/string.lisp b/src/code/string.lisp index b1fe487..da9a068 100644 --- a/src/code/string.lisp +++ b/src/code/string.lisp @@ -16,16 +16,16 @@ 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 'string-designator - :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. @@ -46,32 +46,32 @@ (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))) + (,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)))) + (start) + (end (length (the vector ,string)))) ,@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) + start2 end2 &rest forms) `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1))) - (,string2 (if (stringp ,string2) ,string2 (string ,string2)))) + (,string2 (if (stringp ,string2) ,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 (%check-vector-sequence-bounds + ,string1 ,start1 ,end1))) (with-array-data ((,string2 ,string2) - (,start2 ,start2) - (,end2 (%check-vector-sequence-bounds - ,string2 ,start2 ,end2))) - ,@forms)))) + (,start2 ,start2) + (,end2 (%check-vector-sequence-bounds + ,string2 ,start2 ,end2))) + ,@forms)))) ) ; EVAL-WHEN (defun char (string index) @@ -104,7 +104,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 +115,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 +204,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 +234,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 +247,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 +264,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,7 +335,7 @@ (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 @@ -343,8 +343,8 @@ (string-not-greaterp* string1 string2 start1 end1 start2 end2)) (defun make-string (count &key - (element-type 'character) - ((:initial-element fill-char))) + (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." @@ -354,14 +354,14 @@ (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) @@ -369,15 +369,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) @@ -385,25 +385,25 @@ ) ; 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) @@ -413,33 +413,33 @@ (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)) + ((or (= index (the fixnum end)) + (not (find (schar string index) char-bag :test #'char=))) + (subseq (the simple-string string) index end)) (declare (fixnum index))))) (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))) + ((or (< index start) + (not (find (schar string index) char-bag :test #'char=))) + (subseq (the simple-string string) start (1+ index))) (declare (fixnum index))))) (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))))) + ((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))))