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.
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.
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/>.
19 (defun string-length (string)
20 (storage-vector-size string))
22 (defun make-string (n &key initial-element)
23 (make-array n :element-type 'character :initial-element initial-element))
25 (defun char (string index)
26 (unless (stringp string) (error "~S is not a string" string))
27 (storage-vector-ref string index))
31 ((symbolp x) (symbol-name x))
32 (t (make-string 1 :initial-element x))))
34 (defun string= (s1 s2 &key (start1 0) end1 (start2 0) end2)
35 (let* ((s1 (string s1))
41 (when (= (- end2 start2) (- end1 start1))
42 (dotimes (i (- end2 start2) t)
43 (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
44 (return-from string= nil))))))
46 (defun string/= (s1 s2 &key (start1 0) end1 (start2 0) end2)
47 (let* ((s1 (string s1))
53 (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
54 (when (or (>= (+ start1 i) n1)
56 (return-from string/= (+ start1 i)))
57 (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
58 (return-from string/= (+ start1 i))))))
61 (defun compare-strings (s1 s2 start1 end1 start2 end2 char-eq char-lt if-eq if-a-sub-b if-b-sub-a)
62 ;; step through strings S1 and S2, using bounds START1 END1 START2 END2.
63 ;; using character comparison functions CHAR-EQ (equality) and CHAR-LT (less-than),
64 ;; find the first difference, if any, and return its index.
65 ;; the IF-* params say what to do if the strings are equal, or a strict prefix substring of the other:
66 ;; if T, it returns the first different index. if NIL, it returns NIL.
67 (let* ((s1 (string s1))
69 (end1 (or end1 (length s1)))
70 (end2 (or end2 (length s2)))
71 (len-1 (- end1 start1))
72 (len-2 (- end2 start2)))
73 (dotimes (i (max len-1 len-2) (if if-eq (+ start1 i) nil))
74 (when (= i len-1) ;; ran off the end of s1
75 (return-from compare-strings (if if-a-sub-b (+ start1 i) nil)))
76 (when (= i len-2) ;; ran off the end of s2
77 (return-from compare-strings (if if-b-sub-a (+ start1 i) nil)))
78 (let ((c1 (char s1 (+ start1 i)))
79 (c2 (char s2 (+ start2 i))))
80 (when (not (funcall char-eq c1 c2)) ;; found a difference
81 (return-from compare-strings
82 (if (not (funcall char-lt c1 c2))
86 (defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
87 (compare-strings s1 s2 start1 end1 start2 end2
88 #'char= #'char> nil t nil))
90 (defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
91 (compare-strings s1 s2 start1 end1 start2 end2
92 #'char= #'char< nil nil t))
94 (defun string<= (s1 s2 &key (start1 0) end1 (start2 0) end2)
95 (compare-strings s1 s2 start1 end1 start2 end2
96 #'char= #'char> t t nil))
98 (defun string>= (s1 s2 &key (start1 0) end1 (start2 0) end2)
99 (compare-strings s1 s2 start1 end1 start2 end2
100 #'char= #'char< t nil t))
102 (defun string-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
103 (compare-strings s1 s2 start1 end1 start2 end2
104 #'char-equal #'char-greaterp nil t nil))
106 (defun string-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
107 (compare-strings s1 s2 start1 end1 start2 end2
108 #'char-equal #'char-lessp nil nil t))
110 (defun string-not-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
111 (compare-strings s1 s2 start1 end1 start2 end2
112 #'char-equal #'char-greaterp t t nil))
114 (defun string-not-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
115 (compare-strings s1 s2 start1 end1 start2 end2
116 #'char-equal #'char-lessp t nil t))
118 (define-setf-expander char (string index)
119 (let ((g!string (gensym))
122 (values (list g!string g!index)
125 `(aset ,g!string ,g!index ,g!value)
126 `(char ,g!string ,g!index))))
129 (defun concat (&rest strs)
130 (flet ((concat-two (str1 str2)
131 (concatenate-storage-vector str1 str2)))
132 (!reduce #'concat-two strs "")))
135 (defun string-upcase (string &key (start 0) end)
136 (let* ((string (string string))
137 (new (make-string (length string))))
138 (dotimes (i (length string) new)
140 (if (and (or (null start) (>= i start))
141 (or (null end) (< i end)))
142 (char-upcase (char string i))
145 (defun nstring-upcase (string &key (start 0) end)
146 (let ((end (or end (length string))))
147 (dotimes (i (- end start) string)
148 (aset string (+ start i)
149 (char-upcase (char string (+ start i)))))))
151 (defun string-downcase (string &key (start 0) end)
152 (let* ((string (string string))
153 (new (make-string (length string))))
154 (dotimes (i (length string) new)
156 (if (and (or (null start) (>= i start))
157 (or (null end) (< i end)))
158 (char-downcase (char string i))
161 (defun nstring-downcase (string &key (start 0) end)
162 (let ((end (or end (length string))))
163 (dotimes (i (- end start) string)
164 (aset string (+ start i)
165 (char-downcase (char string (+ start i)))))))
167 (defun string-capitalize (string &key (start 0) end)
168 (let* ((string (string string))
169 (new (make-string (length string)))
170 (just-saw-alphanum-p nil))
171 (dotimes (i (length string) new)
173 (cond ((or (and start (< i start))
177 (not just-saw-alphanum-p))
178 (char-upcase (char string i)))
180 (char-downcase (char string i)))))
181 (setq just-saw-alphanum-p (alphanumericp (char string i))))))
183 (defun nstring-capitalize (string &key (start 0) end)
184 (let ((end (or end (length string)))
185 (just-saw-alphanum-p nil))
186 (dotimes (i (- end start) string)
187 (aset string (+ start i)
189 (not just-saw-alphanum-p))
190 (char-upcase (char string (+ start i)))
191 (char-downcase (char string (+ start i)))))
192 (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
194 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
195 (let* ((s1 (string s1))
199 (start1 (or start1 0))
201 (start2 (or start2 0))
203 (when (= (- end2 start2) (- end1 start1))
204 (dotimes (i (- end2 start2) t)
205 (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
206 (return-from string-equal nil))))))
208 ;; just like string/= but with char-equal instead of char=
209 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
210 (let* ((s1 (string s1))
216 (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
217 (when (or (>= (+ start1 i) n1)
218 (>= (+ start2 i) n2))
219 (return-from string-not-equal (+ start1 i)))
220 (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
221 (return-from string-not-equal (+ start1 i))))))
223 (defun string-trim (character-bag string)
224 (string-left-trim character-bag (string-right-trim character-bag string)))
226 (defun string-left-trim (character-bag string)
227 (let* ((string (string string))
229 (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
230 (subseq string start)))
232 (defun string-right-trim (character-bag string)
233 (let* ((string (string string))
236 (when (not (find (char string (- n i 1)) character-bag))
237 (return-from string-right-trim (subseq string 0 (- n i)))))))