diff --git a/src/ikarus.boot b/src/ikarus.boot index ce1bbad..b31d9b1 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 d719959..49a5ad7 100644 --- a/src/ikarus.chars.ss +++ b/src/ikarus.chars.ss @@ -1,10 +1,13 @@ (library (ikarus chars) - (export char=? char? char>=?) + (export char=? char? char>=? char-whitespace? + char-alphabetic? char-downcase) (import - (except (ikarus) char=? char? char>=?) + (except (ikarus) + char=? char? char>=? + char-whitespace? char-alphabetic? char-downcase) (only (scheme) - $car $cdr + $car $cdr $fx+ $fx- $fixnum->char $char->fixnum $char= $char< $char<= $char> $char>=)) ;;; FIXME: this file is embarrasing @@ -192,4 +195,38 @@ (err ($car c*)))))) (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)]))) + + (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)]))) + + (define char-downcase + (lambda (c) + (cond + [(char? c) + (cond + [(and ($char<= #\A c) ($char<= c #\Z)) + ($fixnum->char + ($fx+ ($char->fixnum c) + ($fx- ($char->fixnum #\a) + ($char->fixnum #\A))))] + [else c])] + [else + (error 'char-downcase "~s is not a character" c)]))) + ) diff --git a/src/ikarus.core.ss b/src/ikarus.core.ss index 166eea6..e91492f 100644 --- a/src/ikarus.core.ss +++ b/src/ikarus.core.ss @@ -69,40 +69,6 @@ ls (f x (cdr ls))))))) -(primitive-set! '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)]))) - -(primitive-set! '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)]))) - -(primitive-set! 'char-downcase - (lambda (c) - (cond - [(char? c) - (cond - [(and ($char<= #\A c) ($char<= c #\Z)) - ($fixnum->char - ($fx+ ($char->fixnum c) - ($fx- ($char->fixnum #\a) - ($char->fixnum #\A))))] - [else c])] - [else - (error 'char-downcase "~s is not a character" c)]))) - - (primitive-set! 'set-car! (lambda (x y) (unless (pair? x)