1 /*===========================================================================
2 * Filename : char.c
3 * About : R5RS characters
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46
47 /*=======================================
48 File Local Type Definitions
49 =======================================*/
50
51 /*=======================================
52 Variable Definitions
53 =======================================*/
54
55 /*=======================================
56 File Local Function Declarations
57 =======================================*/
58
59 /*=======================================
60 Function Definitions
61 =======================================*/
62 /*===========================================================================
63 R5RS : 6.3 Other data types : 6.3.4 Characters
64 ===========================================================================*/
65 SCM_EXPORT ScmObj
scm_p_charp(ScmObj obj)66 scm_p_charp(ScmObj obj)
67 {
68 DECLARE_FUNCTION("char?", procedure_fixed_1);
69
70 return MAKE_BOOL(CHARP(obj));
71 }
72
73 SCM_EXPORT ScmObj
scm_p_char_equalp(ScmObj ch1,ScmObj ch2)74 scm_p_char_equalp(ScmObj ch1, ScmObj ch2)
75 {
76 DECLARE_FUNCTION("char=?", procedure_fixed_2);
77
78 ENSURE_CHAR(ch1);
79 ENSURE_CHAR(ch2);
80
81 #if SCM_HAS_IMMEDIATE_CHAR_ONLY
82 return MAKE_BOOL(EQ(ch1, ch2));
83 #else
84 return MAKE_BOOL(SCM_CHAR_VALUE(ch1) == SCM_CHAR_VALUE(ch2));
85 #endif
86 }
87
88 #define CHAR_CMP_BODY(op, ch1, ch2) \
89 do { \
90 ENSURE_CHAR(ch1); \
91 ENSURE_CHAR(ch2); \
92 \
93 return MAKE_BOOL(SCM_CHAR_VALUE(ch1) op SCM_CHAR_VALUE(ch2)); \
94 } while (/* CONSTCOND */ 0)
95
96 SCM_EXPORT ScmObj
scm_p_char_lessp(ScmObj ch1,ScmObj ch2)97 scm_p_char_lessp(ScmObj ch1, ScmObj ch2)
98 {
99 DECLARE_FUNCTION("char<?", procedure_fixed_2);
100
101 CHAR_CMP_BODY(<, ch1, ch2);
102 }
103
104 SCM_EXPORT ScmObj
scm_p_char_greaterp(ScmObj ch1,ScmObj ch2)105 scm_p_char_greaterp(ScmObj ch1, ScmObj ch2)
106 {
107 DECLARE_FUNCTION("char>?", procedure_fixed_2);
108
109 CHAR_CMP_BODY(>, ch1, ch2);
110 }
111
112 SCM_EXPORT ScmObj
scm_p_char_less_equalp(ScmObj ch1,ScmObj ch2)113 scm_p_char_less_equalp(ScmObj ch1, ScmObj ch2)
114 {
115 DECLARE_FUNCTION("char<=?", procedure_fixed_2);
116
117 CHAR_CMP_BODY(<=, ch1, ch2);
118 }
119
120 SCM_EXPORT ScmObj
scm_p_char_greater_equalp(ScmObj ch1,ScmObj ch2)121 scm_p_char_greater_equalp(ScmObj ch1, ScmObj ch2)
122 {
123 DECLARE_FUNCTION("char>=?", procedure_fixed_2);
124
125 CHAR_CMP_BODY(>=, ch1, ch2);
126 }
127
128 #undef CHAR_CMP_BODY
129
130 #define CHAR_CI_CMP_BODY(op, ch1, ch2) \
131 do { \
132 scm_ichar_t val1, val2; \
133 \
134 ENSURE_CHAR(ch1); \
135 ENSURE_CHAR(ch2); \
136 \
137 val1 = ICHAR_FOLDCASE(SCM_CHAR_VALUE(ch1)); \
138 val2 = ICHAR_FOLDCASE(SCM_CHAR_VALUE(ch2)); \
139 \
140 return MAKE_BOOL(val1 op val2); \
141 } while (/* CONSTCOND */ 0)
142
143 SCM_EXPORT ScmObj
scm_p_char_ci_equalp(ScmObj ch1,ScmObj ch2)144 scm_p_char_ci_equalp(ScmObj ch1, ScmObj ch2)
145 {
146 DECLARE_FUNCTION("char-ci=?", procedure_fixed_2);
147
148 CHAR_CI_CMP_BODY(==, ch1, ch2);
149 }
150
151 SCM_EXPORT ScmObj
scm_p_char_ci_lessp(ScmObj ch1,ScmObj ch2)152 scm_p_char_ci_lessp(ScmObj ch1, ScmObj ch2)
153 {
154 DECLARE_FUNCTION("char-ci<?", procedure_fixed_2);
155
156 CHAR_CI_CMP_BODY(<, ch1, ch2);
157 }
158
159 SCM_EXPORT ScmObj
scm_p_char_ci_greaterp(ScmObj ch1,ScmObj ch2)160 scm_p_char_ci_greaterp(ScmObj ch1, ScmObj ch2)
161 {
162 DECLARE_FUNCTION("char-ci>?", procedure_fixed_2);
163
164 CHAR_CI_CMP_BODY(>, ch1, ch2);
165 }
166
167 SCM_EXPORT ScmObj
scm_p_char_ci_less_equalp(ScmObj ch1,ScmObj ch2)168 scm_p_char_ci_less_equalp(ScmObj ch1, ScmObj ch2)
169 {
170 DECLARE_FUNCTION("char-ci<=?", procedure_fixed_2);
171
172 CHAR_CI_CMP_BODY(<=, ch1, ch2);
173 }
174
175 SCM_EXPORT ScmObj
scm_p_char_ci_greater_equalp(ScmObj ch1,ScmObj ch2)176 scm_p_char_ci_greater_equalp(ScmObj ch1, ScmObj ch2)
177 {
178 DECLARE_FUNCTION("char-ci>=?", procedure_fixed_2);
179
180 CHAR_CI_CMP_BODY(>=, ch1, ch2);
181 }
182
183 #undef CHAR_CI_CMP_BODY
184
185 SCM_EXPORT ScmObj
scm_p_char_alphabeticp(ScmObj ch)186 scm_p_char_alphabeticp(ScmObj ch)
187 {
188 scm_ichar_t val;
189 DECLARE_FUNCTION("char-alphabetic?", procedure_fixed_1);
190
191 ENSURE_CHAR(ch);
192
193 val = SCM_CHAR_VALUE(ch);
194
195 return MAKE_BOOL(ICHAR_ALPHABETICP(val));
196 }
197
198 SCM_EXPORT ScmObj
scm_p_char_numericp(ScmObj ch)199 scm_p_char_numericp(ScmObj ch)
200 {
201 scm_ichar_t val;
202 DECLARE_FUNCTION("char-numeric?", procedure_fixed_1);
203
204 ENSURE_CHAR(ch);
205
206 val = SCM_CHAR_VALUE(ch);
207
208 return MAKE_BOOL(ICHAR_NUMERICP(val));
209 }
210
211 SCM_EXPORT ScmObj
scm_p_char_whitespacep(ScmObj ch)212 scm_p_char_whitespacep(ScmObj ch)
213 {
214 scm_ichar_t val;
215 DECLARE_FUNCTION("char-whitespace?", procedure_fixed_1);
216
217 ENSURE_CHAR(ch);
218
219 val = SCM_CHAR_VALUE(ch);
220
221 return MAKE_BOOL(ICHAR_WHITESPACEP(val));
222 }
223
224 SCM_EXPORT ScmObj
scm_p_char_upper_casep(ScmObj ch)225 scm_p_char_upper_casep(ScmObj ch)
226 {
227 scm_ichar_t val;
228 DECLARE_FUNCTION("char-upper-case?", procedure_fixed_1);
229
230 ENSURE_CHAR(ch);
231
232 val = SCM_CHAR_VALUE(ch);
233
234 return MAKE_BOOL(ICHAR_UPPER_CASEP(val));
235 }
236
237 SCM_EXPORT ScmObj
scm_p_char_lower_casep(ScmObj ch)238 scm_p_char_lower_casep(ScmObj ch)
239 {
240 scm_ichar_t val;
241 DECLARE_FUNCTION("char-lower-case?", procedure_fixed_1);
242
243 ENSURE_CHAR(ch);
244
245 val = SCM_CHAR_VALUE(ch);
246
247 return MAKE_BOOL(ICHAR_LOWER_CASEP(val));
248 }
249
250 SCM_EXPORT ScmObj
scm_p_char2integer(ScmObj ch)251 scm_p_char2integer(ScmObj ch)
252 {
253 DECLARE_FUNCTION("char->integer", procedure_fixed_1);
254
255 ENSURE_CHAR(ch);
256
257 return MAKE_INT(SCM_CHAR_VALUE(ch));
258 }
259
260 /*
261 * R6RS: 9.13 Characters
262 *
263 * procedure: (integer->char sv)
264 *
265 * Sv must be a Unicode scalar value, i.e. a non-negative exact integer in
266 * [0, #xD7FF] ∪ [#xE000, #x10FFFF].
267 */
268 SCM_EXPORT ScmObj
scm_p_integer2char(ScmObj n)269 scm_p_integer2char(ScmObj n)
270 {
271 scm_int_t val;
272 DECLARE_FUNCTION("integer->char", procedure_fixed_1);
273
274 ENSURE_INT(n);
275
276 val = SCM_INT_VALUE(n);
277 #if SCM_USE_MULTIBYTE_CHAR
278 if ((SCM_CHARCODEC_CCS(scm_current_char_codec) == SCM_CCS_UNICODE
279 && !ICHAR_VALID_UNICODEP(val))
280 || (!SCM_CHARCODEC_CHAR_LEN(scm_current_char_codec, val)
281 && val != 0)) /* NUL is a valid char */
282 #else
283 if (!ICHAR_SINGLEBYTEP(val)) /* accepts ISO-8859-1 loosely */
284 #endif
285 ERR("invalid char value: #x~MX", val);
286
287 return MAKE_CHAR((scm_ichar_t)val);
288 }
289
290 SCM_EXPORT ScmObj
scm_p_char_upcase(ScmObj ch)291 scm_p_char_upcase(ScmObj ch)
292 {
293 scm_ichar_t val;
294 DECLARE_FUNCTION("char-upcase", procedure_fixed_1);
295
296 ENSURE_CHAR(ch);
297
298 val = SCM_CHAR_VALUE(ch);
299
300 return MAKE_CHAR(ICHAR_UPCASE(val));
301 }
302
303 SCM_EXPORT ScmObj
scm_p_char_downcase(ScmObj ch)304 scm_p_char_downcase(ScmObj ch)
305 {
306 scm_ichar_t val;
307 DECLARE_FUNCTION("char-downcase", procedure_fixed_1);
308
309 ENSURE_CHAR(ch);
310
311 val = SCM_CHAR_VALUE(ch);
312
313 return MAKE_CHAR(ICHAR_DOWNCASE(val));
314 }
315