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