Commit | Line | Data |
---|---|---|
ca003b26 MG |
1 | /* srfi-14.c --- SRFI-14 procedures for Guile |
2 | * | |
e81d98ec | 3 | * Copyright (C) 2001 Free Software Foundation, Inc. |
645f5e0e | 4 | * |
73be1d9e MV |
5 | * This library is free software; you can redistribute it and/or |
6 | * modify it under the terms of the GNU Lesser General Public | |
7 | * License as published by the Free Software Foundation; either | |
8 | * version 2.1 of the License, or (at your option) any later version. | |
645f5e0e | 9 | * |
73be1d9e MV |
10 | * This library is distributed in the hope that it will be useful, |
11 | * but WITHOUT ANY WARRANTY; without even the implied warranty of | |
ca003b26 | 12 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
73be1d9e | 13 | * Lesser General Public License for more details. |
645f5e0e | 14 | * |
73be1d9e MV |
15 | * You should have received a copy of the GNU Lesser General Public |
16 | * License along with this library; if not, write to the Free Software | |
17 | * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA | |
18 | */ | |
ca003b26 MG |
19 | |
20 | ||
21 | #include <string.h> | |
22 | ||
23 | #include <libguile.h> | |
24 | ||
25 | #include "srfi-14.h" | |
26 | ||
ca003b26 | 27 | |
cc0ce1e7 RB |
28 | #define SCM_CHARSET_SET(cs, idx) \ |
29 | (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \ | |
30 | (1L << ((idx) % SCM_BITS_PER_LONG))) | |
ca003b26 | 31 | |
4c4185ee MG |
32 | #define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8) |
33 | #define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG) | |
34 | ||
35 | ||
ca003b26 MG |
36 | /* Smob type code for character sets. */ |
37 | int scm_tc16_charset = 0; | |
38 | ||
39 | ||
40 | /* Smob print hook for character sets. */ | |
41 | static int | |
e81d98ec | 42 | charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED) |
ca003b26 MG |
43 | { |
44 | int i; | |
45 | int first = 1; | |
46 | ||
47 | scm_puts ("#<charset {", port); | |
48 | for (i = 0; i < SCM_CHARSET_SIZE; i++) | |
49 | if (SCM_CHARSET_GET (charset, i)) | |
50 | { | |
51 | if (first) | |
52 | first = 0; | |
53 | else | |
54 | scm_puts (" ", port); | |
55 | scm_write (SCM_MAKE_CHAR (i), port); | |
56 | } | |
57 | scm_puts ("}>", port); | |
58 | return 1; | |
59 | } | |
60 | ||
61 | ||
62 | /* Smob free hook for character sets. */ | |
1be6b49c | 63 | static size_t |
ca003b26 MG |
64 | charset_free (SCM charset) |
65 | { | |
66 | return scm_smob_free (charset); | |
67 | } | |
68 | ||
69 | ||
70 | /* Create a new, empty character set. */ | |
71 | static SCM | |
72 | make_char_set (const char * func_name) | |
73 | { | |
74 | long * p; | |
645f5e0e | 75 | |
6c70aef1 | 76 | p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set"); |
4c4185ee | 77 | memset (p, 0, BYTES_PER_CHARSET); |
ca003b26 MG |
78 | SCM_RETURN_NEWSMOB (scm_tc16_charset, p); |
79 | } | |
80 | ||
81 | ||
645f5e0e | 82 | SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0, |
ca003b26 MG |
83 | (SCM obj), |
84 | "Return @code{#t} if @var{obj} is a character set, @code{#f}\n" | |
85 | "otherwise.") | |
86 | #define FUNC_NAME s_scm_char_set_p | |
87 | { | |
88 | return SCM_BOOL (SCM_SMOB_PREDICATE (scm_tc16_charset, obj)); | |
89 | } | |
90 | #undef FUNC_NAME | |
91 | ||
92 | ||
dd84cd4d GH |
93 | SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1, |
94 | (SCM char_sets), | |
ca003b26 MG |
95 | "Return @code{#t} if all given character sets are equal.") |
96 | #define FUNC_NAME s_scm_char_set_eq | |
97 | { | |
dd84cd4d GH |
98 | int argnum = 1; |
99 | long *cs1_data = NULL; | |
ca003b26 | 100 | |
dd84cd4d | 101 | SCM_VALIDATE_REST_ARGUMENT (char_sets); |
ca003b26 | 102 | |
dd84cd4d | 103 | while (!SCM_NULLP (char_sets)) |
ca003b26 | 104 | { |
be390de2 GH |
105 | SCM csi = SCM_CAR (char_sets); |
106 | long *csi_data; | |
dd84cd4d | 107 | |
b87f5a83 GH |
108 | SCM_VALIDATE_SMOB (argnum, csi, charset); |
109 | argnum++; | |
be390de2 | 110 | csi_data = (long *) SCM_SMOB_DATA (csi); |
dd84cd4d | 111 | if (cs1_data == NULL) |
be390de2 | 112 | cs1_data = csi_data; |
4c4185ee | 113 | else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0) |
dd84cd4d GH |
114 | return SCM_BOOL_F; |
115 | char_sets = SCM_CDR (char_sets); | |
ca003b26 MG |
116 | } |
117 | return SCM_BOOL_T; | |
118 | } | |
119 | #undef FUNC_NAME | |
120 | ||
121 | ||
be390de2 GH |
122 | SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1, |
123 | (SCM char_sets), | |
ca003b26 MG |
124 | "Return @code{#t} if every character set @var{cs}i is a subset\n" |
125 | "of character set @var{cs}i+1.") | |
126 | #define FUNC_NAME s_scm_char_set_leq | |
127 | { | |
be390de2 GH |
128 | int argnum = 1; |
129 | long *prev_data = NULL; | |
ca003b26 | 130 | |
be390de2 | 131 | SCM_VALIDATE_REST_ARGUMENT (char_sets); |
ca003b26 | 132 | |
be390de2 | 133 | while (!SCM_NULLP (char_sets)) |
ca003b26 | 134 | { |
be390de2 GH |
135 | SCM csi = SCM_CAR (char_sets); |
136 | long *csi_data; | |
137 | ||
b87f5a83 GH |
138 | SCM_VALIDATE_SMOB (argnum, csi, charset); |
139 | argnum++; | |
be390de2 GH |
140 | csi_data = (long *) SCM_SMOB_DATA (csi); |
141 | if (prev_data) | |
ca003b26 | 142 | { |
be390de2 | 143 | int k; |
645f5e0e | 144 | |
4c4185ee | 145 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
be390de2 GH |
146 | { |
147 | if ((prev_data[k] & csi_data[k]) != prev_data[k]) | |
148 | return SCM_BOOL_F; | |
149 | } | |
ca003b26 | 150 | } |
be390de2 GH |
151 | prev_data = csi_data; |
152 | char_sets = SCM_CDR (char_sets); | |
ca003b26 MG |
153 | } |
154 | return SCM_BOOL_T; | |
155 | } | |
156 | #undef FUNC_NAME | |
157 | ||
158 | ||
159 | SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0, | |
160 | (SCM cs, SCM bound), | |
161 | "Compute a hash value for the character set @var{cs}. If\n" | |
396f36cd | 162 | "@var{bound} is given and non-zero, it restricts the\n" |
ca003b26 MG |
163 | "returned value to the range 0 @dots{} @var{bound - 1}.") |
164 | #define FUNC_NAME s_scm_char_set_hash | |
165 | { | |
396f36cd | 166 | const int default_bnd = 871; |
ca003b26 MG |
167 | int bnd; |
168 | long * p; | |
cc0ce1e7 | 169 | unsigned long val = 0; |
ca003b26 MG |
170 | int k; |
171 | ||
172 | SCM_VALIDATE_SMOB (1, cs, charset); | |
645f5e0e | 173 | |
396f36cd GH |
174 | if (SCM_UNBNDP (bound)) |
175 | bnd = default_bnd; | |
ca003b26 | 176 | else |
396f36cd GH |
177 | { |
178 | SCM_VALIDATE_INUM_MIN_COPY (2, bound, 0, bnd); | |
179 | if (bnd == 0) | |
180 | bnd = default_bnd; | |
181 | } | |
ca003b26 MG |
182 | |
183 | p = (long *) SCM_SMOB_DATA (cs); | |
4c4185ee | 184 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 | 185 | { |
cebf3d62 MG |
186 | if (p[k] != 0) |
187 | val = p[k] + (val << 1); | |
ca003b26 MG |
188 | } |
189 | return SCM_MAKINUM (val % bnd); | |
190 | } | |
191 | #undef FUNC_NAME | |
192 | ||
193 | ||
194 | SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0, | |
195 | (SCM cs), | |
196 | "Return a cursor into the character set @var{cs}.") | |
197 | #define FUNC_NAME s_scm_char_set_cursor | |
198 | { | |
199 | int idx; | |
200 | ||
201 | SCM_VALIDATE_SMOB (1, cs, charset); | |
202 | for (idx = 0; idx < SCM_CHARSET_SIZE; idx++) | |
203 | { | |
204 | if (SCM_CHARSET_GET (cs, idx)) | |
205 | break; | |
206 | } | |
207 | return SCM_MAKINUM (idx); | |
208 | } | |
209 | #undef FUNC_NAME | |
210 | ||
211 | ||
212 | SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0, | |
213 | (SCM cs, SCM cursor), | |
214 | "Return the character at the current cursor position\n" | |
215 | "@var{cursor} in the character set @var{cs}. It is an error to\n" | |
216 | "pass a cursor for which @code{end-of-char-set?} returns true.") | |
217 | #define FUNC_NAME s_scm_char_set_ref | |
218 | { | |
219 | int ccursor; | |
220 | ||
221 | SCM_VALIDATE_SMOB (1, cs, charset); | |
8b19021c | 222 | SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); |
ca003b26 MG |
223 | |
224 | if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) | |
2c4df451 | 225 | SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); |
ca003b26 MG |
226 | return SCM_MAKE_CHAR (ccursor); |
227 | } | |
228 | #undef FUNC_NAME | |
229 | ||
230 | ||
231 | SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0, | |
232 | (SCM cs, SCM cursor), | |
233 | "Advance the character set cursor @var{cursor} to the next\n" | |
234 | "character in the character set @var{cs}. It is an error if the\n" | |
235 | "cursor given satisfies @code{end-of-char-set?}.") | |
236 | #define FUNC_NAME s_scm_char_set_cursor_next | |
237 | { | |
238 | int ccursor; | |
239 | ||
240 | SCM_VALIDATE_SMOB (1, cs, charset); | |
8b19021c | 241 | SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor); |
ca003b26 MG |
242 | |
243 | if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor)) | |
2c4df451 | 244 | SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor)); |
ca003b26 MG |
245 | for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++) |
246 | { | |
247 | if (SCM_CHARSET_GET (cs, ccursor)) | |
248 | break; | |
249 | } | |
250 | return SCM_MAKINUM (ccursor); | |
251 | } | |
252 | #undef FUNC_NAME | |
253 | ||
254 | ||
255 | SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0, | |
256 | (SCM cursor), | |
257 | "Return @code{#t} if @var{cursor} has reached the end of a\n" | |
258 | "character set, @code{#f} otherwise.") | |
259 | #define FUNC_NAME s_scm_end_of_char_set_p | |
260 | { | |
261 | int ccursor; | |
262 | ||
8b19021c | 263 | SCM_VALIDATE_INUM_MIN_COPY (1, cursor, 0, ccursor); |
ca003b26 MG |
264 | return SCM_BOOL (ccursor >= SCM_CHARSET_SIZE); |
265 | } | |
266 | #undef FUNC_NAME | |
267 | ||
268 | ||
269 | SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0, | |
270 | (SCM kons, SCM knil, SCM cs), | |
271 | "Fold the procedure @var{kons} over the character set @var{cs},\n" | |
272 | "initializing it with @var{knil}.") | |
273 | #define FUNC_NAME s_scm_char_set_fold | |
274 | { | |
275 | int k; | |
276 | ||
277 | SCM_VALIDATE_PROC (1, kons); | |
278 | SCM_VALIDATE_SMOB (3, cs, charset); | |
279 | ||
280 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
281 | if (SCM_CHARSET_GET (cs, k)) | |
282 | { | |
2c4df451 | 283 | knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil); |
ca003b26 MG |
284 | } |
285 | return knil; | |
286 | } | |
287 | #undef FUNC_NAME | |
288 | ||
2c4df451 | 289 | |
ca003b26 MG |
290 | SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0, |
291 | (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), | |
292 | "This is a fundamental constructor for character sets.\n" | |
2d953700 | 293 | "@itemize @bullet\n" |
9401323e | 294 | "@item @var{g} is used to generate a series of ``seed'' values\n" |
ca003b26 MG |
295 | "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" |
296 | "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" | |
297 | "@item @var{p} tells us when to stop -- when it returns true\n" | |
9401323e | 298 | "when applied to one of the seed values.\n" |
ca003b26 MG |
299 | "@item @var{f} maps each seed value to a character. These\n" |
300 | "characters are added to the base character set @var{base_cs} to\n" | |
301 | "form the result; @var{base_cs} defaults to the empty set.\n" | |
302 | "@end itemize") | |
303 | #define FUNC_NAME s_scm_char_set_unfold | |
304 | { | |
305 | SCM result, tmp; | |
306 | ||
307 | SCM_VALIDATE_PROC (1, p); | |
308 | SCM_VALIDATE_PROC (2, f); | |
309 | SCM_VALIDATE_PROC (3, g); | |
310 | if (!SCM_UNBNDP (base_cs)) | |
311 | { | |
312 | SCM_VALIDATE_SMOB (5, base_cs, charset); | |
313 | result = scm_char_set_copy (base_cs); | |
314 | } | |
315 | else | |
316 | result = make_char_set (FUNC_NAME); | |
317 | ||
2c4df451 | 318 | tmp = scm_call_1 (p, seed); |
ca003b26 MG |
319 | while (SCM_FALSEP (tmp)) |
320 | { | |
2c4df451 | 321 | SCM ch = scm_call_1 (f, seed); |
ca003b26 | 322 | if (!SCM_CHARP (ch)) |
2c4df451 | 323 | SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); |
ca003b26 MG |
324 | SCM_CHARSET_SET (result, SCM_CHAR (ch)); |
325 | ||
2c4df451 MG |
326 | seed = scm_call_1 (g, seed); |
327 | tmp = scm_call_1 (p, seed); | |
ca003b26 MG |
328 | } |
329 | return result; | |
330 | } | |
331 | #undef FUNC_NAME | |
332 | ||
333 | ||
334 | SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0, | |
335 | (SCM p, SCM f, SCM g, SCM seed, SCM base_cs), | |
336 | "This is a fundamental constructor for character sets.\n" | |
2d953700 | 337 | "@itemize @bullet\n" |
ca003b26 | 338 | "@item @var{g} is used to generate a series of ``seed'' values\n" |
9401323e | 339 | "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n" |
ca003b26 MG |
340 | "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n" |
341 | "@item @var{p} tells us when to stop -- when it returns true\n" | |
9401323e | 342 | "when applied to one of the seed values.\n" |
ca003b26 MG |
343 | "@item @var{f} maps each seed value to a character. These\n" |
344 | "characters are added to the base character set @var{base_cs} to\n" | |
345 | "form the result; @var{base_cs} defaults to the empty set.\n" | |
346 | "@end itemize") | |
347 | #define FUNC_NAME s_scm_char_set_unfold_x | |
348 | { | |
349 | SCM tmp; | |
350 | ||
351 | SCM_VALIDATE_PROC (1, p); | |
352 | SCM_VALIDATE_PROC (2, f); | |
353 | SCM_VALIDATE_PROC (3, g); | |
354 | SCM_VALIDATE_SMOB (5, base_cs, charset); | |
355 | ||
2c4df451 | 356 | tmp = scm_call_1 (p, seed); |
ca003b26 MG |
357 | while (SCM_FALSEP (tmp)) |
358 | { | |
2c4df451 | 359 | SCM ch = scm_call_1 (f, seed); |
ca003b26 | 360 | if (!SCM_CHARP (ch)) |
2c4df451 | 361 | SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f)); |
ca003b26 MG |
362 | SCM_CHARSET_SET (base_cs, SCM_CHAR (ch)); |
363 | ||
2c4df451 MG |
364 | seed = scm_call_1 (g, seed); |
365 | tmp = scm_call_1 (p, seed); | |
ca003b26 MG |
366 | } |
367 | return base_cs; | |
368 | } | |
369 | #undef FUNC_NAME | |
370 | ||
371 | ||
372 | SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0, | |
373 | (SCM proc, SCM cs), | |
374 | "Apply @var{proc} to every character in the character set\n" | |
375 | "@var{cs}. The return value is not specified.") | |
376 | #define FUNC_NAME s_scm_char_set_for_each | |
377 | { | |
378 | int k; | |
379 | ||
380 | SCM_VALIDATE_PROC (1, proc); | |
381 | SCM_VALIDATE_SMOB (2, cs, charset); | |
382 | ||
383 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
384 | if (SCM_CHARSET_GET (cs, k)) | |
2c4df451 | 385 | scm_call_1 (proc, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
386 | return SCM_UNSPECIFIED; |
387 | } | |
388 | #undef FUNC_NAME | |
389 | ||
390 | ||
391 | SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0, | |
392 | (SCM proc, SCM cs), | |
393 | "Map the procedure @var{proc} over every character in @var{cs}.\n" | |
394 | "@var{proc} must be a character -> character procedure.") | |
395 | #define FUNC_NAME s_scm_char_set_map | |
396 | { | |
397 | SCM result; | |
398 | int k; | |
399 | ||
400 | SCM_VALIDATE_PROC (1, proc); | |
401 | SCM_VALIDATE_SMOB (2, cs, charset); | |
402 | ||
403 | result = make_char_set (FUNC_NAME); | |
404 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
405 | if (SCM_CHARSET_GET (cs, k)) | |
406 | { | |
2c4df451 | 407 | SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k)); |
ca003b26 | 408 | if (!SCM_CHARP (ch)) |
2c4df451 | 409 | SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc)); |
139777e5 | 410 | SCM_CHARSET_SET (result, SCM_CHAR (ch)); |
ca003b26 MG |
411 | } |
412 | return result; | |
413 | } | |
414 | #undef FUNC_NAME | |
415 | ||
416 | ||
417 | SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0, | |
418 | (SCM cs), | |
419 | "Return a newly allocated character set containing all\n" | |
420 | "characters in @var{cs}.") | |
421 | #define FUNC_NAME s_scm_char_set_copy | |
422 | { | |
423 | SCM ret; | |
424 | long * p1, * p2; | |
425 | int k; | |
426 | ||
427 | SCM_VALIDATE_SMOB (1, cs, charset); | |
428 | ret = make_char_set (FUNC_NAME); | |
429 | p1 = (long *) SCM_SMOB_DATA (cs); | |
430 | p2 = (long *) SCM_SMOB_DATA (ret); | |
4c4185ee | 431 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
432 | p2[k] = p1[k]; |
433 | return ret; | |
434 | } | |
435 | #undef FUNC_NAME | |
436 | ||
437 | ||
438 | SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1, | |
439 | (SCM rest), | |
440 | "Return a character set containing all given characters.") | |
441 | #define FUNC_NAME s_scm_char_set | |
442 | { | |
b87f5a83 | 443 | SCM cs; |
ca003b26 | 444 | long * p; |
b87f5a83 | 445 | int argnum = 1; |
ca003b26 MG |
446 | |
447 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
ca003b26 MG |
448 | cs = make_char_set (FUNC_NAME); |
449 | p = (long *) SCM_SMOB_DATA (cs); | |
b87f5a83 | 450 | while (!SCM_NULLP (rest)) |
ca003b26 | 451 | { |
ca003b26 MG |
452 | int c; |
453 | ||
b87f5a83 GH |
454 | SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c); |
455 | argnum++; | |
456 | rest = SCM_CDR (rest); | |
cc0ce1e7 | 457 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
458 | } |
459 | return cs; | |
460 | } | |
461 | #undef FUNC_NAME | |
462 | ||
463 | ||
464 | SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0, | |
465 | (SCM list, SCM base_cs), | |
466 | "Convert the character list @var{list} to a character set. If\n" | |
467 | "the character set @var{base_cs} is given, the character in this\n" | |
468 | "set are also included in the result.") | |
469 | #define FUNC_NAME s_scm_list_to_char_set | |
470 | { | |
471 | SCM cs; | |
472 | long * p; | |
473 | ||
474 | SCM_VALIDATE_LIST (1, list); | |
475 | if (SCM_UNBNDP (base_cs)) | |
476 | cs = make_char_set (FUNC_NAME); | |
477 | else | |
478 | { | |
479 | SCM_VALIDATE_SMOB (2, base_cs, charset); | |
480 | cs = scm_char_set_copy (base_cs); | |
481 | } | |
482 | p = (long *) SCM_SMOB_DATA (cs); | |
483 | while (!SCM_NULLP (list)) | |
484 | { | |
485 | SCM chr = SCM_CAR (list); | |
486 | int c; | |
487 | ||
8b19021c | 488 | SCM_VALIDATE_CHAR_COPY (0, chr, c); |
ca003b26 MG |
489 | list = SCM_CDR (list); |
490 | ||
cc0ce1e7 | 491 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
492 | } |
493 | return cs; | |
494 | } | |
495 | #undef FUNC_NAME | |
496 | ||
497 | ||
498 | SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0, | |
499 | (SCM list, SCM base_cs), | |
500 | "Convert the character list @var{list} to a character set. The\n" | |
501 | "characters are added to @var{base_cs} and @var{base_cs} is\n" | |
502 | "returned.") | |
cc0ce1e7 | 503 | #define FUNC_NAME s_scm_list_to_char_set_x |
ca003b26 MG |
504 | { |
505 | long * p; | |
506 | ||
507 | SCM_VALIDATE_LIST (1, list); | |
508 | SCM_VALIDATE_SMOB (2, base_cs, charset); | |
509 | p = (long *) SCM_SMOB_DATA (base_cs); | |
510 | while (!SCM_NULLP (list)) | |
511 | { | |
512 | SCM chr = SCM_CAR (list); | |
513 | int c; | |
514 | ||
8b19021c | 515 | SCM_VALIDATE_CHAR_COPY (0, chr, c); |
ca003b26 MG |
516 | list = SCM_CDR (list); |
517 | ||
cc0ce1e7 | 518 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
519 | } |
520 | return base_cs; | |
521 | } | |
522 | #undef FUNC_NAME | |
523 | ||
524 | ||
525 | SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0, | |
526 | (SCM str, SCM base_cs), | |
527 | "Convert the string @var{str} to a character set. If the\n" | |
528 | "character set @var{base_cs} is given, the characters in this\n" | |
529 | "set are also included in the result.") | |
530 | #define FUNC_NAME s_scm_string_to_char_set | |
531 | { | |
532 | SCM cs; | |
533 | long * p; | |
534 | char * s; | |
cc0ce1e7 | 535 | size_t k = 0; |
ca003b26 MG |
536 | |
537 | SCM_VALIDATE_STRING (1, str); | |
538 | if (SCM_UNBNDP (base_cs)) | |
539 | cs = make_char_set (FUNC_NAME); | |
540 | else | |
541 | { | |
542 | SCM_VALIDATE_SMOB (2, base_cs, charset); | |
543 | cs = scm_char_set_copy (base_cs); | |
544 | } | |
545 | p = (long *) SCM_SMOB_DATA (cs); | |
546 | s = SCM_STRING_CHARS (str); | |
547 | while (k < SCM_STRING_LENGTH (str)) | |
548 | { | |
549 | int c = s[k++]; | |
cc0ce1e7 | 550 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
551 | } |
552 | return cs; | |
553 | } | |
554 | #undef FUNC_NAME | |
555 | ||
556 | ||
557 | SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0, | |
558 | (SCM str, SCM base_cs), | |
559 | "Convert the string @var{str} to a character set. The\n" | |
560 | "characters from the string are added to @var{base_cs}, and\n" | |
561 | "@var{base_cs} is returned.") | |
562 | #define FUNC_NAME s_scm_string_to_char_set_x | |
563 | { | |
564 | long * p; | |
565 | char * s; | |
cc0ce1e7 | 566 | size_t k = 0; |
ca003b26 MG |
567 | |
568 | SCM_VALIDATE_STRING (1, str); | |
569 | SCM_VALIDATE_SMOB (2, base_cs, charset); | |
570 | p = (long *) SCM_SMOB_DATA (base_cs); | |
571 | s = SCM_STRING_CHARS (str); | |
572 | while (k < SCM_STRING_LENGTH (str)) | |
573 | { | |
574 | int c = s[k++]; | |
cc0ce1e7 | 575 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
576 | } |
577 | return base_cs; | |
578 | } | |
579 | #undef FUNC_NAME | |
580 | ||
581 | ||
582 | SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0, | |
583 | (SCM pred, SCM cs, SCM base_cs), | |
584 | "Return a character set containing every character from @var{cs}\n" | |
585 | "so that it satisfies @var{pred}. If provided, the characters\n" | |
586 | "from @var{base_cs} are added to the result.") | |
587 | #define FUNC_NAME s_scm_char_set_filter | |
588 | { | |
589 | SCM ret; | |
590 | int k; | |
591 | long * p; | |
592 | ||
593 | SCM_VALIDATE_PROC (1, pred); | |
594 | SCM_VALIDATE_SMOB (2, cs, charset); | |
595 | if (!SCM_UNBNDP (base_cs)) | |
596 | { | |
597 | SCM_VALIDATE_SMOB (3, base_cs, charset); | |
598 | ret = scm_char_set_copy (base_cs); | |
599 | } | |
600 | else | |
601 | ret = make_char_set (FUNC_NAME); | |
602 | p = (long *) SCM_SMOB_DATA (ret); | |
603 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
604 | { | |
605 | if (SCM_CHARSET_GET (cs, k)) | |
606 | { | |
2c4df451 | 607 | SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
608 | |
609 | if (!SCM_FALSEP (res)) | |
cc0ce1e7 | 610 | p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); |
ca003b26 MG |
611 | } |
612 | } | |
613 | return ret; | |
614 | } | |
615 | #undef FUNC_NAME | |
616 | ||
617 | ||
618 | SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0, | |
619 | (SCM pred, SCM cs, SCM base_cs), | |
620 | "Return a character set containing every character from @var{cs}\n" | |
621 | "so that it satisfies @var{pred}. The characters are added to\n" | |
622 | "@var{base_cs} and @var{base_cs} is returned.") | |
623 | #define FUNC_NAME s_scm_char_set_filter_x | |
624 | { | |
625 | int k; | |
626 | long * p; | |
627 | ||
628 | SCM_VALIDATE_PROC (1, pred); | |
629 | SCM_VALIDATE_SMOB (2, cs, charset); | |
630 | SCM_VALIDATE_SMOB (3, base_cs, charset); | |
631 | p = (long *) SCM_SMOB_DATA (base_cs); | |
632 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
633 | { | |
634 | if (SCM_CHARSET_GET (cs, k)) | |
635 | { | |
2c4df451 | 636 | SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
637 | |
638 | if (!SCM_FALSEP (res)) | |
cc0ce1e7 | 639 | p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG); |
ca003b26 MG |
640 | } |
641 | } | |
642 | return base_cs; | |
643 | } | |
644 | #undef FUNC_NAME | |
645 | ||
646 | ||
647 | SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0, | |
648 | (SCM lower, SCM upper, SCM error, SCM base_cs), | |
649 | "Return a character set containing all characters whose\n" | |
650 | "character codes lie in the half-open range\n" | |
651 | "[@var{lower},@var{upper}).\n" | |
652 | "\n" | |
653 | "If @var{error} is a true value, an error is signalled if the\n" | |
654 | "specified range contains characters which are not contained in\n" | |
655 | "the implemented character range. If @var{error} is @code{#f},\n" | |
656 | "these characters are silently left out of the resultung\n" | |
657 | "character set.\n" | |
658 | "\n" | |
659 | "The characters in @var{base_cs} are added to the result, if\n" | |
660 | "given.") | |
661 | #define FUNC_NAME s_scm_ucs_range_to_char_set | |
662 | { | |
663 | SCM cs; | |
664 | int clower, cupper; | |
665 | long * p; | |
666 | ||
667 | SCM_VALIDATE_INUM_COPY (1, lower, clower); | |
668 | SCM_VALIDATE_INUM_COPY (2, upper, cupper); | |
669 | SCM_ASSERT_RANGE (1, lower, clower >= 0); | |
670 | SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); | |
671 | if (!SCM_UNBNDP (error)) | |
672 | { | |
673 | if (!SCM_FALSEP (error)) | |
674 | { | |
675 | SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); | |
676 | SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); | |
677 | } | |
678 | } | |
679 | if (clower > SCM_CHARSET_SIZE) | |
680 | clower = SCM_CHARSET_SIZE; | |
681 | if (cupper > SCM_CHARSET_SIZE) | |
682 | cupper = SCM_CHARSET_SIZE; | |
683 | if (SCM_UNBNDP (base_cs)) | |
684 | cs = make_char_set (FUNC_NAME); | |
685 | else | |
686 | { | |
687 | SCM_VALIDATE_SMOB (2, base_cs, charset); | |
688 | cs = scm_char_set_copy (base_cs); | |
689 | } | |
690 | p = (long *) SCM_SMOB_DATA (cs); | |
691 | while (clower < cupper) | |
692 | { | |
cc0ce1e7 | 693 | p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); |
ca003b26 MG |
694 | clower++; |
695 | } | |
696 | return cs; | |
697 | } | |
698 | #undef FUNC_NAME | |
699 | ||
700 | ||
701 | SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0, | |
702 | (SCM lower, SCM upper, SCM error, SCM base_cs), | |
703 | "Return a character set containing all characters whose\n" | |
704 | "character codes lie in the half-open range\n" | |
705 | "[@var{lower},@var{upper}).\n" | |
706 | "\n" | |
707 | "If @var{error} is a true value, an error is signalled if the\n" | |
708 | "specified range contains characters which are not contained in\n" | |
709 | "the implemented character range. If @var{error} is @code{#f},\n" | |
710 | "these characters are silently left out of the resultung\n" | |
711 | "character set.\n" | |
712 | "\n" | |
713 | "The characters are added to @var{base_cs} and @var{base_cs} is\n" | |
714 | "returned.") | |
715 | #define FUNC_NAME s_scm_ucs_range_to_char_set_x | |
716 | { | |
717 | int clower, cupper; | |
718 | long * p; | |
719 | ||
720 | SCM_VALIDATE_INUM_COPY (1, lower, clower); | |
721 | SCM_VALIDATE_INUM_COPY (2, upper, cupper); | |
722 | SCM_ASSERT_RANGE (1, lower, clower >= 0); | |
723 | SCM_ASSERT_RANGE (2, upper, cupper >= 0 && cupper >= clower); | |
724 | if (!SCM_FALSEP (error)) | |
725 | { | |
726 | SCM_ASSERT_RANGE (1, lower, clower <= SCM_CHARSET_SIZE); | |
727 | SCM_ASSERT_RANGE (2, upper, cupper <= SCM_CHARSET_SIZE); | |
728 | } | |
729 | if (clower > SCM_CHARSET_SIZE) | |
730 | clower = SCM_CHARSET_SIZE; | |
731 | if (cupper > SCM_CHARSET_SIZE) | |
732 | cupper = SCM_CHARSET_SIZE; | |
733 | p = (long *) SCM_SMOB_DATA (base_cs); | |
734 | while (clower < cupper) | |
735 | { | |
cc0ce1e7 | 736 | p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG); |
ca003b26 MG |
737 | clower++; |
738 | } | |
739 | return base_cs; | |
740 | } | |
741 | #undef FUNC_NAME | |
742 | ||
743 | ||
744 | SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0, | |
745 | (SCM cs), | |
746 | "Return the number of elements in character set @var{cs}.") | |
747 | #define FUNC_NAME s_scm_char_set_size | |
748 | { | |
749 | int k, count = 0; | |
750 | ||
751 | SCM_VALIDATE_SMOB (1, cs, charset); | |
752 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
753 | if (SCM_CHARSET_GET (cs, k)) | |
754 | count++; | |
755 | return SCM_MAKINUM (count); | |
756 | } | |
757 | #undef FUNC_NAME | |
758 | ||
759 | ||
760 | SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0, | |
761 | (SCM pred, SCM cs), | |
762 | "Return the number of the elements int the character set\n" | |
763 | "@var{cs} which satisfy the predicate @var{pred}.") | |
764 | #define FUNC_NAME s_scm_char_set_count | |
765 | { | |
766 | int k, count = 0; | |
767 | ||
768 | SCM_VALIDATE_PROC (1, pred); | |
769 | SCM_VALIDATE_SMOB (2, cs, charset); | |
770 | ||
771 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
772 | if (SCM_CHARSET_GET (cs, k)) | |
773 | { | |
2c4df451 | 774 | SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
775 | if (!SCM_FALSEP (res)) |
776 | count++; | |
777 | } | |
778 | return SCM_MAKINUM (count); | |
779 | } | |
780 | #undef FUNC_NAME | |
781 | ||
782 | ||
783 | SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0, | |
784 | (SCM cs), | |
785 | "Return a list containing the elements of the character set\n" | |
786 | "@var{cs}.") | |
787 | #define FUNC_NAME s_scm_char_set_to_list | |
788 | { | |
789 | int k; | |
790 | SCM result = SCM_EOL; | |
791 | ||
792 | SCM_VALIDATE_SMOB (1, cs, charset); | |
793 | for (k = SCM_CHARSET_SIZE; k > 0; k--) | |
794 | if (SCM_CHARSET_GET (cs, k - 1)) | |
795 | result = scm_cons (SCM_MAKE_CHAR (k - 1), result); | |
796 | return result; | |
797 | } | |
798 | #undef FUNC_NAME | |
799 | ||
800 | ||
801 | SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0, | |
802 | (SCM cs), | |
803 | "Return a string containing the elements of the character set\n" | |
804 | "@var{cs}. The order in which the characters are placed in the\n" | |
805 | "string is not defined.") | |
806 | #define FUNC_NAME s_scm_char_set_to_string | |
807 | { | |
808 | int k; | |
809 | int count = 0; | |
810 | int idx = 0; | |
811 | SCM result; | |
812 | char * p; | |
813 | ||
814 | SCM_VALIDATE_SMOB (1, cs, charset); | |
815 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
816 | if (SCM_CHARSET_GET (cs, k)) | |
817 | count++; | |
818 | result = scm_allocate_string (count); | |
819 | p = SCM_STRING_CHARS (result); | |
820 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
821 | if (SCM_CHARSET_GET (cs, k)) | |
822 | p[idx++] = k; | |
823 | return result; | |
824 | } | |
825 | #undef FUNC_NAME | |
826 | ||
827 | ||
828 | SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0, | |
829 | (SCM cs, SCM ch), | |
830 | "Return @code{#t} iff the character @var{ch} is contained in the\n" | |
831 | "character set @var{cs}.") | |
832 | #define FUNC_NAME s_scm_char_set_contains_p | |
833 | { | |
834 | SCM_VALIDATE_SMOB (1, cs, charset); | |
835 | SCM_VALIDATE_CHAR (2, ch); | |
836 | return SCM_BOOL (SCM_CHARSET_GET (cs, SCM_CHAR (ch))); | |
837 | } | |
838 | #undef FUNC_NAME | |
839 | ||
840 | ||
841 | SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0, | |
842 | (SCM pred, SCM cs), | |
843 | "Return a true value if every character in the character set\n" | |
844 | "@var{cs} satisfies the predicate @var{pred}.") | |
845 | #define FUNC_NAME s_scm_char_set_every | |
846 | { | |
847 | int k; | |
848 | SCM res = SCM_BOOL_T; | |
849 | ||
850 | SCM_VALIDATE_PROC (1, pred); | |
851 | SCM_VALIDATE_SMOB (2, cs, charset); | |
852 | ||
853 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
854 | if (SCM_CHARSET_GET (cs, k)) | |
855 | { | |
2c4df451 | 856 | res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
857 | if (SCM_FALSEP (res)) |
858 | return res; | |
859 | } | |
860 | return res; | |
861 | } | |
862 | #undef FUNC_NAME | |
863 | ||
864 | ||
865 | SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0, | |
866 | (SCM pred, SCM cs), | |
867 | "Return a true value if any character in the character set\n" | |
868 | "@var{cs} satisfies the predicate @var{pred}.") | |
869 | #define FUNC_NAME s_scm_char_set_any | |
870 | { | |
871 | int k; | |
872 | ||
873 | SCM_VALIDATE_PROC (1, pred); | |
874 | SCM_VALIDATE_SMOB (2, cs, charset); | |
875 | ||
876 | for (k = 0; k < SCM_CHARSET_SIZE; k++) | |
877 | if (SCM_CHARSET_GET (cs, k)) | |
878 | { | |
2c4df451 | 879 | SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k)); |
ca003b26 MG |
880 | if (!SCM_FALSEP (res)) |
881 | return res; | |
882 | } | |
883 | return SCM_BOOL_F; | |
884 | } | |
885 | #undef FUNC_NAME | |
886 | ||
887 | ||
888 | SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1, | |
889 | (SCM cs, SCM rest), | |
890 | "Add all character arguments to the first argument, which must\n" | |
891 | "be a character set.") | |
892 | #define FUNC_NAME s_scm_char_set_adjoin | |
893 | { | |
894 | long * p; | |
895 | ||
896 | SCM_VALIDATE_SMOB (1, cs, charset); | |
897 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
898 | cs = scm_char_set_copy (cs); | |
899 | ||
900 | p = (long *) SCM_SMOB_DATA (cs); | |
901 | while (!SCM_NULLP (rest)) | |
902 | { | |
903 | SCM chr = SCM_CAR (rest); | |
904 | int c; | |
905 | ||
906 | SCM_VALIDATE_CHAR_COPY (1, chr, c); | |
907 | rest = SCM_CDR (rest); | |
908 | ||
cc0ce1e7 | 909 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
910 | } |
911 | return cs; | |
912 | } | |
913 | #undef FUNC_NAME | |
914 | ||
2c4df451 | 915 | |
ca003b26 MG |
916 | SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1, |
917 | (SCM cs, SCM rest), | |
918 | "Delete all character arguments from the first argument, which\n" | |
919 | "must be a character set.") | |
920 | #define FUNC_NAME s_scm_char_set_delete | |
921 | { | |
922 | long * p; | |
923 | ||
924 | SCM_VALIDATE_SMOB (1, cs, charset); | |
925 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
926 | cs = scm_char_set_copy (cs); | |
927 | ||
928 | p = (long *) SCM_SMOB_DATA (cs); | |
929 | while (!SCM_NULLP (rest)) | |
930 | { | |
931 | SCM chr = SCM_CAR (rest); | |
932 | int c; | |
933 | ||
934 | SCM_VALIDATE_CHAR_COPY (1, chr, c); | |
935 | rest = SCM_CDR (rest); | |
936 | ||
cc0ce1e7 | 937 | p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); |
ca003b26 MG |
938 | } |
939 | return cs; | |
940 | } | |
941 | #undef FUNC_NAME | |
942 | ||
2c4df451 | 943 | |
ca003b26 MG |
944 | SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1, |
945 | (SCM cs, SCM rest), | |
946 | "Add all character arguments to the first argument, which must\n" | |
947 | "be a character set.") | |
948 | #define FUNC_NAME s_scm_char_set_adjoin_x | |
949 | { | |
950 | long * p; | |
951 | ||
952 | SCM_VALIDATE_SMOB (1, cs, charset); | |
953 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
954 | ||
955 | p = (long *) SCM_SMOB_DATA (cs); | |
956 | while (!SCM_NULLP (rest)) | |
957 | { | |
958 | SCM chr = SCM_CAR (rest); | |
959 | int c; | |
960 | ||
961 | SCM_VALIDATE_CHAR_COPY (1, chr, c); | |
962 | rest = SCM_CDR (rest); | |
963 | ||
cc0ce1e7 | 964 | p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG); |
ca003b26 MG |
965 | } |
966 | return cs; | |
967 | } | |
968 | #undef FUNC_NAME | |
969 | ||
2c4df451 | 970 | |
ca003b26 MG |
971 | SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1, |
972 | (SCM cs, SCM rest), | |
973 | "Delete all character arguments from the first argument, which\n" | |
974 | "must be a character set.") | |
975 | #define FUNC_NAME s_scm_char_set_delete_x | |
976 | { | |
977 | long * p; | |
978 | ||
979 | SCM_VALIDATE_SMOB (1, cs, charset); | |
980 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
981 | ||
982 | p = (long *) SCM_SMOB_DATA (cs); | |
983 | while (!SCM_NULLP (rest)) | |
984 | { | |
985 | SCM chr = SCM_CAR (rest); | |
986 | int c; | |
987 | ||
988 | SCM_VALIDATE_CHAR_COPY (1, chr, c); | |
989 | rest = SCM_CDR (rest); | |
990 | ||
cc0ce1e7 | 991 | p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG)); |
ca003b26 MG |
992 | } |
993 | return cs; | |
994 | } | |
995 | #undef FUNC_NAME | |
996 | ||
997 | ||
998 | SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0, | |
999 | (SCM cs), | |
1000 | "Return the complement of the character set @var{cs}.") | |
1001 | #define FUNC_NAME s_scm_char_set_complement | |
1002 | { | |
1003 | int k; | |
1004 | SCM res; | |
1005 | long * p, * q; | |
1006 | ||
1007 | SCM_VALIDATE_SMOB (1, cs, charset); | |
1008 | ||
1009 | res = make_char_set (FUNC_NAME); | |
1010 | p = (long *) SCM_SMOB_DATA (res); | |
1011 | q = (long *) SCM_SMOB_DATA (cs); | |
4c4185ee | 1012 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1013 | p[k] = ~q[k]; |
1014 | return res; | |
1015 | } | |
1016 | #undef FUNC_NAME | |
1017 | ||
1018 | ||
1019 | SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1, | |
1020 | (SCM rest), | |
1021 | "Return the union of all argument character sets.") | |
1022 | #define FUNC_NAME s_scm_char_set_union | |
1023 | { | |
1024 | int c = 1; | |
1025 | SCM res; | |
1026 | long * p; | |
1027 | ||
1028 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1029 | ||
1030 | res = make_char_set (FUNC_NAME); | |
1031 | p = (long *) SCM_SMOB_DATA (res); | |
1032 | while (!SCM_NULLP (rest)) | |
1033 | { | |
1034 | int k; | |
1035 | SCM cs = SCM_CAR (rest); | |
1036 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1037 | c++; | |
1038 | rest = SCM_CDR (rest); | |
1039 | ||
4c4185ee | 1040 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1041 | p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; |
1042 | } | |
1043 | return res; | |
1044 | } | |
1045 | #undef FUNC_NAME | |
1046 | ||
1047 | ||
d1bc6602 GH |
1048 | SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1, |
1049 | (SCM rest), | |
ca003b26 MG |
1050 | "Return the intersection of all argument character sets.") |
1051 | #define FUNC_NAME s_scm_char_set_intersection | |
1052 | { | |
ca003b26 | 1053 | SCM res; |
ca003b26 | 1054 | |
ca003b26 MG |
1055 | SCM_VALIDATE_REST_ARGUMENT (rest); |
1056 | ||
d1bc6602 GH |
1057 | if (SCM_NULLP (rest)) |
1058 | res = make_char_set (FUNC_NAME); | |
1059 | else | |
ca003b26 | 1060 | { |
d1bc6602 GH |
1061 | long *p; |
1062 | int argnum = 2; | |
1063 | ||
1064 | res = scm_char_set_copy (SCM_CAR (rest)); | |
1065 | p = (long *) SCM_SMOB_DATA (res); | |
ca003b26 MG |
1066 | rest = SCM_CDR (rest); |
1067 | ||
d1bc6602 GH |
1068 | while (SCM_CONSP (rest)) |
1069 | { | |
1070 | int k; | |
1071 | SCM cs = SCM_CAR (rest); | |
1072 | long *cs_data; | |
1073 | ||
1074 | SCM_VALIDATE_SMOB (argnum, cs, charset); | |
1075 | argnum++; | |
1076 | cs_data = (long *) SCM_SMOB_DATA (cs); | |
1077 | rest = SCM_CDR (rest); | |
1078 | for (k = 0; k < LONGS_PER_CHARSET; k++) | |
1079 | p[k] &= cs_data[k]; | |
1080 | } | |
ca003b26 | 1081 | } |
d1bc6602 | 1082 | |
ca003b26 MG |
1083 | return res; |
1084 | } | |
1085 | #undef FUNC_NAME | |
1086 | ||
1087 | ||
1088 | SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1, | |
1089 | (SCM cs1, SCM rest), | |
1090 | "Return the difference of all argument character sets.") | |
1091 | #define FUNC_NAME s_scm_char_set_difference | |
1092 | { | |
1093 | int c = 2; | |
1094 | SCM res; | |
1095 | long * p; | |
1096 | ||
1097 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1098 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1099 | ||
1100 | res = scm_char_set_copy (cs1); | |
1101 | p = (long *) SCM_SMOB_DATA (res); | |
1102 | while (!SCM_NULLP (rest)) | |
1103 | { | |
1104 | int k; | |
1105 | SCM cs = SCM_CAR (rest); | |
1106 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1107 | c++; | |
1108 | rest = SCM_CDR (rest); | |
1109 | ||
4c4185ee | 1110 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1111 | p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; |
1112 | } | |
1113 | return res; | |
1114 | } | |
1115 | #undef FUNC_NAME | |
1116 | ||
1117 | ||
d1bc6602 GH |
1118 | SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1, |
1119 | (SCM rest), | |
2671725a | 1120 | "Return the exclusive-or of all argument character sets.") |
ca003b26 MG |
1121 | #define FUNC_NAME s_scm_char_set_xor |
1122 | { | |
ca003b26 | 1123 | SCM res; |
ca003b26 | 1124 | |
ca003b26 MG |
1125 | SCM_VALIDATE_REST_ARGUMENT (rest); |
1126 | ||
d1bc6602 GH |
1127 | if (SCM_NULLP (rest)) |
1128 | res = make_char_set (FUNC_NAME); | |
1129 | else | |
ca003b26 | 1130 | { |
d1bc6602 | 1131 | int argnum = 2; |
d95744e9 | 1132 | long * p; |
d1bc6602 GH |
1133 | |
1134 | res = scm_char_set_copy (SCM_CAR (rest)); | |
1135 | p = (long *) SCM_SMOB_DATA (res); | |
ca003b26 MG |
1136 | rest = SCM_CDR (rest); |
1137 | ||
d1bc6602 GH |
1138 | while (SCM_CONSP (rest)) |
1139 | { | |
d1bc6602 | 1140 | SCM cs = SCM_CAR (rest); |
42b54c05 | 1141 | long *cs_data; |
d95744e9 | 1142 | int k; |
d1bc6602 GH |
1143 | |
1144 | SCM_VALIDATE_SMOB (argnum, cs, charset); | |
1145 | argnum++; | |
1146 | cs_data = (long *) SCM_SMOB_DATA (cs); | |
1147 | rest = SCM_CDR (rest); | |
1148 | ||
1149 | for (k = 0; k < LONGS_PER_CHARSET; k++) | |
d95744e9 | 1150 | p[k] ^= cs_data[k]; |
d1bc6602 | 1151 | } |
ca003b26 MG |
1152 | } |
1153 | return res; | |
1154 | } | |
1155 | #undef FUNC_NAME | |
1156 | ||
1157 | ||
1158 | SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1, | |
1159 | (SCM cs1, SCM rest), | |
1160 | "Return the difference and the intersection of all argument\n" | |
1161 | "character sets.") | |
1162 | #define FUNC_NAME s_scm_char_set_diff_plus_intersection | |
1163 | { | |
1164 | int c = 2; | |
1165 | SCM res1, res2; | |
1166 | long * p, * q; | |
1167 | ||
1168 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1169 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1170 | ||
1171 | res1 = scm_char_set_copy (cs1); | |
9be74503 | 1172 | res2 = make_char_set (FUNC_NAME); |
ca003b26 MG |
1173 | p = (long *) SCM_SMOB_DATA (res1); |
1174 | q = (long *) SCM_SMOB_DATA (res2); | |
1175 | while (!SCM_NULLP (rest)) | |
1176 | { | |
1177 | int k; | |
1178 | SCM cs = SCM_CAR (rest); | |
9be74503 GH |
1179 | long *r; |
1180 | ||
ca003b26 MG |
1181 | SCM_VALIDATE_SMOB (c, cs, charset); |
1182 | c++; | |
9be74503 | 1183 | r = (long *) SCM_SMOB_DATA (cs); |
ca003b26 | 1184 | |
4c4185ee | 1185 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 | 1186 | { |
9be74503 GH |
1187 | q[k] |= p[k] & r[k]; |
1188 | p[k] &= ~r[k]; | |
ca003b26 | 1189 | } |
9be74503 | 1190 | rest = SCM_CDR (rest); |
ca003b26 | 1191 | } |
2c4df451 | 1192 | return scm_values (scm_list_2 (res1, res2)); |
ca003b26 MG |
1193 | } |
1194 | #undef FUNC_NAME | |
1195 | ||
1196 | ||
1197 | SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0, | |
1198 | (SCM cs), | |
1199 | "Return the complement of the character set @var{cs}.") | |
1200 | #define FUNC_NAME s_scm_char_set_complement_x | |
1201 | { | |
1202 | int k; | |
1203 | long * p; | |
1204 | ||
1205 | SCM_VALIDATE_SMOB (1, cs, charset); | |
1206 | p = (long *) SCM_SMOB_DATA (cs); | |
4c4185ee | 1207 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1208 | p[k] = ~p[k]; |
1209 | return cs; | |
1210 | } | |
1211 | #undef FUNC_NAME | |
1212 | ||
1213 | ||
1214 | SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1, | |
1215 | (SCM cs1, SCM rest), | |
1216 | "Return the union of all argument character sets.") | |
1217 | #define FUNC_NAME s_scm_char_set_union_x | |
1218 | { | |
1219 | int c = 2; | |
1220 | long * p; | |
1221 | ||
1222 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1223 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1224 | ||
1225 | p = (long *) SCM_SMOB_DATA (cs1); | |
1226 | while (!SCM_NULLP (rest)) | |
1227 | { | |
1228 | int k; | |
1229 | SCM cs = SCM_CAR (rest); | |
1230 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1231 | c++; | |
1232 | rest = SCM_CDR (rest); | |
1233 | ||
4c4185ee | 1234 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1235 | p[k] |= ((long *) SCM_SMOB_DATA (cs))[k]; |
1236 | } | |
1237 | return cs1; | |
1238 | } | |
1239 | #undef FUNC_NAME | |
1240 | ||
1241 | ||
1242 | SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1, | |
1243 | (SCM cs1, SCM rest), | |
1244 | "Return the intersection of all argument character sets.") | |
1245 | #define FUNC_NAME s_scm_char_set_intersection_x | |
1246 | { | |
1247 | int c = 2; | |
1248 | long * p; | |
1249 | ||
1250 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1251 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1252 | ||
1253 | p = (long *) SCM_SMOB_DATA (cs1); | |
1254 | while (!SCM_NULLP (rest)) | |
1255 | { | |
1256 | int k; | |
1257 | SCM cs = SCM_CAR (rest); | |
1258 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1259 | c++; | |
1260 | rest = SCM_CDR (rest); | |
1261 | ||
4c4185ee | 1262 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1263 | p[k] &= ((long *) SCM_SMOB_DATA (cs))[k]; |
1264 | } | |
1265 | return cs1; | |
1266 | } | |
1267 | #undef FUNC_NAME | |
1268 | ||
1269 | ||
1270 | SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1, | |
1271 | (SCM cs1, SCM rest), | |
1272 | "Return the difference of all argument character sets.") | |
1273 | #define FUNC_NAME s_scm_char_set_difference_x | |
1274 | { | |
1275 | int c = 2; | |
1276 | long * p; | |
1277 | ||
1278 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1279 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1280 | ||
1281 | p = (long *) SCM_SMOB_DATA (cs1); | |
1282 | while (!SCM_NULLP (rest)) | |
1283 | { | |
1284 | int k; | |
1285 | SCM cs = SCM_CAR (rest); | |
1286 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1287 | c++; | |
1288 | rest = SCM_CDR (rest); | |
1289 | ||
4c4185ee | 1290 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1291 | p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k]; |
1292 | } | |
1293 | return cs1; | |
1294 | } | |
1295 | #undef FUNC_NAME | |
1296 | ||
1297 | ||
1298 | SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1, | |
1299 | (SCM cs1, SCM rest), | |
2671725a | 1300 | "Return the exclusive-or of all argument character sets.") |
ca003b26 MG |
1301 | #define FUNC_NAME s_scm_char_set_xor_x |
1302 | { | |
9be74503 GH |
1303 | /* a side-effecting variant should presumably give consistent results: |
1304 | (define a (char-set #\a)) | |
1305 | (char-set-xor a a a) -> char set #\a | |
1306 | (char-set-xor! a a a) -> char set #\a | |
1307 | */ | |
1308 | return scm_char_set_xor (scm_cons (cs1, rest)); | |
1309 | ||
1310 | #if 0 | |
1311 | /* this would give (char-set-xor! a a a) -> empty char set. */ | |
ca003b26 MG |
1312 | int c = 2; |
1313 | long * p; | |
1314 | ||
1315 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
1316 | SCM_VALIDATE_REST_ARGUMENT (rest); | |
1317 | ||
1318 | p = (long *) SCM_SMOB_DATA (cs1); | |
1319 | while (!SCM_NULLP (rest)) | |
1320 | { | |
1321 | int k; | |
1322 | SCM cs = SCM_CAR (rest); | |
1323 | SCM_VALIDATE_SMOB (c, cs, charset); | |
1324 | c++; | |
1325 | rest = SCM_CDR (rest); | |
1326 | ||
4c4185ee | 1327 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 MG |
1328 | p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k]; |
1329 | } | |
1330 | return cs1; | |
9be74503 | 1331 | #endif |
ca003b26 MG |
1332 | } |
1333 | #undef FUNC_NAME | |
1334 | ||
1335 | ||
9be74503 GH |
1336 | SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1, |
1337 | (SCM cs1, SCM cs2, SCM rest), | |
2c4df451 MG |
1338 | "Return the difference and the intersection of all argument\n" |
1339 | "character sets.") | |
ca003b26 MG |
1340 | #define FUNC_NAME s_scm_char_set_diff_plus_intersection_x |
1341 | { | |
9be74503 | 1342 | int c = 3; |
ca003b26 | 1343 | long * p, * q; |
9be74503 | 1344 | int k; |
ca003b26 MG |
1345 | |
1346 | SCM_VALIDATE_SMOB (1, cs1, charset); | |
9be74503 | 1347 | SCM_VALIDATE_SMOB (2, cs2, charset); |
ca003b26 MG |
1348 | SCM_VALIDATE_REST_ARGUMENT (rest); |
1349 | ||
ca003b26 | 1350 | p = (long *) SCM_SMOB_DATA (cs1); |
9be74503 GH |
1351 | q = (long *) SCM_SMOB_DATA (cs2); |
1352 | if (p == q) | |
1353 | { | |
1354 | /* (char-set-diff+intersection! a a ...): can't share storage, | |
1355 | but we know the answer without checking for further | |
1356 | arguments. */ | |
1357 | return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1)); | |
1358 | } | |
1359 | for (k = 0; k < LONGS_PER_CHARSET; k++) | |
1360 | { | |
1361 | long t = p[k]; | |
1362 | ||
1363 | p[k] &= ~q[k]; | |
1364 | q[k] = t & q[k]; | |
1365 | } | |
ca003b26 MG |
1366 | while (!SCM_NULLP (rest)) |
1367 | { | |
ca003b26 | 1368 | SCM cs = SCM_CAR (rest); |
9be74503 GH |
1369 | long *r; |
1370 | ||
ca003b26 MG |
1371 | SCM_VALIDATE_SMOB (c, cs, charset); |
1372 | c++; | |
9be74503 | 1373 | r = (long *) SCM_SMOB_DATA (cs); |
ca003b26 | 1374 | |
4c4185ee | 1375 | for (k = 0; k < LONGS_PER_CHARSET; k++) |
ca003b26 | 1376 | { |
9be74503 GH |
1377 | q[k] |= p[k] & r[k]; |
1378 | p[k] &= ~r[k]; | |
ca003b26 | 1379 | } |
9be74503 | 1380 | rest = SCM_CDR (rest); |
ca003b26 | 1381 | } |
9be74503 | 1382 | return scm_values (scm_list_2 (cs1, cs2)); |
ca003b26 MG |
1383 | } |
1384 | #undef FUNC_NAME | |
1385 | ||
1386 | ||
2c4df451 | 1387 | /* Create the charset smob type. */ |
ca003b26 | 1388 | void |
94451729 | 1389 | scm_c_init_srfi_14 (void) |
ca003b26 | 1390 | { |
2c4df451 MG |
1391 | /* Charset smob creation is protected by this variable because this |
1392 | function can be both called from the SRFI-13 and SRFI-14 | |
1393 | initialization functions. This is because the SRFI-13 procedures | |
1394 | access the charset smob type code. */ | |
5d980558 | 1395 | static int initialized = 0; |
94451729 MV |
1396 | |
1397 | if (!initialized) | |
1398 | { | |
2671725a | 1399 | scm_tc16_charset = scm_make_smob_type ("character-set", |
4c4185ee | 1400 | BYTES_PER_CHARSET); |
94451729 MV |
1401 | scm_set_smob_free (scm_tc16_charset, charset_free); |
1402 | scm_set_smob_print (scm_tc16_charset, charset_print); | |
1403 | initialized = 1; | |
1404 | } | |
1405 | } | |
ca003b26 | 1406 | |
2c4df451 MG |
1407 | |
1408 | /* Initialize the SRFI-14 module. This function will be called by the | |
1409 | loading Scheme module. */ | |
94451729 MV |
1410 | void |
1411 | scm_init_srfi_14 (void) | |
1412 | { | |
4c4185ee MG |
1413 | #if 0 |
1414 | fprintf(stderr, "bytes-per-charset: %d\n", BYTES_PER_CHARSET); | |
1415 | fprintf(stderr, "bits-per-long: %d\n", SCM_BITS_PER_LONG); | |
1416 | fprintf(stderr, "longs-per-charset: %d\n", LONGS_PER_CHARSET); | |
1417 | fflush (stderr); | |
1418 | #endif /* 0 */ | |
1419 | ||
2c4df451 | 1420 | /* Do the smob type initialization. */ |
94451729 | 1421 | scm_c_init_srfi_14 (); |
2c4df451 MG |
1422 | |
1423 | /* Install the charset primitives. */ | |
485efc12 | 1424 | #include "srfi/srfi-14.x" |
ca003b26 | 1425 | } |
2c4df451 MG |
1426 | |
1427 | /* End of srfi-14.c. */ |