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)
(export char=? char<? char<=? char>? char>=? char-whitespace?
(export char=? char<? char<=? char>? char>=? ;char-whitespace?
char->integer integer->char
char-alphabetic? char-downcase)
;char-alphabetic?
char-downcase)
(import
(except (ikarus)
char=? char<? 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)

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

@ -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<=? char-ci>? char-ci>=?
string-ci=? string-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<=?
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
(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<=? char-ci>? char-ci>=?
string-ci=? string-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<=? 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? ))
; (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)])

7
src/makefile.ss
View File

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

10
src/todo-r6rs.ss
View File

@ -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<? C uc se]
[char-ci=? C uc se]
@ -748,10 +748,10 @@
[char-titlecase C uc]
[char-upcase C uc se]
[char-general-category C uc]
[char-lower-case? S uc se]
[char-numeric? S uc se]
[char-title-case? S uc]
[char-upper-case? S uc se]
[char-lower-case? C uc se]
[char-numeric? C uc se]
[char-title-case? C uc]
[char-upper-case? C uc se]
[char-whitespace? C uc se]
[string-ci<=? C uc se]
[string-ci<? C uc se]