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 ;;; With-One-String is used to set up some string hacking things. The keywords
  31 ;;; are parsed, and the string is hacked into a simple-string.
  32
  33 (eval-when (:compile-toplevel)
  34
  35 (sb!xc:defmacro with-one-string (string start end cum-offset &rest forms)
  36   `(let ((,string (if (stringp ,string) ,string (string ,string))))
  37      (with-array-data ((,string ,string :offset-var ,cum-offset)
  38                        (,start ,start)
  39                        (,end (or ,end (length (the vector ,string)))))
  40        ,@forms)))
  41
  42 ) ; EVAN-WHEN
  43
  44 ;;; With-String is like With-One-String, but doesn't parse keywords.
  45
  46 (eval-when (:compile-toplevel)
  47
  48 (sb!xc:defmacro with-string (string &rest forms)
  49   `(let ((,string (if (stringp ,string) ,string (string ,string))))
  50      (with-array-data ((,string ,string)
  51                        (start)
  52                        (end (length (the vector ,string))))
  53        ,@forms)))
  54
  55 ) ; EVAL-WHEN
  56
  57 ;;; With-Two-Strings is used to set up string comparison operations. The
  58 ;;; keywords are parsed, and the strings are hacked into simple-strings.
  59
  60 (eval-when (:compile-toplevel)
  61
  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 (or ,end1 (length (the vector ,string1)))))
  69        (with-array-data ((,string2 ,string2)
  70                          (,start2 ,start2)
  71                          (,end2 (or ,end2 (length (the vector ,string2)))))
  72          ,@forms))))
  73
  74 ) ; EVAL-WHEN
  75
  76 (defun char (string index)
  77   #!+sb-doc
  78   "Given a string and a non-negative integer index less than the length of
  79   the string, returns the character object representing the character at
  80   that position in the string."
  81   (declare (optimize (safety 1)))
  82   (char string index))
  83
  84 (defun %charset (string index new-el)
  85   (declare (optimize (safety 1)))
  86   (setf (char string index) new-el))
  87
  88 (defun schar (string index)
  89   #!+sb-doc
  90   "SCHAR returns the character object at an indexed position in a string
  91    just as CHAR does, except the string must be a simple-string."
  92   (declare (optimize (safety 1)))
  93   (schar string index))
  94
  95 (defun %scharset (string index new-el)
  96   (declare (optimize (safety 1)))
  97   (setf (schar string index) new-el))
  98
  99 (defun string=* (string1 string2 start1 end1 start2 end2)
 100   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 101     (not (%sp-string-compare string1 start1 end1 string2 start2 end2))))
 102
 103 (defun string/=* (string1 string2 start1 end1 start2 end2)
 104   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 105     (let ((comparison (%sp-string-compare string1 start1 end1
 106                                           string2 start2 end2)))
 107       (if comparison (- (the fixnum comparison) offset1)))))
 108
 109 (eval-when (:compile-toplevel :execute)
 110
 111 ;;; Lessp is true if the desired expansion is for string<* or string<=*.
 112 ;;; Equalp is true if the desired expansion is for string<=* or string>=*.
 113 (sb!xc:defmacro string<>=*-body (lessp equalp)
 114   (let ((offset1 (gensym)))
 115     `(with-two-strings string1 string2 start1 end1 ,offset1 start2 end2
 116        (let ((index (%sp-string-compare string1 start1 end1
 117                                         string2 start2 end2)))
 118          (if index
 119              (cond ((= (the fixnum index) (the fixnum end1))
 120                     ,(if lessp
 121                          `(- (the fixnum index) ,offset1)
 122                        `nil))
 123                    ((= (+ (the fixnum index) (- start2 start1))
 124                        (the fixnum end2))
 125                     ,(if lessp
 126                          `nil
 127                        `(- (the fixnum index) ,offset1)))
 128                    ((,(if lessp 'char< 'char>)
 129                      (schar string1 index)
 130                      (schar string2 (+ (the fixnum index) (- start2 start1))))
 131                     (- (the fixnum index) ,offset1))
 132                    (t nil))
 133              ,(if equalp `(- (the fixnum end1) ,offset1) 'nil))))))
 134 ) ; eval-when
 135
 136 (defun string<* (string1 string2 start1 end1 start2 end2)
 137   (declare (fixnum start1 start2))
 138   (string<>=*-body t nil))
 139
 140 (defun string>* (string1 string2 start1 end1 start2 end2)
 141   (declare (fixnum start1 start2))
 142   (string<>=*-body nil nil))
 143
 144 (defun string<=* (string1 string2 start1 end1 start2 end2)
 145   (declare (fixnum start1 start2))
 146   (string<>=*-body t t))
 147
 148 (defun string>=* (string1 string2 start1 end1 start2 end2)
 149   (declare (fixnum start1 start2))
 150   (string<>=*-body nil t))
 151
 152 (defun string< (string1 string2 &key (start1 0) end1 (start2 0) end2)
 153   #!+sb-doc
 154   "Given two strings, if the first string is lexicographically less than
 155   the second string, returns the longest common prefix (using char=)
 156   of the two strings. Otherwise, returns ()."
 157   (string<* string1 string2 start1 end1 start2 end2))
 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 greater 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 less than
 169   or equal to the second string, returns the longest common prefix
 170   (using char=) 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   "Given two strings, if the first string is lexicographically greater
 175   than or equal to the second string, returns the longest common prefix
 176   (using char=) of the two strings. Otherwise, returns ()."
 177   (string>=* string1 string2 start1 end1 start2 end2))
 178
 179 ;;; Note: (STRING= "PREFIX" "SHORT" :END2 (LENGTH "PREFIX")) gives
 180 ;;; an error instead of returning NIL as I would have expected.
 181 ;;; The ANSI spec for STRING= itself doesn't seem to clarify this
 182 ;;; much, but the SUBSEQ-OUT-OF-BOUNDS writeup seems to say that
 183 ;;; this is conforming (and required) behavior, because any index
 184 ;;; out of range is an error. (So there seems to be no concise and
 185 ;;; efficient way to test for strings which begin with a particular
 186 ;;; pattern. Alas..) -- WHN 19991206
 187 (defun string= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 188   #!+sb-doc
 189   "Given two strings (string1 and string2), and optional integers start1,
 190   start2, end1 and end2, compares characters in string1 to characters in
 191   string2 (using char=)."
 192   (string=* string1 string2 start1 end1 start2 end2))
 193
 194 (defun string/= (string1 string2 &key (start1 0) end1 (start2 0) end2)
 195   #!+sb-doc
 196   "Given two strings, if the first string is not lexicographically equal
 197   to the second string, returns the longest common prefix (using char=)
 198   of the two strings. Otherwise, returns ()."
 199   (string/=* string1 string2 start1 end1 start2 end2))
 200
 201 (eval-when (:compile-toplevel :execute)
 202
 203 ;;; STRING-NOT-EQUAL-LOOP is used to generate character comparison loops for
 204 ;;; STRING-EQUAL and STRING-NOT-EQUAL.
 205 (sb!xc:defmacro string-not-equal-loop (end
 206                                          end-value
 207                                          &optional (abort-value nil abortp))
 208   (declare (fixnum end))
 209   (let ((end-test (if (= end 1)
 210                       `(= index1 (the fixnum end1))
 211                       `(= index2 (the fixnum end2)))))
 212     `(do ((index1 start1 (1+ index1))
 213           (index2 start2 (1+ index2)))
 214          (,(if abortp
 215                end-test
 216                `(or ,end-test
 217                     (not (char-equal (schar string1 index1)
 218                                      (schar string2 index2)))))
 219           ,end-value)
 220        (declare (fixnum index1 index2))
 221        ,@(if abortp
 222              `((if (not (char-equal (schar string1 index1)
 223                                     (schar string2 index2)))
 224                    (return ,abort-value)))))))
 225
 226 ) ; EVAL-WHEN
 227
 228 (defun string-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
 229   #!+sb-doc
 230   "Given two strings (string1 and string2), and optional integers start1,
 231   start2, end1 and end2, compares characters in string1 to characters in
 232   string2 (using char-equal)."
 233   (declare (fixnum start1 start2))
 234   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 235     (let ((slen1 (- (the fixnum end1) start1))
 236           (slen2 (- (the fixnum end2) start2)))
 237       (declare (fixnum slen1 slen2))
 238       (if (or (minusp slen1) (minusp slen2))
 239           ;;prevent endless looping later.
 240           (error "Improper bounds for string comparison."))
 241       (if (= slen1 slen2)
 242           ;;return () immediately if lengths aren't equal.
 243           (string-not-equal-loop 1 t nil)))))
 244
 245 (defun string-not-equal (string1 string2 &key (start1 0) end1 (start2 0) end2)
 246   #!+sb-doc
 247   "Given two strings, if the first string is not lexicographically equal
 248   to the second string, returns the longest common prefix (using char-equal)
 249   of the two strings. Otherwise, returns ()."
 250   (with-two-strings string1 string2 start1 end1 offset1 start2 end2
 251     (let ((slen1 (- end1 start1))
 252           (slen2 (- end2 start2)))
 253       (declare (fixnum slen1 slen2))
 254       (if (or (minusp slen1) (minusp slen2))
 255           ;;prevent endless looping later.
 256           (error "Improper bounds for string comparison."))
 257       (cond ((or (minusp slen1) (or (minusp slen2)))
 258              (error "Improper substring for comparison."))
 259             ((= slen1 slen2)
 260              (string-not-equal-loop 1 nil (- index1 offset1)))
 261             ((< slen1 slen2)
 262              (string-not-equal-loop 1 (- index1 offset1)))
 263             (t
 264              (string-not-equal-loop 2 (- index1 offset1)))))))
 265
 266 (eval-when (:compile-toplevel :execute)
 267
 268 ;;; STRING-LESS-GREATER-EQUAL-TESTS returns a test on the lengths of string1
 269 ;;; and string2 and a test on the current characters from string1 and string2
 270 ;;; for the following macro.
 271 (defun string-less-greater-equal-tests (lessp equalp)
 272   (if lessp
 273       (if equalp
 274           ;; STRING-NOT-GREATERP
 275           (values '<= `(not (char-greaterp char1 char2)))
 276           ;; STRING-LESSP
 277           (values '< `(char-lessp char1 char2)))
 278       (if equalp
 279           ;; STRING-NOT-LESSP
 280           (values '>= `(not (char-lessp char1 char2)))
 281           ;; STRING-GREATERP
 282           (values '> `(char-greaterp char1 char2)))))
 283
 284 (sb!xc:defmacro string-less-greater-equal (lessp equalp)
 285   (multiple-value-bind (length-test character-test)
 286       (string-less-greater-equal-tests lessp equalp)
 287     `(with-two-strings string1 string2 start1 end1 offset1 start2 end2
 288        (let ((slen1 (- (the fixnum end1) start1))
 289              (slen2 (- (the fixnum end2) start2)))
 290          (declare (fixnum slen1 slen2))
 291          (if (or (minusp slen1) (minusp slen2))
 292              ;;prevent endless looping later.
 293              (error "Improper bounds for string comparison."))
 294          (do ((index1 start1 (1+ index1))
 295               (index2 start2 (1+ index2))
 296               (char1)
 297               (char2))
 298              ((or (= index1 (the fixnum end1)) (= index2 (the fixnum end2)))
 299               (if (,length-test slen1 slen2) (- index1 offset1)))
 300            (declare (fixnum index1 index2))
 301            (setq char1 (schar string1 index1))
 302            (setq char2 (schar string2 index2))
 303            (if (not (char-equal char1 char2))
 304                (if ,character-test
 305                    (return (- index1 offset1))
 306                    (return ()))))))))
 307
 308 ) ; EVAL-WHEN
 309
 310 (defun string-lessp* (string1 string2 start1 end1 start2 end2)
 311   (declare (fixnum start1 start2))
 312   (string-less-greater-equal t nil))
 313
 314 (defun string-greaterp* (string1 string2 start1 end1 start2 end2)
 315   (declare (fixnum start1 start2))
 316   (string-less-greater-equal nil nil))
 317
 318 (defun string-not-lessp* (string1 string2 start1 end1 start2 end2)
 319   (declare (fixnum start1 start2))
 320   (string-less-greater-equal nil t))
 321
 322 (defun string-not-greaterp* (string1 string2 start1 end1 start2 end2)
 323   (declare (fixnum start1 start2))
 324   (string-less-greater-equal t t))
 325
 326 (defun string-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 327   #!+sb-doc
 328   "Given two strings, if the first string is lexicographically less than
 329   the second string, returns the longest common prefix (using char-equal)
 330   of the two strings. Otherwise, returns ()."
 331   (string-lessp* string1 string2 start1 end1 start2 end2))
 332
 333 (defun string-greaterp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 334   #!+sb-doc
 335   "Given two strings, if the first string is lexicographically greater than
 336   the second string, returns the longest common prefix (using char-equal)
 337   of the two strings. Otherwise, returns ()."
 338   (string-greaterp* string1 string2 start1 end1 start2 end2))
 339
 340 (defun string-not-lessp (string1 string2 &key (start1 0) end1 (start2 0) end2)
 341   #!+sb-doc
 342   "Given two strings, if the first string is lexicographically greater
 343   than or equal to the second string, returns the longest common prefix
 344   (using char-equal) of the two strings. Otherwise, returns ()."
 345   (string-not-lessp* string1 string2 start1 end1 start2 end2))
 346
 347 (defun string-not-greaterp (string1 string2 &key (start1 0) end1 (start2 0)
 348                                     end2)
 349   #!+sb-doc
 350   "Given two strings, if the first string is lexicographically less than
 351   or equal to the second string, returns the longest common prefix
 352   (using char-equal) of the two strings. Otherwise, returns ()."
 353   (string-not-greaterp* string1 string2 start1 end1 start2 end2))
 354
 355 (defun make-string (count &key element-type ((:initial-element fill-char)))
 356   #!+sb-doc
 357   "Given a character count and an optional fill character, makes and returns
 358    a new string Count long filled with the fill character."
 359   (declare (fixnum count)
 360            (ignore element-type))
 361   (if fill-char
 362       (do ((i 0 (1+ i))
 363            (string (make-string count)))
 364           ((= i count) string)
 365         (declare (fixnum i))
 366         (setf (schar string i) fill-char))
 367       (make-string count)))
 368
 369 (defun string-upcase (string &key (start 0) end)
 370   #!+sb-doc
 371   "Given a string, returns a new string that is a copy of it with
 372   all lower case alphabetic characters converted to uppercase."
 373   (declare (fixnum start))
 374   (let* ((string (if (stringp string) string (string string)))
 375          (slen (length string)))
 376     (declare (fixnum slen))
 377     (with-one-string string start end offset
 378       (let ((offset-slen (+ slen offset))
 379             (newstring (make-string slen)))
 380         (declare (fixnum offset-slen))
 381         (do ((index offset (1+ index))
 382              (new-index 0 (1+ new-index)))
 383             ((= index start))
 384           (declare (fixnum index new-index))
 385           (setf (schar newstring new-index) (schar string index)))
 386         (do ((index start (1+ index))
 387              (new-index (- start offset) (1+ new-index)))
 388             ((= index (the fixnum end)))
 389           (declare (fixnum index new-index))
 390           (setf (schar newstring new-index)
 391                 (char-upcase (schar string index))))
 392         (do ((index end (1+ index))
 393              (new-index (- (the fixnum end) offset) (1+ new-index)))
 394             ((= index offset-slen))
 395           (declare (fixnum index new-index))
 396           (setf (schar newstring new-index) (schar string index)))
 397         newstring))))
 398
 399 (defun string-downcase (string &key (start 0) end)
 400   #!+sb-doc
 401   "Given a string, returns a new string that is a copy of it with
 402   all upper case alphabetic characters converted to lowercase."
 403   (declare (fixnum start))
 404   (let* ((string (if (stringp string) string (string string)))
 405          (slen (length string)))
 406     (declare (fixnum slen))
 407     (with-one-string string start end offset
 408       (let ((offset-slen (+ slen offset))
 409             (newstring (make-string slen)))
 410         (declare (fixnum offset-slen))
 411         (do ((index offset (1+ index))
 412              (new-index 0 (1+ new-index)))
 413             ((= index start))
 414           (declare (fixnum index new-index))
 415           (setf (schar newstring new-index) (schar string index)))
 416         (do ((index start (1+ index))
 417              (new-index (- start offset) (1+ new-index)))
 418             ((= index (the fixnum end)))
 419           (declare (fixnum index new-index))
 420           (setf (schar newstring new-index)
 421                 (char-downcase (schar string index))))
 422         (do ((index end (1+ index))
 423              (new-index (- (the fixnum end) offset) (1+ new-index)))
 424             ((= index offset-slen))
 425           (declare (fixnum index new-index))
 426           (setf (schar newstring new-index) (schar string index)))
 427         newstring))))
 428
 429 (defun string-capitalize (string &key (start 0) end)
 430   #!+sb-doc
 431   "Given a string, returns a copy of the string with the first
 432   character of each ``word'' converted to upper-case, and remaining
 433   chars in the word converted to lower case. A ``word'' is defined
 434   to be a string of case-modifiable characters delimited by
 435   non-case-modifiable chars."
 436   (declare (fixnum start))
 437   (let* ((string (if (stringp string) string (string string)))
 438          (slen (length string)))
 439     (declare (fixnum slen))
 440     (with-one-string string start end offset
 441       (let ((offset-slen (+ slen offset))
 442             (newstring (make-string slen)))
 443         (declare (fixnum offset-slen))
 444         (do ((index offset (1+ index))
 445              (new-index 0 (1+ new-index)))
 446             ((= index start))
 447           (declare (fixnum index new-index))
 448           (setf (schar newstring new-index) (schar string index)))
 449         (do ((index start (1+ index))
 450              (new-index (- start offset) (1+ new-index))
 451              (newword t)
 452              (char ()))
 453             ((= index (the fixnum end)))
 454           (declare (fixnum index new-index))
 455           (setq char (schar string index))
 456           (cond ((not (alphanumericp char))
 457                  (setq newword t))
 458                 (newword
 459                  ;;char is first case-modifiable after non-case-modifiable
 460                  (setq char (char-upcase char))
 461                  (setq newword ()))
 462                 ;;char is case-modifiable, but not first
 463                 (t (setq char (char-downcase char))))
 464           (setf (schar newstring new-index) char))
 465         (do ((index end (1+ index))
 466              (new-index (- (the fixnum end) offset) (1+ new-index)))
 467             ((= index offset-slen))
 468           (declare (fixnum index new-index))
 469           (setf (schar newstring new-index) (schar string index)))
 470         newstring))))
 471
 472 (defun nstring-upcase (string &key (start 0) end)
 473   #!+sb-doc
 474   "Given a string, returns that string with all lower case alphabetic
 475   characters converted to uppercase."
 476   (declare (fixnum start))
 477   (let ((save-header string))
 478     (with-one-string string start end offset
 479       (do ((index start (1+ index)))
 480           ((= index (the fixnum end)))
 481         (declare (fixnum index))
 482         (setf (schar string index) (char-upcase (schar string index)))))
 483     save-header))
 484
 485 (defun nstring-downcase (string &key (start 0) end)
 486   #!+sb-doc
 487   "Given a string, returns that string with all upper case alphabetic
 488   characters converted to lowercase."
 489   (declare (fixnum start))
 490   (let ((save-header string))
 491     (with-one-string string start end offset
 492       (do ((index start (1+ index)))
 493           ((= index (the fixnum end)))
 494         (declare (fixnum index))
 495         (setf (schar string index) (char-downcase (schar string index)))))
 496     save-header))
 497
 498 (defun nstring-capitalize (string &key (start 0) end)
 499   #!+sb-doc
 500   "Given a string, returns that string with the first
 501   character of each ``word'' converted to upper-case, and remaining
 502   chars in the word converted to lower case. A ``word'' is defined
 503   to be a string of case-modifiable characters delimited by
 504   non-case-modifiable chars."
 505   (declare (fixnum start))
 506   (let ((save-header string))
 507     (with-one-string string start end offset
 508       (do ((index start (1+ index))
 509            (newword t)
 510            (char ()))
 511           ((= index (the fixnum end)))
 512         (declare (fixnum index))
 513         (setq char (schar string index))
 514         (cond ((not (alphanumericp char))
 515                (setq newword t))
 516               (newword
 517                ;;char is first case-modifiable after non-case-modifiable
 518                (setf (schar string index) (char-upcase char))
 519                (setq newword ()))
 520               (t
 521                (setf (schar string index) (char-downcase char))))))
 522     save-header))
 523
 524 (defun string-left-trim (char-bag string)
 525   #!+sb-doc
 526   "Given a set of characters (a list or string) and a string, returns
 527   a copy of the string with the characters in the set removed from the
 528   left end."
 529   (with-string string
 530     (do ((index start (1+ index)))
 531         ((or (= index (the fixnum end))
 532              (not (find (schar string index) char-bag :test #'char=)))
 533          (subseq (the simple-string string) index end))
 534       (declare (fixnum index)))))
 535
 536 (defun string-right-trim (char-bag string)
 537   #!+sb-doc
 538   "Given a set of characters (a list or string) and a string, returns
 539   a copy of the string with the characters in the set removed from the
 540   right end."
 541   (with-string string
 542     (do ((index (1- (the fixnum end)) (1- index)))
 543         ((or (< index start)
 544              (not (find (schar string index) char-bag :test #'char=)))
 545          (subseq (the simple-string string) start (1+ index)))
 546       (declare (fixnum index)))))
 547
 548 (defun string-trim (char-bag string)
 549   #!+sb-doc
 550   "Given a set of characters (a list or string) and a string, returns a
 551   copy of the string with the characters in the set removed from both
 552   ends."
 553   (with-string string
 554     (let* ((left-end (do ((index start (1+ index)))
 555                          ((or (= index (the fixnum end))
 556                               (not (find (schar string index)
 557                                          char-bag
 558                                          :test #'char=)))
 559                           index)
 560                        (declare (fixnum index))))
 561            (right-end (do ((index (1- (the fixnum end)) (1- index)))
 562                           ((or (< index left-end)
 563                                (not (find (schar string index)
 564                                           char-bag
 565                                           :test #'char=)))
 566                            (1+ index))
 567                         (declare (fixnum index)))))
 568       (subseq (the simple-string string) left-end right-end))))