src/code/string.lisp

   1 ;;;; This software is part of the SBCL system. See the README file for
   2 ;;;; more information.
   3 ;;;;
   4 ;;;; This software is derived from the CMU CL system, which was
   5 ;;;; written at Carnegie Mellon University and released into the
   6 ;;;; public domain. The software is in the public domain and is
   7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
   8 ;;;; files for more information.
   9
  10 (in-package "SB!IMPL")
  11
  12 (defun string (x)
  13   #!+sb-doc
  14   "Coerces X into a string. If X is a string, X is returned. If X is a
  15    symbol, X's pname is returned. If X is a character then a one element
  16    string containing that character is returned. If X cannot be coerced
  17    into a string, an error occurs."
  18   (cond ((stringp x) x)
  19         ((symbolp x) (symbol-name x))
  20         ((characterp x)
  21          (let ((res (make-string 1)))
  22            (setf (schar res 0) x) res))
  23         (t
  24          (error 'simple-type-error
  25                 :datum x
  26                 :expected-type 'string-designator
  27                 :format-control "~S cannot be coerced to a string."
  28                 :format-arguments (list x)))))
  29
  30 ;;; %CHECK-VECTOR-SEQUENCE-BOUNDS is used to verify that the START and
  31 ;;; END arguments are valid bounding indices.
  32 ;;;
  33 ;;; FIXME: This causes a certain amount of double checking that could
  34 ;;; be avoided, as if the string passes this (more stringent) test it
  35 ;;; will automatically pass the tests in WITH-ARRAY-DATA.  Fixing this
  36 ;;; would necessitate rearranging the transforms (maybe converting to
  37 ;;; strings in the unasterisked versions and using this in the
  38 ;;; transforms conditional on SAFETY>SPEED,SPACE).
  39 (defun %check-vector-sequence-bounds (vector start end)
  40   (%check-vector-sequence-bounds vector start end))
  41
  42 (eval-when (:compile-toplevel)
  43 ;;; WITH-ONE-STRING is used to set up some string hacking things. The
  44 ;;; keywords are parsed, and the string is hacked into a
  45 ;;; simple-string.
  46 (sb!xc:defmacro with-one-string ((string start end) &body forms)
  47   `(let* ((,string (if (stringp ,string) ,string (string ,string))))
  48      (with-array-data ((,string ,string)
  49                        (,start ,start)
  50                        (,end
  51                         (%check-vector-sequence-bounds ,string ,start ,end)))
  52        ,@forms)))
  53 ;;; WITH-STRING is like WITH-ONE-STRING, but doesn't parse keywords.
  54 (sb!xc:defmacro with-string (string &rest forms)
  55   `(let ((,string (if (stringp ,string) ,string (string ,string))))
  56      (with-array-data ((,string ,string)
  57                        (start)
  58                        (end (length (the vector ,string))))
  59        ,@forms)))
  60 ;;; WITH-TWO-STRINGS is used to set up string comparison operations. The
  61 ;;; keywords are parsed, and the strings are hacked into SIMPLE-STRINGs.
  62 (sb!xc:defmacro with-two-strings (string1 string2 start1 end1 cum-offset-1
  63                                             start2 end2 &rest forms)
  64   `(let ((,string1 (if (stringp ,string1) ,string1 (string ,string1)))
  65          (,string2 (if (stringp ,string2) ,string2 (string ,string2))))
  66      (with-array-data ((,string1 ,string1 :offset-var ,cum-offset-1)
  67                        (,start1 ,start1)
  68                        (,end1 (%check-vector-sequence-bounds
  69                                ,string1 ,start1 ,end1)))
  70        (with-array-data ((,string2 ,string2)
  71                          (,start2 ,start2)
  72                          (,end2 (%check-vector-sequence-bounds
  73                                  ,string2 ,start2 ,end2)))
  74          ,@forms))))
  75 ) ; EVAL-WHEN
  76
  77 (defun char (string index)
  78   #!+sb-doc
  79   "Given a string and a non-negative integer index less than the length of
  80   the string, returns the character object representing the character at
  81   that position in the string."
  82   (declare (optimize (safety 1)))
  83   (char string index))
  84
  85 (defun %charset (string index new-el)
  86   (declare (optimize (safety 1)))
  87   (setf (char string index) new-el))
  88
  89 (defun schar (string index)
  90   #!+sb-doc
  91   "SCHAR returns the character object at an indexed position in a string
  92    just as CHAR does, except the string must be a simple-string."
  93   (declare (optimize (safety 1)))
  94   (schar string index))
  95
  96 (defun %scharset (string index new-el)
  97   (declare (optimize (safety 1)))
  98   (setf (schar string index) new-el))
  99
 100 (defun string=* (string1 string2 start1 end1 start2 end2)
 101   (with-two-strings string1 string2 start1 end1 nil start2 end2
 102     (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
 103
 104 (defun string/=* (string1 string2 start1 end1 start2 end2)
 105   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 106     (let ((comparison (%sp-string-compare string1 start1 end1
 107                                           string2 start2 end2)))
 108       (if comparison (- (the fixnum comparison) offset1)))))
 109
 110 (eval-when (:compile-toplevel :execute)
 111
 112 ;;; LESSP is true if the desired expansion is for STRING<* or STRING<=*.
 113 ;;; EQUALP is true if the desired expansion is for STRING<=* or STRING>=*.
 114 (sb!xc:defmacro string<>=*-body (lessp equalp)
 115   (let ((offset1 (gensym)))
 116     `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
 117        (let ((index (%sp-string-compare string1 start1 end1
 118                                         string2 start2 end2)))
 119          (if index
 120              (cond ((= (the fixnum index) (the fixnum end1))
 121                     ,(if lessp
 122                          `(- (the fixnum index) ,offset1)
 123                        `nil))
 124                    ((= (+ (the fixnum index) (- start2 start1))
 125                        (the fixnum end2))
 126                     ,(if lessp
 127                          `nil
 128                        `(- (the fixnum index) ,offset1)))
 129                    ((,(if lessp 'char< 'char>)
 130                      (schar string1 index)
 131                      (schar string2 (+ (the fixnum index) (- start2 start1))))
 132                     (- (the fixnum index) ,offset1))
 133                    (t nil))
 134              ,(if equalp `(- (the fixnum end1) ,offset1) nil))))))
 135 ) ; EVAL-WHEN
 136
 137 (defun string<* (string1 string2 start1 end1 start2 end2)
 138   (declare (fixnum start1 start2))
 139   (string<>=*-body t nil))
 140
 141 (defun string>* (string1 string2 start1 end1 start2 end2)
 142   (declare (fixnum start1 start2))
 143   (string<>=*-body nil nil))
 144
 145 (defun string<=* (string1 string2 start1 end1 start2 end2)
 146   (declare (fixnum start1 start2))
 147   (string<>=*-body t t))
 148
 149 (defun string>=* (string1 string2 start1 end1 start2 end2)
 150   (declare (fixnum start1 start2))
 151   (string<>=*-body nil t))
 152
 153 (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
 154   #!+sb-doc
 155   "Given two strings, if the first string is lexicographically less than
 156   the second string, returns the longest common prefix (using char=)
 157   of the two strings. Otherwise, returns ()."
 158   (string<* string1 string2 start1 end1 start2 end2))
 159
 160 (defun string> (string1 string2 &key (start1 0) end1 (start2 0) end2)
 161   #!+sb-doc
 162   "Given two strings, if the first string is lexicographically greater than
 163   the second string, returns the longest common prefix (using char=)
 164   of the two strings. Otherwise, returns ()."
 165   (string>* string1 string2 start1 end1 start2 end2))
 166
 167 (defun string<= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 168   #!+sb-doc
 169   "Given two strings, if the first string is lexicographically less than
 170   or equal to the second string, returns the longest common prefix
 171   (using char=) of the two strings. Otherwise, returns ()."
 172   (string<=* string1 string2 start1 end1 start2 end2))
 173
 174 (defun string>= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 175   "Given two strings, if the first string is lexicographically greater
 176   than or equal to the second string, returns the longest common prefix
 177   (using char=) of the two strings. Otherwise, returns ()."
 178   (string>=* string1 string2 start1 end1 start2 end2))
 179
 180 ;;; Note: (STRING= "PREFIX" "SHORT" :END2 (LENGTH "PREFIX")) gives
 181 ;;; an error instead of returning NIL as I would have expected.
 182 ;;; The ANSI spec for STRING= itself doesn't seem to clarify this
 183 ;;; much, but the SUBSEQ-OUT-OF-BOUNDS writeup seems to say that
 184 ;;; this is conforming (and required) behavior, because any index
 185 ;;; out of range is an error. (So there seems to be no concise and
 186 ;;; efficient way to test for strings which begin with a particular
 187 ;;; pattern. Alas..) -- WHN 19991206
 188 (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 189   #!+sb-doc
 190   "Given two strings (string1 and string2), and optional integers start1,
 191   start2, end1 and end2, compares characters in string1 to characters in
 192   string2 (using char=)."
 193   (string=* string1 string2 start1 end1 start2 end2))
 194
 195 (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 196   #!+sb-doc
 197   "Given two strings, if the first string is not lexicographically equal
 198   to the second string, returns the longest common prefix (using char=)
 199   of the two strings. Otherwise, returns ()."
 200   (string/=* string1 string2 start1 end1 start2 end2))
 201
 202 (eval-when (:compile-toplevel :execute)
 203
 204 ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
 205 ;;; STRING-EQUAL and STRING-NOT-EQUAL.
 206 (sb!xc:defmacro string-not-equal-loop (end
 207                                          end-value
 208                                          &optional (abort-value nil abortp))
 209   (declare (fixnum end))
 210   (let ((end-test (if (= end 1)
 211                       `(= index1 (the fixnum end1))
 212                       `(= index2 (the fixnum end2)))))
 213     `(do ((index1 start1 (1+ index1))
 214           (index2 start2 (1+ index2)))
 215          (,(if abortp
 216                end-test
 217                `(or ,end-test
 218                     (not (char-equal (schar string1 index1)
 219                                      (schar string2 index2)))))
 220           ,end-value)
 221        (declare (fixnum index1 index2))
 222        ,@(if abortp
 223              `((if (not (char-equal (schar string1 index1)
 224                                     (schar string2 index2)))
 225                    (return ,abort-value)))))))
 226
 227 ) ; EVAL-WHEN
 228
 229 (defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
 230   #!+sb-doc
 231   "Given two strings (string1 and string2), and optional integers start1,
 232   start2, end1 and end2, compares characters in string1 to characters in
 233   string2 (using char-equal)."
 234   (declare (fixnum start1 start2))
 235   (with-two-strings string1 string2 start1 end1 nil start2 end2
 236     (let ((slen1 (- (the fixnum end1) start1))
 237           (slen2 (- (the fixnum end2) start2)))
 238       (declare (fixnum slen1 slen2))
 239       (if (= slen1 slen2)
 240           ;;return () immediately if lengths aren't equal.
 241           (string-not-equal-loop 1 t nil)))))
 242
 243 (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
 244   #!+sb-doc
 245   "Given two strings, if the first string is not lexicographically equal
 246   to the second string, returns the longest common prefix (using char-equal)
 247   of the two strings. Otherwise, returns ()."
 248   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 249     (let ((slen1 (- end1 start1))
 250           (slen2 (- end2 start2)))
 251       (declare (fixnum slen1 slen2))
 252       (cond ((= slen1 slen2)
 253              (string-not-equal-loop 1 nil (- index1 offset1)))
 254             ((< slen1 slen2)
 255              (string-not-equal-loop 1 (- index1 offset1)))
 256             (t
 257              (string-not-equal-loop 2 (- index1 offset1)))))))
 258
 259 (eval-when (:compile-toplevel :execute)
 260
 261 ;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
 262 ;;; and string2 and a test on the current characters from string1 and string2
 263 ;;; for the following macro.
 264 (defun string-less-greater-equal-tests (lessp equalp)
 265   (if lessp
 266       (if equalp
 267           ;; STRING-NOT-GREATERP
 268           (values '<= `(not (char-greaterp char1 char2)))
 269           ;; STRING-LESSP
 270           (values '< `(char-lessp char1 char2)))
 271       (if equalp
 272           ;; STRING-NOT-LESSP
 273           (values '>= `(not (char-lessp char1 char2)))
 274           ;; STRING-GREATERP
 275           (values '> `(char-greaterp char1 char2)))))
 276
 277 (sb!xc:defmacro string-less-greater-equal (lessp equalp)
 278   (multiple-value-bind (length-test character-test)
 279       (string-less-greater-equal-tests lessp equalp)
 280     `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
 281        (let ((slen1 (- (the fixnum end1) start1))
 282              (slen2 (- (the fixnum end2) start2)))
 283          (declare (fixnum slen1 slen2))
 284          (do ((index1 start1 (1+ index1))
 285               (index2 start2 (1+ index2))
 286               (char1)
 287               (char2))
 288              ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
 289               (if (,length-test slen1 slen2) (- index1 offset1)))
 290            (declare (fixnum index1 index2))
 291            (setq char1 (schar string1 index1))
 292            (setq char2 (schar string2 index2))
 293            (if (not (char-equal char1 char2))
 294                (if ,character-test
 295                    (return (- index1 offset1))
 296                    (return ()))))))))
 297
 298 ) ; EVAL-WHEN
 299
 300 (defun string-lessp* (string1 string2 start1 end1 start2 end2)
 301   (declare (fixnum start1 start2))
 302   (string-less-greater-equal t nil))
 303
 304 (defun string-greaterp* (string1 string2 start1 end1 start2 end2)
 305   (declare (fixnum start1 start2))
 306   (string-less-greater-equal nil nil))
 307
 308 (defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
 309   (declare (fixnum start1 start2))
 310   (string-less-greater-equal nil t))
 311
 312 (defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
 313   (declare (fixnum start1 start2))
 314   (string-less-greater-equal t t))
 315
 316 (defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 317   #!+sb-doc
 318   "Given two strings, if the first string is lexicographically less than
 319   the second string, returns the longest common prefix (using char-equal)
 320   of the two strings. Otherwise, returns ()."
 321   (string-lessp* string1 string2 start1 end1 start2 end2))
 322
 323 (defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 324   #!+sb-doc
 325   "Given two strings, if the first string is lexicographically greater than
 326   the second string, returns the longest common prefix (using char-equal)
 327   of the two strings. Otherwise, returns ()."
 328   (string-greaterp* string1 string2 start1 end1 start2 end2))
 329
 330 (defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 331   #!+sb-doc
 332   "Given two strings, if the first string is lexicographically greater
 333   than or equal to the second string, returns the longest common prefix
 334   (using char-equal) of the two strings. Otherwise, returns ()."
 335   (string-not-lessp* string1 string2 start1 end1 start2 end2))
 336
 337 (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
 338                                     end2)
 339   #!+sb-doc
 340   "Given two strings, if the first string is lexicographically less than
 341   or equal to the second string, returns the longest common prefix
 342   (using char-equal) of the two strings. Otherwise, returns ()."
 343   (string-not-greaterp* string1 string2 start1 end1 start2 end2))
 344
 345 (defun make-string (count &key
 346                     (element-type 'character)
 347                     ((:initial-element fill-char)))
 348   #!+sb-doc
 349   "Given a character count and an optional fill character, makes and returns a
 350 new string COUNT long filled with the fill character."
 351   (declare (fixnum count))
 352   (if fill-char
 353       (make-string count :element-type element-type :initial-element fill-char)
 354       (make-string count :element-type element-type)))
 355
 356 (flet ((%upcase (string start end)
 357          (declare (string string) (index start) (type sequence-end end))
 358          (let ((saved-header string))
 359            (with-one-string (string start end)
 360              (do ((index start (1+ index)))
 361                  ((= index (the fixnum end)))
 362                (declare (fixnum index))
 363                (setf (schar string index) (char-upcase (schar string index)))))
 364            saved-header)))
 365 (defun string-upcase (string &key (start 0) end)
 366   (%upcase (copy-seq (string string)) start end))
 367 (defun nstring-upcase (string &key (start 0) end)
 368   (%upcase string start end))
 369 ) ; FLET
 370
 371 (flet ((%downcase (string start end)
 372          (declare (string string) (index start) (type sequence-end end))
 373          (let ((saved-header string))
 374            (with-one-string (string start end)
 375              (do ((index start (1+ index)))
 376                  ((= index (the fixnum end)))
 377                (declare (fixnum index))
 378                (setf (schar string index)
 379                      (char-downcase (schar string index)))))
 380            saved-header)))
 381 (defun string-downcase (string &key (start 0) end)
 382   (%downcase (copy-seq (string string)) start end))
 383 (defun nstring-downcase (string &key (start 0) end)
 384   (%downcase string start end))
 385 ) ; FLET
 386
 387 (flet ((%capitalize (string start end)
 388          (declare (string string) (index start) (type sequence-end end))
 389          (let ((saved-header string))
 390            (with-one-string (string start end)
 391              (do ((index start (1+ index))
 392                   (new-word? t)
 393                   (char nil))
 394                  ((= index (the fixnum end)))
 395                (declare (fixnum index))
 396                (setq char (schar string index))
 397                (cond ((not (alphanumericp char))
 398                       (setq new-word? t))
 399                      (new-word?
 400                       ;; CHAR is the first case-modifiable character after
 401                       ;; a sequence of non-case-modifiable characters.
 402                       (setf (schar string index) (char-upcase char))
 403                       (setq new-word? nil))
 404                      (t
 405                       (setf (schar string index) (char-downcase char))))))
 406            saved-header)))
 407 (defun string-capitalize (string &key (start 0) end)
 408   (%capitalize (copy-seq (string string)) start end))
 409 (defun nstring-capitalize (string &key (start 0) end)
 410   (%capitalize string start end))
 411 ) ; FLET
 412
 413 (defun string-left-trim (char-bag string)
 414   (with-string string
 415     (do ((index start (1+ index)))
 416         ((or (= index (the fixnum end))
 417              (not (find (schar string index) char-bag :test #'char=)))
 418          (subseq (the simple-string string) index end))
 419       (declare (fixnum index)))))
 420
 421 (defun string-right-trim (char-bag string)
 422   (with-string string
 423     (do ((index (1- (the fixnum end)) (1- index)))
 424         ((or (< index start)
 425              (not (find (schar string index) char-bag :test #'char=)))
 426          (subseq (the simple-string string) start (1+ index)))
 427       (declare (fixnum index)))))
 428
 429 (defun string-trim (char-bag string)
 430   (with-string string
 431     (let* ((left-end (do ((index start (1+ index)))
 432                          ((or (= index (the fixnum end))
 433                               (not (find (schar string index)
 434                                          char-bag
 435                                          :test #'char=)))
 436                           index)
 437                        (declare (fixnum index))))
 438            (right-end (do ((index (1- (the fixnum end)) (1- index)))
 439                           ((or (< index left-end)
 440                                (not (find (schar string index)
 441                                           char-bag
 442                                           :test #'char=)))
 443                            (1+ index))
 444                         (declare (fixnum index)))))
 445       (subseq (the simple-string string) left-end right-end))))