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

* moved char-whitespace?, char-alphabetic?, and char-downcase to 

ikarus.chars
This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 05:14:24 -04:00
parent 01a161d409
commit fd5c6a1e47
3 changed files with 40 additions and 37 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.

43
src/ikarus.chars.ss
View File

@ -1,10 +1,13 @@
(library (ikarus chars)
(export char=? char<? char<=? char>? char>=?)
(export char=? char<? char<=? char>? char>=? char-whitespace?
char-alphabetic? char-downcase)
(import
(except (ikarus) char=? char<? char<=? char>? char>=?)
(except (ikarus)
char=? char<? 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)])))
)

34
src/ikarus.core.ss
View File

@ -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)