X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fstring.lisp;h=8aba28ed7914c940d60e9338c6bd672f40aa16db;hb=5bccb7e18630391bfb2e65a39627899daf4d2edf;hp=8fe63688dd31ad102ca31773f434927b62abd6c1;hpb=6475d2c606e3295d58ce44c069271fd617d9d00f;p=jscl.git

diff --git a/src/string.lisp b/src/string.lisp
index 8fe6368..8aba28e 100644
--- a/src/string.lisp
+++ b/src/string.lisp
@@ -13,39 +13,109 @@
 ;; You should have received a copy of the GNU General Public License
 ;; along with JSCL.  If not, see <http://www.gnu.org/licenses/>.
 
+(/debug "loading string.lisp!")
+
 (defun stringp (s)
   (stringp s))
 
+(defun string-length (string)
+  (storage-vector-size string))
+
 (defun make-string (n &key initial-element)
   (make-array n :element-type 'character :initial-element initial-element))
 
-;; (defun char-to-string (x)
-;;   (make-string 1 :initial-element x))
+(defun char (string index)
+  (unless (stringp string) (error "~S is not a string" string))
+  (storage-vector-ref string index))
 
 (defun string (x)
   (cond ((stringp x) x)
         ((symbolp x) (symbol-name x))
-        (t (char-to-string x))))
+        (t (make-string 1 :initial-element x))))
 
