(unless (char= (char s1 (+ start1 i)) (char s2 (+ start2 i)))
(return-from string/= (+ start1 i))))))
-(defun string< (s1 s2 &key (start1 0) end1 (start2 0) end2)
+
+(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)))
- (cond ((= len-2 0) nil)
- ((= len-1 0) 0)
- (t (dotimes (i len-1 nil)
- (when (= i len-2) ;; ran off the end of s2
- (return-from string< nil))
- (when (char< (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
- (return-from string< (+ start1 i)))
- (when (char> (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
- (return-from string< nil))
- (when (and (= i (1- len-1)) (> len-2 len-1)) ;; ran off the end of s1
- (return-from string< (+ start1 i 1))))))))
-
-;; just like string< but with everything flipped, except the result is still relative to s1
+ (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)
- (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)))
- (cond ((= len-1 0) nil)
- ((= len-2 0) 0)
- (t (dotimes (i len-2 nil)
- (when (= i len-1) ;; ran off the end of s1
- (return-from string> nil))
- (when (char> (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
- (return-from string> (+ start1 i)))
- (when (char< (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
- (return-from string> nil))
- (when (and (= i (1- len-2)) (> len-1 len-2)) ;; ran off the end of s2
- (return-from string> (+ start1 i 1))))))))
+ (compare-strings s1 s2 start1 end1 start2 end2
+ #'char= #'char<
+ nil nil t))
(defun string<= (s1 s2 &key (start1 0) end1 (start2 0) end2)
- (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 len-1 end1)
- (when (= i len-2) ;; ran off the end of s2
- (return-from string<= nil))
- (when (char/= (char s1 (+ start1 i)) (char s2 (+ start2 i))) ;; found a difference
- (return-from string<=
- (if (char< (char s1 (+ start1 i)) (char s2 (+ start2 i)))
- (+ start1 i)
- nil)))
- (when (and (= i (1- len-1)) (> len-2 len-1)) ;; ran off the end of s1
- (return-from string<= (+ start1 i 1))))))
-
-;; TODO: string>=
+ (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))
(define-setf-expander char (string index)
(let ((g!string (gensym))
(test (string-equal "foo" "Foo"))
(test (string= "abcd" "01234abcd9012" :start2 5 :end2 9))
(test (eql (string< "aaaa" "aaab") 3))
-;; JSCL: STRING>= doesn't exist yet, disabled
-;; (test (eql (string>= "aaaaa" "aaaa") 4))
+(test (eql (string>= "aaaaa" "aaaa") 4))
;; JSCL: STRING-NOT-GREATERP doesn't exist yet, disabling:
;; (test (eql (string-not-greaterp "Abcde" "abcdE") 5))
;; (test (eql (string-lessp "012AAAA789" "01aaab6"
(test (not (string<= #\z #\a)))
-;; (test (eql (string>= "" "") 0))
-;; (test (eql (string>= "dog" "dog") 3))
-;; (test (eql (string>= " " " ") 1))
-;; (test (eql (string>= "abc" "") 0))
-;; (test (not (string>= "" "abc")))
-;; (test (not (string>= "ab" "abc")))
-;; (test (eql (string>= "abc" "ab") 2))
-;; (test (eql (string>= "aba" "aaa") 1))
-;; (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))
-;; (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>= "xyzXYZ" "abcxyz" :start2 3) 3))
-;; (test (eql (string>= "abcxyz" "abcxyz" :end2 3) 3))
-;; (test (not (string>= "xyzXYZ" "abcxyz" :end1 2 :start2 3)))
-;; (test (eql (string>= "xyzabc" "abcdef" :start1 3 :end2 3) 6))
-;; (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))
+(test (eql (string>= "" "") 0))
+(test (eql (string>= "dog" "dog") 3))
+(test (eql (string>= " " " ") 1))
+(test (eql (string>= "abc" "") 0))
+(test (not (string>= "" "abc")))
+(test (not (string>= "ab" "abc")))
+(test (eql (string>= "abc" "ab") 2))
+(test (eql (string>= "aba" "aaa") 1))
+(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))
+(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>= "xyzXYZ" "abcxyz" :start2 3) 3))
+(test (eql (string>= "abcxyz" "abcxyz" :end2 3) 3))
+(test (not (string>= "xyzXYZ" "abcxyz" :end1 2 :start2 3)))
+(test (eql (string>= "xyzabc" "abcdef" :start1 3 :end2 3) 6))
+(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))
;; (test (eql (string>= (make-array 0 :element-type 'character)
;; (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>= #\a #\a) 1))
-;; (test (not (string>= #\a #\b)))
-;; (test (= (string>= #\z #\a) 0))
+(test (= (string>= 'love 'hate) 0))
+(test (not (string>= 'peace 'war)))
+(test (= (string>= 'love 'love) 4))
+(test (= (string>= #\a #\a) 1))
+(test (not (string>= #\a #\b)))
+(test (= (string>= #\z #\a) 0))
projects / jscl.git / commitdiff