-/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009 Free Software Foundation, Inc.
- *
+/* Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008, 2009,
+ * 2010, 2011, 2014 Free Software Foundation, Inc.
+ *
* 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 3 of
#include <ctype.h>
#include <limits.h>
#include <unicase.h>
+#include <unictype.h>
#include "libguile/_scm.h"
#include "libguile/validate.h"
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff code point of @var{x} is equal to the code point\n"
- "of @var{y}, else @code{#f}.\n")
-#define FUNC_NAME s_scm_char_eq_p
+static SCM scm_i_char_eq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_eq_p, "char=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is equal to the\n"
+ "code point of @var{y}, else @code{#f}.\n")
+#define FUNC_NAME s_scm_i_char_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the code point of @var{x} is less than the code\n"
- "point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_less_p
+static SCM scm_i_char_less_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_less_p, "char<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the code point of @var{x} is less than the code\n"
+ "point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the code point of @var{x} is less than or equal\n"
- "to the code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_leq_p
+static SCM scm_i_char_leq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_leq_p, "char<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is less than or\n"
+ "equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the code point of @var{x} is greater than the\n"
- "code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_gr_p
+static SCM scm_i_char_gr_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_gr_p, "char>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the code point of @var{x} is greater than or\n"
- "equal to the code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_geq_p
+static SCM scm_i_char_geq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_geq_p, "char>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the Unicode code point of @var{x} is greater than\n"
+ "or equal to the code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
implementation would be to use that table and make a char-foldcase
function. */
-SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is the same\n"
- "as the case-folded code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_eq_p
+static SCM scm_i_char_ci_eq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_ci_eq_p, "char-ci=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "the same as the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_eq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_eq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_eq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_eq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_eq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is less\n"
- "than the case-folded code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_less_p
+static SCM scm_i_char_ci_less_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_ci_less_p, "char-ci<?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} if the case-folded Unicode code point of @var{x} is\n"
+ "less than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_less_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_less_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_less_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_less_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_less_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is less\n"
- "than or equal to the case-folded code point of @var{y}, else\n"
- "@code{#f}")
-#define FUNC_NAME s_scm_char_ci_leq_p
+static SCM scm_i_char_ci_leq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_ci_leq_p, "char-ci<=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
+ "less than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}")
+#define FUNC_NAME s_scm_i_char_ci_leq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_leq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_leq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_leq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_leq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
- "than the case-folded code point of @var{y}, else @code{#f}.")
-#define FUNC_NAME s_scm_char_ci_gr_p
+static SCM scm_i_char_ci_gr_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_ci_gr_p, "char-ci>?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
+ "than the case-folded code point of @var{y}, else @code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_gr_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_gr_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_gr_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_gr_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_gr_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
- (SCM x, SCM y),
- "Return @code{#t} iff the case-folded code point of @var{x} is greater\n"
- "than or equal to the case-folded code point of @var{y}, else\n"
- "@code{#f}.")
-#define FUNC_NAME s_scm_char_ci_geq_p
+static SCM scm_i_char_ci_geq_p (SCM x, SCM y, SCM rest);
+SCM_DEFINE (scm_i_char_ci_geq_p, "char-ci>=?", 0, 2, 1,
+ (SCM x, SCM y, SCM rest),
+ "Return @code{#t} iff the case-folded Unicode code point of @var{x} is\n"
+ "greater than or equal to the case-folded code point of @var{y}, else\n"
+ "@code{#f}.")
+#define FUNC_NAME s_scm_i_char_ci_geq_p
+{
+ if (SCM_UNBNDP (x) || SCM_UNBNDP (y))
+ return SCM_BOOL_T;
+ while (!scm_is_null (rest))
+ {
+ if (scm_is_false (scm_char_ci_geq_p (x, y)))
+ return SCM_BOOL_F;
+ x = y;
+ y = scm_car (rest);
+ rest = scm_cdr (rest);
+ }
+ return scm_char_ci_geq_p (x, y);
+}
+#undef FUNC_NAME
+
+SCM scm_char_ci_geq_p (SCM x, SCM y)
+#define FUNC_NAME s_scm_i_char_ci_geq_p
{
SCM_VALIDATE_CHAR (1, x);
SCM_VALIDATE_CHAR (2, y);
}
#undef FUNC_NAME
-
SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
(SCM chr),
- "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n")
+ "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else\n"
+ "@code{#f}.\n")
#define FUNC_NAME s_scm_char_is_both_p
{
if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
(SCM chr),
- "Return the code point of @var{chr}.")
+ "Return the Unicode code point of @var{chr}.")
#define FUNC_NAME s_scm_char_to_integer
{
SCM_VALIDATE_CHAR (1, chr);
SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
(SCM n),
- "Return the character that has code point @var{n}. The integer @var{n}\n"
- "must be a valid code point. Valid code points are in the ranges 0 to\n"
- "@code{#xD7FF} inclusive or @code{#xE000} to @code{#x10FFFF} inclusive.")
+ "Return the character that has Unicode code point @var{n}. The integer\n"
+ "@var{n} must be a valid code point. Valid code points are in the\n"
+ "ranges 0 to @code{#xD7FF} inclusive or @code{#xE000} to\n"
+ "@code{#x10FFFF} inclusive.")
#define FUNC_NAME s_scm_integer_to_char
{
scm_t_wchar cn;
}
#undef FUNC_NAME
+SCM_DEFINE (scm_char_titlecase, "char-titlecase", 1, 0, 0,
+ (SCM chr),
+ "Return the titlecase character version of @var{chr}.")
+#define FUNC_NAME s_scm_char_titlecase
+{
+ SCM_VALIDATE_CHAR (1, chr);
+ return SCM_MAKE_CHAR (scm_c_titlecase (SCM_CHAR(chr)));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_char_general_category, "char-general-category", 1, 0, 0,
+ (SCM chr),
+ "Return a symbol representing the Unicode general category of "
+ "@var{chr} or @code{#f} if a named category cannot be found.")
+#define FUNC_NAME s_scm_char_general_category
+{
+ const char *sym;
+ uc_general_category_t cat;
+
+ SCM_VALIDATE_CHAR (1, chr);
+ cat = uc_general_category (SCM_CHAR (chr));
+ sym = uc_general_category_name (cat);
+
+ if (sym != NULL)
+ return scm_from_utf8_symbol (sym);
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
\f
return uc_tolower ((int) c);
}
+scm_t_wchar
+scm_c_titlecase (scm_t_wchar c)
+{
+ return uc_totitle ((int) c);
+}
+
\f
/* There are a few sets of character names: R5RS, Guile
"space", "newline"
};
-static const scm_t_uint32 const scm_r5rs_charnums[] = {
- 0x20, 0x0A
+static const scm_t_uint32 scm_r5rs_charnums[] = {
+ 0x20, 0x0a
};
#define SCM_N_R5RS_CHARNAMES (sizeof (scm_r5rs_charnames) / sizeof (char *))
+static const char *const scm_r6rs_charnames[] = {
+ "nul", "alarm", "backspace", "tab", "linefeed", "vtab", "page",
+ "return", "esc", "delete"
+ /* 'space' and 'newline' are already included from the R5RS list. */
+};
+
+static const scm_t_uint32 scm_r6rs_charnums[] = {
+ 0x00, 0x07, 0x08, 0x09, 0x0a, 0x0b, 0x0c,
+ 0x0d, 0x1b, 0x7f
+};
+
+#define SCM_N_R6RS_CHARNAMES (sizeof (scm_r6rs_charnames) / sizeof (char *))
+
+static const char *const scm_r7rs_charnames[] = {
+ "escape"
+};
+
+static const scm_t_uint32 scm_r7rs_charnums[] = {
+ 0x1b
+};
+
+#define SCM_N_R7RS_CHARNAMES (sizeof (scm_r7rs_charnames) / sizeof (char *))
+
/* The abbreviated names for control characters. */
static const char *const scm_C0_control_charnames[] = {
/* C0 controls */
"sp", "del"
};
-static const scm_t_uint32 const scm_C0_control_charnums[] = {
+static const scm_t_uint32 scm_C0_control_charnums[] = {
0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07,
0x08, 0x09, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f,
0x10, 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17,
#define SCM_N_C0_CONTROL_CHARNAMES (sizeof (scm_C0_control_charnames) / sizeof (char *))
static const char *const scm_alt_charnames[] = {
- "null", "backspace", "tab", "nl", "newline", "np", "page", "return",
+ "null", "nl", "np"
};
-static const scm_t_uint32 const scm_alt_charnums[] = {
- 0x00, 0x08, 0x09, 0x0a, 0x0a, 0x0c, 0x0c, 0x0d
+static const scm_t_uint32 scm_alt_charnums[] = {
+ 0x00, 0x0a, 0x0c
};
#define SCM_N_ALT_CHARNAMES (sizeof (scm_alt_charnames) / sizeof (char *))
if (scm_r5rs_charnums[c] == i)
return scm_r5rs_charnames[c];
+ for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
+ if (scm_r6rs_charnums[c] == i)
+ return scm_r6rs_charnames[c];
+
+ for (c = 0; c < SCM_N_R7RS_CHARNAMES; c++)
+ if (scm_r7rs_charnums[c] == i)
+ return scm_r7rs_charnames[c];
+
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if (scm_C0_control_charnums[c] == i)
return scm_C0_control_charnames[c];
+ /* Since the characters in scm_alt_charnums is a subset of
+ scm_C0_control_charnums, this code is never reached. */
for (c = 0; c < SCM_N_ALT_CHARNAMES; c++)
if (scm_alt_charnums[c] == i)
- return scm_alt_charnames[i];
+ return scm_alt_charnames[c];
return NULL;
}
{
size_t c;
- /* The R5RS charnames. These are supposed to be case
- insensitive. */
+ /* The R5RS charnames. These are supposed to be case insensitive. */
for (c = 0; c < SCM_N_R5RS_CHARNAMES; c++)
if ((strlen (scm_r5rs_charnames[c]) == charname_len)
&& (!strncasecmp (scm_r5rs_charnames[c], charname, charname_len)))
return SCM_MAKE_CHAR (scm_r5rs_charnums[c]);
- /* Then come the controls. These are not case sensitive. */
+ /* The R6RS charnames. R6RS says that these should be case-sensitive.
+ They are left as case-insensitive to avoid confusion. */
+ for (c = 0; c < SCM_N_R6RS_CHARNAMES; c++)
+ if ((strlen (scm_r6rs_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_r6rs_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_r6rs_charnums[c]);
+
+ /* The R7RS charnames. R7RS says that these should be case-sensitive.
+ They are left as case-insensitive to avoid confusion. */
+ for (c = 0; c < SCM_N_R7RS_CHARNAMES; c++)
+ if ((strlen (scm_r7rs_charnames[c]) == charname_len)
+ && (!strncasecmp (scm_r7rs_charnames[c], charname, charname_len)))
+ return SCM_MAKE_CHAR (scm_r7rs_charnums[c]);
+
+ /* Then come the controls. By Guile convention, these are not case
+ sensitive. */
for (c = 0; c < SCM_N_C0_CONTROL_CHARNAMES; c++)
if ((strlen (scm_C0_control_charnames[c]) == charname_len)
&& (!strncasecmp (scm_C0_control_charnames[c], charname, charname_len)))
HCoop / bpt / guile.git / blobdiff