(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)))
+ (>= (+ start2 i) n2))
+ (return-from string/= (+ start1 i)))
(unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
- (return-from string/= (+ start1 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)
;; 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)))
+ (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)))
+ (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)))
+ (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)))))))
+ (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))
+ #'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))
+ #'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))
+ #'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))
+ #'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))
+ #'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))
+ #'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))
+ #'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))
+ #'char-equal #'char-lessp t nil t))
(define-setf-expander char (string index)
(let ((g!string (gensym))
(let ((end (or end (length string))))
(dotimes (i (- end start) string)
(aset string (+ start i)
- (char-upcase (char string (+ start i)))))))
+ (char-upcase (char string (+ start i)))))))
(defun string-downcase (string &key (start 0) end)
(let* ((string (string string))
(let ((end (or end (length string))))
(dotimes (i (- end start) string)
(aset string (+ start i)
- (char-downcase (char 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))
+ (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)))))
+ (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))
+ (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)))))
+ (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)
(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)))
+ (>= (+ 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))))))
+ (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)))
+ (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)))
+ (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)))))))
+ (return-from string-right-trim (subseq string 0 (- n i)))))))
;; (test (char= (schar "abc" 2) #\c))
;; JSCL: no :FILL-POINTER yet, so disabled
;; (test (let ((str (make-array 10
-;; :element-type 'character
-;; :fill-pointer 3
-;; :initial-contents "0123456789")))
+;; :element-type 'character
+;; :fill-pointer 3
+;; :initial-contents "0123456789")))
;; (and (string= str "012")
;; (char= (char str 3) #\3)
;; (char= (char str 4) #\4)
(test (string= (string-upcase "abcde") "ABCDE"))
(test (string= (string-upcase "Dr. Livingston, I presume?")
- "DR. LIVINGSTON, I PRESUME?"))
+ "DR. LIVINGSTON, I PRESUME?"))
(test (string= (string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
- "Dr. LiVINGston, I presume?"))
+ "Dr. LiVINGston, I presume?"))
(test (string= (string-upcase 'Kludgy-HASH-Search) "KLUDGY-HASH-SEARCH"))
(test (string= (string-upcase "abcde" :start 2 :end nil) "abCDE"))
(test (string= (string-downcase "Dr. Livingston, I presume?")
- "dr. livingston, i presume?"))
+ "dr. livingston, i presume?"))
(test (string= (string-downcase 'Kludgy-HASH-Search) "kludgy-hash-search"))
(test (string= (string-downcase "A FOOL" :start 2 :end nil) "A fool"))
(test (string= (string-capitalize "elm 13c arthur;fig don't")
- "Elm 13c Arthur;Fig Don'T"))
+ "Elm 13c Arthur;Fig Don'T"))
(test (string= (string-capitalize " hello ") " Hello "))
(test (string= (string-capitalize
- "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
- "Occluded Casements Forestall Inadvertent Defenestration"))
+ "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
+ "Occluded Casements Forestall Inadvertent Defenestration"))
(test (string= (string-capitalize 'kludgy-hash-search) "Kludgy-Hash-Search"))
(test (string= (string-capitalize "DON'T!") "Don'T!")) ;not "Don't!"
(test (string= (string-capitalize "pipe 13a, foo16c") "Pipe 13a, Foo16c"))
(and (eq str0 str)
(string= str " Hello "))))
(test (let* ((str0 (copy-seq
- "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION"))
+ "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION"))
(str (nstring-capitalize str0)))
(and (eq str0 str)
(string= str
- "Occluded Casements Forestall Inadvertent Defenestration"))))
+ "Occluded Casements Forestall Inadvertent Defenestration"))))
(test (let* ((str0 (copy-seq "DON'T!"))
(str (nstring-capitalize str0)))
(and (eq str0 str)
;; (test (string= (string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
;; ") "garbanzo beans"))
(test (string= (string-trim " (*)" " ( *three (silly) words* ) ")
- "three (silly) words"))
+ "three (silly) words"))
(test (string= (string-left-trim "abc" "labcabcabc") "labcabcabc"))
(test (string= (string-left-trim " (*)" " ( *three (silly) words* ) ")
- "three (silly) words* ) "))
+ "three (silly) words* ) "))
(test (string= (string-right-trim " (*)" " ( *three (silly) words* ) ")
- " ( *three (silly) words"))
+ " ( *three (silly) words"))
(test (string= (string-trim "ABC" "abc") "abc"))
(test (string= (string-trim "AABBCC" "abc") "abc"))
(test (string= (string-trim "" "abc") "abc"))
(test (eql (string>= "aaaaa" "aaaa") 4))
(test (eql (string-not-greaterp "Abcde" "abcdE") 5))
(test (eql (string-lessp "012AAAA789" "01aaab6"
- :start1 3 :end1 7
- :start2 2 :end2 6) 6))
+ :start1 3 :end1 7
+ :start2 2 :end2 6) 6))
(test (not (string-not-equal "AAAA" "aaaA")))
(test (string= "" ""))
;; JSCL: making an array of BASE-CHAR doesn't make a string, yet
;; (test (string= (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)))
+;; (make-array 0 :element-type 'base-char)))
(test (not (string= "abc" "")))
(test (not (string= "" "abc")))
(test (not (string= "A" "a")))
(test (not (string/= "" "")))
;; (test (not (string/= (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (eql (string/= "abc" "") 0))
(test (eql (string/= "" "abc") 0))
(test (eql (string/= "A" "a") 0))
(test (not (string< "aba" "aaa")))
(test (not (string< "my cat food" "your dog food" :start1 6 :start2 8)))
(test (not (string< "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9)))
+ :start1 3 :end1 9 :start2 3 :end2 9)))
(test (eql (string< "xyzabc" "abcd" :start1 3) 6))
(test (eql (string< "abc" "abc" :end1 1) 1))
(test (eql (string< "xyzabc" "abc" :start1 3 :end1 5) 5))
(test (eql (string< "aaaa" "z") 0))
(test (eql (string< "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6))
(test (eql (string< "pppTTTaTTTqqq" "pTTTxTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (not (string< (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (not (string< 'love 'hate)))
(test (= (string< 'peace 'war) 0))
(test (not (string< 'love 'love)))
(test (not (string> "aaa" "aba")))
(test (not (string> "my cat food" "your dog food" :start1 6 :start2 8)))
(test (not (string> "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9)))
+ :start1 3 :end1 9 :start2 3 :end2 9)))
(test (eql (string> "xyzabcde" "abcd" :start1 3) 7))
(test (not (string> "abc" "abc" :end1 1)))
(test (eql (string> "xyzabc" "a" :start1 3 :end1 5) 4))
(test (eql (string> "z" "aaaa") 0))
(test (eql (string> "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4))
(test (eql (string> "pppTTTxTTTqqq" "pTTTaTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (not (string> (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (= (string> 'love 'hate) 0))
(test (not (string> 'peace 'war)))
(test (not (string> 'love 'love)))
(test (not (string<= "aba" "aaa")))
(test (eql (string<= "my cat food" "your dog food" :start1 6 :start2 8) 11))
(test (eql (string<= "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9) 9))
+ :start1 3 :end1 9 :start2 3 :end2 9) 9))
(test (eql (string<= "xyzabc" "abcd" :start1 3) 6))
(test (eql (string<= "abc" "abc" :end1 1) 1))
(test (eql (string<= "xyzabc" "abc" :start1 3 :end1 5) 5))
(test (eql (string<= "aaaa" "z") 0))
(test (eql (string<= "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6))
(test (eql (string<= "pppTTTaTTTqqq" "pTTTxTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (eql (string<= (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)) 0))
+;; (make-array 0 :element-type 'base-char)) 0))
(test (not (string<= 'love 'hate)))
(test (= (string<= 'peace 'war) 0))
(test (= (string<= 'love 'love) 4))
(test (not (string>= "aaa" "aba")))
(test (eql (string>= "my cat food" "your dog food" :start1 6 :start2 8) 11))
(test (eql (string>= "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9) 9))
+ :start1 3 :end1 9 :start2 3 :end2 9) 9))
(test (eql (string>= "xyzabcde" "abcd" :start1 3) 7))
(test (not (string>= "abc" "abc" :end1 1)))
(test (eql (string>= "xyzabc" "a" :start1 3 :end1 5) 4))
(test (eql (string>= "z" "aaaa") 0))
(test (eql (string>= "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4))
(test (eql (string>= "pppTTTxTTTqqq" "pTTTaTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (eql (string>= (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)) 0))
+;; (make-array 0 :element-type 'base-char)) 0))
(test (= (string>= 'love 'hate) 0))
(test (not (string>= 'peace 'war)))
(test (= (string>= 'love 'love) 4))
(test (string-equal "" ""))
;; (test (string-equal (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)))
+;; (make-array 0 :element-type 'base-char)))
(test (not (string-equal "abc" "")))
(test (not (string-equal "" "abc")))
(test (string-equal "A" "a"))
(test (not (string-not-equal "" "")))
;; (test (not (string-not-equal (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (eql (string-not-equal "abc" "") 0))
(test (eql (string-not-equal "" "abc") 0))
(test (not (string-not-equal "A" "a")))
(test (not (string-lessp "aba" "aaa")))
(test (not (string-lessp "my cat food" "your dog food" :start1 6 :start2 8)))
(test (not (string-lessp "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9)))
+ :start1 3 :end1 9 :start2 3 :end2 9)))
(test (eql (string-lessp "xyzabc" "abcd" :start1 3) 6))
(test (eql (string-lessp "abc" "abc" :end1 1) 1))
(test (eql (string-lessp "xyzabc" "abc" :start1 3 :end1 5) 5))
(test (eql (string-lessp "aaaa" "z") 0))
(test (eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6))
(test (eql (string-lessp "pppTTTaTTTqqq" "pTTTxTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (not (string-lessp (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (and (not (string-lessp "abc" "ABC"))
(not (string-lessp "ABC" "abc"))))
(test (not (string-lessp 'love 'hate)))
(test (not (string-greaterp "aaa" "aba")))
(test (not (string-greaterp "my cat food" "your dog food" :start1 6 :start2 8)))
(test (not (string-greaterp "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9)))
+ :start1 3 :end1 9 :start2 3 :end2 9)))
(test (eql (string-greaterp "xyzabcde" "abcd" :start1 3) 7))
(test (not (string-greaterp "abc" "abc" :end1 1)))
(test (eql (string-greaterp "xyzabc" "a" :start1 3 :end1 5) 4))
(test (eql (string-greaterp "z" "aaaa") 0))
(test (eql (string-greaterp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4))
(test (eql (string-greaterp "pppTTTxTTTqqq" "pTTTaTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (not (string-greaterp (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char))))
+;; (make-array 0 :element-type 'base-char))))
(test (and (not (string-greaterp "abc" "ABC"))
(not (string-greaterp "ABC" "abc"))))
(test (= (string-greaterp 'love 'hate) 0))
(test (not (string-not-greaterp "aba" "aaa")))
(test (eql (string-not-greaterp "my cat food" "your dog food" :start1 6 :start2 8) 11))
(test (eql (string-not-greaterp "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9) 9))
+ :start1 3 :end1 9 :start2 3 :end2 9) 9))
(test (eql (string-not-greaterp "xyzabc" "abcd" :start1 3) 6))
(test (eql (string-not-greaterp "abc" "abc" :end1 1) 1))
(test (eql (string-not-greaterp "xyzabc" "abc" :start1 3 :end1 5) 5))
(test (eql (string-not-greaterp "aaaa" "z") 0))
(test (eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT" :start1 3 :start2 1) 6))
(test (eql (string-not-greaterp "pppTTTaTTTqqq" "pTTTxTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (eql (string-not-greaterp (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)) 0))
+;; (make-array 0 :element-type 'base-char)) 0))
(test (and (eql (string-not-greaterp "abc" "ABC") 3)
(eql (string-not-greaterp "ABC" "abc") 3)))
(test (not (string-not-greaterp 'love 'hate)))
(test (not (string-not-lessp "aaa" "aba")))
(test (eql (string-not-lessp "my cat food" "your dog food" :start1 6 :start2 8) 11))
(test (eql (string-not-lessp "cat food 2 dollars" "dog food 3 dollars"
- :start1 3 :end1 9 :start2 3 :end2 9) 9))
+ :start1 3 :end1 9 :start2 3 :end2 9) 9))
(test (eql (string-not-lessp "xyzabcde" "abcd" :start1 3) 7))
(test (not (string-not-lessp "abc" "abc" :end1 1)))
(test (eql (string-not-lessp "xyzabc" "a" :start1 3 :end1 5) 4))
(test (eql (string-not-lessp "z" "aaaa") 0))
(test (eql (string-not-lessp "pTTTxTTTqqq" "pppTTTaTTT" :start1 1 :start2 3) 4))
(test (eql (string-not-lessp "pppTTTxTTTqqq" "pTTTaTTT"
- :start1 6 :end1 7
- :start2 4 :end2 5) 6))
+ :start1 6 :end1 7
+ :start2 4 :end2 5) 6))
;; (test (eql (string-not-lessp (make-array 0 :element-type 'character)
-;; (make-array 0 :element-type 'base-char)) 0))
+;; (make-array 0 :element-type 'base-char)) 0))
(test (and (eql (string-not-lessp "abc" "ABC") 3)
(eql (string-not-lessp "ABC" "abc") 3)))
(test (= (string-not-lessp 'love 'hate) 0))
;; JSCL: BUG?: this barfs inside the JS function xstring(), and i don't know why.
;; (test (subtypep (upgraded-array-element-type
-;; (array-element-type (make-string 3 :element-type 'standard-char)))
-;; 'character))
+;; (array-element-type (make-string 3 :element-type 'standard-char)))
+;; 'character))
projects / jscl.git / commitdiff