diff --git a/src/ikarus.boot b/src/ikarus.boot index 676faad..886589c 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.chars.ss b/src/ikarus.chars.ss index 1cf84c3..edcbf17 100644 --- a/src/ikarus.chars.ss +++ b/src/ikarus.chars.ss @@ -1,13 +1,15 @@ (library (ikarus chars) - (export char=? char? char>=? char-whitespace? + (export char=? char? char>=? ;char-whitespace? char->integer integer->char - char-alphabetic? char-downcase) + ;char-alphabetic? + char-downcase) (import (except (ikarus) char=? char? char>=? integer->char char->integer - char-whitespace? char-alphabetic? char-downcase) + ;char-whitespace? char-alphabetic? + char-downcase) (ikarus system $pairs) (ikarus system $chars) (ikarus system $fx)) @@ -216,24 +218,25 @@ (err c2))))) (err c1))]))) - (define char-whitespace? - (lambda (c) - (cond - [(memq c '(#\space #\tab #\newline #\return)) #t] - [(char? c) #f] - [else - (error 'char-whitespace? "~s is not a character" c)]))) + + ;;; XXX (define char-whitespace? + ;;; XXX (lambda (c) + ;;; XXX (cond + ;;; XXX [(memq c '(#\space #\tab #\newline #\return)) #t] + ;;; XXX [(char? c) #f] + ;;; XXX [else + ;;; XXX (error 'char-whitespace? "~s is not a character" c)]))) - (define char-alphabetic? - (lambda (c) - (cond - [(char? c) - (cond - [($char<= #\a c) ($char<= c #\z)] - [($char<= #\A c) ($char<= c #\Z)] - [else #f])] - [else - (error 'char-alphabetic? "~s is not a character" c)]))) + ;;; XXX (define char-alphabetic? + ;;; XXX (lambda (c) + ;;; XXX (cond + ;;; XXX [(char? c) + ;;; XXX (cond + ;;; XXX [($char<= #\a c) ($char<= c #\z)] + ;;; XXX [($char<= #\A c) ($char<= c #\Z)] + ;;; XXX [else #f])] + ;;; XXX [else + ;;; XXX (error 'char-alphabetic? "~s is not a character" c)]))) (define char-downcase (lambda (c) diff --git a/src/ikarus.unicode-data.ss b/src/ikarus.unicode-data.ss index 295cc8e..736cf5b 100644 --- a/src/ikarus.unicode-data.ss +++ b/src/ikarus.unicode-data.ss @@ -1,10 +1,17 @@ + + + (library (ikarus unicode-data) - (export unicode-printable-char? - char-downcase char-upcase char-titlecase char-foldcase - char-ci=? char-ci? char-ci>=? - string-ci=? string-ci? string-ci>=? - string-foldcase char-general-category ) + + (export + unicode-printable-char? char-downcase char-upcase + char-titlecase char-foldcase char-ci=? char-ci? char-ci>=? string-ci=? string-ci? string-ci>=? string-foldcase char-general-category + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char-title-case? ) + (import (ikarus system $fx) (ikarus system $vectors) @@ -12,12 +19,14 @@ (ikarus system $pairs) (ikarus system $strings) (ikarus system $io) - (except (ikarus) char-downcase char-upcase char-titlecase char-foldcase - char-ci=? char-ci? char-ci>=? - string-ci=? string-ci? string-ci>=? - string-foldcase char-general-category)) + (except (ikarus) + char-downcase char-upcase char-titlecase char-foldcase + char-ci=? char-ci? char-ci>=? + string-ci=? string-ci? + string-ci>=? string-foldcase char-general-category + char-alphabetic? char-numeric? char-whitespace? + char-upper-case? char-lower-case? char-title-case? )) - ; (include "unicode/unicode-constituents.ss") (include "unicode/unicode-char-cases.ss") (include "unicode/unicode-charinfo.ss") @@ -56,18 +65,29 @@ (fxlogand 63 (lookup-char-info c))) (error 'char-general-category "~s is not a char" c))) - (define (binary-search-on? n v) - ($fx= ($fxlogand (binary-search n v) 1) 1)) - - ;(define (unicode-printable-char? c) - ; (binary-search-on? - ; ($char->fixnum c) - ; unicode-constituents-vector)) - (define (unicode-printable-char? c) + (define (char-has-property? c prop-val who) (if (char? c) - (not (fxzero? (fxlogand (lookup-char-info c) constituent-property))) - (error 'unicode-printable-char? "~s is not a char" c))) + (not (fxzero? (fxlogand (lookup-char-info c) prop-val))) + (error who "~s is not a char" c))) + + (define (unicode-printable-char? c) + (char-has-property? c constituent-property 'unicode-printable-char?)) + (define (char-alphabetic? c) + (char-has-property? c alphabetic-property 'char-alphabetic?)) + (define (char-numeric? c) + (char-has-property? c numeric-property 'char-numeric?)) + (define (char-whitespace? c) + (char-has-property? c whitespace-property 'char-whitespace?)) + (define (char-upper-case? c) + (char-has-property? c uppercase-property 'char-upper-case?)) + (define (char-lower-case? c) + (char-has-property? c lowercase-property 'char-lower-case?)) + (define (char-title-case? c) + (char-has-property? c titlecase-property 'char-title-case?)) + + + (define (convert-char x adjustment-vec) (let ([n ($char->fixnum x)]) (let ([idx (binary-search n charcase-search-vector)]) diff --git a/src/makefile.ss b/src/makefile.ss index 641f7ee..2a2566e 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -349,7 +349,6 @@ [char>=? i r] [integer->char i r] [char->integer i r] - [char-whitespace? i r] [char-downcase i unicode] [char-upcase i unicode] [char-titlecase i unicode] @@ -359,6 +358,12 @@ [char-ci<=? i unicode] [char-ci>? i unicode] [char-ci>=? i unicode] + [char-alphabetic? i unicode] + [char-numeric? i unicode] + [char-whitespace? i unicode] + [char-upper-case? i unicode] + [char-lower-case? i unicode] + [char-title-case? i unicode] [string? i r] [string i r] [make-string i r] diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index 51a10d7..3a5faa1 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -737,7 +737,7 @@ [identifier? C sc] [make-variable-transformer C sc] ;;; - [char-alphabetic? S uc se] + [char-alphabetic? C uc se] [char-ci<=? C uc se] [char-ci