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)
  35   (let* ((s1 (string s1))
  36          (s2 (string s2))
  37          (n (length s1)))
  38     (when (= (length s2) n)
  39       (dotimes (i n t)
  40         (unless (char= (char s1 i) (char s2 i))
  41           (return-from string= nil))))))
  42
  43 (defun string< (s1 s2)
  44   (let ((len-1 (length s1))
  45         (len-2 (length s2)))
  46     (cond ((= len-2 0) nil)
  47           ((= len-1 0) 0)
  48           (t (dotimes (i len-1 nil)
  49                (when (char< (char s1 i) (char s2 i))
  50                  (return-from string< i))
  51                (when (and (= i (1- len-1)) (> len-2 len-1))
  52                  (return-from string< (1+ i))))))))
  53
  54 (define-setf-expander char (string index)
  55   (let ((g!string (gensym))
  56         (g!index (gensym))
  57         (g!value (gensym)))
  58     (values (list g!string g!index)
  59             (list string index)
  60             (list g!value)
  61             `(aset ,g!string ,g!index ,g!value)
  62             `(char ,g!string ,g!index))))
  63
  64
  65 (defun concat-two (string1 string2)
  66   (let* ((len1 (length string1))
  67          (len2 (length string2))
  68          (string (make-array (+ len1 len2) :element-type 'character))
  69          (i 0))
  70     (dotimes (j len1)
  71       (aset string i (char string1 j))
  72       (incf i))
  73     (dotimes (j len2)
  74       (aset string i (char string2 j))
  75       (incf i))
  76     string))
  77
  78 (defun concat (&rest strs)
  79   (!reduce #'concat-two strs ""))
  80
  81
  82 (defun string-upcase (string)
  83   (let ((new (make-string (length string))))
  84     (dotimes (i (length string) new)
  85       (aset new i (char-upcase (char string i))))))
  86
  87 (defun string-downcase (string)
  88   (let ((new (make-string (length string))))
  89     (dotimes (i (length string) new)
  90       (aset new i (char-downcase (char string i))))))