HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Optimize charset union operator
[bpt/guile.git] / libguile / srfi-14.c
CommitLineData
63181a97
MV		 1/* srfi-14.c --- SRFI-14 procedures for Guile
2 *
6caac03c 3 * Copyright (C) 2001, 2004, 2006, 2007 Free Software Foundation, Inc.
63181a97
MV		 4 *
5 * This library is free software; you can redistribute it and/or
53befeb7
NJ		 6 * modify it under the terms of the GNU Lesser General Public License
7 * as published by the Free Software Foundation; either version 3 of
8 * the License, or (at your option) any later version.
63181a97 9 *
53befeb7
NJ		 10 * This library is distributed in the hope that it will be useful, but
11 * WITHOUT ANY WARRANTY; without even the implied warranty of
63181a97
MV		 12 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 * Lesser General Public License for more details.
14 *
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
53befeb7
NJ		 17 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
18 * 02110-1301 USA
63181a97
MV		 19 */
20
a17d2654
LC		 21#ifdef HAVE_CONFIG_H
22# include <config.h>
23#endif
24
25
63181a97 26#include <string.h>
f49dbcad 27#include <unictype.h>
63181a97
MV		 28
29#include "libguile.h"
30#include "libguile/srfi-14.h"
f49dbcad 31#include "libguile/strings.h"
24d23822 32#include "libguile/chars.h"
63181a97 33
f49dbcad
MG		 34/* Include the pre-computed standard charset data. */
35#include "libguile/srfi-14.i.c"
63181a97 36
f49dbcad 37#define SCM_CHARSET_DATA(charset) ((scm_t_char_set *) SCM_SMOB_DATA (charset))
63181a97 38
f49dbcad
MG		 39#define SCM_CHARSET_SET(cs, idx) \
40 scm_i_charset_set (SCM_CHARSET_DATA (cs), idx)
63181a97 41
f49dbcad
MG		 42#define SCM_CHARSET_UNSET(cs, idx) \
43 scm_i_charset_unset (SCM_CHARSET_DATA (cs), idx)
63181a97
MV		 44
45/* Smob type code for character sets. */
46int scm_tc16_charset = 0;
f49dbcad
MG		 47int scm_tc16_charset_cursor = 0;
48
49/* True if N exists in charset CS. */
50int
51scm_i_charset_get (scm_t_char_set *cs, scm_t_wchar n)
52{
53 size_t i;
54
55 i = 0;
56 while (i < cs->len)
57 {
58 if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
59 return 1;
60 i++;
61 }
62
63 return 0;
64}
65
66/* Put N into charset CS. */
67void
68scm_i_charset_set (scm_t_char_set *cs, scm_t_wchar n)
69{
70 size_t i;
71 size_t len;
72
73 len = cs->len;
74
75 i = 0;
76 while (i < len)
77 {
78 /* Already in this range */
79 if (cs->ranges[i].lo <= n && n <= cs->ranges[i].hi)
80 {
81 return;
82 }
83
84 if (n == cs->ranges[i].lo - 1)
85 {
86 /* This char is one below the current range. */
87 if (i > 0 && cs->ranges[i - 1].hi + 1 == n)
88 {
89 /* It is also one above the previous range, so combine them. */
90 cs->ranges[i - 1].hi = cs->ranges[i].hi;
91 if (i < len - 1)
92 memmove (cs->ranges + i, cs->ranges + (i + 1),
93 sizeof (scm_t_char_range) * (len - i - 1));
94 cs->ranges = scm_gc_realloc (cs->ranges,
95 sizeof (scm_t_char_range) * len,
96 sizeof (scm_t_char_range) * (len -
97 1),
98 "character-set");
99 cs->len = len - 1;
100 return;
101 }
102 else
103 {
104 /* Expand the range down by one. */
105 cs->ranges[i].lo = n;
106 return;
107 }
108 }
109 else if (n == cs->ranges[i].hi + 1)
110 {
111 /* This char is one above the current range. */
112 if (i < len - 1 && cs->ranges[i + 1].lo - 1 == n)
113 {
114 /* It is also one below the next range, so combine them. */
115 cs->ranges[i].hi = cs->ranges[i + 1].hi;
116 if (i < len - 2)
117 memmove (cs->ranges + (i + 1), cs->ranges + (i + 2),
118 sizeof (scm_t_char_range) * (len - i - 2));
119 cs->ranges = scm_gc_realloc (cs->ranges,
120 sizeof (scm_t_char_range) * len,
121 sizeof (scm_t_char_range) * (len -
122 1),
123 "character-set");
124 cs->len = len - 1;
125 return;
126 }
127 else
128 {
129 /* Expand the range up by one. */
130 cs->ranges[i].hi = n;
131 return;
132 }
133 }
134 else if (n < cs->ranges[i].lo - 1)
135 {
136 /* This is a new range below the current one. */
137 cs->ranges = scm_gc_realloc (cs->ranges,
138 sizeof (scm_t_char_range) * len,
139 sizeof (scm_t_char_range) * (len + 1),
140 "character-set");
141 memmove (cs->ranges + (i + 1), cs->ranges + i,
142 sizeof (scm_t_char_range) * (len - i));
143 cs->ranges[i].lo = n;
144 cs->ranges[i].hi = n;
145 cs->len = len + 1;
146 return;
147 }
148
149 i++;
150 }
151
152 /* This is a new range above all previous ranges. */
153 if (len == 0)
154 {
155 cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
156 }
157 else
158 {
159 cs->ranges = scm_gc_realloc (cs->ranges,
160 sizeof (scm_t_char_range) * len,
161 sizeof (scm_t_char_range) * (len + 1),
162 "character-set");
163 }
164 cs->ranges[len].lo = n;
165 cs->ranges[len].hi = n;
166 cs->len = len + 1;
167
168 return;
169}
170
91772d8f
MG		 171/* Put LO to HI inclusive into charset CS. */
172static void
173scm_i_charset_set_range (scm_t_char_set *cs, scm_t_wchar lo, scm_t_wchar hi)
174{
175 size_t i;
176
177 i = 0;
178 while (i < cs->len)
179 {
180 /* Already in this range */
181 if (cs->ranges[i].lo <= lo && cs->ranges[i].hi >= hi)
182 return;
183
184 /* cur: +---+
185 new: +---+
186 */
187 if (cs->ranges[i].lo - 1 > hi)
188 {
189 /* Add a new range below the current one. */
190 cs->ranges = scm_gc_realloc (cs->ranges,
191 sizeof (scm_t_char_range) * cs->len,
192 sizeof (scm_t_char_range) * (cs->len + 1),
193 "character-set");
194 memmove (cs->ranges + (i + 1), cs->ranges + i,
195 sizeof (scm_t_char_range) * (cs->len - i));
196 cs->ranges[i].lo = lo;
197 cs->ranges[i].hi = hi;
198 cs->len += 1;
199 return;
200 }
201
202 /* cur: +---+ or +---+ or +---+
203 new: +---+ +---+ +---+
204 */
205 if (cs->ranges[i].lo > lo
206 && (cs->ranges[i].lo - 1 <= hi && cs->ranges[i].hi >= hi))
207 {
208 cs->ranges[i].lo = lo;
209 return;
210 }
211
212 /* cur: +---+ or +---+ or +---+
213 new: +---+ +---+ +---+
214 */
215 else if (cs->ranges[i].hi + 1 >= lo && cs->ranges[i].hi < hi)
216 {
217 if (cs->ranges[i].lo > lo)
218 cs->ranges[i].lo = lo;
219 if (cs->ranges[i].hi < hi)
220 cs->ranges[i].hi = hi;
221 while (i < cs->len - 1)
222 {
223 /* cur: --+ +---+
224 new: -----+
225 */
226 if (cs->ranges[i + 1].lo - 1 > hi)
227 break;
228
229 /* cur: --+ +---+ or --+ +---+ or --+ +--+
230 new: -----+ ------+ ---------+
231 */
232 /* Combine this range with the previous one. */
233 if (cs->ranges[i + 1].hi > hi)
234 cs->ranges[i].hi = cs->ranges[i + 1].hi;
235 if (i + 1 < cs->len)
236 memmove (cs->ranges + i + 1, cs->ranges + i + 2,
237 sizeof (scm_t_char_range) * (cs->len - i - 2));
238 cs->ranges = scm_gc_realloc (cs->ranges,
239 sizeof (scm_t_char_range) * cs->len,
240 sizeof (scm_t_char_range) * (cs->len - 1),
241 "character-set");
242 cs->len -= 1;
243 }
244 return;
245 }
246 i ++;
247 }
248
249 /* This is a new range above all previous ranges. */
250 if (cs->len == 0)
251 {
252 cs->ranges = scm_gc_malloc (sizeof (scm_t_char_range), "character-set");
253 }
254 else
255 {
256 cs->ranges = scm_gc_realloc (cs->ranges,
257 sizeof (scm_t_char_range) * cs->len,
258 sizeof (scm_t_char_range) * (cs->len + 1),
259 "character-set");
260 }
261 cs->len += 1;
262 cs->ranges[cs->len - 1].lo = lo;
263 cs->ranges[cs->len - 1].hi = hi;
264
265 return;
266}
267
f49dbcad
MG		 268/* If N is in charset CS, remove it. */
269void
270scm_i_charset_unset (scm_t_char_set *cs, scm_t_wchar n)
271{
272 size_t i;
273 size_t len;
274
275 len = cs->len;
276
277 i = 0;
278 while (i < len)
279 {
280 if (n < cs->ranges[i].lo)
281 /* Not in this set. */
282 return;
283
284 if (n == cs->ranges[i].lo && n == cs->ranges[i].hi)
285 {
286 /* Remove this one-character range. */
287 if (len == 1)
288 {
289 scm_gc_free (cs->ranges,
290 sizeof (scm_t_char_range) * cs->len,
291 "character-set");
292 cs->ranges = NULL;
293 cs->len = 0;
294 return;
295 }
296 else if (i < len - 1)
297 {
298 memmove (cs->ranges + i, cs->ranges + (i + 1),
299 sizeof (scm_t_char_range) * (len - i - 1));
300 cs->ranges = scm_gc_realloc (cs->ranges,
301 sizeof (scm_t_char_range) * len,
302 sizeof (scm_t_char_range) * (len -
303 1),
304 "character-set");
305 cs->len = len - 1;
306 return;
307 }
308 else if (i == len - 1)
309 {
310 cs->ranges = scm_gc_realloc (cs->ranges,
311 sizeof (scm_t_char_range) * len,
312 sizeof (scm_t_char_range) * (len -
313 1),
314 "character-set");
315 cs->len = len - 1;
316 return;
317 }
318 }
319 else if (n == cs->ranges[i].lo)
320 {
321 /* Shrink this range from the left. */
322 cs->ranges[i].lo = n + 1;
323 return;
324 }
325 else if (n == cs->ranges[i].hi)
326 {
327 /* Shrink this range from the right. */
328 cs->ranges[i].hi = n - 1;
329 return;
330 }
331 else if (n > cs->ranges[i].lo && n < cs->ranges[i].hi)
332 {
333 /* Split this range into two pieces. */
334 cs->ranges = scm_gc_realloc (cs->ranges,
335 sizeof (scm_t_char_range) * len,
336 sizeof (scm_t_char_range) * (len + 1),
337 "character-set");
338 if (i < len - 1)
339 memmove (cs->ranges + (i + 2), cs->ranges + (i + 1),
340 sizeof (scm_t_char_range) * (len - i - 1));
341 cs->ranges[i + 1].hi = cs->ranges[i].hi;
342 cs->ranges[i + 1].lo = n + 1;
343 cs->ranges[i].hi = n - 1;
344 cs->len = len + 1;
345 return;
346 }
347
348 i++;
349 }
350
351 /* This value is above all ranges, so do nothing here. */
352 return;
353}
354
355static int
356charsets_equal (scm_t_char_set *a, scm_t_char_set *b)
357{
358 if (a->len != b->len)
359 return 0;
360
361 if (memcmp (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len) != 0)
362 return 0;
363
364 return 1;
365}
366
367/* Return true if every character in A is also in B. */
368static int
369charsets_leq (scm_t_char_set *a, scm_t_char_set *b)
370{
371 size_t i = 0, j = 0;
372 scm_t_wchar alo, ahi;
373
374 if (a->len == 0)
375 return 1;
376 if (b->len == 0)
377 return 0;
378 while (i < a->len)
379 {
380 alo = a->ranges[i].lo;
381 ahi = a->ranges[i].hi;
382 while (b->ranges[j].hi < alo)
383 {
384 if (j < b->len - 1)
385 j++;
386 else
387 return 0;
388 }
389 if (alo < b->ranges[j].lo || ahi > b->ranges[j].hi)
390 return 0;
391 i++;
392 }
393
394 return 1;
395}
396
397/* Merge B into A. */
398static void
399charsets_union (scm_t_char_set *a, scm_t_char_set *b)
400{
401 size_t i = 0;
aff31b0f 402 scm_t_wchar blo, bhi;
f49dbcad
MG		 403
404 if (b->len == 0)
405 return;
406
407 if (a->len == 0)
408 {
409 a->len = b->len;
410 a->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * b->len,
411 "character-set");
412 memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * b->len);
413 return;
414 }
415
f49dbcad
MG		 416 while (i < b->len)
417 {
418 blo = b->ranges[i].lo;
419 bhi = b->ranges[i].hi;
aff31b0f 420 scm_i_charset_set_range (a, blo, bhi);
f49dbcad
MG		 421
422 i++;
423 }
424
425 return;
426}
427
428/* Remove elements not both in A and B from A. */
429static void
430charsets_intersection (scm_t_char_set *a, scm_t_char_set *b)
431{
432 size_t i = 0;
433 scm_t_wchar blo, bhi, n;
434 scm_t_char_set *c;
435
436 if (a->len == 0)
437 return;
438
439 if (b->len == 0)
440 {
441 scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
442 "character-set");
443 a->len = 0;
444 return;
445 }
446
447 c = (scm_t_char_set *) scm_malloc (sizeof (scm_t_char_set));
448 c->len = 0;
449 c->ranges = NULL;
450
451 while (i < b->len)
452 {
453 blo = b->ranges[i].lo;
454 bhi = b->ranges[i].hi;
455 for (n = blo; n <= bhi; n++)
456 if (scm_i_charset_get (a, n))
457 scm_i_charset_set (c, n);
458 i++;
459 }
460 scm_gc_free (a->ranges, sizeof (scm_t_char_range) * a->len,
461 "character-set");
462
463 a->len = c->len;
464 if (c->len != 0)
465 a->ranges = c->ranges;
466 else
467 a->ranges = NULL;
468 free (c);
469 return;
470}
471
f4cdfe61
MG		 472#define SCM_ADD_RANGE(low, high) \
473 do { \
474 p->ranges[idx].lo = (low); \
475 p->ranges[idx++].hi = (high); \
476 } while (0)
477#define SCM_ADD_RANGE_SKIP_SURROGATES(low, high) \
478 do { \
479 p->ranges[idx].lo = (low); \
480 p->ranges[idx++].hi = SCM_CODEPOINT_SURROGATE_START - 1; \
481 p->ranges[idx].lo = SCM_CODEPOINT_SURROGATE_END + 1; \
482 p->ranges[idx++].hi = (high); \
483 } while (0)
484
485
486
f49dbcad
MG		 487/* Make P the compelement of Q. */
488static void
489charsets_complement (scm_t_char_set *p, scm_t_char_set *q)
490{
491 int k, idx;
492
f4cdfe61 493 idx = 0;
f49dbcad
MG		 494 if (q->len == 0)
495 {
496 /* Fill with all valid codepoints. */
497 p->len = 2;
498 p->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * 2,
499 "character-set");
f4cdfe61 500 SCM_ADD_RANGE_SKIP_SURROGATES (0, SCM_CODEPOINT_MAX);
f49dbcad
MG		 501 return;
502 }
503
504 if (p->len > 0)
505 scm_gc_free (p->ranges, sizeof (scm_t_char_set) * p->len,
506 "character-set");
507
f4cdfe61 508 /* Count the number of ranges needed for the output. */
f49dbcad
MG		 509 p->len = 0;
510 if (q->ranges[0].lo > 0)
511 p->len++;
512 if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
513 p->len++;
f4cdfe61 514 p->len += q->len;
f49dbcad
MG		 515 p->ranges =
516 (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) * p->len,
517 "character-set");
f49dbcad
MG		 518 if (q->ranges[0].lo > 0)
519 {
f4cdfe61
MG		 520 if (q->ranges[0].lo > SCM_CODEPOINT_SURROGATE_END)
521 SCM_ADD_RANGE_SKIP_SURROGATES (0, q->ranges[0].lo - 1);
522 else
523 SCM_ADD_RANGE (0, q->ranges[0].lo - 1);
f49dbcad
MG		 524 }
525 for (k = 1; k < q->len; k++)
526 {
f4cdfe61
MG		 527 if (q->ranges[k - 1].hi < SCM_CODEPOINT_SURROGATE_START
528 && q->ranges[k].lo - 1 > SCM_CODEPOINT_SURROGATE_END)
529 SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
530 else
531 SCM_ADD_RANGE (q->ranges[k - 1].hi + 1, q->ranges[k].lo - 1);
f49dbcad
MG		 532 }
533 if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_MAX)
534 {
f4cdfe61
MG		 535 if (q->ranges[q->len - 1].hi < SCM_CODEPOINT_SURROGATE_START)
536 SCM_ADD_RANGE_SKIP_SURROGATES (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
537 else
538 SCM_ADD_RANGE (q->ranges[q->len - 1].hi + 1, SCM_CODEPOINT_MAX);
f49dbcad
MG		 539 }
540 return;
541}
f4cdfe61
MG		 542#undef SCM_ADD_RANGE
543#undef SCM_ADD_RANGE_SKIP_SURROGATES
f49dbcad
MG		 544
545/* Replace A with elements only found in one of A or B. */
546static void
547charsets_xor (scm_t_char_set *a, scm_t_char_set *b)
548{
549 size_t i = 0;
550 scm_t_wchar blo, bhi, n;
551
552 if (b->len == 0)
553 {
554 return;
555 }
63181a97 556
f49dbcad
MG		 557 if (a->len == 0)
558 {
559 a->ranges =
560 (scm_t_char_range *) scm_gc_malloc (sizeof (scm_t_char_range) *
561 b->len, "character-set");
562 a->len = b->len;
563 memcpy (a->ranges, b->ranges, sizeof (scm_t_char_range) * a->len);
564 return;
565 }
566
567 while (i < b->len)
568 {
569 blo = b->ranges[i].lo;
570 bhi = b->ranges[i].hi;
571 for (n = blo; n <= bhi; n++)
572 {
573 if (scm_i_charset_get (a, n))
574 scm_i_charset_unset (a, n);
575 else
576 scm_i_charset_set (a, n);
577 }
578
579 i++;
580 }
581 return;
582}
63181a97
MV		 583
584/* Smob print hook for character sets. */
585static int
586charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
587{
f49dbcad 588 size_t i;
63181a97 589 int first = 1;
f49dbcad
MG		 590 scm_t_char_set *p;
591 const size_t max_ranges_to_print = 50;
592
593 p = SCM_CHARSET_DATA (charset);
63181a97
MV		 594
595 scm_puts ("#<charset {", port);
f49dbcad
MG		 596 for (i = 0; i < p->len; i++)
597 {
598 if (first)
599 first = 0;
600 else
601 scm_puts (" ", port);
602 scm_write (SCM_MAKE_CHAR (p->ranges[i].lo), port);
603 if (p->ranges[i].lo != p->ranges[i].hi)
604 {
605 scm_puts ("..", port);
606 scm_write (SCM_MAKE_CHAR (p->ranges[i].hi), port);
607 }
608 if (i >= max_ranges_to_print)
609 {
610 /* Too many to print here. Quit early. */
611 scm_puts (" ...", port);
612 break;
613 }
614 }
63181a97
MV		 615 scm_puts ("}>", port);
616 return 1;
617}
618
619
620/* Smob free hook for character sets. */
621static size_t
622charset_free (SCM charset)
623{
f49dbcad
MG		 624 scm_t_char_set *cs;
625 size_t len = 0;
626
627 cs = SCM_CHARSET_DATA (charset);
628 if (cs != NULL)
629 len = cs->len;
630 if (len > 0)
631 scm_gc_free (cs->ranges, sizeof (scm_t_char_range) * len,
632 "character-set");
633
634 cs->ranges = NULL;
635 cs->len = 0;
636
637 scm_gc_free (cs, sizeof (scm_t_char_set), "character-set");
638
639 scm_remember_upto_here_1 (charset);
640
641 return 0;
642}
643
644
645/* Smob print hook for character sets cursors. */
646static int
647charset_cursor_print (SCM cursor, SCM port,
648 scm_print_state *pstate SCM_UNUSED)
649{
650 scm_t_char_set_cursor *cur;
651
652 cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
653
654 scm_puts ("#<charset-cursor ", port);
655 if (cur->range == (size_t) (-1))
656 scm_puts ("(empty)", port);
657 else
658 {
659 scm_write (scm_from_size_t (cur->range), port);
660 scm_puts (":", port);
661 scm_write (scm_from_int32 (cur->n), port);
662 }
663 scm_puts (">", port);
664 return 1;
665}
666
667/* Smob free hook for character sets. */
668static size_t
669charset_cursor_free (SCM charset)
670{
671 scm_t_char_set_cursor *cur;
672
673 cur = (scm_t_char_set_cursor *) SCM_SMOB_DATA (charset);
674 scm_gc_free (cur, sizeof (scm_t_char_set_cursor), "charset-cursor");
675 scm_remember_upto_here_1 (charset);
676
677 return 0;
63181a97
MV		 678}
679
680
681/* Create a new, empty character set. */
682static SCM
f49dbcad 683make_char_set (const char *func_name)
63181a97 684{
f49dbcad 685 scm_t_char_set *p;
63181a97 686
f49dbcad
MG		 687 p = scm_gc_malloc (sizeof (scm_t_char_set), "character-set");
688 memset (p, 0, sizeof (scm_t_char_set));
63181a97
MV		 689 SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
690}
691
692
693SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
694 (SCM obj),
695 "Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
696 "otherwise.")
697#define FUNC_NAME s_scm_char_set_p
698{
699 return scm_from_bool (SCM_SMOB_PREDICATE (scm_tc16_charset, obj));
700}
701#undef FUNC_NAME
702
703
704SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
705 (SCM char_sets),
706 "Return @code{#t} if all given character sets are equal.")
707#define FUNC_NAME s_scm_char_set_eq
708{
709 int argnum = 1;
f49dbcad 710 scm_t_char_set *cs1_data = NULL;
63181a97
MV		 711
712 SCM_VALIDATE_REST_ARGUMENT (char_sets);
713
d2e53ed6 714 while (!scm_is_null (char_sets))
63181a97
MV		 715 {
716 SCM csi = SCM_CAR (char_sets);
f49dbcad 717 scm_t_char_set *csi_data;
63181a97
MV		 718
719 SCM_VALIDATE_SMOB (argnum, csi, charset);
720 argnum++;
f49dbcad 721 csi_data = SCM_CHARSET_DATA (csi);
63181a97 722 if (cs1_data == NULL)
f49dbcad
MG		 723 cs1_data = csi_data;
724 else if (!charsets_equal (cs1_data, csi_data))
725 return SCM_BOOL_F;
63181a97
MV		 726 char_sets = SCM_CDR (char_sets);
727 }
728 return SCM_BOOL_T;
729}
730#undef FUNC_NAME
731
732
733SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
734 (SCM char_sets),
735 "Return @code{#t} if every character set @var{cs}i is a subset\n"
736 "of character set @var{cs}i+1.")
737#define FUNC_NAME s_scm_char_set_leq
738{
739 int argnum = 1;
f49dbcad 740 scm_t_char_set *prev_data = NULL;
63181a97
MV		 741
742 SCM_VALIDATE_REST_ARGUMENT (char_sets);
743
d2e53ed6 744 while (!scm_is_null (char_sets))
63181a97
MV		 745 {
746 SCM csi = SCM_CAR (char_sets);
f49dbcad 747 scm_t_char_set *csi_data;
63181a97
MV		 748
749 SCM_VALIDATE_SMOB (argnum, csi, charset);
750 argnum++;
f49dbcad 751 csi_data = SCM_CHARSET_DATA (csi);
63181a97 752 if (prev_data)
f49dbcad
MG		 753 {
754 if (!charsets_leq (prev_data, csi_data))
755 return SCM_BOOL_F;
756 }
63181a97
MV		 757 prev_data = csi_data;
758 char_sets = SCM_CDR (char_sets);
759 }
760 return SCM_BOOL_T;
761}
762#undef FUNC_NAME
763
764
765SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
766 (SCM cs, SCM bound),
767 "Compute a hash value for the character set @var{cs}. If\n"
768 "@var{bound} is given and non-zero, it restricts the\n"
769 "returned value to the range 0 @dots{} @var{bound - 1}.")
770#define FUNC_NAME s_scm_char_set_hash
771{
772 const unsigned long default_bnd = 871;
773 unsigned long bnd;
f49dbcad 774 scm_t_char_set *p;
63181a97
MV		 775 unsigned long val = 0;
776 int k;
f49dbcad 777 scm_t_wchar c;
63181a97
MV		 778
779 SCM_VALIDATE_SMOB (1, cs, charset);
780
781 if (SCM_UNBNDP (bound))
782 bnd = default_bnd;
783 else
784 {
785 bnd = scm_to_ulong (bound);
786 if (bnd == 0)
f49dbcad 787 bnd = default_bnd;
63181a97
MV		 788 }
789
f49dbcad
MG		 790 p = SCM_CHARSET_DATA (cs);
791 for (k = 0; k < p->len; k++)
63181a97 792 {
f49dbcad
MG		 793 for (c = p->ranges[k].lo; c <= p->ranges[k].hi; c++)
794 val = c + (val << 1);
63181a97
MV		 795 }
796 return scm_from_ulong (val % bnd);
797}
798#undef FUNC_NAME
799
800
801SCM_DEFINE (scm_char_set_cursor, "char-set-cursor", 1, 0, 0,
f49dbcad 802 (SCM cs), "Return a cursor into the character set @var{cs}.")
63181a97
MV		 803#define FUNC_NAME s_scm_char_set_cursor
804{
f49dbcad
MG		 805 scm_t_char_set *cs_data;
806 scm_t_char_set_cursor *cur_data;
63181a97
MV		 807
808 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 809 cs_data = SCM_CHARSET_DATA (cs);
810 cur_data =
811 (scm_t_char_set_cursor *) scm_gc_malloc (sizeof (scm_t_char_set_cursor),
812 "charset-cursor");
813 if (cs_data->len == 0)
63181a97 814 {
f49dbcad
MG		 815 cur_data->range = (size_t) (-1);
816 cur_data->n = 0;
63181a97 817 }
f49dbcad
MG		 818 else
819 {
820 cur_data->range = 0;
821 cur_data->n = cs_data->ranges[0].lo;
822 }
823 SCM_RETURN_NEWSMOB (scm_tc16_charset_cursor, cur_data);
63181a97
MV		 824}
825#undef FUNC_NAME
826
827
828SCM_DEFINE (scm_char_set_ref, "char-set-ref", 2, 0, 0,
f49dbcad
MG		 829 (SCM cs, SCM cursor),
830 "Return the character at the current cursor position\n"
831 "@var{cursor} in the character set @var{cs}. It is an error to\n"
832 "pass a cursor for which @code{end-of-char-set?} returns true.")
63181a97
MV		 833#define FUNC_NAME s_scm_char_set_ref
834{
f49dbcad
MG		 835 scm_t_char_set *cs_data;
836 scm_t_char_set_cursor *cur_data;
837 size_t i;
838
63181a97 839 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 840 SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
841
842 cs_data = SCM_CHARSET_DATA (cs);
843 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
63181a97 844
f49dbcad
MG		 845 /* Validate that this cursor is still true. */
846 i = cur_data->range;
847 if (i == (size_t) (-1)
848 || i >= cs_data->len
849 || cur_data->n < cs_data->ranges[i].lo
850 || cur_data->n > cs_data->ranges[i].hi)
63181a97 851 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
f49dbcad 852 return SCM_MAKE_CHAR (cur_data->n);
63181a97
MV		 853}
854#undef FUNC_NAME
855
856
857SCM_DEFINE (scm_char_set_cursor_next, "char-set-cursor-next", 2, 0, 0,
f49dbcad
MG		 858 (SCM cs, SCM cursor),
859 "Advance the character set cursor @var{cursor} to the next\n"
860 "character in the character set @var{cs}. It is an error if the\n"
861 "cursor given satisfies @code{end-of-char-set?}.")
63181a97
MV		 862#define FUNC_NAME s_scm_char_set_cursor_next
863{
f49dbcad
MG		 864 scm_t_char_set *cs_data;
865 scm_t_char_set_cursor *cur_data;
866 size_t i;
867
63181a97 868 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 869 SCM_VALIDATE_SMOB (2, cursor, charset_cursor);
870
871 cs_data = SCM_CHARSET_DATA (cs);
872 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
63181a97 873
f49dbcad
MG		 874 /* Validate that this cursor is still true. */
875 i = cur_data->range;
876 if (i == (size_t) (-1)
877 || i >= cs_data->len
878 || cur_data->n < cs_data->ranges[i].lo
879 || cur_data->n > cs_data->ranges[i].hi)
63181a97 880 SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
f49dbcad
MG		 881 /* Increment the cursor. */
882 if (cur_data->n == cs_data->ranges[i].hi)
63181a97 883 {
f49dbcad
MG		 884 if (i + 1 < cs_data->len)
885 {
886 cur_data->range = i + 1;
887 cur_data->n = cs_data->ranges[i + 1].lo;
888 }
889 else
890 {
891 /* This is the end of the road. */
892 cur_data->range = (size_t) (-1);
893 cur_data->n = 0;
894 }
63181a97 895 }
f49dbcad
MG		 896 else
897 {
898 cur_data->n = cur_data->n + 1;
899 }
900
901 return cursor;
63181a97
MV		 902}
903#undef FUNC_NAME
904
905
906SCM_DEFINE (scm_end_of_char_set_p, "end-of-char-set?", 1, 0, 0,
f49dbcad
MG		 907 (SCM cursor),
908 "Return @code{#t} if @var{cursor} has reached the end of a\n"
909 "character set, @code{#f} otherwise.")
63181a97
MV		 910#define FUNC_NAME s_scm_end_of_char_set_p
911{
f49dbcad
MG		 912 scm_t_char_set_cursor *cur_data;
913 SCM_VALIDATE_SMOB (1, cursor, charset_cursor);
914
915 cur_data = (scm_t_char_set_cursor *) SCM_SMOB_DATA (cursor);
916 if (cur_data->range == (size_t) (-1))
917 return SCM_BOOL_T;
918
919 return SCM_BOOL_F;
63181a97
MV		 920}
921#undef FUNC_NAME
922
923
924SCM_DEFINE (scm_char_set_fold, "char-set-fold", 3, 0, 0,
f49dbcad
MG		 925 (SCM kons, SCM knil, SCM cs),
926 "Fold the procedure @var{kons} over the character set @var{cs},\n"
927 "initializing it with @var{knil}.")
63181a97
MV		 928#define FUNC_NAME s_scm_char_set_fold
929{
f49dbcad 930 scm_t_char_set *cs_data;
63181a97 931 int k;
f49dbcad 932 scm_t_wchar n;
63181a97
MV		 933
934 SCM_VALIDATE_PROC (1, kons);
935 SCM_VALIDATE_SMOB (3, cs, charset);
936
f49dbcad
MG		 937 cs_data = SCM_CHARSET_DATA (cs);
938
939 if (cs_data->len == 0)
940 return knil;
941
942 for (k = 0; k < cs_data->len; k++)
943 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
63181a97 944 {
f49dbcad 945 knil = scm_call_2 (kons, SCM_MAKE_CHAR (n), knil);
63181a97
MV		 946 }
947 return knil;
948}
949#undef FUNC_NAME
950
951
952SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
953 (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
954 "This is a fundamental constructor for character sets.\n"
955 "@itemize @bullet\n"
956 "@item @var{g} is used to generate a series of ``seed'' values\n"
957 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
958 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
959 "@item @var{p} tells us when to stop -- when it returns true\n"
960 "when applied to one of the seed values.\n"
961 "@item @var{f} maps each seed value to a character. These\n"
962 "characters are added to the base character set @var{base_cs} to\n"
963 "form the result; @var{base_cs} defaults to the empty set.\n"
964 "@end itemize")
965#define FUNC_NAME s_scm_char_set_unfold
966{
967 SCM result, tmp;
968
969 SCM_VALIDATE_PROC (1, p);
970 SCM_VALIDATE_PROC (2, f);
971 SCM_VALIDATE_PROC (3, g);
972 if (!SCM_UNBNDP (base_cs))
973 {
974 SCM_VALIDATE_SMOB (5, base_cs, charset);
975 result = scm_char_set_copy (base_cs);
976 }
977 else
978 result = make_char_set (FUNC_NAME);
979
980 tmp = scm_call_1 (p, seed);
981 while (scm_is_false (tmp))
982 {
983 SCM ch = scm_call_1 (f, seed);
984 if (!SCM_CHARP (ch))
985 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
986 SCM_CHARSET_SET (result, SCM_CHAR (ch));
987
988 seed = scm_call_1 (g, seed);
989 tmp = scm_call_1 (p, seed);
990 }
991 return result;
992}
993#undef FUNC_NAME
994
995
996SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
997 (SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
998 "This is a fundamental constructor for character sets.\n"
999 "@itemize @bullet\n"
1000 "@item @var{g} is used to generate a series of ``seed'' values\n"
1001 "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
1002 "(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
1003 "@item @var{p} tells us when to stop -- when it returns true\n"
1004 "when applied to one of the seed values.\n"
1005 "@item @var{f} maps each seed value to a character. These\n"
1006 "characters are added to the base character set @var{base_cs} to\n"
1007 "form the result; @var{base_cs} defaults to the empty set.\n"
1008 "@end itemize")
1009#define FUNC_NAME s_scm_char_set_unfold_x
1010{
1011 SCM tmp;
1012
1013 SCM_VALIDATE_PROC (1, p);
1014 SCM_VALIDATE_PROC (2, f);
1015 SCM_VALIDATE_PROC (3, g);
1016 SCM_VALIDATE_SMOB (5, base_cs, charset);
1017
1018 tmp = scm_call_1 (p, seed);
1019 while (scm_is_false (tmp))
1020 {
1021 SCM ch = scm_call_1 (f, seed);
1022 if (!SCM_CHARP (ch))
1023 SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
1024 SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
1025
1026 seed = scm_call_1 (g, seed);
1027 tmp = scm_call_1 (p, seed);
1028 }
1029 return base_cs;
1030}
1031#undef FUNC_NAME
1032
1033
1034SCM_DEFINE (scm_char_set_for_each, "char-set-for-each", 2, 0, 0,
f49dbcad
MG		 1035 (SCM proc, SCM cs),
1036 "Apply @var{proc} to every character in the character set\n"
1037 "@var{cs}. The return value is not specified.")
63181a97
MV		 1038#define FUNC_NAME s_scm_char_set_for_each
1039{
f49dbcad 1040 scm_t_char_set *cs_data;
63181a97 1041 int k;
f49dbcad 1042 scm_t_wchar n;
63181a97
MV		 1043
1044 SCM_VALIDATE_PROC (1, proc);
1045 SCM_VALIDATE_SMOB (2, cs, charset);
1046
f49dbcad
MG		 1047 cs_data = SCM_CHARSET_DATA (cs);
1048
1049 if (cs_data->len == 0)
1050 return SCM_UNSPECIFIED;
1051
1052 for (k = 0; k < cs_data->len; k++)
1053 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1054 {
1055 scm_call_1 (proc, SCM_MAKE_CHAR (n));
1056 }
1057
63181a97
MV		 1058 return SCM_UNSPECIFIED;
1059}
1060#undef FUNC_NAME
1061
1062
1063SCM_DEFINE (scm_char_set_map, "char-set-map", 2, 0, 0,
1064 (SCM proc, SCM cs),
1065 "Map the procedure @var{proc} over every character in @var{cs}.\n"
1066 "@var{proc} must be a character -> character procedure.")
1067#define FUNC_NAME s_scm_char_set_map
1068{
1069 SCM result;
1070 int k;
f49dbcad
MG		 1071 scm_t_char_set *cs_data;
1072 scm_t_wchar n;
63181a97
MV		 1073
1074 SCM_VALIDATE_PROC (1, proc);
1075 SCM_VALIDATE_SMOB (2, cs, charset);
1076
1077 result = make_char_set (FUNC_NAME);
f49dbcad
MG		 1078 cs_data = SCM_CHARSET_DATA (cs);
1079
1080 if (cs_data->len == 0)
1081 return result;
1082
1083 for (k = 0; k < cs_data->len; k++)
1084 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
63181a97 1085 {
f49dbcad
MG		 1086 SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (n));
1087 if (!SCM_CHARP (ch))
1088 SCM_MISC_ERROR ("procedure ~S returned non-char",
1089 scm_list_1 (proc));
1090 SCM_CHARSET_SET (result, SCM_CHAR (ch));
63181a97
MV		 1091 }
1092 return result;
1093}
1094#undef FUNC_NAME
1095
1096
1097SCM_DEFINE (scm_char_set_copy, "char-set-copy", 1, 0, 0,
1098 (SCM cs),
1099 "Return a newly allocated character set containing all\n"
1100 "characters in @var{cs}.")
1101#define FUNC_NAME s_scm_char_set_copy
1102{
1103 SCM ret;
f49dbcad 1104 scm_t_char_set *p1, *p2;
63181a97
MV		 1105
1106 SCM_VALIDATE_SMOB (1, cs, charset);
1107 ret = make_char_set (FUNC_NAME);
f49dbcad
MG		 1108 p1 = SCM_CHARSET_DATA (cs);
1109 p2 = SCM_CHARSET_DATA (ret);
1110 p2->len = p1->len;
1111
1112 if (p1->len == 0)
1113 p2->ranges = NULL;
1114 else
1115 {
1116 p2->ranges = scm_gc_malloc (sizeof (scm_t_char_range) * p1->len,
1117 "character-set");
1118 memcpy (p2->ranges, p1->ranges, sizeof (scm_t_char_range) * p1->len);
1119 }
1120
63181a97
MV		 1121 return ret;
1122}
1123#undef FUNC_NAME
1124
1125
1126SCM_DEFINE (scm_char_set, "char-set", 0, 0, 1,
1127 (SCM rest),
1128 "Return a character set containing all given characters.")
1129#define FUNC_NAME s_scm_char_set
1130{
1131 SCM cs;
63181a97
MV		 1132 int argnum = 1;
1133
1134 SCM_VALIDATE_REST_ARGUMENT (rest);
1135 cs = make_char_set (FUNC_NAME);
d2e53ed6 1136 while (!scm_is_null (rest))
63181a97 1137 {
f49dbcad 1138 scm_t_wchar c;
63181a97
MV		 1139
1140 SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
1141 argnum++;
1142 rest = SCM_CDR (rest);
f49dbcad 1143 SCM_CHARSET_SET (cs, c);
63181a97
MV		 1144 }
1145 return cs;
1146}
1147#undef FUNC_NAME
1148
1149
1150SCM_DEFINE (scm_list_to_char_set, "list->char-set", 1, 1, 0,
1151 (SCM list, SCM base_cs),
1152 "Convert the character list @var{list} to a character set. If\n"
1153 "the character set @var{base_cs} is given, the character in this\n"
1154 "set are also included in the result.")
1155#define FUNC_NAME s_scm_list_to_char_set
1156{
1157 SCM cs;
63181a97
MV		 1158
1159 SCM_VALIDATE_LIST (1, list);
1160 if (SCM_UNBNDP (base_cs))
1161 cs = make_char_set (FUNC_NAME);
1162 else
1163 {
1164 SCM_VALIDATE_SMOB (2, base_cs, charset);
1165 cs = scm_char_set_copy (base_cs);
1166 }
d2e53ed6 1167 while (!scm_is_null (list))
63181a97
MV		 1168 {
1169 SCM chr = SCM_CAR (list);
f49dbcad 1170 scm_t_wchar c;
63181a97
MV		 1171
1172 SCM_VALIDATE_CHAR_COPY (0, chr, c);
1173 list = SCM_CDR (list);
1174
f49dbcad
MG		 1175
1176 SCM_CHARSET_SET (cs, c);
63181a97
MV		 1177 }
1178 return cs;
1179}
1180#undef FUNC_NAME
1181
1182
1183SCM_DEFINE (scm_list_to_char_set_x, "list->char-set!", 2, 0, 0,
f49dbcad
MG		 1184 (SCM list, SCM base_cs),
1185 "Convert the character list @var{list} to a character set. The\n"
1186 "characters are added to @var{base_cs} and @var{base_cs} is\n"
1187 "returned.")
63181a97
MV		 1188#define FUNC_NAME s_scm_list_to_char_set_x
1189{
63181a97
MV		 1190 SCM_VALIDATE_LIST (1, list);
1191 SCM_VALIDATE_SMOB (2, base_cs, charset);
d2e53ed6 1192 while (!scm_is_null (list))
63181a97
MV		 1193 {
1194 SCM chr = SCM_CAR (list);
f49dbcad 1195 scm_t_wchar c;
63181a97
MV		 1196
1197 SCM_VALIDATE_CHAR_COPY (0, chr, c);
1198 list = SCM_CDR (list);
1199
f49dbcad 1200 SCM_CHARSET_SET (base_cs, c);
63181a97
MV		 1201 }
1202 return base_cs;
1203}
1204#undef FUNC_NAME
1205
1206
1207SCM_DEFINE (scm_string_to_char_set, "string->char-set", 1, 1, 0,
1208 (SCM str, SCM base_cs),
1209 "Convert the string @var{str} to a character set. If the\n"
1210 "character set @var{base_cs} is given, the characters in this\n"
1211 "set are also included in the result.")
1212#define FUNC_NAME s_scm_string_to_char_set
1213{
1214 SCM cs;
63181a97
MV		 1215 size_t k = 0, len;
1216
1217 SCM_VALIDATE_STRING (1, str);
1218 if (SCM_UNBNDP (base_cs))
1219 cs = make_char_set (FUNC_NAME);
1220 else
1221 {
1222 SCM_VALIDATE_SMOB (2, base_cs, charset);
1223 cs = scm_char_set_copy (base_cs);
1224 }
63181a97
MV		 1225 len = scm_i_string_length (str);
1226 while (k < len)
1227 {
f49dbcad
MG		 1228 scm_t_wchar c = scm_i_string_ref (str, k++);
1229 SCM_CHARSET_SET (cs, c);
63181a97
MV		 1230 }
1231 scm_remember_upto_here_1 (str);
1232 return cs;
1233}
1234#undef FUNC_NAME
1235
1236
1237SCM_DEFINE (scm_string_to_char_set_x, "string->char-set!", 2, 0, 0,
f49dbcad
MG		 1238 (SCM str, SCM base_cs),
1239 "Convert the string @var{str} to a character set. The\n"
1240 "characters from the string are added to @var{base_cs}, and\n"
1241 "@var{base_cs} is returned.")
63181a97
MV		 1242#define FUNC_NAME s_scm_string_to_char_set_x
1243{
63181a97
MV		 1244 size_t k = 0, len;
1245
1246 SCM_VALIDATE_STRING (1, str);
1247 SCM_VALIDATE_SMOB (2, base_cs, charset);
63181a97
MV		 1248 len = scm_i_string_length (str);
1249 while (k < len)
1250 {
f49dbcad
MG		 1251 scm_t_wchar c = scm_i_string_ref (str, k++);
1252 SCM_CHARSET_SET (base_cs, c);
63181a97
MV		 1253 }
1254 scm_remember_upto_here_1 (str);
1255 return base_cs;
1256}
1257#undef FUNC_NAME
1258
1259
1260SCM_DEFINE (scm_char_set_filter, "char-set-filter", 2, 1, 0,
1261 (SCM pred, SCM cs, SCM base_cs),
1262 "Return a character set containing every character from @var{cs}\n"
1263 "so that it satisfies @var{pred}. If provided, the characters\n"
1264 "from @var{base_cs} are added to the result.")
1265#define FUNC_NAME s_scm_char_set_filter
1266{
1267 SCM ret;
1268 int k;
f49dbcad
MG		 1269 scm_t_wchar n;
1270 scm_t_char_set *p;
63181a97
MV		 1271
1272 SCM_VALIDATE_PROC (1, pred);
1273 SCM_VALIDATE_SMOB (2, cs, charset);
1274 if (!SCM_UNBNDP (base_cs))
1275 {
1276 SCM_VALIDATE_SMOB (3, base_cs, charset);
1277 ret = scm_char_set_copy (base_cs);
1278 }
1279 else
1280 ret = make_char_set (FUNC_NAME);
63181a97 1281
f49dbcad
MG		 1282 p = SCM_CHARSET_DATA (cs);
1283
1284 if (p->len == 0)
1285 return ret;
1286
1287 for (k = 0; k < p->len; k++)
1288 for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
1289 {
1290 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1291
1292 if (scm_is_true (res))
1293 SCM_CHARSET_SET (ret, n);
1294 }
63181a97
MV		 1295 return ret;
1296}
1297#undef FUNC_NAME
1298
1299
1300SCM_DEFINE (scm_char_set_filter_x, "char-set-filter!", 3, 0, 0,
1301 (SCM pred, SCM cs, SCM base_cs),
1302 "Return a character set containing every character from @var{cs}\n"
1303 "so that it satisfies @var{pred}. The characters are added to\n"
1304 "@var{base_cs} and @var{base_cs} is returned.")
1305#define FUNC_NAME s_scm_char_set_filter_x
1306{
1307 int k;
f49dbcad
MG		 1308 scm_t_wchar n;
1309 scm_t_char_set *p;
63181a97
MV		 1310
1311 SCM_VALIDATE_PROC (1, pred);
1312 SCM_VALIDATE_SMOB (2, cs, charset);
1313 SCM_VALIDATE_SMOB (3, base_cs, charset);
f49dbcad
MG		 1314 p = SCM_CHARSET_DATA (cs);
1315 if (p->len == 0)
1316 return base_cs;
63181a97 1317
f49dbcad
MG		 1318 for (k = 0; k < p->len; k++)
1319 for (n = p->ranges[k].lo; n <= p->ranges[k].hi; n++)
1320 {
bde543e8 1321 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
f49dbcad
MG		 1322
1323 if (scm_is_true (res))
1324 SCM_CHARSET_SET (base_cs, n);
1325 }
63181a97
MV		 1326 return base_cs;
1327}
1328#undef FUNC_NAME
1329
1330
91772d8f
MG		 1331/* Return a character set containing all the characters from [LOWER,UPPER),
1332 giving range errors if ERROR, adding chars from BASE_CS, and recycling
1333 BASE_CS if REUSE is true. */
1334static SCM
1335scm_i_ucs_range_to_char_set (const char *FUNC_NAME, SCM lower, SCM upper,
1336 SCM error, SCM base_cs, int reuse)
63181a97
MV		 1337{
1338 SCM cs;
1339 size_t clower, cupper;
63181a97
MV		 1340
1341 clower = scm_to_size_t (lower);
91772d8f
MG		 1342 cupper = scm_to_size_t (upper) - 1;
1343 SCM_ASSERT_RANGE (1, lower, clower >= 0);
1344 SCM_ASSERT_RANGE (2, upper, cupper >= 0);
63181a97
MV		 1345 SCM_ASSERT_RANGE (2, upper, cupper >= clower);
1346 if (!SCM_UNBNDP (error))
1347 {
1348 if (scm_is_true (error))
f49dbcad
MG		 1349 {
1350 SCM_ASSERT_RANGE (1, lower, SCM_IS_UNICODE_CHAR (clower));
1351 SCM_ASSERT_RANGE (2, upper, SCM_IS_UNICODE_CHAR (cupper));
91772d8f
MG		 1352 if (clower < SCM_CODEPOINT_SURROGATE_START
1353 && cupper > SCM_CODEPOINT_SURROGATE_END)
1354 scm_error(scm_out_of_range_key,
1355 FUNC_NAME, "invalid range - contains surrogate characters: ~S to ~S",
1356 scm_list_2 (lower, upper), scm_list_1 (upper));
f49dbcad 1357 }
63181a97 1358 }
91772d8f 1359
63181a97
MV		 1360 if (SCM_UNBNDP (base_cs))
1361 cs = make_char_set (FUNC_NAME);
1362 else
1363 {
1364 SCM_VALIDATE_SMOB (4, base_cs, charset);
91772d8f
MG		 1365 if (reuse)
1366 cs = base_cs;
1367 else
1368 cs = scm_char_set_copy (base_cs);
63181a97 1369 }
91772d8f
MG		 1370
1371 if ((clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
1372 && (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END))
1373 return cs;
1374
1375 if (clower > SCM_CODEPOINT_MAX)
1376 clower = SCM_CODEPOINT_MAX;
1377 if (clower >= SCM_CODEPOINT_SURROGATE_START && clower <= SCM_CODEPOINT_SURROGATE_END)
1378 clower = SCM_CODEPOINT_SURROGATE_END + 1;
1379 if (cupper > SCM_CODEPOINT_MAX)
1380 cupper = SCM_CODEPOINT_MAX;
1381 if (cupper >= SCM_CODEPOINT_SURROGATE_START && cupper <= SCM_CODEPOINT_SURROGATE_END)
1382 cupper = SCM_CODEPOINT_SURROGATE_START - 1;
1383 if (clower < SCM_CODEPOINT_SURROGATE_START && cupper > SCM_CODEPOINT_SURROGATE_END)
63181a97 1384 {
91772d8f
MG		 1385 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, SCM_CODEPOINT_SURROGATE_START - 1);
1386 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), SCM_CODEPOINT_SURROGATE_END + 1, cupper);
63181a97 1387 }
91772d8f
MG		 1388 else
1389 scm_i_charset_set_range (SCM_CHARSET_DATA (cs), clower, cupper);
63181a97
MV		 1390 return cs;
1391}
91772d8f
MG		 1392
1393SCM_DEFINE (scm_ucs_range_to_char_set, "ucs-range->char-set", 2, 2, 0,
1394 (SCM lower, SCM upper, SCM error, SCM base_cs),
1395 "Return a character set containing all characters whose\n"
1396 "character codes lie in the half-open range\n"
1397 "[@var{lower},@var{upper}).\n"
1398 "\n"
1399 "If @var{error} is a true value, an error is signalled if the\n"
1400 "specified range contains characters which are not valid\n"
1401 "Unicode code points. If @var{error} is @code{#f},\n"
1402 "these characters are silently left out of the resultung\n"
1403 "character set.\n"
1404 "\n"
1405 "The characters in @var{base_cs} are added to the result, if\n"
1406 "given.")
1407#define FUNC_NAME s_scm_ucs_range_to_char_set
1408{
1409 return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
1410 error, base_cs, 0);
1411}
63181a97
MV		 1412#undef FUNC_NAME
1413
1414
1415SCM_DEFINE (scm_ucs_range_to_char_set_x, "ucs-range->char-set!", 4, 0, 0,
1416 (SCM lower, SCM upper, SCM error, SCM base_cs),
1417 "Return a character set containing all characters whose\n"
1418 "character codes lie in the half-open range\n"
1419 "[@var{lower},@var{upper}).\n"
1420 "\n"
1421 "If @var{error} is a true value, an error is signalled if the\n"
1422 "specified range contains characters which are not contained in\n"
1423 "the implemented character range. If @var{error} is @code{#f},\n"
1424 "these characters are silently left out of the resultung\n"
1425 "character set.\n"
1426 "\n"
1427 "The characters are added to @var{base_cs} and @var{base_cs} is\n"
1428 "returned.")
1429#define FUNC_NAME s_scm_ucs_range_to_char_set_x
1430{
91772d8f
MG		 1431 SCM_VALIDATE_SMOB (4, base_cs, charset);
1432 return scm_i_ucs_range_to_char_set (FUNC_NAME, lower, upper,
1433 error, base_cs, 1);
63181a97
MV		 1434}
1435#undef FUNC_NAME
1436
1437SCM_DEFINE (scm_to_char_set, "->char-set", 1, 0, 0,
1438 (SCM x),
1439 "Coerces x into a char-set. @var{x} may be a string, character or char-set. A string is converted to the set of its constituent characters; a character is converted to a singleton set; a char-set is returned as-is.")
1440#define FUNC_NAME s_scm_to_char_set
1441{
1442 if (scm_is_string (x))
1443 return scm_string_to_char_set (x, SCM_UNDEFINED);
1444 else if (SCM_CHARP (x))
1445 return scm_char_set (scm_list_1 (x));
1446 else if (SCM_SMOB_PREDICATE (scm_tc16_charset, x))
1447 return x;
1448 else
1449 scm_wrong_type_arg (NULL, 0, x);
1450}
1451#undef FUNC_NAME
1452
1453SCM_DEFINE (scm_char_set_size, "char-set-size", 1, 0, 0,
1454 (SCM cs),
1455 "Return the number of elements in character set @var{cs}.")
1456#define FUNC_NAME s_scm_char_set_size
1457{
1458 int k, count = 0;
f49dbcad 1459 scm_t_char_set *cs_data;
63181a97
MV		 1460
1461 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 1462 cs_data = SCM_CHARSET_DATA (cs);
1463
1464 if (cs_data->len == 0)
1465 return scm_from_int (0);
1466
1467 for (k = 0; k < cs_data->len; k++)
1468 count += cs_data->ranges[k].hi - cs_data->ranges[k].lo + 1;
1469
1470 return scm_from_int (count);
63181a97
MV		 1471}
1472#undef FUNC_NAME
1473
1474
1475SCM_DEFINE (scm_char_set_count, "char-set-count", 2, 0, 0,
1476 (SCM pred, SCM cs),
1477 "Return the number of the elements int the character set\n"
1478 "@var{cs} which satisfy the predicate @var{pred}.")
1479#define FUNC_NAME s_scm_char_set_count
1480{
1481 int k, count = 0;
f49dbcad
MG		 1482 scm_t_wchar n;
1483 scm_t_char_set *cs_data;
63181a97
MV		 1484
1485 SCM_VALIDATE_PROC (1, pred);
1486 SCM_VALIDATE_SMOB (2, cs, charset);
f49dbcad
MG		 1487 cs_data = SCM_CHARSET_DATA (cs);
1488 if (cs_data->len == 0)
1489 return scm_from_int (0);
63181a97 1490
f49dbcad
MG		 1491 for (k = 0; k < cs_data->len; k++)
1492 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
63181a97 1493 {
f49dbcad
MG		 1494 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1495 if (scm_is_true (res))
1496 count++;
63181a97
MV		 1497 }
1498 return SCM_I_MAKINUM (count);
1499}
1500#undef FUNC_NAME
1501
1502
1503SCM_DEFINE (scm_char_set_to_list, "char-set->list", 1, 0, 0,
1504 (SCM cs),
1505 "Return a list containing the elements of the character set\n"
1506 "@var{cs}.")
1507#define FUNC_NAME s_scm_char_set_to_list
1508{
1509 int k;
f49dbcad 1510 scm_t_wchar n;
63181a97 1511 SCM result = SCM_EOL;
f49dbcad 1512 scm_t_char_set *p;
63181a97
MV		 1513
1514 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 1515 p = SCM_CHARSET_DATA (cs);
1516 if (p->len == 0)
1517 return SCM_EOL;
1518
1519 for (k = p->len - 1; k >= 0; k--)
1520 for (n = p->ranges[k].hi; n >= p->ranges[k].lo; n--)
1521 result = scm_cons (SCM_MAKE_CHAR (n), result);
63181a97
MV		 1522 return result;
1523}
1524#undef FUNC_NAME
1525
1526
1527SCM_DEFINE (scm_char_set_to_string, "char-set->string", 1, 0, 0,
1528 (SCM cs),
1529 "Return a string containing the elements of the character set\n"
1530 "@var{cs}. The order in which the characters are placed in the\n"
1531 "string is not defined.")
1532#define FUNC_NAME s_scm_char_set_to_string
1533{
1534 int k;
1535 int count = 0;
1536 int idx = 0;
f49dbcad 1537 int wide = 0;
63181a97 1538 SCM result;
f49dbcad
MG		 1539 scm_t_wchar n;
1540 scm_t_char_set *cs_data;
1541 char *buf;
1542 scm_t_wchar *wbuf;
63181a97
MV		 1543
1544 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad
MG		 1545 cs_data = SCM_CHARSET_DATA (cs);
1546 if (cs_data->len == 0)
1547 return scm_nullstr;
1548
1549 if (cs_data->ranges[cs_data->len - 1].hi > 255)
1550 wide = 1;
1551
1552 count = scm_to_int (scm_char_set_size (cs));
1553 if (wide)
1554 result = scm_i_make_wide_string (count, &wbuf);
1555 else
1556 result = scm_i_make_string (count, &buf);
1557
1558 for (k = 0; k < cs_data->len; k++)
1559 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
1560 {
1561 if (wide)
1562 wbuf[idx++] = n;
1563 else
1564 buf[idx++] = n;
1565 }
63181a97
MV		 1566 return result;
1567}
1568#undef FUNC_NAME
1569
1570
1571SCM_DEFINE (scm_char_set_contains_p, "char-set-contains?", 2, 0, 0,
1572 (SCM cs, SCM ch),
1573 "Return @code{#t} iff the character @var{ch} is contained in the\n"
1574 "character set @var{cs}.")
1575#define FUNC_NAME s_scm_char_set_contains_p
1576{
1577 SCM_VALIDATE_SMOB (1, cs, charset);
1578 SCM_VALIDATE_CHAR (2, ch);
1579 return scm_from_bool (SCM_CHARSET_GET (cs, SCM_CHAR (ch)));
1580}
1581#undef FUNC_NAME
1582
1583
1584SCM_DEFINE (scm_char_set_every, "char-set-every", 2, 0, 0,
1585 (SCM pred, SCM cs),
1586 "Return a true value if every character in the character set\n"
1587 "@var{cs} satisfies the predicate @var{pred}.")
1588#define FUNC_NAME s_scm_char_set_every
1589{
1590 int k;
f49dbcad 1591 scm_t_wchar n;
63181a97 1592 SCM res = SCM_BOOL_T;
f49dbcad 1593 scm_t_char_set *cs_data;
63181a97
MV		 1594
1595 SCM_VALIDATE_PROC (1, pred);
1596 SCM_VALIDATE_SMOB (2, cs, charset);
1597
f49dbcad
MG		 1598 cs_data = SCM_CHARSET_DATA (cs);
1599 if (cs_data->len == 0)
1600 return SCM_BOOL_T;
1601
1602 for (k = 0; k < cs_data->len; k++)
1603 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
63181a97 1604 {
f49dbcad
MG		 1605 res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1606 if (scm_is_false (res))
1607 return res;
63181a97 1608 }
f49dbcad 1609 return SCM_BOOL_T;
63181a97
MV		 1610}
1611#undef FUNC_NAME
1612
1613
1614SCM_DEFINE (scm_char_set_any, "char-set-any", 2, 0, 0,
1615 (SCM pred, SCM cs),
1616 "Return a true value if any character in the character set\n"
1617 "@var{cs} satisfies the predicate @var{pred}.")
1618#define FUNC_NAME s_scm_char_set_any
1619{
1620 int k;
f49dbcad
MG		 1621 scm_t_wchar n;
1622 scm_t_char_set *cs_data;
63181a97
MV		 1623
1624 SCM_VALIDATE_PROC (1, pred);
1625 SCM_VALIDATE_SMOB (2, cs, charset);
1626
693e7289
MG		 1627 cs_data = SCM_CHARSET_DATA (cs);
1628 if (cs_data->len == 0)
1629 return SCM_BOOL_T;
f49dbcad
MG		 1630
1631 for (k = 0; k < cs_data->len; k++)
1632 for (n = cs_data->ranges[k].lo; n <= cs_data->ranges[k].hi; n++)
63181a97 1633 {
f49dbcad
MG		 1634 SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (n));
1635 if (scm_is_true (res))
1636 return res;
63181a97
MV		 1637 }
1638 return SCM_BOOL_F;
1639}
1640#undef FUNC_NAME
1641
1642
1643SCM_DEFINE (scm_char_set_adjoin, "char-set-adjoin", 1, 0, 1,
f49dbcad
MG		 1644 (SCM cs, SCM rest),
1645 "Add all character arguments to the first argument, which must\n"
1646 "be a character set.")
63181a97
MV		 1647#define FUNC_NAME s_scm_char_set_adjoin
1648{
63181a97
MV		 1649 SCM_VALIDATE_SMOB (1, cs, charset);
1650 SCM_VALIDATE_REST_ARGUMENT (rest);
1651 cs = scm_char_set_copy (cs);
1652
d2e53ed6 1653 while (!scm_is_null (rest))
63181a97
MV		 1654 {
1655 SCM chr = SCM_CAR (rest);
f49dbcad 1656 scm_t_wchar c;
63181a97
MV		 1657
1658 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1659 rest = SCM_CDR (rest);
1660
f49dbcad 1661 SCM_CHARSET_SET (cs, c);
63181a97
MV		 1662 }
1663 return cs;
1664}
1665#undef FUNC_NAME
1666
1667
1668SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
f49dbcad
MG		 1669 (SCM cs, SCM rest),
1670 "Delete all character arguments from the first argument, which\n"
1671 "must be a character set.")
63181a97
MV		 1672#define FUNC_NAME s_scm_char_set_delete
1673{
63181a97
MV		 1674 SCM_VALIDATE_SMOB (1, cs, charset);
1675 SCM_VALIDATE_REST_ARGUMENT (rest);
1676 cs = scm_char_set_copy (cs);
1677
d2e53ed6 1678 while (!scm_is_null (rest))
63181a97
MV		 1679 {
1680 SCM chr = SCM_CAR (rest);
f49dbcad 1681 scm_t_wchar c;
63181a97
MV		 1682
1683 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1684 rest = SCM_CDR (rest);
1685
f49dbcad 1686 SCM_CHARSET_UNSET (cs, c);
63181a97
MV		 1687 }
1688 return cs;
1689}
1690#undef FUNC_NAME
1691
1692
1693SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
f49dbcad
MG		 1694 (SCM cs, SCM rest),
1695 "Add all character arguments to the first argument, which must\n"
1696 "be a character set.")
63181a97
MV		 1697#define FUNC_NAME s_scm_char_set_adjoin_x
1698{
63181a97
MV		 1699 SCM_VALIDATE_SMOB (1, cs, charset);
1700 SCM_VALIDATE_REST_ARGUMENT (rest);
1701
d2e53ed6 1702 while (!scm_is_null (rest))
63181a97
MV		 1703 {
1704 SCM chr = SCM_CAR (rest);
f49dbcad 1705 scm_t_wchar c;
63181a97
MV		 1706
1707 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1708 rest = SCM_CDR (rest);
1709
f49dbcad 1710 SCM_CHARSET_SET (cs, c);
63181a97
MV		 1711 }
1712 return cs;
1713}
1714#undef FUNC_NAME
1715
1716
1717SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
f49dbcad
MG		 1718 (SCM cs, SCM rest),
1719 "Delete all character arguments from the first argument, which\n"
1720 "must be a character set.")
63181a97
MV		 1721#define FUNC_NAME s_scm_char_set_delete_x
1722{
63181a97
MV		 1723 SCM_VALIDATE_SMOB (1, cs, charset);
1724 SCM_VALIDATE_REST_ARGUMENT (rest);
1725
d2e53ed6 1726 while (!scm_is_null (rest))
63181a97
MV		 1727 {
1728 SCM chr = SCM_CAR (rest);
f49dbcad 1729 scm_t_wchar c;
63181a97
MV		 1730
1731 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1732 rest = SCM_CDR (rest);
1733
f49dbcad 1734 SCM_CHARSET_UNSET (cs, c);
63181a97
MV		 1735 }
1736 return cs;
1737}
1738#undef FUNC_NAME
1739
1740
1741SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
f49dbcad 1742 (SCM cs), "Return the complement of the character set @var{cs}.")
63181a97
MV		 1743#define FUNC_NAME s_scm_char_set_complement
1744{
63181a97 1745 SCM res;
f49dbcad 1746 scm_t_char_set *p, *q;
63181a97
MV		 1747
1748 SCM_VALIDATE_SMOB (1, cs, charset);
1749
1750 res = make_char_set (FUNC_NAME);
f49dbcad
MG		 1751 p = SCM_CHARSET_DATA (res);
1752 q = SCM_CHARSET_DATA (cs);
1753
1754 charsets_complement (p, q);
63181a97
MV		 1755 return res;
1756}
1757#undef FUNC_NAME
1758
1759
1760SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
1761 (SCM rest),
1762 "Return the union of all argument character sets.")
1763#define FUNC_NAME s_scm_char_set_union
1764{
1765 int c = 1;
1766 SCM res;
f49dbcad 1767 scm_t_char_set *p;
63181a97
MV		 1768
1769 SCM_VALIDATE_REST_ARGUMENT (rest);
1770
1771 res = make_char_set (FUNC_NAME);
f49dbcad 1772 p = SCM_CHARSET_DATA (res);
d2e53ed6 1773 while (!scm_is_null (rest))
63181a97 1774 {
63181a97
MV		 1775 SCM cs = SCM_CAR (rest);
1776 SCM_VALIDATE_SMOB (c, cs, charset);
1777 c++;
1778 rest = SCM_CDR (rest);
1779
f49dbcad
MG		 1780
1781 charsets_union (p, (scm_t_char_set *) SCM_SMOB_DATA (cs));
63181a97
MV		 1782 }
1783 return res;
1784}
1785#undef FUNC_NAME
1786
1787
1788SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
1789 (SCM rest),
1790 "Return the intersection of all argument character sets.")
1791#define FUNC_NAME s_scm_char_set_intersection
1792{
1793 SCM res;
1794
1795 SCM_VALIDATE_REST_ARGUMENT (rest);
1796
d2e53ed6 1797 if (scm_is_null (rest))
63181a97
MV		 1798 res = make_char_set (FUNC_NAME);
1799 else
1800 {
f49dbcad 1801 scm_t_char_set *p;
63181a97
MV		 1802 int argnum = 2;
1803
1804 res = scm_char_set_copy (SCM_CAR (rest));
f49dbcad 1805 p = SCM_CHARSET_DATA (res);
63181a97
MV		 1806 rest = SCM_CDR (rest);
1807
d2e53ed6 1808 while (scm_is_pair (rest))
f49dbcad
MG		 1809 {
1810 SCM cs = SCM_CAR (rest);
1811 scm_t_char_set *cs_data;
1812
1813 SCM_VALIDATE_SMOB (argnum, cs, charset);
1814 argnum++;
1815 cs_data = SCM_CHARSET_DATA (cs);
1816 rest = SCM_CDR (rest);
1817 charsets_intersection (p, cs_data);
1818 }
63181a97
MV		 1819 }
1820
1821 return res;
1822}
1823#undef FUNC_NAME
1824
1825
1826SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
1827 (SCM cs1, SCM rest),
1828 "Return the difference of all argument character sets.")
1829#define FUNC_NAME s_scm_char_set_difference
1830{
1831 int c = 2;
f49dbcad
MG		 1832 SCM res, compl;
1833 scm_t_char_set *p, *q;
63181a97
MV		 1834
1835 SCM_VALIDATE_SMOB (1, cs1, charset);
1836 SCM_VALIDATE_REST_ARGUMENT (rest);
1837
1838 res = scm_char_set_copy (cs1);
f49dbcad
MG		 1839 p = SCM_CHARSET_DATA (res);
1840 compl = make_char_set (FUNC_NAME);
1841 q = SCM_CHARSET_DATA (compl);
d2e53ed6 1842 while (!scm_is_null (rest))
63181a97 1843 {
63181a97
MV		 1844 SCM cs = SCM_CAR (rest);
1845 SCM_VALIDATE_SMOB (c, cs, charset);
1846 c++;
1847 rest = SCM_CDR (rest);
1848
f49dbcad
MG		 1849 charsets_complement (q, SCM_CHARSET_DATA (cs));
1850 charsets_intersection (p, q);
63181a97
MV		 1851 }
1852 return res;
1853}
1854#undef FUNC_NAME
1855
1856
1857SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
1858 (SCM rest),
1859 "Return the exclusive-or of all argument character sets.")
1860#define FUNC_NAME s_scm_char_set_xor
1861{
1862 SCM res;
1863
1864 SCM_VALIDATE_REST_ARGUMENT (rest);
1865
d2e53ed6 1866 if (scm_is_null (rest))
63181a97
MV		 1867 res = make_char_set (FUNC_NAME);
1868 else
1869 {
1870 int argnum = 2;
f49dbcad 1871 scm_t_char_set *p;
63181a97
MV		 1872
1873 res = scm_char_set_copy (SCM_CAR (rest));
f49dbcad 1874 p = SCM_CHARSET_DATA (res);
63181a97
MV		 1875 rest = SCM_CDR (rest);
1876
d2e53ed6 1877 while (scm_is_pair (rest))
f49dbcad
MG		 1878 {
1879 SCM cs = SCM_CAR (rest);
1880 scm_t_char_set *cs_data;
1881
1882 SCM_VALIDATE_SMOB (argnum, cs, charset);
1883 argnum++;
1884 cs_data = SCM_CHARSET_DATA (cs);
1885 rest = SCM_CDR (rest);
1886
1887 charsets_xor (p, cs_data);
1888 }
63181a97
MV		 1889 }
1890 return res;
1891}
1892#undef FUNC_NAME
1893
1894
1895SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
1896 (SCM cs1, SCM rest),
1897 "Return the difference and the intersection of all argument\n"
1898 "character sets.")
1899#define FUNC_NAME s_scm_char_set_diff_plus_intersection
1900{
1901 int c = 2;
1902 SCM res1, res2;
f49dbcad 1903 scm_t_char_set *p, *q;
63181a97
MV		 1904
1905 SCM_VALIDATE_SMOB (1, cs1, charset);
1906 SCM_VALIDATE_REST_ARGUMENT (rest);
1907
1908 res1 = scm_char_set_copy (cs1);
1909 res2 = make_char_set (FUNC_NAME);
f49dbcad
MG		 1910 p = SCM_CHARSET_DATA (res1);
1911 q = SCM_CHARSET_DATA (res2);
d2e53ed6 1912 while (!scm_is_null (rest))
63181a97 1913 {
63181a97 1914 SCM cs = SCM_CAR (rest);
f49dbcad 1915 scm_t_char_set *r;
63181a97
MV		 1916
1917 SCM_VALIDATE_SMOB (c, cs, charset);
1918 c++;
f49dbcad 1919 r = SCM_CHARSET_DATA (cs);
63181a97 1920
f49dbcad
MG		 1921 charsets_union (q, r);
1922 charsets_intersection (p, r);
63181a97
MV		 1923 rest = SCM_CDR (rest);
1924 }
1925 return scm_values (scm_list_2 (res1, res2));
1926}
1927#undef FUNC_NAME
1928
1929
1930SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
f49dbcad 1931 (SCM cs), "Return the complement of the character set @var{cs}.")
63181a97
MV		 1932#define FUNC_NAME s_scm_char_set_complement_x
1933{
63181a97 1934 SCM_VALIDATE_SMOB (1, cs, charset);
f49dbcad 1935 cs = scm_char_set_complement (cs);
63181a97
MV		 1936 return cs;
1937}
1938#undef FUNC_NAME
1939
1940
1941SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
f49dbcad
MG		 1942 (SCM cs1, SCM rest),
1943 "Return the union of all argument character sets.")
63181a97
MV		 1944#define FUNC_NAME s_scm_char_set_union_x
1945{
63181a97
MV		 1946 SCM_VALIDATE_SMOB (1, cs1, charset);
1947 SCM_VALIDATE_REST_ARGUMENT (rest);
1948
f49dbcad 1949 cs1 = scm_char_set_union (scm_cons (cs1, rest));
63181a97
MV		 1950 return cs1;
1951}
1952#undef FUNC_NAME
1953
1954
1955SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
f49dbcad
MG		 1956 (SCM cs1, SCM rest),
1957 "Return the intersection of all argument character sets.")
63181a97
MV		 1958#define FUNC_NAME s_scm_char_set_intersection_x
1959{
63181a97
MV		 1960 SCM_VALIDATE_SMOB (1, cs1, charset);
1961 SCM_VALIDATE_REST_ARGUMENT (rest);
1962
f49dbcad 1963 cs1 = scm_char_set_intersection (scm_cons (cs1, rest));
63181a97
MV		 1964 return cs1;
1965}
1966#undef FUNC_NAME
1967
1968
1969SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
f49dbcad
MG		 1970 (SCM cs1, SCM rest),
1971 "Return the difference of all argument character sets.")
63181a97
MV		 1972#define FUNC_NAME s_scm_char_set_difference_x
1973{
63181a97
MV		 1974 SCM_VALIDATE_SMOB (1, cs1, charset);
1975 SCM_VALIDATE_REST_ARGUMENT (rest);
1976
f49dbcad 1977 cs1 = scm_char_set_difference (cs1, rest);
63181a97
MV		 1978 return cs1;
1979}
1980#undef FUNC_NAME
1981
1982
1983SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
1984 (SCM cs1, SCM rest),
1985 "Return the exclusive-or of all argument character sets.")
1986#define FUNC_NAME s_scm_char_set_xor_x
1987{
1988 /* a side-effecting variant should presumably give consistent results:
1989 (define a (char-set #\a))
1990 (char-set-xor a a a) -> char set #\a
1991 (char-set-xor! a a a) -> char set #\a
f49dbcad 1992 */
7165abeb
MG		 1993 cs1 = scm_char_set_xor (scm_cons (cs1, rest));
1994 return cs1;
63181a97
MV		 1995}
1996#undef FUNC_NAME
1997
1998
f49dbcad
MG		 1999SCM_DEFINE (scm_char_set_diff_plus_intersection_x,
2000 "char-set-diff+intersection!", 2, 0, 1, (SCM cs1, SCM cs2,
2001 SCM rest),
2002 "Return the difference and the intersection of all argument\n"
2003 "character sets.")
63181a97
MV		 2004#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
2005{
f49dbcad 2006 SCM diff, intersect;
63181a97 2007
f49dbcad
MG		 2008 diff = scm_char_set_difference (cs1, scm_cons (cs2, rest));
2009 intersect =
2010 scm_char_set_intersection (scm_cons (cs1, scm_cons (cs2, rest)));
2011 cs1 = diff;
2012 cs2 = intersect;
63181a97
MV		 2013 return scm_values (scm_list_2 (cs1, cs2));
2014}
f49dbcad 2015#undef FUNC_NAME
d5ecf579 2016
a17d2654 2017\f
f49dbcad 2018
a17d2654
LC		 2019/* Standard character sets. */
2020
63181a97
MV		 2021SCM scm_char_set_lower_case;
2022SCM scm_char_set_upper_case;
2023SCM scm_char_set_title_case;
2024SCM scm_char_set_letter;
2025SCM scm_char_set_digit;
2026SCM scm_char_set_letter_and_digit;
2027SCM scm_char_set_graphic;
2028SCM scm_char_set_printing;
2029SCM scm_char_set_whitespace;
2030SCM scm_char_set_iso_control;
2031SCM scm_char_set_punctuation;
2032SCM scm_char_set_symbol;
2033SCM scm_char_set_hex_digit;
2034SCM scm_char_set_blank;
2035SCM scm_char_set_ascii;
2036SCM scm_char_set_empty;
2037SCM scm_char_set_full;
2038
63181a97 2039
a17d2654
LC		 2040/* Create an empty character set and return it after binding it to NAME. */
2041static inline SCM
f49dbcad 2042define_charset (const char *name, const scm_t_char_set *p)
63181a97 2043{
f49dbcad
MG		 2044 SCM cs;
2045
2046 SCM_NEWSMOB (cs, scm_tc16_charset, p);
63181a97
MV		 2047 scm_c_define (name, cs);
2048 return scm_permanent_object (cs);
2049}
2050
f49dbcad
MG		 2051#ifdef SCM_CHARSET_DEBUG
2052SCM_DEFINE (scm_debug_char_set, "debug-char-set", 1, 0, 0,
2053 (SCM charset),
2054 "Print out the internal C structure of @var{charset}.\n")
d5ecf579 2055#define FUNC_NAME s_scm_debug_char_set
63181a97 2056{
f49dbcad
MG		 2057 int i;
2058 scm_t_char_set *cs = SCM_CHARSET_DATA (charset);
2059 fprintf (stderr, "cs %p\n", cs);
2060 fprintf (stderr, "len %d\n", cs->len);
2061 fprintf (stderr, "arr %p\n", cs->ranges);
2062 for (i = 0; i < cs->len; i++)
63181a97 2063 {
f49dbcad
MG		 2064 if (cs->ranges[i].lo == cs->ranges[i].hi)
2065 fprintf (stderr, "%04x\n", cs->ranges[i].lo);
2066 else
2067 fprintf (stderr, "%04x..%04x\t[%d]\n",
2068 cs->ranges[i].lo,
2069 cs->ranges[i].hi, cs->ranges[i].hi - cs->ranges[i].lo + 1);
63181a97 2070 }
f49dbcad
MG		 2071 printf ("\n");
2072 return SCM_UNSPECIFIED;
63181a97 2073}
f49dbcad 2074#undef FUNC_NAME
d5ecf579 2075#endif /* SCM_CHARSET_DEBUG */
a17d2654 2076\f
f49dbcad
MG		 2077
2078
63181a97
MV		 2079void
2080scm_init_srfi_14 (void)
2081{
f49dbcad 2082 scm_tc16_charset = scm_make_smob_type ("character-set", 0);
63181a97
MV		 2083 scm_set_smob_free (scm_tc16_charset, charset_free);
2084 scm_set_smob_print (scm_tc16_charset, charset_print);
2085
f49dbcad
MG		 2086 scm_tc16_charset_cursor = scm_make_smob_type ("char-set-cursor", 0);
2087 scm_set_smob_free (scm_tc16_charset_cursor, charset_cursor_free);
2088 scm_set_smob_print (scm_tc16_charset_cursor, charset_cursor_print);
2089
2090 scm_char_set_upper_case =
2091 define_charset ("char-set:upper-case", &cs_upper_case);
2092 scm_char_set_lower_case =
2093 define_charset ("char-set:lower-case", &cs_lower_case);
2094 scm_char_set_title_case =
2095 define_charset ("char-set:title-case", &cs_title_case);
2096 scm_char_set_letter = define_charset ("char-set:letter", &cs_letter);
2097 scm_char_set_digit = define_charset ("char-set:digit", &cs_digit);
2098 scm_char_set_letter_and_digit =
2099 define_charset ("char-set:letter+digit", &cs_letter_plus_digit);
2100 scm_char_set_graphic = define_charset ("char-set:graphic", &cs_graphic);
2101 scm_char_set_printing = define_charset ("char-set:printing", &cs_printing);
2102 scm_char_set_whitespace =
2103 define_charset ("char-set:whitespace", &cs_whitespace);
2104 scm_char_set_iso_control =
2105 define_charset ("char-set:iso-control", &cs_iso_control);
2106 scm_char_set_punctuation =
2107 define_charset ("char-set:punctuation", &cs_punctuation);
2108 scm_char_set_symbol = define_charset ("char-set:symbol", &cs_symbol);
2109 scm_char_set_hex_digit =
2110 define_charset ("char-set:hex-digit", &cs_hex_digit);
2111 scm_char_set_blank = define_charset ("char-set:blank", &cs_blank);
2112 scm_char_set_ascii = define_charset ("char-set:ascii", &cs_ascii);
2113 scm_char_set_empty = define_charset ("char-set:empty", &cs_empty);
2114 scm_char_set_full = define_charset ("char-set:full", &cs_full);
63181a97
MV		 2115
2116#include "libguile/srfi-14.x"
2117}
2118
2119/* End of srfi-14.c. */
Unnamed repository; edit this file 'description' to name the repository.