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