HCoop / bpt / guile.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
* srfi-13.c (scm_init_srfi_13), srfi-14.c (scm_init_srfi_14):
[bpt/guile.git] / srfi / srfi-14.c
CommitLineData
ca003b26
MG		 1/* srfi-14.c --- SRFI-14 procedures for Guile
2 *
3 * Copyright (C) 2001 Free Software Foundation, Inc.
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
63charset_print (SCM charset, SCM port, scm_print_state *pstate)
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. */
84static scm_sizet
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))
240 SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor));
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))
259 SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor));
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 {
298 knil = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (k), (knil)),
299 SCM_EOL);
300 }
301 return knil;
302}
303#undef FUNC_NAME
304
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"
308 "@itemize\n"
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
333 tmp = scm_apply (p, seed, scm_listofnull);
334 while (SCM_FALSEP (tmp))
335 {
336 SCM ch = scm_apply (f, seed, scm_listofnull);
337 if (!SCM_CHARP (ch))
338 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
339 SCM_CHARSET_SET (result, SCM_CHAR (ch));
340
341 seed = scm_apply (g, seed, scm_listofnull);
342 tmp = scm_apply (p, seed, scm_listofnull);
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"
352 "@itemize\n"
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
371 tmp = scm_apply (p, seed, scm_listofnull);
372 while (SCM_FALSEP (tmp))
373 {
374 SCM ch = scm_apply (f, seed, scm_listofnull);
375 if (!SCM_CHARP (ch))
376 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
377 SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
378
379 seed = scm_apply (g, seed, scm_listofnull);
380 tmp = scm_apply (p, seed, scm_listofnull);
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))
400 scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
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 {
422 SCM ch = scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
423 if (!SCM_CHARP (ch))
424 SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
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 {
623 SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
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 {
652 SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
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 {
790 SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
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 {
872 res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
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 {
895 SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
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
931SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
932 (SCM cs, SCM rest),
933 "Delete all character arguments from the first argument, which\n"
934 "must be a character set.")
935#define FUNC_NAME s_scm_char_set_delete
936{
937 long * p;
938
939 SCM_VALIDATE_SMOB (1, cs, charset);
940 SCM_VALIDATE_REST_ARGUMENT (rest);
941 cs = scm_char_set_copy (cs);
942
943 p = (long *) SCM_SMOB_DATA (cs);
944 while (!SCM_NULLP (rest))
945 {
946 SCM chr = SCM_CAR (rest);
947 int c;
948
949 SCM_VALIDATE_CHAR_COPY (1, chr, c);
950 rest = SCM_CDR (rest);
951
952 p[c / sizeof (long)] &= ~(1 << (c % sizeof (long)));
953 }
954 return cs;
955}
956#undef FUNC_NAME
957
958SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
959 (SCM cs, SCM rest),
960 "Add all character arguments to the first argument, which must\n"
961 "be a character set.")
962#define FUNC_NAME s_scm_char_set_adjoin_x
963{
964 long * p;
965
966 SCM_VALIDATE_SMOB (1, cs, charset);
967 SCM_VALIDATE_REST_ARGUMENT (rest);
968
969 p = (long *) SCM_SMOB_DATA (cs);
970 while (!SCM_NULLP (rest))
971 {
972 SCM chr = SCM_CAR (rest);
973 int c;
974
975 SCM_VALIDATE_CHAR_COPY (1, chr, c);
976 rest = SCM_CDR (rest);
977
978 p[c / sizeof (long)] |= 1 << (c % sizeof (long));
979 }
980 return cs;
981}
982#undef FUNC_NAME
983
984SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
985 (SCM cs, SCM rest),
986 "Delete all character arguments from the first argument, which\n"
987 "must be a character set.")
988#define FUNC_NAME s_scm_char_set_delete_x
989{
990 long * p;
991
992 SCM_VALIDATE_SMOB (1, cs, charset);
993 SCM_VALIDATE_REST_ARGUMENT (rest);
994
995 p = (long *) SCM_SMOB_DATA (cs);
996 while (!SCM_NULLP (rest))
997 {
998 SCM chr = SCM_CAR (rest);
999 int c;
1000
1001 SCM_VALIDATE_CHAR_COPY (1, chr, c);
1002 rest = SCM_CDR (rest);
1003
1004 p[c / sizeof (long)] &= ~(1 << (c % sizeof (long)));
1005 }
1006 return cs;
1007}
1008#undef FUNC_NAME
1009
1010
1011SCM_DEFINE (scm_char_set_complement, "char-set-complement", 1, 0, 0,
1012 (SCM cs),
1013 "Return the complement of the character set @var{cs}.")
1014#define FUNC_NAME s_scm_char_set_complement
1015{
1016 int k;
1017 SCM res;
1018 long * p, * q;
1019
1020 SCM_VALIDATE_SMOB (1, cs, charset);
1021
1022 res = make_char_set (FUNC_NAME);
1023 p = (long *) SCM_SMOB_DATA (res);
1024 q = (long *) SCM_SMOB_DATA (cs);
1025 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1026 p[k] = ~q[k];
1027 return res;
1028}
1029#undef FUNC_NAME
1030
1031
1032SCM_DEFINE (scm_char_set_union, "char-set-union", 0, 0, 1,
1033 (SCM rest),
1034 "Return the union of all argument character sets.")
1035#define FUNC_NAME s_scm_char_set_union
1036{
1037 int c = 1;
1038 SCM res;
1039 long * p;
1040
1041 SCM_VALIDATE_REST_ARGUMENT (rest);
1042
1043 res = make_char_set (FUNC_NAME);
1044 p = (long *) SCM_SMOB_DATA (res);
1045 while (!SCM_NULLP (rest))
1046 {
1047 int k;
1048 SCM cs = SCM_CAR (rest);
1049 SCM_VALIDATE_SMOB (c, cs, charset);
1050 c++;
1051 rest = SCM_CDR (rest);
1052
1053 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1054 p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
1055 }
1056 return res;
1057}
1058#undef FUNC_NAME
1059
1060
1061SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 1, 0, 1,
1062 (SCM cs1, SCM rest),
1063 "Return the intersection of all argument character sets.")
1064#define FUNC_NAME s_scm_char_set_intersection
1065{
1066 int c = 2;
1067 SCM res;
1068 long * p;
1069
1070 SCM_VALIDATE_SMOB (1, cs1, charset);
1071 SCM_VALIDATE_REST_ARGUMENT (rest);
1072
1073 res = scm_char_set_copy (cs1);
1074 p = (long *) SCM_SMOB_DATA (res);
1075 while (!SCM_NULLP (rest))
1076 {
1077 int k;
1078 SCM cs = SCM_CAR (rest);
1079 SCM_VALIDATE_SMOB (c, cs, charset);
1080 c++;
1081 rest = SCM_CDR (rest);
1082
1083 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1084 p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
1085 }
1086 return res;
1087}
1088#undef FUNC_NAME
1089
1090
1091SCM_DEFINE (scm_char_set_difference, "char-set-difference", 1, 0, 1,
1092 (SCM cs1, SCM rest),
1093 "Return the difference of all argument character sets.")
1094#define FUNC_NAME s_scm_char_set_difference
1095{
1096 int c = 2;
1097 SCM res;
1098 long * p;
1099
1100 SCM_VALIDATE_SMOB (1, cs1, charset);
1101 SCM_VALIDATE_REST_ARGUMENT (rest);
1102
1103 res = scm_char_set_copy (cs1);
1104 p = (long *) SCM_SMOB_DATA (res);
1105 while (!SCM_NULLP (rest))
1106 {
1107 int k;
1108 SCM cs = SCM_CAR (rest);
1109 SCM_VALIDATE_SMOB (c, cs, charset);
1110 c++;
1111 rest = SCM_CDR (rest);
1112
1113 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1114 p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
1115 }
1116 return res;
1117}
1118#undef FUNC_NAME
1119
1120
1121SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1,
1122 (SCM cs1, SCM rest),
1123 "Return the exclusive--or of all argument character sets.")
1124#define FUNC_NAME s_scm_char_set_xor
1125{
1126 int c = 2;
1127 SCM res;
1128 long * p;
1129
1130 SCM_VALIDATE_SMOB (1, cs1, charset);
1131 SCM_VALIDATE_REST_ARGUMENT (rest);
1132
1133 res = scm_char_set_copy (cs1);
1134 p = (long *) SCM_SMOB_DATA (res);
1135 while (!SCM_NULLP (rest))
1136 {
1137 int k;
1138 SCM cs = SCM_CAR (rest);
1139 SCM_VALIDATE_SMOB (c, cs, charset);
1140 c++;
1141 rest = SCM_CDR (rest);
1142
1143 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1144 p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
1145 }
1146 return res;
1147}
1148#undef FUNC_NAME
1149
1150
1151SCM_DEFINE (scm_char_set_diff_plus_intersection, "char-set-diff+intersection", 1, 0, 1,
1152 (SCM cs1, SCM rest),
1153 "Return the difference and the intersection of all argument\n"
1154 "character sets.")
1155#define FUNC_NAME s_scm_char_set_diff_plus_intersection
1156{
1157 int c = 2;
1158 SCM res1, res2;
1159 long * p, * q;
1160
1161 SCM_VALIDATE_SMOB (1, cs1, charset);
1162 SCM_VALIDATE_REST_ARGUMENT (rest);
1163
1164 res1 = scm_char_set_copy (cs1);
1165 res2 = scm_char_set_copy (cs1);
1166 p = (long *) SCM_SMOB_DATA (res1);
1167 q = (long *) SCM_SMOB_DATA (res2);
1168 while (!SCM_NULLP (rest))
1169 {
1170 int k;
1171 SCM cs = SCM_CAR (rest);
1172 SCM_VALIDATE_SMOB (c, cs, charset);
1173 c++;
1174 rest = SCM_CDR (rest);
1175
1176 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1177 {
1178 p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
1179 q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
1180 }
1181 }
1182 return scm_values (SCM_LIST2 (res1, res2));
1183}
1184#undef FUNC_NAME
1185
1186
1187SCM_DEFINE (scm_char_set_complement_x, "char-set-complement!", 1, 0, 0,
1188 (SCM cs),
1189 "Return the complement of the character set @var{cs}.")
1190#define FUNC_NAME s_scm_char_set_complement_x
1191{
1192 int k;
1193 long * p;
1194
1195 SCM_VALIDATE_SMOB (1, cs, charset);
1196 p = (long *) SCM_SMOB_DATA (cs);
1197 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1198 p[k] = ~p[k];
1199 return cs;
1200}
1201#undef FUNC_NAME
1202
1203
1204SCM_DEFINE (scm_char_set_union_x, "char-set-union!", 1, 0, 1,
1205 (SCM cs1, SCM rest),
1206 "Return the union of all argument character sets.")
1207#define FUNC_NAME s_scm_char_set_union_x
1208{
1209 int c = 2;
1210 long * p;
1211
1212 SCM_VALIDATE_SMOB (1, cs1, charset);
1213 SCM_VALIDATE_REST_ARGUMENT (rest);
1214
1215 p = (long *) SCM_SMOB_DATA (cs1);
1216 while (!SCM_NULLP (rest))
1217 {
1218 int k;
1219 SCM cs = SCM_CAR (rest);
1220 SCM_VALIDATE_SMOB (c, cs, charset);
1221 c++;
1222 rest = SCM_CDR (rest);
1223
1224 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1225 p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
1226 }
1227 return cs1;
1228}
1229#undef FUNC_NAME
1230
1231
1232SCM_DEFINE (scm_char_set_intersection_x, "char-set-intersection!", 1, 0, 1,
1233 (SCM cs1, SCM rest),
1234 "Return the intersection of all argument character sets.")
1235#define FUNC_NAME s_scm_char_set_intersection_x
1236{
1237 int c = 2;
1238 long * p;
1239
1240 SCM_VALIDATE_SMOB (1, cs1, charset);
1241 SCM_VALIDATE_REST_ARGUMENT (rest);
1242
1243 p = (long *) SCM_SMOB_DATA (cs1);
1244 while (!SCM_NULLP (rest))
1245 {
1246 int k;
1247 SCM cs = SCM_CAR (rest);
1248 SCM_VALIDATE_SMOB (c, cs, charset);
1249 c++;
1250 rest = SCM_CDR (rest);
1251
1252 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1253 p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
1254 }
1255 return cs1;
1256}
1257#undef FUNC_NAME
1258
1259
1260SCM_DEFINE (scm_char_set_difference_x, "char-set-difference!", 1, 0, 1,
1261 (SCM cs1, SCM rest),
1262 "Return the difference of all argument character sets.")
1263#define FUNC_NAME s_scm_char_set_difference_x
1264{
1265 int c = 2;
1266 long * p;
1267
1268 SCM_VALIDATE_SMOB (1, cs1, charset);
1269 SCM_VALIDATE_REST_ARGUMENT (rest);
1270
1271 p = (long *) SCM_SMOB_DATA (cs1);
1272 while (!SCM_NULLP (rest))
1273 {
1274 int k;
1275 SCM cs = SCM_CAR (rest);
1276 SCM_VALIDATE_SMOB (c, cs, charset);
1277 c++;
1278 rest = SCM_CDR (rest);
1279
1280 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1281 p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
1282 }
1283 return cs1;
1284}
1285#undef FUNC_NAME
1286
1287
1288SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
1289 (SCM cs1, SCM rest),
1290 "Return the exclusive--or of all argument character sets.")
1291#define FUNC_NAME s_scm_char_set_xor_x
1292{
1293 int c = 2;
1294 long * p;
1295
1296 SCM_VALIDATE_SMOB (1, cs1, charset);
1297 SCM_VALIDATE_REST_ARGUMENT (rest);
1298
1299 p = (long *) SCM_SMOB_DATA (cs1);
1300 while (!SCM_NULLP (rest))
1301 {
1302 int k;
1303 SCM cs = SCM_CAR (rest);
1304 SCM_VALIDATE_SMOB (c, cs, charset);
1305 c++;
1306 rest = SCM_CDR (rest);
1307
1308 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1309 p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
1310 }
1311 return cs1;
1312}
1313#undef FUNC_NAME
1314
1315
1316SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1,
1317 (SCM cs1, SCM rest),
1318 "Return the difference and the intersection of all argument character sets.")
1319#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
1320{
1321 int c = 2;
1322 SCM res2;
1323 long * p, * q;
1324
1325 SCM_VALIDATE_SMOB (1, cs1, charset);
1326 SCM_VALIDATE_REST_ARGUMENT (rest);
1327
1328 res2 = scm_char_set_copy (cs1);
1329 p = (long *) SCM_SMOB_DATA (cs1);
1330 q = (long *) SCM_SMOB_DATA (res2);
1331 while (!SCM_NULLP (rest))
1332 {
1333 int k;
1334 SCM cs = SCM_CAR (rest);
1335 SCM_VALIDATE_SMOB (c, cs, charset);
1336 c++;
1337 rest = SCM_CDR (rest);
1338
1339 for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
1340 {
1341 p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
1342 q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
1343 }
1344 }
1345 return scm_values (SCM_LIST2 (cs1, res2));
1346}
1347#undef FUNC_NAME
1348
1349
1350void
653c7291 1351scm_init_srfi_14 (void)
ca003b26
MG		 1352{
1353 scm_tc16_charset = scm_make_smob_type ("character-set",
1354 SCM_CHARSET_SIZE * sizeof (long));
1355 scm_set_smob_free (scm_tc16_charset, charset_free);
1356 scm_set_smob_print (scm_tc16_charset, charset_print);
1357
1358#ifndef SCM_MAGIC_SNARFER
485efc12 1359#include "srfi/srfi-14.x"
ca003b26
MG		 1360#endif
1361}
Unnamed repository; edit this file 'description' to name the repository.