-(defun string= (s1 s2)
+(defun string= (s1 s2 &key (start1 0) end1 (start2 0) end2)
   (let* ((s1 (string s1))
          (s2 (string s2))
-         (n (length s1)))
-    (when (= (length s2) n)
-      (dotimes (i n t)
-        (unless (char= (char s1 i) (char s2 i))
+         (n1 (length s1))
+         (n2 (length s2))
+         (end1 (or end1 n1))
+         (end2 (or end2 n2)))
+    (when (= (- end2 start2) (- end1 start1))
+      (dotimes (i (- end2 start2) t)
+        (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
           (return-from string= nil))))))
 
-(defun string< (s1 s2)
-  (let ((len-1 (length s1))
-        (len-2 (length s2)))
-    (cond ((= len-2 0) nil)
-          ((= len-1 0) 0)
-          (t (dotimes (i len-1 nil)
-               (when (char< (char s1 i) (char s2 i))
-                 (return-from string< i))
-               (when (and (= i (1- len-1)) (> len-2 len-1))
-                 (return-from string< (1+ i))))))))
+(defun string/= (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (let* ((s1 (string s1))
+         (s2 (string s2))
+         (n1 (length s1))
+         (n2 (length s2))
+         (end1 (or end1 n1))
+         (end2 (or end2 n2)))
+    (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
+      (when (or (>= (+ start1 i) n1)
+                (>= (+ start2 i) n2))
+        (return-from string/= (+ start1 i)))
+      (unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
+        (return-from string/= (+ start1 i))))))
+
+
+(defun compare-strings (s1 s2 start1 end1 start2 end2 char-eq char-lt if-eq if-a-sub-b if-b-sub-a)
+  ;; step through strings S1 and S2, using bounds START1 END1 START2 END2.
+  ;; using character comparison functions CHAR-EQ (equality) and CHAR-LT (less-than),
+  ;; find the first difference, if any, and return its index.
+  ;; the IF-* params say what to do if the strings are equal, or a strict prefix substring of the other:
+  ;; if T, it returns the first different index.  if NIL, it returns NIL.
+  (let* ((s1 (string s1))
+         (s2 (string s2))
+         (end1 (or end1 (length s1)))
+         (end2 (or end2 (length s2)))
+         (len-1 (- end1 start1))
+         (len-2 (- end2 start2)))
+    (dotimes (i (max len-1 len-2) (if if-eq (+ start1 i) nil))
+      (when (= i len-1)  ;; ran off the end of s1
+        (return-from compare-strings (if if-a-sub-b (+ start1 i) nil)))
+      (when (= i len-2)  ;; ran off the end of s2
+        (return-from compare-strings (if if-b-sub-a (+ start1 i) nil)))
+      (let ((c1 (char s1 (+ start1 i)))
+            (c2 (char s2 (+ start2 i))))
+        (when (not (funcall char-eq c1 c2))  ;; found a difference
+          (return-from compare-strings
+                       (if (not (funcall char-lt c1 c2))
+                           (+ start1 i)
+                         nil)))))))
+
+(defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char= #'char> nil t nil))
+
+(defun string> (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char= #'char< nil nil t))
+
+(defun string<= (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char= #'char> t t nil))
+  
+(defun string>= (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char= #'char< t nil t))
+
+(defun string-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char-equal #'char-greaterp nil t nil))
+
+(defun string-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char-equal #'char-lessp nil nil t))
+
+(defun string-not-greaterp (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char-equal #'char-greaterp t t nil))
+
+(defun string-not-lessp (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (compare-strings s1 s2 start1 end1 start2 end2
+                   #'char-equal #'char-lessp t nil t))
 
 (define-setf-expander char (string index)
   (let ((g!string (gensym))
@@ -57,15 +127,113 @@
             `(aset ,g!string ,g!index ,g!value)
             `(char ,g!string ,g!index))))
 
-(defun concatenate-two (string1 string2)
-  (let* ((len1 (length string1))
-         (len2 (length string2))
-         (string (make-array (+ len1 len2) :element-type 'character))
-         (i 0))
-    (dotimes (j len1)
-      (aset string i (char string1 j))
-      (incf i))
-    (dotimes (j len2)
-      (aset string i (char string2 j))
-      (incf i))
-    string))
+
+(defun concat (&rest strs)
+  (flet ((concat-two (str1 str2)
+           (concatenate-storage-vector str1 str2)))
+    (!reduce #'concat-two strs "")))
+
+
+(defun string-upcase (string &key (start 0) end)
+  (let* ((string (string string))
+         (new (make-string (length string))))
+    (dotimes (i (length string) new)
+      (aset new i
+            (if (and (or (null start) (>= i start))
+                     (or (null end) (< i end)))
+                (char-upcase (char string i))
+              (char string i))))))
+
+(defun nstring-upcase (string &key (start 0) end)
+  (let ((end (or end (length string))))
+    (dotimes (i (- end start) string)
+      (aset string (+ start i)
+            (char-upcase (char string (+ start i)))))))
+
+(defun string-downcase (string &key (start 0) end)
+  (let* ((string (string string))
+         (new (make-string (length string))))
+    (dotimes (i (length string) new)
+      (aset new i
+            (if (and (or (null start) (>= i start))
+                     (or (null end) (< i end)))
+                (char-downcase (char string i))
+              (char string i))))))
+
+(defun nstring-downcase (string &key (start 0) end)
+  (let ((end (or end (length string))))
+    (dotimes (i (- end start) string)
+      (aset string (+ start i)
+            (char-downcase (char string (+ start i)))))))
+
+(defun string-capitalize (string &key (start 0) end)
+  (let* ((string (string string))
+         (new (make-string (length string)))
+         (just-saw-alphanum-p nil))
+    (dotimes (i (length string) new)
+      (aset new i
+            (cond ((or (and start (< i start))
+                       (and end (> i end)))
+                   (char string i))
+                  ((or (= i start)
+                       (not just-saw-alphanum-p))
+                   (char-upcase (char string i)))
+                  (t
+                   (char-downcase (char string i)))))
+      (setq just-saw-alphanum-p (alphanumericp (char string i))))))
+
+(defun nstring-capitalize (string &key (start 0) end)
+  (let ((end (or end (length string)))
+        (just-saw-alphanum-p nil))
+    (dotimes (i (- end start) string)
+      (aset string (+ start i)
+            (if (or (zerop i)
+                    (not just-saw-alphanum-p))
+                (char-upcase (char string (+ start i)))
+              (char-downcase (char string (+ start i)))))
+      (setq just-saw-alphanum-p (alphanumericp (char string (+ start i)))))))
+
+(defun string-equal (s1 s2 &key start1 end1 start2 end2)
+  (let* ((s1 (string s1))
+         (s2 (string s2))
+         (n1 (length s1))
+         (n2 (length s2))
+         (start1 (or start1 0))
+         (end1 (or end1 n1))
+         (start2 (or start2 0))
+         (end2 (or end2 n2)))
+    (when (= (- end2 start2) (- end1 start1))
+      (dotimes (i (- end2 start2) t)
+        (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
+          (return-from string-equal nil))))))
+
+;; just like string/= but with char-equal instead of char=
+(defun string-not-equal (s1 s2 &key (start1 0) end1 (start2 0) end2)
+  (let* ((s1 (string s1))
+         (s2 (string s2))
+         (n1 (length s1))
+         (n2 (length s2))
+         (end1 (or end1 n1))
+         (end2 (or end2 n2)))
+    (dotimes (i (max (- end1 start1) (- end2 start2)) nil)
+      (when (or (>= (+ start1 i) n1)
+                (>= (+ start2 i) n2))
+        (return-from string-not-equal (+ start1 i)))
+      (unless (char-equal (char s1 (+ start1 i)) (char s2 (+ start2 i)))
+        (return-from string-not-equal (+ start1 i))))))
+
+(defun string-trim (character-bag string)
+  (string-left-trim character-bag (string-right-trim character-bag string)))
+
+(defun string-left-trim (character-bag string)
+  (let* ((string (string string))
+         (n (length string))
+         (start (or (position-if-not (lambda (c) (find c character-bag)) string) n)))
+    (subseq string start)))
+
+(defun string-right-trim (character-bag string)
+  (let* ((string (string string))
+         (n (length string)))
+    (dotimes (i n "")
+      (when (not (find (char string (- n i 1)) character-bag))
+        (return-from string-right-trim (subseq string 0 (- n i)))))))