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 (defun stringp (s)
  17   (stringp s))
  18
  19 (defun string-length (string)
  20   (storage-vector-size string))
  21
  22 (defun make-string (n &key initial-element)
  23   (make-array n :element-type 'character :initial-element initial-element))
  24
  25 (defun char (string index)
  26   (unless (stringp string) (error "~S is not a string" string))
  27   (storage-vector-ref string index))
  28
  29 (defun string (x)
  30   (cond ((stringp x) x)
  31         ((symbolp x) (symbol-name x))
  32         (t (make-string 1 :initial-element x))))
  33
  34 (defun string= (s1 s2 &key (start1 0) end1 (start2 0) end2)
  35   (let* ((s1 (string s1))
  36          (s2 (string s2))
  37          (n1 (length s1))
  38          (n2 (length s2))
  39          (end1 (or end1 n1))
  40          (end2 (or end2 n2)))
  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))))))
  45
  46 (defun string/= (s1 s2 &key (start1 0) end1 (start2 0) end2)
  47   (let* ((s1 (string s1))
  48          (s2 (string s2))
  49          (n1 (length s1))
  50          (n2 (length s2))
  51          (end1 (or end1 n1))
  52          (end2 (or end2 n2)))
  53     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
  54       (when (or (>= (+ start1 i) n1)
  55                 (>= (+ start2 i) n2))
  56         (return-from string/= (+ start1 i)))
  57       (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
  58         (return-from string/= (+ start1 i))))))
  59
  60 (defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
  61   (let* ((s1 (string s1))
  62          (s2 (string s2))
  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)
  68           ((= len-1 0) 0)
  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))))))))
  78
  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))
  82          (s2 (string s2))
  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)
  88           ((= len-2 0) 0)
  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))))))))
  98
  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.
 102
 103 (define-setf-expander char (string index)
 104   (let ((g!string (gensym))
 105         (g!index (gensym))
 106         (g!value (gensym)))
 107     (values (list g!string g!index)
 108             (list string index)
 109             (list g!value)
 110             `(aset ,g!string ,g!index ,g!value)
 111             `(char ,g!string ,g!index))))
 112
 113
 114 (defun concat (&rest strs)
 115   (flet ((concat-two (str1 str2)
 116            (concatenate-storage-vector str1 str2)))
 117     (!reduce #'concat-two strs "")))
 118
 119
 120 (defun string-upcase (string &key (start 0) end)
 121   (let* ((string (string string))
 122          (new (make-string (length string))))
 123     (dotimes (i (length string) new)
 124       (aset new i
 125             (if (and (or (null start) (>= i start))
 126                      (or (null end) (< i end)))
 127                 (char-upcase (char string i))
 128               (char string i))))))
 129
 130 (defun nstring-upcase (string &key (start 0) end)
 131   (let ((end (or end (length string))))
 132     (dotimes (i (- end start) string)
 133       (aset string (+ start i)
 134             (char-upcase (char string (+ start i)))))))
 135
 136 (defun string-downcase (string &key (start 0) end)
 137   (let* ((string (string string))
 138          (new (make-string (length string))))
 139     (dotimes (i (length string) new)
 140       (aset new i
 141             (if (and (or (null start) (>= i start))
 142                      (or (null end) (< i end)))
 143                 (char-downcase (char string i))
 144               (char string i))))))
 145
 146 (defun nstring-downcase (string &key (start 0) end)
 147   (let ((end (or end (length string))))
 148     (dotimes (i (- end start) string)
 149       (aset string (+ start i)
 150             (char-downcase (char string (+ start i)))))))
 151
 152 (defun string-capitalize (string &key (start 0) end)
 153   (let* ((string (string string))
 154          (new (make-string (length string)))
 155          (just-saw-alphanum-p nil))
 156     (dotimes (i (length string) new)
 157       (aset new i
 158             (cond ((or (and start (< i start))
 159                        (and end (> i end)))
 160                    (char string i))
 161                   ((or (= i start)
 162                        (not just-saw-alphanum-p))
 163                    (char-upcase (char string i)))
 164                   (t
 165                    (char-downcase (char string i)))))
 166       (setq just-saw-alphanum-p (alphanumericp (char string i))))))
 167
 168 (defun nstring-capitalize (string &key (start 0) end)
 169   (let ((end (or end (length string)))
 170         (just-saw-alphanum-p nil))
 171     (dotimes (i (- end start) string)
 172       (aset string (+ start i)
 173             (if (or (zerop i)
 174                     (not just-saw-alphanum-p))
 175                 (char-upcase (char string (+ start i)))
 176               (char-downcase (char string (+ start i)))))
 177       (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
 178
 179 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
 180   (let* ((s1 (string s1))
 181          (s2 (string s2))
 182          (n1 (length s1))
 183          (n2 (length s2))
 184          (start1 (or start1 0))
 185          (end1 (or end1 n1))
 186          (start2 (or start2 0))
 187          (end2 (or end2 n2)))
 188     (when (= (- end2 start2) (- end1 start1))
 189       (dotimes (i (- end2 start2) t)
 190         (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 191           (return-from string-equal nil))))))
 192
 193 ;; just like string/= but with char-equal instead of char=
 194 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
 195   (let* ((s1 (string s1))
 196          (s2 (string s2))
 197          (n1 (length s1))
 198          (n2 (length s2))
 199          (end1 (or end1 n1))
 200          (end2 (or end2 n2)))
 201     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
 202       (when (or (>= (+ start1 i) n1)
 203                 (>= (+ start2 i) n2))
 204         (return-from string-not-equal (+ start1 i)))
 205       (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 206         (return-from string-not-equal (+ start1 i))))))
 207
 208 (defun string-trim (character-bag string)
 209   (string-left-trim character-bag (string-right-trim character-bag string)))
 210
 211 (defun string-left-trim (character-bag string)
 212   (let* ((string (string string))
 213          (n (length string))
 214          (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
 215     (subseq string start)))
 216
 217 (defun string-right-trim (character-bag string)
 218   (let* ((string (string string))
 219          (n (length string)))
 220     (dotimes (i n "")
 221       (when (not (find (char string (- n i 1)) character-bag))
 222         (return-from string-right-trim (subseq string 0 (- n i)))))))