X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fstring.lisp;h=8aba28ed7914c940d60e9338c6bd672f40aa16db;hb=259f6aaee78865c11889b9b83f3306192fee6bd9;hp=c9267f03bd5daf6f4a8b940b5d6a6b99a27283b8;hpb=2305b15fffc6679e9fdf42f6cd5bf49ee0dd3ce8;p=jscl.git diff --git a/src/string.lisp b/src/string.lisp index c9267f0..8aba28e 100644 --- a/src/string.lisp +++ b/src/string.lisp @@ -13,6 +13,8 @@ ;; You should have received a copy of the GNU General Public License ;; along with JSCL. If not, see . +(/debug "loading string.lisp!") + (defun stringp (s) (stringp s)) @@ -52,53 +54,68 @@ (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 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 + (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) - (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)))))))) - -;; TODO: string<=, string>= -;; - mostly like string< / string> -;; - if we run off the end of s1 and s2 at the same time, then it's =, so return len. + (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)) @@ -131,7 +148,7 @@ (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)) @@ -147,33 +164,33 @@ (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) @@ -200,23 +217,23 @@ (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)))))))