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