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