(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)
;;; %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))
;;; 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
(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)
(%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))
projects / sbcl.git / blobdiff