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 (/debug "loading string.lisp!")
  17
  18 (defun stringp (s)
  19   (stringp s))
  20
  21 (defun string-length (string)
  22   (storage-vector-size string))
  23
  24 (defun make-string (n &key initial-element)
  25   (make-array n :element-type 'character :initial-element initial-element))
  26
  27 (defun char (string index)
  28   (unless (stringp string) (error "~S is not a string" string))
  29   (storage-vector-ref string index))
  30
  31 (defun string (x)
  32   (cond ((stringp x) x)
  33         ((symbolp x) (symbol-name x))
  34         (t (make-string 1 :initial-element x))))
  35
  36 (defun string= (s1 s2 &key (start1 0) end1 (start2 0) end2)
  37   (let* ((s1 (string s1))
  38          (s2 (string s2))
  39          (n1 (length s1))
  40          (n2 (length s2))
  41          (end1 (or end1 n1))
  42          (end2 (or end2 n2)))
  43     (when (= (- end2 start2) (- end1 start1))
  44       (dotimes (i (- end2 start2) t)
  45         (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
  46           (return-from string= nil))))))
  47
  48 (defun string/= (s1 s2 &key (start1 0) end1 (start2 0) end2)
  49   (let* ((s1 (string s1))
  50          (s2 (string s2))
  51          (n1 (length s1))
  52          (n2 (length s2))
  53          (end1 (or end1 n1))
  54          (end2 (or end2 n2)))
  55     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
  56       (when (or (>= (+ start1 i) n1)
  57                 (>= (+ start2 i) n2))
  58         (return-from string/= (+ start1 i)))
  59       (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
  60         (return-from string/= (+ start1 i))))))
  61
  62
  63 (defun compare-strings (s1 s2 start1 end1 start2 end2 char-eq char-lt if-eq if-a-sub-b if-b-sub-a)
  64   ;; step through strings S1 and S2, using bounds START1 END1 START2 END2.
  65   ;; using character comparison functions CHAR-EQ (equality) and CHAR-LT (less-than),
  66   ;; find the first difference, if any, and return its index.
  67   ;; the IF-* params say what to do if the strings are equal, or a strict prefix substring of the other:
  68   ;; if T, it returns the first different index.  if NIL, it returns NIL.
  69   (let* ((s1 (string s1))
  70          (s2 (string s2))
  71          (end1 (or end1 (length s1)))
  72          (end2 (or end2 (length s2)))
  73          (len-1 (- end1 start1))
  74          (len-2 (- end2 start2)))
  75     (dotimes (i (max len-1 len-2) (if if-eq (+ start1 i) nil))
  76       (when (= i len-1)  ;; ran off the end of s1
  77         (return-from compare-strings (if if-a-sub-b (+ start1 i) nil)))
  78       (when (= i len-2)  ;; ran off the end of s2
  79         (return-from compare-strings (if if-b-sub-a (+ start1 i) nil)))
  80       (let ((c1 (char s1 (+ start1 i)))
  81             (c2 (char s2 (+ start2 i))))
  82         (when (not (funcall char-eq c1 c2))  ;; found a difference
  83           (return-from compare-strings
  84                        (if (not (funcall char-lt c1 c2))
  85                            (+ start1 i)
  86                          nil)))))))
  87
  88 (defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
  89   (compare-strings s1 s2 start1 end1 start2 end2
  90                    #'char= #'char> nil t nil))
  91
  92 (defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
  93   (compare-strings s1 s2 start1 end1 start2 end2
  94                    #'char= #'char< 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> t t nil))
  99
 100 (defun string>= (s1 s2 &key (start1 0) end1 (start2 0) end2)
 101   (compare-strings s1 s2 start1 end1 start2 end2
 102                    #'char= #'char< t nil t))
 103
 104 (defun string-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
 105   (compare-strings s1 s2 start1 end1 start2 end2
 106                    #'char-equal #'char-greaterp nil t nil))
 107
 108 (defun string-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
 109   (compare-strings s1 s2 start1 end1 start2 end2
 110                    #'char-equal #'char-lessp nil nil t))
 111
 112 (defun string-not-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
 113   (compare-strings s1 s2 start1 end1 start2 end2
 114                    #'char-equal #'char-greaterp t t nil))
 115
 116 (defun string-not-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
 117   (compare-strings s1 s2 start1 end1 start2 end2
 118                    #'char-equal #'char-lessp t nil t))
 119
 120 (define-setf-expander char (string index)
 121   (let ((g!string (gensym))
 122         (g!index (gensym))
 123         (g!value (gensym)))
 124     (values (list g!string g!index)
 125             (list string index)
 126             (list g!value)
 127             `(aset ,g!string ,g!index ,g!value)
 128             `(char ,g!string ,g!index))))
 129
 130
 131 (defun concat (&rest strs)
 132   (flet ((concat-two (str1 str2)
 133            (concatenate-storage-vector str1 str2)))
 134     (!reduce #'concat-two strs "")))
 135
 136
 137 (defun string-upcase (string &key (start 0) end)
 138   (let* ((string (string string))
 139          (new (make-string (length string))))
 140     (dotimes (i (length string) new)
 141       (aset new i
 142             (if (and (or (null start) (>= i start))
 143                      (or (null end) (< i end)))
 144                 (char-upcase (char string i))
 145               (char string i))))))
 146
 147 (defun nstring-upcase (string &key (start 0) end)
 148   (let ((end (or end (length string))))
 149     (dotimes (i (- end start) string)
 150       (aset string (+ start i)
 151             (char-upcase (char string (+ start i)))))))
 152
 153 (defun string-downcase (string &key (start 0) end)
 154   (let* ((string (string string))
 155          (new (make-string (length string))))
 156     (dotimes (i (length string) new)
 157       (aset new i
 158             (if (and (or (null start) (>= i start))
 159                      (or (null end) (< i end)))
 160                 (char-downcase (char string i))
 161               (char string i))))))
 162
 163 (defun nstring-downcase (string &key (start 0) end)
 164   (let ((end (or end (length string))))
 165     (dotimes (i (- end start) string)
 166       (aset string (+ start i)
 167             (char-downcase (char string (+ start i)))))))
 168
 169 (defun string-capitalize (string &key (start 0) end)
 170   (let* ((string (string string))
 171          (new (make-string (length string)))
 172          (just-saw-alphanum-p nil))
 173     (dotimes (i (length string) new)
 174       (aset new i
 175             (cond ((or (and start (< i start))
 176                        (and end (> i end)))
 177                    (char string i))
 178                   ((or (= i start)
 179                        (not just-saw-alphanum-p))
 180                    (char-upcase (char string i)))
 181                   (t
 182                    (char-downcase (char string i)))))
 183       (setq just-saw-alphanum-p (alphanumericp (char string i))))))
 184
 185 (defun nstring-capitalize (string &key (start 0) end)
 186   (let ((end (or end (length string)))
 187         (just-saw-alphanum-p nil))
 188     (dotimes (i (- end start) string)
 189       (aset string (+ start i)
 190             (if (or (zerop i)
 191                     (not just-saw-alphanum-p))
 192                 (char-upcase (char string (+ start i)))
 193               (char-downcase (char string (+ start i)))))
 194       (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
 195
 196 (defun string-equal (s1 s2 &key start1 end1 start2 end2)
 197   (let* ((s1 (string s1))
 198          (s2 (string s2))
 199          (n1 (length s1))
 200          (n2 (length s2))
 201          (start1 (or start1 0))
 202          (end1 (or end1 n1))
 203          (start2 (or start2 0))
 204          (end2 (or end2 n2)))
 205     (when (= (- end2 start2) (- end1 start1))
 206       (dotimes (i (- end2 start2) t)
 207         (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 208           (return-from string-equal nil))))))
 209
 210 ;; just like string/= but with char-equal instead of char=
 211 (defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
 212   (let* ((s1 (string s1))
 213          (s2 (string s2))
 214          (n1 (length s1))
 215          (n2 (length s2))
 216          (end1 (or end1 n1))
 217          (end2 (or end2 n2)))
 218     (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
 219       (when (or (>= (+ start1 i) n1)
 220                 (>= (+ start2 i) n2))
 221         (return-from string-not-equal (+ start1 i)))
 222       (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
 223         (return-from string-not-equal (+ start1 i))))))
 224
 225 (defun string-trim (character-bag string)
 226   (string-left-trim character-bag (string-right-trim character-bag string)))
 227
 228 (defun string-left-trim (character-bag string)
 229   (let* ((string (string string))
 230          (n (length string))
 231          (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
 232     (subseq string start)))
 233
 234 (defun string-right-trim (character-bag string)
 235   (let* ((string (string string))
 236          (n (length string)))
 237     (dotimes (i n "")
 238       (when (not (find (char string (- n i 1)) character-bag))
 239         (return-from string-right-trim (subseq string 0 (- n i)))))))