conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added missing string<?, string<=?, string>?, and string>=? 

* Added string-ci=?, string-ci<?, string-ci<=?, string-ci>?, and
  string-ci>=?
This commit is contained in:
Abdulaziz Ghuloum 2007-09-03 00:17:15 -04:00
parent aa9f5e3ad1
commit 0bbbcf9604
7 changed files with 181 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

99
src/ikarus.strings.ss
View File

@ -1,8 +1,9 @@
(library (ikarus strings)
(export string-length string-ref string-set! make-string string->list string=?
(export string-length string-ref string-set! make-string string->list
string-append substring string list->string uuid
string-copy string-for-each string-fill!)
string-copy string-for-each string-fill!
string=? string<? string<=? string>? string>=?)
(import
(ikarus system $strings)
(ikarus system $fx)
@ -10,8 +11,9 @@
(ikarus system $bytevectors)
(ikarus system $pairs)
(except (ikarus) string-length string-ref string-set! make-string
string->list string=? string-append substring string
string->list string-append substring string
list->string uuid string-copy string-for-each
string=? string<? string<=? string>? string>=?
string-fill!))
@ -165,6 +167,97 @@
(strings=? s s* ($string-length s))
(err s))])))
(define string-cmp
(lambda (who cmp)
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
(cmp s1 s2)
(error who "~s is not a string" s2))
(error who "~s is not a string" s1))]
[(s1 . s*)
(if (string? s1)
(let f ([s1 s1] [s* s*])
(cond
[(null? s*) #t]
[else
(let ([s2 (car s*)])
(if (string? s2)
(if (cmp s1 s2)
(f s2 (cdr s*))
(let f ([s* (cdr s*)])
(cond
[(null? s*) #f]
[(string? (car s*))
(f (cdr s*))]
[else
(error who "~s is not a string"
(car s*))]))))
(error who "~s is not a string" s2))])))
(error who "~s is not a string" s1)])))
(define ($string<? s1 s2)
(let ([n1 ($string-length s1)]
[n2 ($string-length s2)])
(if ($fx< n1 n2)
(let f ([i 0] [n n1] [s1 s1] [s2 s2])
(if ($fx= i n)
#t
(let ([c1 ($string-ref s1 i)]
[c2 ($string-ref s2 i)])
(if ($char< c1 c2)
#t
(if ($char= c1 c2)
(f ($fxadd1 i) n s1 s2)
#f)))))
(let f ([i 0] [n n2] [s1 s1] [s2 s2])
(if ($fx= i n)
#f
(let ([c1 ($string-ref s1 i)]
[c2 ($string-ref s2 i)])
(if ($char< c1 c2)
#t
(if ($char= c1 c2)
(f ($fxadd1 i) n s1 s2)
#f))))))))
(define ($string<=? s1 s2)
(let ([n1 ($string-length s1)]
[n2 ($string-length s2)])
(if ($fx<= n1 n2)
(let f ([i 0] [n n1] [s1 s1] [s2 s2])
(if ($fx= i n)
#t
(let ([c1 ($string-ref s1 i)]
[c2 ($string-ref s2 i)])
(if ($char< c1 c2)
#t
(if ($char= c1 c2)
(f ($fxadd1 i) n s1 s2)
#f)))))
(let f ([i 0] [n n2] [s1 s1] [s2 s2])
(if ($fx= i n)
#f
(let ([c1 ($string-ref s1 i)]
[c2 ($string-ref s2 i)])
(if ($char< c1 c2)
#t
(if ($char= c1 c2)
(f ($fxadd1 i) n s1 s2)
#f))))))))
(define ($string>? s1 s2)
($string<? s2 s1))
(define ($string>=? s1 s2)
($string<=? s2 s1))
(define string<? (string-cmp 'string<? $string<?))
(define string<=? (string-cmp 'string<=? $string<=?))
(define string>? (string-cmp 'string>? $string>?))
(define string>=? (string-cmp 'string>=? $string>=?))
(define string->list
(lambda (x)
(unless (string? x)

60
src/ikarus.unicode-data.ss
View File

@ -3,8 +3,8 @@
(export unicode-printable-char?
char-downcase char-upcase char-titlecase char-foldcase
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
string-foldcase
string-ci=?)
string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?
string-foldcase)
(import
(ikarus system $fx)
(ikarus system $vectors)
@ -14,8 +14,8 @@
(ikarus system $io)
(except (ikarus) char-downcase char-upcase char-titlecase char-foldcase
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
string-foldcase
string-ci=?))
string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?
string-foldcase))
(include "unicode/unicode-constituents.ss")
(include "unicode/unicode-char-cases.ss")
@ -160,12 +160,52 @@
($string-foldcase str)
(error 'string-foldcase "~s is not a string" str)))
(define (string-ci=? s1 s2)
(if (string? s1)
(if (string? s2)
(string=? ($string-foldcase s1) ($string-foldcase s2))
(error 'string-ci=? "~s is not a string" s2))
(error 'string-ci=? "~s is not a string" s1)))
(define string-ci-cmp
(lambda (who cmp)
(case-lambda
[(s1 s2)
(if (string? s1)
(if (string? s2)
(cmp ($string-foldcase s1) ($string-foldcase s2))
(error who "~s is not a string" s2))
(error who "~s is not a string" s1))]
[(s1 . s*)
(if (string? s1)
(let ([s1 ($string-foldcase s1)])
(let f ([s1 s1] [s* s*])
(cond
[(null? s*) #t]
[else
(let ([s2 (car s*)])
(if (string? s2)
(let ([s2 ($string-foldcase s2)])
(if (cmp s1 s2)
(f s2 (cdr s*))
(let f ([s* (cdr s*)])
(cond
[(null? s*) #f]
[(string? (car s*))
(f (cdr s*))]
[else
(error who "~s is not a string"
(car s*))]))))
(error who "~s is not a string" s2)))])))
(error who "~s is not a string" s1))])))
(define string-ci=? (string-ci-cmp 'string-ci=? string=?))
(define string-ci<? (string-ci-cmp 'string-ci<? string<?))
(define string-ci<=? (string-ci-cmp 'string-ci<=? string<=?))
(define string-ci>? (string-ci-cmp 'string-ci>? string>?))
(define string-ci>=? (string-ci-cmp 'string-ci>=? string>=?))
;(define (string-ci=? s1 s2)
; (if (string? s1)
; (if (string? s2)
; (string=? ($string-foldcase s1) ($string-foldcase s2))
; (error 'string-ci=? "~s is not a string" s2))
; (error 'string-ci=? "~s is not a string" s1)))
)

8
src/makefile.ss
View File

@ -352,7 +352,15 @@
[string-fill! i r]
[string-length i r]
[string=? i r]
[string<? i r]
[string<=? i r]
[string>? i r]
[string>=? i r]
[string-ci=? i unicode]
[string-ci<? i unicode]
[string-ci<=? i unicode]
[string-ci>? i unicode]
[string-ci>=? i unicode]
[substring i r]
[string-copy i r]
[string-append i r]

2
src/run-tests.ss
View File

@ -3,6 +3,7 @@
(import (ikarus)
(tests reader)
(tests bytevectors)
(tests strings)
(tests bignum-to-flonum)
(tests string-to-number))
@ -21,6 +22,7 @@
(test-reader)
(test-bytevectors)
(test-strings)
(test-exact-integer-sqrt)
(test-bignum-to-flonum)
(test-string-to-number)

20
src/tests/strings.ss Normal file
View File

@ -0,0 +1,20 @@
(library (tests strings)
(export test-strings)
(import (ikarus) (tests framework))
(define-tests test-strings
[values
(string-ci=? "Strasse" "Stra\xDF;e")]
;[(lambda (x) (string=? x "STRASSE"))
; (string-upcase "Stra\xDF;e")]
;[(lambda (x) (string=? x "stra\xDF;e"))
; (string-downcase "Stra\xDF;e")]
[(lambda (x) (string=? x "strasse"))
(string-foldcase "Stra\xDF;e")]
;[(lambda (x) (string=? x "strasse"))
; (string-downcase "STRASSE")]
[values (string-ci=? "Stra\xDF;e" "Strasse")]
[values (string-ci=? "Stra\xDF;e" "STRASSE")]
))

10
src/todo-r6rs.ss
View File

@ -753,11 +753,11 @@
[char-title-case? S uc]
[char-upper-case? S uc se]
[char-whitespace? C uc se]
[string-ci<=? S uc se]
[string-ci<? S uc se]
[string-ci=? S uc se]
[string-ci>=? S uc se]
[string-ci>? S uc se]
[string-ci<=? C uc se]
[string-ci<? C uc se]
[string-ci=? C uc se]
[string-ci>=? C uc se]
[string-ci>? C uc se]
[string-downcase S uc]
[string-foldcase S uc]
[string-normalize-nfc S uc]