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