#include "srfi-14.h"
-#define SCM_CHARSET_SET(cs, idx) (((long *) SCM_SMOB_DATA (cs))[(idx) / SCM_BITS_PER_LONG] |= (1 << ((idx) % SCM_BITS_PER_LONG)))
-
+#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)
{
long * p;
- p = scm_must_malloc (BYTES_PER_CHARSET, func_name);
+ p = scm_gc_malloc (BYTES_PER_CHARSET, "character-set");
memset (p, 0, BYTES_PER_CHARSET);
SCM_RETURN_NEWSMOB (scm_tc16_charset, p);
}
const int default_bnd = 871;
int bnd;
long * p;
- unsigned val = 0;
+ unsigned long val = 0;
int k;
SCM_VALIDATE_SMOB (1, cs, charset);
(SCM p, SCM f, SCM g, SCM seed, SCM base_cs),
"This is a fundamental constructor for character sets.\n"
"@itemize @bullet\n"
- "@item @var{g} is used to generate a series of ``seed'' values \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"
"This is a fundamental constructor for character sets.\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_CHAR_COPY (argnum, SCM_CAR (rest), c);
argnum++;
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
SCM_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_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_VALIDATE_CHAR_COPY (0, chr, c);
list = SCM_CDR (list);
- p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_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 / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_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 / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return base_cs;
}
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
- p[k / SCM_BITS_PER_LONG] |= 1 << (k % SCM_BITS_PER_LONG);
+ p[k / SCM_BITS_PER_LONG] |= 1L << (k % SCM_BITS_PER_LONG);
}
}
return ret;
SCM res = scm_call_1 (pred, SCM_MAKE_CHAR (k));
if (!SCM_FALSEP (res))
- p[k / SCM_BITS_PER_LONG] |= 1 << (k % SCM_BITS_PER_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 / SCM_BITS_PER_LONG] |= 1 << (clower % SCM_BITS_PER_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 / SCM_BITS_PER_LONG] |= 1 << (clower % SCM_BITS_PER_LONG);
+ p[clower / SCM_BITS_PER_LONG] |= 1L << (clower % SCM_BITS_PER_LONG);
clower++;
}
return base_cs;
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] &= ~(1 << (c % SCM_BITS_PER_LONG));
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
}
return cs;
}
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] |= 1 << (c % SCM_BITS_PER_LONG);
+ p[c / SCM_BITS_PER_LONG] |= 1L << (c % SCM_BITS_PER_LONG);
}
return cs;
}
SCM_VALIDATE_CHAR_COPY (1, chr, c);
rest = SCM_CDR (rest);
- p[c / SCM_BITS_PER_LONG] &= ~(1 << (c % SCM_BITS_PER_LONG));
+ p[c / SCM_BITS_PER_LONG] &= ~(1L << (c % SCM_BITS_PER_LONG));
}
return cs;
}
#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 < LONGS_PER_CHARSET; 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
#undef FUNC_NAME
-SCM_DEFINE (scm_char_set_xor, "char-set-xor", 1, 0, 1,
- (SCM cs1, SCM rest),
+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 < LONGS_PER_CHARSET; 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 < 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_list_2 (res1, res2));
}
"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;
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),
+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 < 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_list_2 (cs1, res2));
+ return scm_values (scm_list_2 (cs1, cs2));
}
#undef FUNC_NAME
HCoop / bpt / guile.git / blobdiff