(in-package "SB!IMPL")
-(file-comment
- "$Header$")
-
(defun string (x)
#!+sb-doc
"Coerces X into a string. If X is a string, X is returned. If X is a
: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.
+;;; %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))
(eval-when (:compile-toplevel)
-
-(sb!xc:defmacro with-one-string (string start end cum-offset &rest forms)
- `(let ((,string (if (stringp ,string) ,string (string ,string))))
- (with-array-data ((,string ,string :offset-var ,cum-offset)
- (,start ,start)
- (,end (or ,end (length (the vector ,string)))))
+;;; 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))))
+ (with-array-data ((,string ,string)
+ (,start ,start)
+ (,end
+ (%check-vector-sequence-bounds ,string ,start ,end)))
,@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)))
-
-) ; 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)))
(,string2 (if (stringp ,string2) ,string2 (string ,string2))))
(with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
(,start1 ,start1)
- (,end1 (or ,end1 (length (the vector ,string1)))))
+ (,end1 (%check-vector-sequence-bounds
+ ,string1 ,start1 ,end1)))
(with-array-data ((,string2 ,string2)
(,start2 ,start2)
- (,end2 (or ,end2 (length (the vector ,string2)))))
+ (,end2 (%check-vector-sequence-bounds
+ ,string2 ,start2 ,end2)))
,@forms))))
-
) ; EVAL-WHEN
(defun char (string index)
(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)
(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
(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))
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))
- (if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
- (error "Improper bounds for string comparison."))
(if (= slen1 slen2)
;;return () immediately if lengths aren't equal.
(string-not-equal-loop 1 t nil)))))
(let ((slen1 (- end1 start1))
(slen2 (- end2 start2)))
(declare (fixnum slen1 slen2))
- (if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
- (error "Improper bounds for string comparison."))
- (cond ((or (minusp slen1) (or (minusp slen2)))
- (error "Improper substring for comparison."))
- ((= slen1 slen2)
+ (cond ((= slen1 slen2)
(string-not-equal-loop 1 nil (- index1 offset1)))
((< slen1 slen2)
(string-not-equal-loop 1 (- index1 offset1)))
(let ((slen1 (- (the fixnum end1) start1))
(slen2 (- (the fixnum end2) start2)))
(declare (fixnum slen1 slen2))
- (if (or (minusp slen1) (minusp slen2))
- ;;prevent endless looping later.
- (error "Improper bounds for string comparison."))
(do ((index1 start1 (1+ index1))
(index2 start2 (1+ index2))
(char1)
(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))
+ 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)))
(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)
- #!+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)
- #!+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)
- #!+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)
- #!+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))
(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)
(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))
projects / sbcl.git / blobdiff