Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-12 15:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

string[-ci]<>=? are also n-ary

Browse source
This commit is contained in:
Alex Shinn 2012-12-26 23:58:08 +09:00
parent 544b6a50c5
commit e701c63762
3 changed files with 34 additions and 21 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

26
lib/init-7.scm
View file

@ -419,17 +419,23 @@
(define (string . args) (list->string args)) (define (string . args) (list->string args))
(define (string-append . args) (string-concatenate args)) (define (string-append . args) (string-concatenate args))
(define (string=? s1 s2) (eq? (string-cmp s1 s2 #f) 0)) (define (string-cmp-ls op ci? s ls)
(define (string<? s1 s2) (< (string-cmp s1 s2 #f) 0)) (if (null? ls)
(define (string<=? s1 s2) (<= (string-cmp s1 s2 #f) 0)) #t
(define (string>? s1 s2) (> (string-cmp s1 s2 #f) 0)) (and (op (string-cmp s (car ls) ci?) 0)
(define (string>=? s1 s2) (>= (string-cmp s1 s2 #f) 0)) (string-cmp-ls op ci? (car ls) (cdr ls)))))
(define (string-ci=? s1 s2) (eq? (string-cmp s1 s2 #t) 0)) (define (string=? s . ls) (string-cmp-ls eq? #f s ls))
(define (string-ci<? s1 s2) (< (string-cmp s1 s2 #t) 0)) (define (string<? s . ls) (string-cmp-ls < #f s ls))
(define (string-ci<=? s1 s2) (<= (string-cmp s1 s2 #t) 0)) (define (string>? s . ls) (string-cmp-ls > #f s ls))
(define (string-ci>? s1 s2) (> (string-cmp s1 s2 #t) 0)) (define (string<=? s . ls) (string-cmp-ls <= #f s ls))
(define (string-ci>=? s1 s2) (>= (string-cmp s1 s2 #t) 0)) (define (string>=? s . ls) (string-cmp-ls >= #f s ls))
(define (string-ci=? s . ls) (string-cmp-ls eq? #t s ls))
(define (string-ci<? s . ls) (string-cmp-ls < #t s ls))
(define (string-ci>? s . ls) (string-cmp-ls > #t s ls))
(define (string-ci<=? s . ls) (string-cmp-ls <= #t s ls))
(define (string-ci>=? s . ls) (string-cmp-ls >= #t s ls))
;; list utils ;; list utils

17
lib/scheme/char/full.scm
View file

@ -71,8 +71,15 @@
(define (string-foldcase str) (define (string-foldcase str)
(string-map char-foldcase str)) (string-map char-foldcase str))
(define (string-ci<=? a b) (string<=? (string-foldcase a) (string-foldcase b))) (define (string-cmp-ci op a ls)
(define (string-ci<? a b) (string<? (string-foldcase a) (string-foldcase b))) (let lp ((op op) (a (string-foldcase a)) (ls ls))
(define (string-ci=? a b) (string=? (string-foldcase a) (string-foldcase b))) (if (null? ls)
(define (string-ci>=? a b) (string>=? (string-foldcase a) (string-foldcase b))) #t
(define (string-ci>? a b) (string>? (string-foldcase a) (string-foldcase b))) (let ((b (string-foldcase (car ls))))
(and (op a b) (lp op b (cdr ls)))))))
(define (string-ci=? a . ls) (string-cmp-ci string=? a ls))
(define (string-ci<? a . ls) (string-cmp-ci string<? a ls))
(define (string-ci>? a . ls) (string-cmp-ci string>? a ls))
(define (string-ci<=? a . ls) (string-cmp-ci string<=? a ls))
(define (string-ci>=? a . ls) (string-cmp-ci string>=? a ls))

12
tests/r7rs-tests.scm
View file

@ -980,32 +980,32 @@
(test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str)) (test "a-c" (let ((str (string #\a #\b #\c))) (string-set! str 1 #\-) str))
(test #t (string=? "" "")) (test #t (string=? "" ""))
(test #t (string=? "abc" "abc")) (test #t (string=? "abc" "abc" "abc"))
(test #f (string=? "" "abc")) (test #f (string=? "" "abc"))
(test #f (string=? "abc" "aBc")) (test #f (string=? "abc" "aBc"))
(test #f (string<? "" "")) (test #f (string<? "" ""))
(test #f (string<? "abc" "abc")) (test #f (string<? "abc" "abc"))
(test #t (string<? "abc" "abcd")) (test #t (string<? "abc" "abcd" "acd"))
(test #f (string<? "abcd" "abc")) (test #f (string<? "abcd" "abc"))
(test #t (string<? "abc" "bbc")) (test #t (string<? "abc" "bbc"))
(test #f (string>? "" "")) (test #f (string>? "" ""))
(test #f (string>? "abc" "abc")) (test #f (string>? "abc" "abc"))
(test #f (string>? "abc" "abcd")) (test #f (string>? "abc" "abcd"))
(test #t (string>? "abcd" "abc")) (test #t (string>? "acd" "abcd" "abc"))
(test #f (string>? "abc" "bbc")) (test #f (string>? "abc" "bbc"))
(test #t (string<=? "" "")) (test #t (string<=? "" ""))
(test #t (string<=? "abc" "abc")) (test #t (string<=? "abc" "abc"))
(test #t (string<=? "abc" "abcd")) (test #t (string<=? "abc" "abcd" "abcd"))
(test #f (string<=? "abcd" "abc")) (test #f (string<=? "abcd" "abc"))
(test #t (string<=? "abc" "bbc")) (test #t (string<=? "abc" "bbc"))
(test #t (string>=? "" "")) (test #t (string>=? "" ""))
(test #t (string>=? "abc" "abc")) (test #t (string>=? "abc" "abc"))
(test #f (string>=? "abc" "abcd")) (test #f (string>=? "abc" "abcd"))
(test #t (string>=? "abcd" "abc")) (test #t (string>=? "abcd" "abcd" "abc"))
(test #f (string>=? "abc" "bbc")) (test #f (string>=? "abc" "bbc"))
(test #t (string-ci=? "" "")) (test #t (string-ci=? "" ""))
@ -1030,7 +1030,7 @@
(test #f (string-ci>=? "abc" "aBcD")) (test #f (string-ci>=? "abc" "aBcD"))
(test #t (string-ci>=? "ABCd" "aBc")) (test #t (string-ci>=? "ABCd" "aBc"))
(test #t (string-ci=? "ΑΒΓ" "αβγ")) (test #t (string-ci=? "ΑΒΓ" "αβγ" "αβγ"))
(test #f (string-ci<? "ΑΒΓ" "αβγ")) (test #f (string-ci<? "ΑΒΓ" "αβγ"))
(test #f (string-ci>? "ΑΒΓ" "αβγ")) (test #f (string-ci>? "ΑΒΓ" "αβγ"))
(test #t (string-ci<=? "ΑΒΓ" "αβγ")) (test #t (string-ci<=? "ΑΒΓ" "αβγ"))