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