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
  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))
  68          (s2 (string s2))
  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))
  83                            (+ start1 i)
  84                          nil)))))))
  85
  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))
  89
  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))
  93
  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))
  97
  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))
 101
 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))
 105
 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))
 109
 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))
 113
 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))
 117
 118 (define-setf-expander char (string index)
 119   (let ((g!string (gensym))
 120         (g!index (gensym))
 121         (g!value (gensym)))
 122     (values (list g!string g!index)
 123             (list string index)
 124             (list g!value)
 125             `(aset ,g!string ,g!index ,g!value)
 126             `(char ,g!string ,g!index))))
 127
 128
 129 (defun concat (&rest strs)
 130   (flet ((concat-two (str1 str2)
 131            (concatenate-storage-vector str1 str2)))
 132     (!reduce #'concat-two strs "")))
 133
 134
 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)
 139       (aset new i
 140             (if (and (or (null start) (>= i start))
 141                      (or (null end) (< i end)))
 142                 (char-upcase (char string i))
 143               (char string i))))))
 144
 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)))))))
 150
 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)
 155       (aset new i
 156             (if (and (or (null start) (>= i start))
 157                      (or (null end) (< i end)))
 158                 (char-downcase (char string i))
 159               (char string i))))))
 160
 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)))))))
 166
 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)
 172       (aset new i
 173             (cond ((or (and start (< i start))
 174                        (and end (> i end)))
 175                    (char string i))
 176                   ((or (= i start)
 177                        (not just-saw-alphanum-p))
 178                    (char-upcase (char string i)))
 179                   (t
 180                    (char-downcase (char string i)))))
 181       (setq just-saw-alphanum-p (alphanumericp (char string i))))))
 182
 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)
 188             (if (or (zerop 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)))))))
 193
 194 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
 195   (let* ((s1 (string s1))
 196          (s2 (string s2))
 197          (n1 (length s1))
 198          (n2 (length s2))
 199          (start1 (or start1 0))
 200          (end1 (or end1 n1))
 201          (start2 (or start2 0))
 202          (end2 (or end2 n2)))
 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))))))
 207
 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))
 211          (s2 (string s2))
 212          (n1 (length s1))
 213          (n2 (length s2))
 214          (end1 (or end1 n1))
 215          (end2 (or end2 n2)))
 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))))))
 222
 223 (defun string-trim (character-bag string)
 224   (string-left-trim character-bag (string-right-trim character-bag string)))
 225
 226 (defun string-left-trim (character-bag string)
 227   (let* ((string (string string))
 228          (n (length string))
 229          (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
 230     (subseq string start)))
 231
 232 (defun string-right-trim (character-bag string)
 233   (let* ((string (string string))
 234          (n (length string)))
 235     (dotimes (i n "")
 236       (when (not (find (char string (- n i 1)) character-bag))
 237         (return-from string-right-trim (subseq string 0 (- n i)))))))