srfi/srfi-14.c

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