1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Mike Sperber
; Character maps, ASCII-only version
; Enable us to change the semantics afterwards (see the bottom of this file)
(define (char-whitespace? c)
(char-whitespace?-proc c))
(define (char-whitespace?-proc c)
(if (memq (char->ascii c) ascii-whitespaces) #t #f))
(define (char-lower-case? c)
(char-lower-case?-proc c))
(define (char-lower-case?-proc c)
(and (char>=? c #\a)
(char<=? c #\z)))
(define (char-upper-case? c)
(char-upper-case?-proc c))
(define (char-upper-case?-proc c)
(and (char>=? c #\A)
(char<=? c #\Z)))
(define (char-numeric? c)
(char-numeric?-proc c))
(define (char-numeric?-proc c)
(and (char>=? c #\0)
(char<=? c #\9)))
(define (char-alphabetic? c)
(char-alphabetic?-proc c))
(define (char-alphabetic?-proc c)
(or (char-upper-case? c)
(char-lower-case? c)))
(define char-case-delta
(- (char->ascii #\a) (char->ascii #\A)))
(define (make-character-map f)
(let ((s (make-string ascii-limit #\0)))
(do ((i 0 (+ i 1)))
((>= i ascii-limit))
(string-set! s i (f (ascii->char i))))
s))
(define upcase-map
(make-character-map
(lambda (c)
(if (char-lower-case? c)
(ascii->char (- (char->ascii c) char-case-delta))
c))))
(define (char-upcase c)
(char-upcase-proc c))
(define (char-upcase-proc c)
(string-ref upcase-map (char->ascii c)))
(define downcase-map
(make-character-map
(lambda (c)
(if (char-upper-case? c)
(ascii->char (+ (char->ascii c) char-case-delta))
c))))
(define (char-downcase c)
(char-downcase-proc c))
(define (char-downcase-proc c)
(string-ref downcase-map (char->ascii c)))
; helper for defining the -ci procedures
; This is relevant for Unicode, where FOLDCASE != DOWNCASE
(define (char-foldcase c)
(char-foldcase-proc c))
(define char-foldcase-proc char-downcase-proc)
(define (char-ci-compare pred)
(lambda (c1 c2) (pred (char-foldcase c1) (char-foldcase c2))))
(define char-ci=? (char-ci-compare char=?))
(define char-ci<? (char-ci-compare char<?))
(define char-ci<=? (char-ci-compare char<=?))
(define char-ci>? (char-ci-compare char>?))
(define char-ci>=? (char-ci-compare char>=?))
; Later, we replace these by the Unicode versions. We don't want them
; in the initial image because they use a lot more memory.
(define (set-char-map-procedures! alphabetic?
numeric?
whitespace?
upper-case?
lower-case?
upcase
downcase
foldcase)
(set! char-alphabetic?-proc alphabetic?)
(set! char-numeric?-proc numeric?)
(set! char-whitespace?-proc whitespace?)
(set! char-upper-case?-proc upper-case?)
(set! char-lower-case?-proc lower-case?)
(set! char-upcase-proc upcase)
(set! char-downcase-proc downcase)
(set! char-foldcase-proc foldcase))
|
