/* srfi-14.c --- SRFI-14 procedures for Guile
*
- * Copyright (C) 2001 Free Software Foundation, Inc.
- *
- * This program is free software; you can redistribute it and/or
- * modify it under the terms of the GNU General Public License as
- * published by the Free Software Foundation; either version 2, or (at
- * your option) any later version.
- *
- * This program is distributed in the hope that it will be useful, but
- * WITHOUT ANY WARRANTY; without even the implied warranty of
- * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
- * General Public License for more details.
- *
- * You should have received a copy of the GNU General Public License
- * along with this software; see the file COPYING. If not, write to
- * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
- * Boston, MA 02111-1307 USA
- *
- * As a special exception, the Free Software Foundation gives
- * permission for additional uses of the text contained in its release
- * of GUILE.
+ * Copyright (C) 2001 Free Software Foundation, Inc.
*
- * The exception is that, if you link the GUILE library with other
- * files to produce an executable, this does not by itself cause the
- * resulting executable to be covered by the GNU General Public
- * License. Your use of that executable is in no way restricted on
- * account of linking the GUILE library code into it.
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public
+ * License as published by the Free Software Foundation; either
+ * version 2.1 of the License, or (at your option) any later version.
*
- * This exception does not however invalidate any other reasons why
- * the executable file might be covered by the GNU General Public
- * License.
- *
- * This exception applies only to the code released by the Free
- * Software Foundation under the name GUILE. If you copy code from
- * other Free Software Foundation releases into a copy of GUILE, as
- * the General Public License permits, the exception does not apply to
- * the code that you add in this way. To avoid misleading anyone as
- * to the status of such modified files, you must delete this
- * exception notice from them.
+ * This library is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
*
- * If you write modifications of your own for GUILE, it is your choice
- * whether to permit this exception to apply to your modifications.
- * If you do not wish that, delete this exception notice. */
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ */
#include <string.h>
#include "srfi-14.h"
-#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / sizeof (long)] |= (1 << ((idx) % sizeof (long))))
-SCM scm_char_set_copy (SCM cs);
+#define SCM_CHARSET_SET(cs, idx) \
+ (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= \
+ (1L << ((idx) % SCM_BITS_PER_LONG)))
+
+#define BYTES_PER_CHARSET (SCM_CHARSET_SIZE / 8)
+#define LONGS_PER_CHARSET (SCM_CHARSET_SIZE / SCM_BITS_PER_LONG)
+
/* Smob type code for character sets. */
int scm_tc16_charset = 0;
/* Smob print hook for character sets. */
static int
-charset_print (SCM charset, SCM port, scm_print_state *pstate)
+charset_print (SCM charset, SCM port, scm_print_state *pstate SCM_UNUSED)
{
int i;
int first = 1;
/* Smob free hook for character sets. */
-static scm_sizet
+static size_t
charset_free (SCM charset)
{
return scm_smob_free (charset);
make_char_set (const char * func_name)
{
long * p;
-
- p = scm_must_malloc (SCM_CHARSET_SIZE, func_name);
- memset (p, 0, SCM_CHARSET_SIZE);
+
+ p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
+ memset (p, 0, BYTES_PER_CHARSET);
SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
}
-SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
+SCM_DEFINE (scm_char_set_p, "char-set?", 1, 0, 0,
(SCM obj),
"Return @code{#t} if @var{obj} is a character set, @code{#f}\n"
"otherwise.")
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_eq, "char-set=", 1, 0, 1,
- (SCM cs1, SCM csr),
+SCM_DEFINE (scm_char_set_eq, "char-set=", 0, 0, 1,
+ (SCM char_sets),
"Return @code{#t} if all given character sets are equal.")
#define FUNC_NAME s_scm_char_set_eq
{
- int argnum = 2;
+ int argnum = 1;
+ long *cs1_data = NULL;
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (csr);
+ SCM_VALIDATE_REST_ARGUMENT (char_sets);
- while (!SCM_NULLP (csr))
+ while (!SCM_NULLP (char_sets))
{
- long * p1, * p2;
- SCM cs2 = SCM_CAR (csr);
- int k;
-
- SCM_VALIDATE_SMOB (argnum++, cs2, charset);
- p1 = (long *) SCM_SMOB_DATA (cs1);
- p2 = (long *) SCM_SMOB_DATA (cs2);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
- {
- if (p1[k] != p2[k])
- return SCM_BOOL_F;
- }
-
- csr = SCM_CDR (csr);
- cs1 = cs2;
+ SCM csi = SCM_CAR (char_sets);
+ long *csi_data;
+
+ SCM_VALIDATE_SMOB (argnum, csi, charset);
+ argnum++;
+ csi_data = (long *) SCM_SMOB_DATA (csi);
+ if (cs1_data == NULL)
+ cs1_data = csi_data;
+ else if (memcmp (cs1_data, csi_data, BYTES_PER_CHARSET) != 0)
+ return SCM_BOOL_F;
+ char_sets = SCM_CDR (char_sets);
}
return SCM_BOOL_T;
}
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_leq, "char-set<=", 1, 0, 1,
- (SCM cs1, SCM csr),
+SCM_DEFINE (scm_char_set_leq, "char-set<=", 0, 0, 1,
+ (SCM char_sets),
"Return @code{#t} if every character set @var{cs}i is a subset\n"
"of character set @var{cs}i+1.")
#define FUNC_NAME s_scm_char_set_leq
{
- int argnum = 2;
+ int argnum = 1;
+ long *prev_data = NULL;
- SCM_VALIDATE_SMOB (1, cs1, charset);
- SCM_VALIDATE_REST_ARGUMENT (csr);
+ SCM_VALIDATE_REST_ARGUMENT (char_sets);
- while (!SCM_NULLP (csr))
+ while (!SCM_NULLP (char_sets))
{
- long * p1, * p2;
- SCM cs2 = SCM_CAR (csr);
- int k;
+ SCM csi = SCM_CAR (char_sets);
+ long *csi_data;
- SCM_VALIDATE_SMOB (argnum++, cs2, charset);
- p1 = (long *) SCM_SMOB_DATA (cs1);
- p2 = (long *) SCM_SMOB_DATA (cs2);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ SCM_VALIDATE_SMOB (argnum, csi, charset);
+ argnum++;
+ csi_data = (long *) SCM_SMOB_DATA (csi);
+ if (prev_data)
{
- if ((p1[k] & p2[k]) != p1[k])
- return SCM_BOOL_F;
- }
+ int k;
- csr = SCM_CDR (csr);
- cs1 = cs2;
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ if ((prev_data[k] & csi_data[k]) != prev_data[k])
+ return SCM_BOOL_F;
+ }
+ }
+ prev_data = csi_data;
+ char_sets = SCM_CDR (char_sets);
}
return SCM_BOOL_T;
}
SCM_DEFINE (scm_char_set_hash, "char-set-hash", 1, 1, 0,
(SCM cs, SCM bound),
"Compute a hash value for the character set @var{cs}. If\n"
- "@var{bound} is given and not @code{#f}, it restricts the\n"
+ "@var{bound} is given and non-zero, it restricts the\n"
"returned value to the range 0 @dots{} @var{bound - 1}.")
#define FUNC_NAME s_scm_char_set_hash
{
+ const int default_bnd = 871;
int bnd;
long * p;
- unsigned val = 0;
+ unsigned long val = 0;
int k;
SCM_VALIDATE_SMOB (1, cs, charset);
- if (SCM_UNBNDP (bound) || SCM_FALSEP (bound))
- bnd = 871;
+
+ if (SCM_UNBNDP (bound))
+ bnd = default_bnd;
else
- SCM_VALIDATE_INUM_COPY (2, bound, bnd);
+ {
+ SCM_VALIDATE_INUM_MIN_COPY (2, bound, 0, bnd);
+ if (bnd == 0)
+ bnd = default_bnd;
+ }
p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < SCM_CHARSET_SIZE - 1; k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
{
- val = p[k] ^ val;
+ if (p[k] != 0)
+ val = p[k] + (val << 1);
}
return SCM_MAKINUM (val % bnd);
}
int ccursor;
SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_INUM_COPY (2, cursor, ccursor);
+ SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor);
if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
- SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor));
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
return SCM_MAKE_CHAR (ccursor);
}
#undef FUNC_NAME
int ccursor;
SCM_VALIDATE_SMOB (1, cs, charset);
- SCM_VALIDATE_INUM_COPY (2, cursor, ccursor);
+ SCM_VALIDATE_INUM_MIN_COPY (2, cursor, 0, ccursor);
if (ccursor >= SCM_CHARSET_SIZE || !SCM_CHARSET_GET (cs, ccursor))
- SCM_MISC_ERROR ("invalid character set cursor: ~A", SCM_LIST1 (cursor));
+ SCM_MISC_ERROR ("invalid character set cursor: ~A", scm_list_1 (cursor));
for (ccursor++; ccursor < SCM_CHARSET_SIZE; ccursor++)
{
if (SCM_CHARSET_GET (cs, ccursor))
{
int ccursor;
- SCM_VALIDATE_INUM_COPY (1, cursor, ccursor);
+ SCM_VALIDATE_INUM_MIN_COPY (1, cursor, 0, ccursor);
return SCM_BOOL (ccursor >= SCM_CHARSET_SIZE);
}
#undef FUNC_NAME
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
{
- knil = scm_apply (kons, SCM_LIST2 (SCM_MAKE_CHAR (k), (knil)),
- SCM_EOL);
+ knil = scm_call_2 (kons, SCM_MAKE_CHAR (k), knil);
}
return knil;
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_char_set_unfold, "char-set-unfold", 4, 1, 0,
(SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
"This is a fundamental constructor for character sets.\n"
- "@itemize\n"
- "@item @var{g} is used to generate a series of ``seed'' values \n"
+ "@itemize @bullet\n"
+ "@item @var{g} is used to generate a series of ``seed'' values\n"
"from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
"(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values. \n"
+ "when applied to one of the seed values.\n"
"@item @var{f} maps each seed value to a character. These\n"
"characters are added to the base character set @var{base_cs} to\n"
"form the result; @var{base_cs} defaults to the empty set.\n"
else
result = make_char_set (FUNC_NAME);
- tmp = scm_apply (p, seed, scm_listofnull);
+ tmp = scm_call_1 (p, seed);
while (SCM_FALSEP (tmp))
{
- SCM ch = scm_apply (f, seed, scm_listofnull);
+ SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
SCM_CHARSET_SET (result, SCM_CHAR (ch));
- seed = scm_apply (g, seed, scm_listofnull);
- tmp = scm_apply (p, seed, scm_listofnull);
+ seed = scm_call_1 (g, seed);
+ tmp = scm_call_1 (p, seed);
}
return result;
}
SCM_DEFINE (scm_char_set_unfold_x, "char-set-unfold!", 5, 0, 0,
(SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
"This is a fundamental constructor for character sets.\n"
- "@itemize\n"
+ "@itemize @bullet\n"
"@item @var{g} is used to generate a series of ``seed'' values\n"
- "from the initial seed: @var{seed}, (@var{g} @var{seed}), \n"
+ "from the initial seed: @var{seed}, (@var{g} @var{seed}),\n"
"(@var{g}^2 @var{seed}), (@var{g}^3 @var{seed}), @dots{}\n"
"@item @var{p} tells us when to stop -- when it returns true\n"
- "when applied to one of the seed values. \n"
+ "when applied to one of the seed values.\n"
"@item @var{f} maps each seed value to a character. These\n"
"characters are added to the base character set @var{base_cs} to\n"
"form the result; @var{base_cs} defaults to the empty set.\n"
SCM_VALIDATE_PROC (3, g);
SCM_VALIDATE_SMOB (5, base_cs, charset);
- tmp = scm_apply (p, seed, scm_listofnull);
+ tmp = scm_call_1 (p, seed);
while (SCM_FALSEP (tmp))
{
- SCM ch = scm_apply (f, seed, scm_listofnull);
+ SCM ch = scm_call_1 (f, seed);
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (f));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (f));
SCM_CHARSET_SET (base_cs, SCM_CHAR (ch));
- seed = scm_apply (g, seed, scm_listofnull);
- tmp = scm_apply (p, seed, scm_listofnull);
+ seed = scm_call_1 (g, seed);
+ tmp = scm_call_1 (p, seed);
}
return base_cs;
}
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
- scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
+ scm_call_1 (proc, SCM_MAKE_CHAR (k));
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
{
- SCM ch = scm_apply (proc, SCM_MAKE_CHAR (k), scm_listofnull);
+ SCM ch = scm_call_1 (proc, SCM_MAKE_CHAR (k));
if (!SCM_CHARP (ch))
- SCM_MISC_ERROR ("procedure ~S returned non-char", SCM_LIST1 (proc));
- SCM_CHARSET_SET (cs, SCM_CHAR (ch));
+ SCM_MISC_ERROR ("procedure ~S returned non-char", scm_list_1 (proc));
+ SCM_CHARSET_SET (result, SCM_CHAR (ch));
}
return result;
}
ret = make_char_set (FUNC_NAME);
p1 = (long *) SCM_SMOB_DATA (cs);
p2 = (long *) SCM_SMOB_DATA (ret);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p2[k] = p1[k];
return ret;
}
"Return a character set containing all given characters.")
#define FUNC_NAME s_scm_char_set
{
- SCM cs, ls;
+ SCM cs;
long * p;
+ int argnum = 1;
SCM_VALIDATE_REST_ARGUMENT (rest);
- ls = rest;
cs = make_char_set (FUNC_NAME);
p = (long *) SCM_SMOB_DATA (cs);
- while (!SCM_NULLP (ls))
+ while (!SCM_NULLP (rest))
{
- SCM chr = SCM_CAR (ls);
int c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
- ls = SCM_CDR (ls);
-
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ SCM_VALIDATE_CHAR_COPY (argnum, SCM_CAR (rest), c);
+ argnum++;
+ rest = SCM_CDR (rest);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
SCM chr = SCM_CAR (list);
int c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
"Convert the character list @var{list} to a character set. The\n"
"characters are added to @var{base_cs} and @var{base_cs} is\n"
"returned.")
-#define FUNC_NAME s_scm_list_to_char_set
+#define FUNC_NAME s_scm_list_to_char_set_x
{
long * p;
SCM chr = SCM_CAR (list);
int c;
- SCM_VALIDATE_CHAR_COPY (1, chr, c);
+ SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return base_cs;
}
SCM cs;
long * p;
char * s;
- int k = 0;
+ size_t k = 0;
SCM_VALIDATE_STRING (1, str);
if (SCM_UNBNDP (base_cs))
while (k < SCM_STRING_LENGTH (str))
{
int c = s[k++];
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
{
long * p;
char * s;
- int k = 0;
+ size_t k = 0;
SCM_VALIDATE_STRING (1, str);
SCM_VALIDATE_SMOB (2, base_cs, charset);
while (k < SCM_STRING_LENGTH (str))
{
int c = s[k++];
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return base_cs;
}
{
if (SCM_CHARSET_GET (cs, k))
{
- SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
- p[k / sizeof (long)] |= 1 << (k % sizeof (long));
+ p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
}
}
return ret;
{
if (SCM_CHARSET_GET (cs, k))
{
- SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
- p[k / sizeof (long)] |= 1 << (k % sizeof (long));
+ p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
}
}
return base_cs;
p = (long *) SCM_SMOB_DATA (cs);
while (clower < cupper)
{
- p[clower / sizeof (long)] |= 1 << (clower % sizeof (long));
+ p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
clower++;
}
return cs;
p = (long *) SCM_SMOB_DATA (base_cs);
while (clower < cupper)
{
- p[clower / sizeof (long)] |= 1 << (clower % sizeof (long));
+ p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
clower++;
}
return base_cs;
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
{
- SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
count++;
}
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
{
- res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (SCM_FALSEP (res))
return res;
}
for (k = 0; k < SCM_CHARSET_SIZE; k++)
if (SCM_CHARSET_GET (cs, k))
{
- SCM res = scm_apply (pred, SCM_MAKE_CHAR (k), scm_listofnull);
+ SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
return res;
}
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_char_set_delete, "char-set-delete", 1, 0, 1,
(SCM cs, SCM rest),
"Delete all character arguments from the first argument, which\n"
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / sizeof (long)] &= ~(1 << (c % sizeof (long)));
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
}
return cs;
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_char_set_adjoin_x, "char-set-adjoin!", 1, 0, 1,
(SCM cs, SCM rest),
"Add all character arguments to the first argument, which must\n"
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / sizeof (long)] |= 1 << (c % sizeof (long));
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
#undef FUNC_NAME
+
SCM_DEFINE (scm_char_set_delete_x, "char-set-delete!", 1, 0, 1,
(SCM cs, SCM rest),
"Delete all character arguments from the first argument, which\n"
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / sizeof (long)] &= ~(1 << (c % sizeof (long)));
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
}
return cs;
}
res = make_char_set (FUNC_NAME);
p = (long *) SCM_SMOB_DATA (res);
q = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] = ~q[k];
return res;
}
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
}
return res;
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 1, 0, 1,
- (SCM cs1, SCM rest),
+SCM_DEFINE (scm_char_set_intersection, "char-set-intersection", 0, 0, 1,
+ (SCM rest),
"Return the intersection of all argument character sets.")
#define FUNC_NAME s_scm_char_set_intersection
{
- int c = 2;
SCM res;
- long * p;
- SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- res = scm_char_set_copy (cs1);
- p = (long *) SCM_SMOB_DATA (res);
- while (!SCM_NULLP (rest))
+ if (SCM_NULLP (rest))
+ res = make_char_set (FUNC_NAME);
+ else
{
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
+ long *p;
+ int argnum = 2;
+
+ res = scm_char_set_copy (SCM_CAR (rest));
+ p = (long *) SCM_SMOB_DATA (res);
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
- p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ while (SCM_CONSP (rest))
+ {
+ int k;
+ SCM cs = SCM_CAR (rest);
+ long *cs_data;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = (long *) SCM_SMOB_DATA (cs);
+ rest = SCM_CDR (rest);
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] &= cs_data[k];
+ }
}
+
return res;
}
#undef FUNC_NAME
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
}
return res;
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the exclusive--or of all argument character sets.")
+SCM_DEFINE (scm_char_set_xor, "char-set-xor", 0, 0, 1,
+ (SCM rest),
+ "Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor
{
- int c = 2;
SCM res;
- long * p;
- SCM_VALIDATE_SMOB (1, cs1, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- res = scm_char_set_copy (cs1);
- p = (long *) SCM_SMOB_DATA (res);
- while (!SCM_NULLP (rest))
+ if (SCM_NULLP (rest))
+ res = make_char_set (FUNC_NAME);
+ else
{
- int k;
- SCM cs = SCM_CAR (rest);
- SCM_VALIDATE_SMOB (c, cs, charset);
- c++;
+ int argnum = 2;
+ long * p;
+
+ res = scm_char_set_copy (SCM_CAR (rest));
+ p = (long *) SCM_SMOB_DATA (res);
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
- p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
+ while (SCM_CONSP (rest))
+ {
+ SCM cs = SCM_CAR (rest);
+ long *cs_data;
+ int k;
+
+ SCM_VALIDATE_SMOB (argnum, cs, charset);
+ argnum++;
+ cs_data = (long *) SCM_SMOB_DATA (cs);
+ rest = SCM_CDR (rest);
+
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ p[k] ^= cs_data[k];
+ }
}
return res;
}
SCM_VALIDATE_REST_ARGUMENT (rest);
res1 = scm_char_set_copy (cs1);
- res2 = scm_char_set_copy (cs1);
+ res2 = make_char_set (FUNC_NAME);
p = (long *) SCM_SMOB_DATA (res1);
q = (long *) SCM_SMOB_DATA (res2);
while (!SCM_NULLP (rest))
{
int k;
SCM cs = SCM_CAR (rest);
+ long *r;
+
SCM_VALIDATE_SMOB (c, cs, charset);
c++;
- rest = SCM_CDR (rest);
+ r = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
{
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
- q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ q[k] |= p[k] & r[k];
+ p[k] &= ~r[k];
}
+ rest = SCM_CDR (rest);
}
- return scm_values (SCM_LIST2 (res1, res2));
+ return scm_values (scm_list_2 (res1, res2));
}
#undef FUNC_NAME
SCM_VALIDATE_SMOB (1, cs, charset);
p = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] = ~p[k];
return cs;
}
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] |= ((long *) SCM_SMOB_DATA (cs))[k];
}
return cs1;
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
}
return cs1;
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
}
return cs1;
SCM_DEFINE (scm_char_set_xor_x, "char-set-xor!", 1, 0, 1,
(SCM cs1, SCM rest),
- "Return the exclusive--or of all argument character sets.")
+ "Return the exclusive-or of all argument character sets.")
#define FUNC_NAME s_scm_char_set_xor_x
{
+ /* a side-effecting variant should presumably give consistent results:
+ (define a (char-set #\a))
+ (char-set-xor a a a) -> char set #\a
+ (char-set-xor! a a a) -> char set #\a
+ */
+ return scm_char_set_xor (scm_cons (cs1, rest));
+
+#if 0
+ /* this would give (char-set-xor! a a a) -> empty char set. */
int c = 2;
long * p;
c++;
rest = SCM_CDR (rest);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
p[k] ^= ((long *) SCM_SMOB_DATA (cs))[k];
}
return cs1;
+#endif
}
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 1, 0, 1,
- (SCM cs1, SCM rest),
- "Return the difference and the intersection of all argument character sets.")
+SCM_DEFINE (scm_char_set_diff_plus_intersection_x, "char-set-diff+intersection!", 2, 0, 1,
+ (SCM cs1, SCM cs2, SCM rest),
+ "Return the difference and the intersection of all argument\n"
+ "character sets.")
#define FUNC_NAME s_scm_char_set_diff_plus_intersection_x
{
- int c = 2;
- SCM res2;
+ int c = 3;
long * p, * q;
+ int k;
SCM_VALIDATE_SMOB (1, cs1, charset);
+ SCM_VALIDATE_SMOB (2, cs2, charset);
SCM_VALIDATE_REST_ARGUMENT (rest);
- res2 = scm_char_set_copy (cs1);
p = (long *) SCM_SMOB_DATA (cs1);
- q = (long *) SCM_SMOB_DATA (res2);
+ q = (long *) SCM_SMOB_DATA (cs2);
+ if (p == q)
+ {
+ /* (char-set-diff+intersection! a a ...): can't share storage,
+ but we know the answer without checking for further
+ arguments. */
+ return scm_values (scm_list_2 (make_char_set (FUNC_NAME), cs1));
+ }
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
+ {
+ long t = p[k];
+
+ p[k] &= ~q[k];
+ q[k] = t & q[k];
+ }
while (!SCM_NULLP (rest))
{
- int k;
SCM cs = SCM_CAR (rest);
+ long *r;
+
SCM_VALIDATE_SMOB (c, cs, charset);
c++;
- rest = SCM_CDR (rest);
+ r = (long *) SCM_SMOB_DATA (cs);
- for (k = 0; k < SCM_CHARSET_SIZE / sizeof (long); k++)
+ for (k = 0; k < LONGS_PER_CHARSET; k++)
{
- p[k] &= ~((long *) SCM_SMOB_DATA (cs))[k];
- q[k] &= ((long *) SCM_SMOB_DATA (cs))[k];
+ q[k] |= p[k] & r[k];
+ p[k] &= ~r[k];
}
+ rest = SCM_CDR (rest);
}
- return scm_values (SCM_LIST2 (cs1, res2));
+ return scm_values (scm_list_2 (cs1, cs2));
}
#undef FUNC_NAME
+/* Create the charset smob type. */
void
-scm_init_srfi_14 (void)
+scm_c_init_srfi_14 (void)
{
- scm_tc16_charset = scm_make_smob_type ("character-set",
- SCM_CHARSET_SIZE * sizeof (long));
- scm_set_smob_free (scm_tc16_charset, charset_free);
- scm_set_smob_print (scm_tc16_charset, charset_print);
+ /* Charset smob creation is protected by this variable because this
+ function can be both called from the SRFI-13 and SRFI-14
+ initialization functions. This is because the SRFI-13 procedures
+ access the charset smob type code. */
+ static int initialized = 0;
-#ifndef SCM_MAGIC_SNARFER
-#include "srfi-14.x"
-#endif
+ if (!initialized)
+ {
+ scm_tc16_charset = scm_make_smob_type ("character-set",
+ BYTES_PER_CHARSET);
+ scm_set_smob_free (scm_tc16_charset, charset_free);
+ scm_set_smob_print (scm_tc16_charset, charset_print);
+ initialized = 1;
+ }
+}
+
+
+/* Initialize the SRFI-14 module. This function will be called by the
+ loading Scheme module. */
+void
+scm_init_srfi_14 (void)
+{
+#if 0
+ fprintf(stderr, "bytes-per-charset: %d\n", BYTES_PER_CHARSET);
+ fprintf(stderr, "bits-per-long: %d\n", SCM_BITS_PER_LONG);
+ fprintf(stderr, "longs-per-charset: %d\n", LONGS_PER_CHARSET);
+ fflush (stderr);
+#endif /* 0 */
+
+ /* Do the smob type initialization. */
+ scm_c_init_srfi_14 ();
+
+ /* Install the charset primitives. */
+#include "srfi/srfi-14.x"
}
+
+/* End of srfi-14.c. */
HCoop / bpt / guile.git / blobdiff