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

char[-ci]<>=? is n-ary (alas)

Browse source
This commit is contained in:
Alex Shinn 2012-12-26 23:26:32 +09:00
parent 119c95b222
commit 544b6a50c5
3 changed files with 46 additions and 30 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

39
lib/init-7.scm
View file

@ -346,22 +346,31 @@
(define (char-upper-case? ch) (<= 65 (char->integer ch) 90)) (define (char-upper-case? ch) (<= 65 (char->integer ch) 90))
(define (char-lower-case? ch) (<= 97 (char->integer ch) 122)) (define (char-lower-case? ch) (<= 97 (char->integer ch) 122))
(define (char=? a b) (= (char->integer a) (char->integer b))) (define (char-cmp op a ls)
(define (char<? a b) (< (char->integer a) (char->integer b))) (let lp ((op op) (a (char->integer a)) (ls ls))
(define (char>? a b) (> (char->integer a) (char->integer b))) (if (null? ls)
(define (char<=? a b) (<= (char->integer a) (char->integer b))) #t
(define (char>=? a b) (>= (char->integer a) (char->integer b))) (let ((b (char->integer (car ls))))
(and (op a b) (lp op b (cdr ls)))))))
(define (char-ci=? a b) (define (char=? a . ls) (char-cmp = a ls))
(= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) (define (char<? a . ls) (char-cmp < a ls))
(define (char-ci<? a b) (define (char>? a . ls) (char-cmp > a ls))
(< (char->integer (char-downcase a)) (char->integer (char-downcase b)))) (define (char<=? a . ls) (char-cmp <= a ls))
(define (char-ci>? a b) (define (char>=? a . ls) (char-cmp >= a ls))
(> (char->integer (char-downcase a)) (char->integer (char-downcase b))))
(define (char-ci<=? a b) (define (char-cmp-ci op a ls)
(<= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) (let lp ((op op) (a (char->integer (char-downcase a))) (ls ls))
(define (char-ci>=? a b) (if (null? ls)
(>= (char->integer (char-downcase a)) (char->integer (char-downcase b)))) #t
(let ((b (char->integer (char-downcase (car ls)))))
(and (op a b) (lp op b (cdr ls)))))))
(define (char-ci=? a . ls) (char-cmp-ci = a ls))
(define (char-ci<? a . ls) (char-cmp-ci < a ls))
(define (char-ci>? a . ls) (char-cmp-ci > a ls))
(define (char-ci<=? a . ls) (char-cmp-ci <= a ls))
(define (char-ci>=? a . ls) (char-cmp-ci >= a ls))
;; string utils ;; string utils

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

@ -49,11 +49,18 @@
(integer->char (- n (cdar ls)))) (integer->char (- n (cdar ls))))
(else (lp (cdr ls))))))) (else (lp (cdr ls)))))))
(define (char-ci<=? a b) (char<=? (char-foldcase a) (char-foldcase b))) (define (char-cmp-ci op a ls)
(define (char-ci<? a b) (char<? (char-foldcase a) (char-foldcase b))) (let lp ((op op) (a (char->integer (char-foldcase a))) (ls ls))
(define (char-ci=? a b) (char=? (char-foldcase a) (char-foldcase b))) (if (null? ls)
(define (char-ci>=? a b) (char>=? (char-foldcase a) (char-foldcase b))) #t
(define (char-ci>? a b) (char>? (char-foldcase a) (char-foldcase b))) (let ((b (char->integer (char-downcase (car ls)))))
(and (op a b) (lp op b (cdr ls)))))))
(define (char-ci=? a . ls) (char-cmp-ci = a ls))
(define (char-ci<? a . ls) (char-cmp-ci < a ls))
(define (char-ci>? a . ls) (char-cmp-ci > a ls))
(define (char-ci<=? a . ls) (char-cmp-ci <= a ls))
(define (char-ci>=? a . ls) (char-cmp-ci >= a ls))
(define (string-downcase str) (define (string-downcase str)
(string-map char-downcase str)) (string-map char-downcase str))

20
tests/r7rs-tests.scm
View file

@ -870,36 +870,36 @@
(test #f (char? 'a)) (test #f (char? 'a))
(test #f (char? 0)) (test #f (char? 0))
(test #t (char=? #\a #\a)) (test #t (char=? #\a #\a #\a))
(test #f (char=? #\a #\A)) (test #f (char=? #\a #\A))
(test #t (char<? #\a #\b)) (test #t (char<? #\a #\b #\c))
(test #f (char<? #\a #\a)) (test #f (char<? #\a #\a))
(test #f (char<? #\b #\a)) (test #f (char<? #\b #\a))
(test #f (char>? #\a #\b)) (test #f (char>? #\a #\b))
(test #f (char>? #\a #\a)) (test #f (char>? #\a #\a))
(test #t (char>? #\b #\a)) (test #t (char>? #\c #\b #\a))
(test #t (char<=? #\a #\b)) (test #t (char<=? #\a #\b #\b))
(test #t (char<=? #\a #\a)) (test #t (char<=? #\a #\a))
(test #f (char<=? #\b #\a)) (test #f (char<=? #\b #\a))
(test #f (char>=? #\a #\b)) (test #f (char>=? #\a #\b))
(test #t (char>=? #\a #\a)) (test #t (char>=? #\a #\a))
(test #t (char>=? #\b #\a)) (test #t (char>=? #\b #\b #\a))
(test #t (char-ci=? #\a #\a)) (test #t (char-ci=? #\a #\a))
(test #t (char-ci=? #\a #\A)) (test #t (char-ci=? #\a #\A #\a))
(test #f (char-ci=? #\a #\b)) (test #f (char-ci=? #\a #\b))
(test #t (char-ci<? #\a #\B)) (test #t (char-ci<? #\a #\B #\c))
(test #f (char-ci<? #\A #\a)) (test #f (char-ci<? #\A #\a))
(test #f (char-ci<? #\b #\A)) (test #f (char-ci<? #\b #\A))
(test #f (char-ci>? #\A #\b)) (test #f (char-ci>? #\A #\b))
(test #f (char-ci>? #\a #\A)) (test #f (char-ci>? #\a #\A))
(test #t (char-ci>? #\B #\a)) (test #t (char-ci>? #\c #\B #\a))
(test #t (char-ci<=? #\a #\B)) (test #t (char-ci<=? #\a #\B #\b))
(test #t (char-ci<=? #\A #\a)) (test #t (char-ci<=? #\A #\a))
(test #f (char-ci<=? #\b #\A)) (test #f (char-ci<=? #\b #\A))
(test #f (char-ci>=? #\A #\b)) (test #f (char-ci>=? #\A #\b))
(test #t (char-ci>=? #\a #\A)) (test #t (char-ci>=? #\a #\A))
(test #t (char-ci>=? #\B #\a)) (test #t (char-ci>=? #\b #\B #\a))
(test #t (char-alphabetic? #\a)) (test #t (char-alphabetic? #\a))
(test #f (char-alphabetic? #\space)) (test #f (char-alphabetic? #\space))