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>
  89                    nil t nil))
  90
  91 (defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
  92   (compare-strings s1 s2 start1 end1 start2 end2
  93                    #'char= #'char<
  94                    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>
  99                    t t nil))
 100
 101 (defun string>= (s1 s2 &key (start1 0) end1 (start2 0) end2)
 102   (compare-strings s1 s2 start1 end1 start2 end2
 103                    #'char= #'char<
 104                    t nil t))
 105
 106 (define-setf-expander char (string index)
 107   (let ((g!string (gensym))
 108         (g!index (gensym))
 109         (g!value (gensym)))
 110     (values (list g!string g!index)
 111             (list string index)
 112             (list g!value)
 113             `(aset ,g!string ,g!index ,g!value)
 114             `(char ,g!string ,g!index))))
 115
 116
 117 (defun concat (&rest strs)
 118   (flet ((concat-two (str1 str2)
 119            (concatenate-storage-vector str1 str2)))
 120     (!reduce #'concat-two strs "")))
 121
 122
 123 (defun string-upcase (string &key (start 0) end)
 124   (let* ((string (string string))
 125          (new (make-string (length string))))
 126     (dotimes (i (length string) new)
 127       (aset new i
 128             (if (and (or (null start) (>= i start))
 129                      (or (null end) (< i end)))
 130                 (char-upcase (char string i))
 131               (char string i))))))
 132
 133 (defun nstring-upcase (string &key (start 0) end)
 134   (let ((end (or end (length string))))
 135     (dotimes (i (- end start) string)
 136       (aset string (+ start i)
 137             (char-upcase (char string (+ start i)))))))
 138
 139 (defun string-downcase (string &key (start 0) end)
 140   (let* ((string (string string))
 141          (new (make-string (length string))))
 142     (dotimes (i (length string) new)
 143       (aset new i
 144             (if (and (or (null start) (>= i start))
 145                      (or (null end) (< i end)))
 146                 (char-downcase (char string i))
 147               (char string i))))))
 148
 149 (defun nstring-downcase (string &key (start 0) end)
 150   (let ((end (or end (length string))))
 151     (dotimes (i (- end start) string)
 152       (aset string (+ start i)
 153             (char-downcase (char string (+ start i)))))))
 154
 155 (defun string-capitalize (string &key (start 0) end)
 156   (let* ((string (string string))
 157          (new (make-string (length string)))
 158          (just-saw-alphanum-p nil))
 159     (dotimes (i (length string) new)
 160       (aset new i
 161             (cond ((or (and start (< i start))
 162                        (and end (> i end)))
 163                    (char string i))
 164                   ((or (= i start)
 165                        (not just-saw-alphanum-p))
 166                    (char-upcase (char string i)))
 167                   (t
 168                    (char-downcase (char string i)))))
 169       (setq just-saw-alphanum-p (alphanumericp (char string i))))))
 170
 171 (defun nstring-capitalize (string &key (start 0) end)
 172   (let ((end (or end (length string)))
 173         (just-saw-alphanum-p nil))
 174     (dotimes (i (- end start) string)
 175       (aset string (+ start i)
 176             (if (or (zerop i)
 177                     (not just-saw-alphanum-p))
 178                 (char-upcase (char string (+ start i)))
 179               (char-downcase (char string (+ start i)))))
 180       (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
 181
 182 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
 183   (let* ((s1 (string s1))
 184          (s2 (string s2))
 185          (n1 (length s1))
 186          (n2 (length s2))
 187          (start1 (or start1 0))
 188          (end1 (or end1 n1))
 189          (start2 (or start2 0))
 190          (end2 (or end2 n2)))
 191     (when (= (- end2 start2) (- end1 start1))
 192       (dotimes (i (- end2 start2) t)
 193         (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 194           (return-from string-equal nil))))))
 195
 196 ;; just like string/= but with char-equal instead of char=
 197 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
 198   (let* ((s1 (string s1))
 199          (s2 (string s2))
 200          (n1 (length s1))
 201          (n2 (length s2))
 202          (end1 (or end1 n1))
 203          (end2 (or end2 n2)))
 204     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
 205       (when (or (>= (+ start1 i) n1)
 206                 (>= (+ start2 i) n2))
 207         (return-from string-not-equal (+ start1 i)))
 208       (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 209         (return-from string-not-equal (+ start1 i))))))
 210
 211 (defun string-trim (character-bag string)
 212   (string-left-trim character-bag (string-right-trim character-bag string)))
 213
 214 (defun string-left-trim (character-bag string)
 215   (let* ((string (string string))
 216          (n (length string))
 217          (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
 218     (subseq string start)))
 219
 220 (defun string-right-trim (character-bag string)
 221   (let* ((string (string string))
 222          (n (length string)))
 223     (dotimes (i n "")
 224       (when (not (find (char string (- n i 1)) character-bag))
 225         (return-from string-right-trim (subseq string 0 (- n i)))))))