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

* Added char-alphabetic? char-numeric? char-whitespace? 

char-upper-case?  char-lower-case?  char-title-case?
This commit is contained in:
Abdulaziz Ghuloum 2007-09-13 06:27:31 -04:00
parent 62ee718fb8
commit 9a62c12c66
5 changed files with 74 additions and 46 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,13 +1,15 @@
(library (ikarus chars) (library (ikarus chars)
(export char=? char<? char<=? char>? char>=? char-whitespace? (export char=? char<? char<=? char>? char>=? ;char-whitespace?
char->integer integer->char char->integer integer->char
char-alphabetic? char-downcase) ;char-alphabetic?
char-downcase)
(import (import
(except (ikarus) (except (ikarus)
char=? char<? char<=? char>? char>=? char=? char<? char<=? char>? char>=?
integer->char char->integer integer->char char->integer
char-whitespace? char-alphabetic? char-downcase) ;char-whitespace? char-alphabetic?
char-downcase)
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $chars) (ikarus system $chars)
(ikarus system $fx)) (ikarus system $fx))
@ -216,24 +218,25 @@
(err c2))))) (err c2)))))
(err c1))]))) (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? ;;; XXX (define char-whitespace?
(lambda (c) ;;; XXX (lambda (c)
(cond ;;; XXX (cond
[(char? c) ;;; XXX [(memq c '(#\space #\tab #\newline #\return)) #t]
(cond ;;; XXX [(char? c) #f]
[($char<= #\a c) ($char<= c #\z)] ;;; XXX [else
[($char<= #\A c) ($char<= c #\Z)] ;;; XXX (error 'char-whitespace? "~s is not a character" c)])))
[else #f])]
[else ;;; XXX (define char-alphabetic?
(error 'char-alphabetic? "~s is not a character" c)]))) ;;; 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 (define char-downcase
(lambda (c) (lambda (c)

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

@ -1,10 +1,17 @@
(library (ikarus unicode-data) (library (ikarus unicode-data)
(export unicode-printable-char?
char-downcase char-upcase char-titlecase char-foldcase (export
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=? unicode-printable-char? char-downcase char-upcase
string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=? char-titlecase char-foldcase char-ci=? char-ci<? char-ci<=?
string-foldcase char-general-category ) char-ci>? char-ci>=? string-ci=? string-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 (import
(ikarus system $fx) (ikarus system $fx)
(ikarus system $vectors) (ikarus system $vectors)
@ -12,12 +19,14 @@
(ikarus system $pairs) (ikarus system $pairs)
(ikarus system $strings) (ikarus system $strings)
(ikarus system $io) (ikarus system $io)
(except (ikarus) char-downcase char-upcase char-titlecase char-foldcase (except (ikarus)
char-downcase char-upcase char-titlecase char-foldcase
char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=? char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=? string-ci=? string-ci<? string-ci<=? string-ci>?
string-foldcase char-general-category)) 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-char-cases.ss")
(include "unicode/unicode-charinfo.ss") (include "unicode/unicode-charinfo.ss")
@ -56,17 +65,28 @@
(fxlogand 63 (lookup-char-info c))) (fxlogand 63 (lookup-char-info c)))
(error 'char-general-category "~s is not a char" c))) (error 'char-general-category "~s is not a char" c)))
(define (binary-search-on? n v) (define (char-has-property? c prop-val who)
($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)
(if (char? c) (if (char? c)
(not (fxzero? (fxlogand (lookup-char-info c) constituent-property))) (not (fxzero? (fxlogand (lookup-char-info c) prop-val)))
(error 'unicode-printable-char? "~s is not a char" c))) (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) (define (convert-char x adjustment-vec)
(let ([n ($char->fixnum x)]) (let ([n ($char->fixnum x)])

7
src/makefile.ss
View File

@ -349,7 +349,6 @@
[char>=? i r] [char>=? i r]
[integer->char i r] [integer->char i r]
[char->integer i r] [char->integer i r]
[char-whitespace? i r]
[char-downcase i unicode] [char-downcase i unicode]
[char-upcase i unicode] [char-upcase i unicode]
[char-titlecase i unicode] [char-titlecase i unicode]
@ -359,6 +358,12 @@
[char-ci<=? i unicode] [char-ci<=? i unicode]
[char-ci>? i unicode] [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]
[string i r] [string i r]
[make-string i r] [make-string i r]

10
src/todo-r6rs.ss
View File

@ -737,7 +737,7 @@
[identifier? C sc] [identifier? C sc]
[make-variable-transformer C sc] [make-variable-transformer C sc]
;;; ;;;
[char-alphabetic? S uc se] [char-alphabetic? C uc se]
[char-ci<=? C uc se] [char-ci<=? C uc se]
[char-ci<? C uc se] [char-ci<? C uc se]
[char-ci=? C uc se] [char-ci=? C uc se]
@ -748,10 +748,10 @@
[char-titlecase C uc] [char-titlecase C uc]
[char-upcase C uc se] [char-upcase C uc se]
[char-general-category C uc] [char-general-category C uc]
[char-lower-case? S uc se] [char-lower-case? C uc se]
[char-numeric? S uc se] [char-numeric? C uc se]
[char-title-case? S uc] [char-title-case? C uc]
[char-upper-case? S uc se] [char-upper-case? C uc se]
[char-whitespace? C uc se] [char-whitespace? C uc se]
[string-ci<=? C uc se] [string-ci<=? C uc se]
[string-ci<? C uc se] [string-ci<? C uc se]