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))))))
60 (defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
61 (let* ((s1 (string s1))
63 (end1 (or end1 (length s1)))
64 (end2 (or end2 (length s2)))
65 (len-1 (- end1 start1))
66 (len-2 (- end2 start2)))
67 (cond ((= len-2 0) nil)
69 (t (dotimes (i len-1 nil)
70 (when (= i len-2) ;; ran off the end of s2
71 (return-from string< nil))
72 (when (char< (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
73 (return-from string< (+ start1 i)))
74 (when (char> (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
75 (return-from string< nil))
76 (when (and (= i (1- len-1)) (> len-2 len-1)) ;; ran off the end of s1
77 (return-from string< (+ start1 i 1))))))))
79 ;; just like string< but with everything flipped, except the result is still relative to s1
80 (defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
81 (let* ((s1 (string s1))
83 (end1 (or end1 (length s1)))
84 (end2 (or end2 (length s2)))
85 (len-1 (- end1 start1))
86 (len-2 (- end2 start2)))
87 (cond ((= len-1 0) nil)
89 (t (dotimes (i len-2 nil)
90 (when (= i len-1) ;; ran off the end of s1
91 (return-from string> nil))
92 (when (char> (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
93 (return-from string> (+ start1 i)))
94 (when (char< (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
95 (return-from string> nil))
96 (when (and (= i (1- len-2)) (> len-1 len-2)) ;; ran off the end of s2
97 (return-from string> (+ start1 i 1))))))))
99 ;; TODO: string<=, string>=
100 ;; - mostly like string< / string>
101 ;; - if we run off the end of s1 and s2 at the same time, then it's =, so return len.
103 (define-setf-expander char (string index)
104 (let ((g!string (gensym))
107 (values (list g!string g!index)
110 `(aset ,g!string ,g!index ,g!value)
111 `(char ,g!string ,g!index))))
114 (defun concat (&rest strs)
115 (flet ((concat-two (str1 str2)
116 (concatenate-storage-vector str1 str2)))
117 (!reduce #'concat-two strs "")))
120 (defun string-upcase (string &key start end)
121 (let* ((string (string string))
122 (new (make-string (length string))))
123 (dotimes (i (length string) new)
125 (if (and (or (null start) (>= i start))
126 (or (null end) (< i end)))
127 (char-upcase (char string i))
130 (defun string-downcase (string &key start end)
131 (let* ((string (string string))
132 (new (make-string (length string))))
133 (dotimes (i (length string) new)
135 (if (and (or (null start) (>= i start))
136 (or (null end) (< i end)))
137 (char-downcase (char string i))
140 (defun string-capitalize (string &key start end)
141 (let* ((string (string string))
142 (new (make-string (length string)))
143 (just-saw-alphanum-p nil))
144 (dotimes (i (length string) new)
146 (cond ((or (and start (< i start))
149 ((or (= i (or start 0))
150 (not just-saw-alphanum-p))
151 (char-upcase (char string i)))
153 (char-downcase (char string i)))))
154 (setq just-saw-alphanum-p (alphanumericp (char string i))))))
156 ;; TODO: NSTRING-{UPCASE,DOWNCASE,CAPITALIZE}
157 ;; - Q: can i just extract the above functions without the MAKE-STRING call, and then have the STRING-* variants do MAKE-STRING + NSTRING-*?
158 ;; - NOTE: sacla's tests depend on COPY-SEQ, which doesn't exist yet.
160 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
161 (let* ((s1 (string s1))
165 (start1 (or start1 0))
167 (start2 (or start2 0))
169 (when (= (- end2 start2) (- end1 start1))
170 (dotimes (i (- end2 start2) t)
171 (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
172 (return-from string-equal nil))))))
174 ;; just like string/= but with char-equal instead of char=
175 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
176 (let* ((s1 (string s1))
182 (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
183 (when (or (>= (+ start1 i) n1)
184 (>= (+ start2 i) n2))
185 (return-from string-not-equal (+ start1 i)))
186 (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
187 (return-from string-not-equal (+ start1 i))))))
189 (defun string-trim (character-bag string)
190 (string-left-trim character-bag (string-right-trim character-bag string)))
192 (defun string-left-trim (character-bag string)
193 (let* ((string (string string))
195 (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
196 (subseq string start)))
198 (defun string-right-trim (character-bag string)
199 (let* ((string (string string))
202 (when (not (find (char string (- n i 1)) character-bag))
203 (return-from string-right-trim (subseq string 0 (- n i)))))))