300 lines
10 KiB
Scheme
300 lines
10 KiB
Scheme
;;; Ikarus Scheme -- A compiler for R6RS Scheme.
|
|
;;; Copyright (C) 2006,2007 Abdulaziz Ghuloum
|
|
;;;
|
|
;;; This program is free software: you can redistribute it and/or modify
|
|
;;; it under the terms of the GNU General Public License version 3 as
|
|
;;; published by the Free Software Foundation.
|
|
;;;
|
|
;;; This program is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;; General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
|
|
|
|
|
|
|
|
(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
|
|
char-alphabetic? char-numeric? char-whitespace?
|
|
char-upper-case? char-lower-case? char-title-case? )
|
|
|
|
(import
|
|
(ikarus system $fx)
|
|
(ikarus system $vectors)
|
|
(ikarus system $chars)
|
|
(ikarus system $pairs)
|
|
(ikarus system $strings)
|
|
(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-char-cases.ss")
|
|
(include "unicode/unicode-charinfo.ss")
|
|
|
|
(define (binary-search n v)
|
|
(let ([k ($fx- ($vector-length v) 1)])
|
|
(let f ([i 0] [k k] [n n] [v v])
|
|
(cond
|
|
[($fx= i k) i]
|
|
[else
|
|
(let ([j ($fxsra ($fx+ i ($fx+ k 1)) 1)])
|
|
(cond
|
|
[($fx<= ($vector-ref v j) n) (f j k n v)]
|
|
[else (f i ($fx- j 1) n v)]))]))))
|
|
|
|
(define (lookup-char-info c)
|
|
(let ([v unicode-categories-lookup-vector]
|
|
[t unicode-categories-values-vector])
|
|
(define (f i k n)
|
|
(cond
|
|
[($fx= i k)
|
|
(let ([idx ($vector-ref t i)])
|
|
(if (fixnum? idx)
|
|
idx
|
|
(let ([idx2 ($fx- n ($vector-ref v i))])
|
|
($vector-ref idx idx2))))]
|
|
[else
|
|
(let ([j ($fxsra ($fx+ i ($fx+ k 1)) 1)])
|
|
(cond
|
|
[($fx<= ($vector-ref v j) n) (f j k n)]
|
|
[else (f i ($fx- j 1) n)]))]))
|
|
(f 0 (fx- (vector-length v) 1) (char->integer c))))
|
|
|
|
(define (char-general-category c)
|
|
(if (char? c)
|
|
(vector-ref unicode-categories-name-vector
|
|
(fxlogand 63 (lookup-char-info c)))
|
|
(error 'char-general-category "not a char" c)))
|
|
|
|
(define (char-has-property? c prop-val who)
|
|
(if (char? c)
|
|
(not (fxzero? (fxlogand (lookup-char-info c) prop-val)))
|
|
(error who "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)])
|
|
(let ([adj ($vector-ref adjustment-vec idx)])
|
|
($fx+ adj n)))))
|
|
|
|
(define (char-downcase x)
|
|
(if (char? x)
|
|
($fixnum->char
|
|
(convert-char x char-downcase-adjustment-vector))
|
|
(error 'char-downcase "not a character" x)))
|
|
|
|
(define (char-upcase x)
|
|
(if (char? x)
|
|
($fixnum->char
|
|
(convert-char x char-upcase-adjustment-vector))
|
|
(error 'char-downcase "not a character" x)))
|
|
|
|
(define (char-titlecase x)
|
|
(if (char? x)
|
|
($fixnum->char
|
|
(convert-char x char-titlecase-adjustment-vector))
|
|
(error 'char-downcase "not a character" x)))
|
|
|
|
(define (char-foldcase x)
|
|
(if (char? x)
|
|
($fixnum->char ($fold x))
|
|
(error 'char-downcase "not a character" x)))
|
|
|
|
(define ($fold x)
|
|
(convert-char x char-foldcase-adjustment-vector))
|
|
|
|
(define (char-ci-loop c0 ls p? who)
|
|
(or (null? ls)
|
|
(let ([c1 (car ls)])
|
|
(unless (char? c1) (error who "not a char" c1))
|
|
(let ([c1 ($fold c1)])
|
|
(if (p? c0 c1)
|
|
(char-ci-loop c1 (cdr ls) p? who)
|
|
(let f ([ls (cdr ls)] [who who])
|
|
(cond
|
|
[(null? ls) #f]
|
|
[(char? (car ls))
|
|
(f (cdr ls) who)]
|
|
[else (error who "not a char" (car ls))])))))))
|
|
|
|
(define char-ci=?
|
|
(case-lambda
|
|
[(x y)
|
|
(if (char? x)
|
|
(or (eq? x y)
|
|
(if (char? y)
|
|
($fx= ($fold x) ($fold y))
|
|
(error 'char-ci=? "not a char" y)))
|
|
(error 'char-ci=? "not a char" x))]
|
|
[(x)
|
|
(or (char? x) (error 'char-ci=? "not a char" x))]
|
|
[(x . x*)
|
|
(if (char? x)
|
|
(char-ci-loop x x* char=? 'char-ci=?)
|
|
(error 'char-ci=? "not a char" x))]))
|
|
|
|
(define char-ci<?
|
|
(case-lambda
|
|
[(x y)
|
|
(if (char? x)
|
|
(or (eq? x y)
|
|
(if (char? y)
|
|
($fx< ($fold x) ($fold y))
|
|
(error 'char-ci<? "not a char" y)))
|
|
(error 'char-ci<? "not a char" x))]
|
|
[(x)
|
|
(or (char? x) (error 'char-ci<? "not a char" x))]
|
|
[(x . x*)
|
|
(if (char? x)
|
|
(char-ci-loop x x* char<? 'char-ci<?)
|
|
(error 'char-ci<? "not a char" x))]))
|
|
|
|
(define char-ci<=?
|
|
(case-lambda
|
|
[(x y)
|
|
(if (char? x)
|
|
(or (eq? x y)
|
|
(if (char? y)
|
|
($fx<= ($fold x) ($fold y))
|
|
(error 'char-ci<=? "not a char" y)))
|
|
(error 'char-ci<=? "not a char" x))]
|
|
[(x)
|
|
(or (char? x) (error 'char-ci<=? "not a char" x))]
|
|
[(x . x*)
|
|
(if (char? x)
|
|
(char-ci-loop x x* char<=? 'char-ci<=?)
|
|
(error 'char-ci<=? "not a char" x))]))
|
|
|
|
(define char-ci>?
|
|
(case-lambda
|
|
[(x y)
|
|
(if (char? x)
|
|
(or (eq? x y)
|
|
(if (char? y)
|
|
($fx> ($fold x) ($fold y))
|
|
(error 'char-ci>? "not a char" y)))
|
|
(error 'char-ci>? "not a char" x))]
|
|
[(x)
|
|
(or (char? x) (error 'char-ci>? "not a char" x))]
|
|
[(x . x*)
|
|
(if (char? x)
|
|
(char-ci-loop x x* char>? 'char-ci>?)
|
|
(error 'char-ci>? "not a char" x))]))
|
|
|
|
(define char-ci>=?
|
|
(case-lambda
|
|
[(x y)
|
|
(if (char? x)
|
|
(or (eq? x y)
|
|
(if (char? y)
|
|
($fx>= ($fold x) ($fold y))
|
|
(error 'char-ci>=? "not a char" y)))
|
|
(error 'char-ci>=? "not a char" x))]
|
|
[(x)
|
|
(or (char? x) (error 'char-ci>=? "not a char" x))]
|
|
[(x . x*)
|
|
(if (char? x)
|
|
(char-ci-loop x x* char>=? 'char-ci>=?)
|
|
(error 'char-ci>=? "not a char" x))]))
|
|
|
|
(define ($string-foldcase str)
|
|
(let-values ([(p e) (open-string-output-port)])
|
|
(let f ([str str] [i 0] [n (string-length str)])
|
|
(cond
|
|
[($fx= i n) (e)]
|
|
[else
|
|
(let* ([n ($char->fixnum ($string-ref str i))])
|
|
(let ([n/ls
|
|
(vector-ref string-foldcase-adjustment-vector
|
|
(binary-search n charcase-search-vector))])
|
|
(if (fixnum? n/ls)
|
|
(write-char ($fixnum->char ($fx+ n n/ls)) p)
|
|
(let f ([ls n/ls])
|
|
(write-char ($car ls) p)
|
|
(let ([ls ($cdr ls)])
|
|
(if (pair? ls)
|
|
(f ls)
|
|
(write-char ls p)))))))
|
|
(f str ($fxadd1 i) n)]))))
|
|
|
|
(define (string-foldcase str)
|
|
(if (string? str)
|
|
($string-foldcase str)
|
|
(error 'string-foldcase "not a string" str)))
|
|
|
|
;;; FIXME: case-insensitive comparison procedures are slow.
|
|
|
|
(define string-ci-cmp
|
|
(lambda (who cmp)
|
|
(case-lambda
|
|
[(s1 s2)
|
|
(if (string? s1)
|
|
(if (string? s2)
|
|
(cmp ($string-foldcase s1) ($string-foldcase s2))
|
|
(error who "not a string" s2))
|
|
(error who "not a string" s1))]
|
|
[(s1 . s*)
|
|
(if (string? s1)
|
|
(let ([s1 ($string-foldcase s1)])
|
|
(let f ([s1 s1] [s* s*])
|
|
(cond
|
|
[(null? s*) #t]
|
|
[else
|
|
(let ([s2 (car s*)])
|
|
(if (string? s2)
|
|
(let ([s2 ($string-foldcase s2)])
|
|
(if (cmp s1 s2)
|
|
(f s2 (cdr s*))
|
|
(let f ([s* (cdr s*)])
|
|
(cond
|
|
[(null? s*) #f]
|
|
[(string? (car s*))
|
|
(f (cdr s*))]
|
|
[else
|
|
(error who "not a string"
|
|
(car s*))]))))
|
|
(error who "not a string" s2)))])))
|
|
(error who "not a string" s1))])))
|
|
|
|
|
|
(define string-ci=? (string-ci-cmp 'string-ci=? string=?))
|
|
(define string-ci<? (string-ci-cmp 'string-ci<? string<?))
|
|
(define string-ci<=? (string-ci-cmp 'string-ci<=? string<=?))
|
|
(define string-ci>? (string-ci-cmp 'string-ci>? string>?))
|
|
(define string-ci>=? (string-ci-cmp 'string-ci>=? string>=?))
|
|
|
|
|
|
)
|
|
|