Add SEARCH, MISMATCH testcases.
[jscl.git] / src / string.lisp
1 ;;; string.lisp
2
3 ;; JSCL is free software: you can redistribute it and/or
4 ;; modify it under the terms of the GNU General Public License as
5 ;; published by the Free Software Foundation, either version 3 of the
6 ;; License, or (at your option) any later version.
7 ;;
8 ;; JSCL is distributed in the hope that it will be useful, but
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
11 ;; General Public License for more details.
12 ;;
13 ;; You should have received a copy of the GNU General Public License
14 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
15
16 (/debug "loading string.lisp!")
17
18 (defun stringp (s)
19   (stringp s))
20
21 (defun string-length (string)
22   (storage-vector-size string))
23
24 (defun make-string (n &key initial-element)
25   (make-array n :element-type 'character :initial-element initial-element))
26
27 (defun char (string index)
28   (unless (stringp string) (error "~S is not a string" string))
29   (storage-vector-ref string index))
30
31 (defun string (x)
32   (cond ((stringp x) x)
33         ((symbolp x) (symbol-name x))
34         (t (make-string 1 :initial-element x))))
35
36 (defun string= (s1 s2 &key (start1 0) end1 (start2 0) end2)
37   (let* ((s1 (string s1))
38          (s2 (string s2))
39          (n1 (length s1))
40          (n2 (length s2))
41          (end1 (or end1 n1))
42          (end2 (or end2 n2)))
43     (when (= (- end2 start2) (- end1 start1))
44       (dotimes (i (- end2 start2) t)
45         (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
46           (return-from string= nil))))))
47
48 (defun string/= (s1 s2 &key (start1 0) end1 (start2 0) end2)
49   (let* ((s1 (string s1))
50          (s2 (string s2))
51          (n1 (length s1))
52          (n2 (length s2))
53          (end1 (or end1 n1))
54          (end2 (or end2 n2)))
55     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
56       (when (or (>= (+ start1 i) n1)
57                 (>= (+ start2 i) n2))
58         (return-from string/= (+ start1 i)))
59       (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
60         (return-from string/= (+ start1 i))))))
61
62
63 (defun compare-strings (s1 s2 start1 end1 start2 end2 char-eq char-lt if-eq if-a-sub-b if-b-sub-a)
64   ;; step through strings S1 and S2, using bounds START1 END1 START2 END2.
65   ;; using character comparison functions CHAR-EQ (equality) and CHAR-LT (less-than),
66   ;; find the first difference, if any, and return its index.
67   ;; the IF-* params say what to do if the strings are equal, or a strict prefix substring of the other:
68   ;; if T, it returns the first different index.  if NIL, it returns NIL.
69   (let* ((s1 (string s1))
70          (s2 (string s2))
71          (end1 (or end1 (length s1)))
72          (end2 (or end2 (length s2)))
73          (len-1 (- end1 start1))
74          (len-2 (- end2 start2)))
75     (dotimes (i (max len-1 len-2) (if if-eq (+ start1 i) nil))
76       (when (= i len-1)  ;; ran off the end of s1
77         (return-from compare-strings (if if-a-sub-b (+ start1 i) nil)))
78       (when (= i len-2)  ;; ran off the end of s2
79         (return-from compare-strings (if if-b-sub-a (+ start1 i) nil)))
80       (let ((c1 (char s1 (+ start1 i)))
81             (c2 (char s2 (+ start2 i))))
82         (when (not (funcall char-eq c1 c2))  ;; found a difference
83           (return-from compare-strings
84                        (if (not (funcall char-lt c1 c2))
85                            (+ start1 i)
86                          nil)))))))
87
88 (defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
89   (compare-strings s1 s2 start1 end1 start2 end2
90                    #'char= #'char> nil t nil))
91
92 (defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
93   (compare-strings s1 s2 start1 end1 start2 end2
94                    #'char= #'char< nil nil t))
95
96 (defun string<= (s1 s2 &key (start1 0) end1 (start2 0) end2)
97   (compare-strings s1 s2 start1 end1 start2 end2
98                    #'char= #'char> t t nil))
99   
100 (defun string>= (s1 s2 &key (start1 0) end1 (start2 0) end2)
101   (compare-strings s1 s2 start1 end1 start2 end2
102                    #'char= #'char< t nil t))
103
104 (defun string-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
105   (compare-strings s1 s2 start1 end1 start2 end2
106                    #'char-equal #'char-greaterp nil t nil))
107
108 (defun string-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
109   (compare-strings s1 s2 start1 end1 start2 end2
110                    #'char-equal #'char-lessp nil nil t))
111
112 (defun string-not-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
113   (compare-strings s1 s2 start1 end1 start2 end2
114                    #'char-equal #'char-greaterp t t nil))
115
116 (defun string-not-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
117   (compare-strings s1 s2 start1 end1 start2 end2
118                    #'char-equal #'char-lessp t nil t))
119
120 (define-setf-expander char (string index)
121   (let ((g!string (gensym))
122         (g!index (gensym))
123         (g!value (gensym)))
124     (values (list g!string g!index)
125             (list string index)
126             (list g!value)
127             `(aset ,g!string ,g!index ,g!value)
128             `(char ,g!string ,g!index))))
129
130
131 (defun concat (&rest strs)
132   (flet ((concat-two (str1 str2)
133            (concatenate-storage-vector str1 str2)))
134     (!reduce #'concat-two strs "")))
135
136
137 (defun string-upcase (string &key (start 0) end)
138   (let* ((string (string string))
139          (new (make-string (length string))))
140     (dotimes (i (length string) new)
141       (aset new i
142             (if (and (or (null start) (>= i start))
143                      (or (null end) (< i end)))
144                 (char-upcase (char string i))
145               (char string i))))))
146
147 (defun nstring-upcase (string &key (start 0) end)
148   (let ((end (or end (length string))))
149     (dotimes (i (- end start) string)
150       (aset string (+ start i)
151             (char-upcase (char string (+ start i)))))))
152
153 (defun string-downcase (string &key (start 0) end)
154   (let* ((string (string string))
155          (new (make-string (length string))))
156     (dotimes (i (length string) new)
157       (aset new i
158             (if (and (or (null start) (>= i start))
159                      (or (null end) (< i end)))
160                 (char-downcase (char string i))
161               (char string i))))))
162
163 (defun nstring-downcase (string &key (start 0) end)
164   (let ((end (or end (length string))))
165     (dotimes (i (- end start) string)
166       (aset string (+ start i)
167             (char-downcase (char string (+ start i)))))))
168
169 (defun string-capitalize (string &key (start 0) end)
170   (let* ((string (string string))
171          (new (make-string (length string)))
172          (just-saw-alphanum-p nil))
173     (dotimes (i (length string) new)
174       (aset new i
175             (cond ((or (and start (< i start))
176                        (and end (> i end)))
177                    (char string i))
178                   ((or (= i start)
179                        (not just-saw-alphanum-p))
180                    (char-upcase (char string i)))
181                   (t
182                    (char-downcase (char string i)))))
183       (setq just-saw-alphanum-p (alphanumericp (char string i))))))
184
185 (defun nstring-capitalize (string &key (start 0) end)
186   (let ((end (or end (length string)))
187         (just-saw-alphanum-p nil))
188     (dotimes (i (- end start) string)
189       (aset string (+ start i)
190             (if (or (zerop i)
191                     (not just-saw-alphanum-p))
192                 (char-upcase (char string (+ start i)))
193               (char-downcase (char string (+ start i)))))
194       (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
195
196 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
197   (let* ((s1 (string s1))
198          (s2 (string s2))
199          (n1 (length s1))
200          (n2 (length s2))
201          (start1 (or start1 0))
202          (end1 (or end1 n1))
203          (start2 (or start2 0))
204          (end2 (or end2 n2)))
205     (when (= (- end2 start2) (- end1 start1))
206       (dotimes (i (- end2 start2) t)
207         (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
208           (return-from string-equal nil))))))
209
210 ;; just like string/= but with char-equal instead of char=
211 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
212   (let* ((s1 (string s1))
213          (s2 (string s2))
214          (n1 (length s1))
215          (n2 (length s2))
216          (end1 (or end1 n1))
217          (end2 (or end2 n2)))
218     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
219       (when (or (>= (+ start1 i) n1)
220                 (>= (+ start2 i) n2))
221         (return-from string-not-equal (+ start1 i)))
222       (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
223         (return-from string-not-equal (+ start1 i))))))
224
225 (defun string-trim (character-bag string)
226   (string-left-trim character-bag (string-right-trim character-bag string)))
227
228 (defun string-left-trim (character-bag string)
229   (let* ((string (string string))
230          (n (length string))
231          (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
232     (subseq string start)))
233
234 (defun string-right-trim (character-bag string)
235   (let* ((string (string string))
236          (n (length string)))
237     (dotimes (i n "")
238       (when (not (find (char string (- n i 1)) character-bag))
239         (return-from string-right-trim (subseq string 0 (- n i)))))))