0.7.13.3
[sbcl.git] / 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))))