libguile/chars.c

   1 /*      Copyright (C) 1995,1996,1998, 2000, 2001, 2004, 2006, 2008 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  16  * 02110-1301 USA
  17  */
  18
  19
  20 \f
  21 #ifdef HAVE_CONFIG_H
  22 # include <config.h>
  23 #endif
  24
  25 #include <ctype.h>
  26 #include <limits.h>
  27 #include "libguile/_scm.h"
  28 #include "libguile/validate.h"
  29
  30 #include "libguile/chars.h"
  31 #include "libguile/srfi-14.h"
  32
  33 \f
  34
  35 SCM_DEFINE (scm_char_p, "char?", 1, 0, 0,
  36             (SCM x),
  37             "Return @code{#t} iff @var{x} is a character, else @code{#f}.")
  38 #define FUNC_NAME s_scm_char_p
  39 {
  40   return scm_from_bool (SCM_CHARP(x));
  41 }
  42 #undef FUNC_NAME
  43
  44 SCM_DEFINE1 (scm_char_eq_p, "char=?", scm_tc7_rpsubr,
  45              (SCM x, SCM y),
  46              "Return @code{#t} iff @var{x} is the same character as @var{y}, else @code{#f}.")
  47 #define FUNC_NAME s_scm_char_eq_p
  48 {
  49   SCM_VALIDATE_CHAR (1, x);
  50   SCM_VALIDATE_CHAR (2, y);
  51   return scm_from_bool (scm_is_eq (x, y));
  52 }
  53 #undef FUNC_NAME
  54
  55
  56 SCM_DEFINE1 (scm_char_less_p, "char<?", scm_tc7_rpsubr,
  57              (SCM x, SCM y),
  58              "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence,\n"
  59              "else @code{#f}.")
  60 #define FUNC_NAME s_scm_char_less_p
  61 {
  62   SCM_VALIDATE_CHAR (1, x);
  63   SCM_VALIDATE_CHAR (2, y);
  64   return scm_from_bool (SCM_CHAR(x) < SCM_CHAR(y));
  65 }
  66 #undef FUNC_NAME
  67
  68 SCM_DEFINE1 (scm_char_leq_p, "char<=?", scm_tc7_rpsubr,
  69              (SCM x, SCM y),
  70              "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
  71              "ASCII sequence, else @code{#f}.")
  72 #define FUNC_NAME s_scm_char_leq_p
  73 {
  74   SCM_VALIDATE_CHAR (1, x);
  75   SCM_VALIDATE_CHAR (2, y);
  76   return scm_from_bool (SCM_CHAR(x) <= SCM_CHAR(y));
  77 }
  78 #undef FUNC_NAME
  79
  80 SCM_DEFINE1 (scm_char_gr_p, "char>?", scm_tc7_rpsubr,
  81              (SCM x, SCM y),
  82              "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
  83              "sequence, else @code{#f}.")
  84 #define FUNC_NAME s_scm_char_gr_p
  85 {
  86   SCM_VALIDATE_CHAR (1, x);
  87   SCM_VALIDATE_CHAR (2, y);
  88   return scm_from_bool (SCM_CHAR(x) > SCM_CHAR(y));
  89 }
  90 #undef FUNC_NAME
  91
  92 SCM_DEFINE1 (scm_char_geq_p, "char>=?", scm_tc7_rpsubr,
  93              (SCM x, SCM y),
  94              "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
  95              "ASCII sequence, else @code{#f}.")
  96 #define FUNC_NAME s_scm_char_geq_p
  97 {
  98   SCM_VALIDATE_CHAR (1, x);
  99   SCM_VALIDATE_CHAR (2, y);
 100   return scm_from_bool (SCM_CHAR(x) >= SCM_CHAR(y));
 101 }
 102 #undef FUNC_NAME
 103
 104 SCM_DEFINE1 (scm_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr,
 105              (SCM x, SCM y),
 106              "Return @code{#t} iff @var{x} is the same character as @var{y} ignoring\n"
 107              "case, else @code{#f}.")
 108 #define FUNC_NAME s_scm_char_ci_eq_p
 109 {
 110   SCM_VALIDATE_CHAR (1, x);
 111   SCM_VALIDATE_CHAR (2, y);
 112   return scm_from_bool (scm_c_upcase(SCM_CHAR(x))==scm_c_upcase(SCM_CHAR(y)));
 113 }
 114 #undef FUNC_NAME
 115
 116 SCM_DEFINE1 (scm_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr,
 117              (SCM x, SCM y),
 118              "Return @code{#t} iff @var{x} is less than @var{y} in the ASCII sequence\n"
 119              "ignoring case, else @code{#f}.")
 120 #define FUNC_NAME s_scm_char_ci_less_p
 121 {
 122   SCM_VALIDATE_CHAR (1, x);
 123   SCM_VALIDATE_CHAR (2, y);
 124   return scm_from_bool ((scm_c_upcase(SCM_CHAR(x))) < scm_c_upcase(SCM_CHAR(y)));
 125 }
 126 #undef FUNC_NAME
 127
 128 SCM_DEFINE1 (scm_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr,
 129              (SCM x, SCM y),
 130              "Return @code{#t} iff @var{x} is less than or equal to @var{y} in the\n"
 131              "ASCII sequence ignoring case, else @code{#f}.")
 132 #define FUNC_NAME s_scm_char_ci_leq_p
 133 {
 134   SCM_VALIDATE_CHAR (1, x);
 135   SCM_VALIDATE_CHAR (2, y);
 136   return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) <= scm_c_upcase(SCM_CHAR(y)));
 137 }
 138 #undef FUNC_NAME
 139
 140 SCM_DEFINE1 (scm_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr,
 141              (SCM x, SCM y),
 142              "Return @code{#t} iff @var{x} is greater than @var{y} in the ASCII\n"
 143              "sequence ignoring case, else @code{#f}.")
 144 #define FUNC_NAME s_scm_char_ci_gr_p
 145 {
 146   SCM_VALIDATE_CHAR (1, x);
 147   SCM_VALIDATE_CHAR (2, y);
 148   return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) > scm_c_upcase(SCM_CHAR(y)));
 149 }
 150 #undef FUNC_NAME
 151
 152 SCM_DEFINE1 (scm_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr,
 153              (SCM x, SCM y),
 154              "Return @code{#t} iff @var{x} is greater than or equal to @var{y} in the\n"
 155              "ASCII sequence ignoring case, else @code{#f}.")
 156 #define FUNC_NAME s_scm_char_ci_geq_p
 157 {
 158   SCM_VALIDATE_CHAR (1, x);
 159   SCM_VALIDATE_CHAR (2, y);
 160   return scm_from_bool (scm_c_upcase(SCM_CHAR(x)) >= scm_c_upcase(SCM_CHAR(y)));
 161 }
 162 #undef FUNC_NAME
 163
 164
 165 SCM_DEFINE (scm_char_alphabetic_p, "char-alphabetic?", 1, 0, 0,
 166            (SCM chr),
 167             "Return @code{#t} iff @var{chr} is alphabetic, else @code{#f}.\n")
 168 #define FUNC_NAME s_scm_char_alphabetic_p
 169 {
 170   return scm_char_set_contains_p (scm_char_set_letter, chr);
 171 }
 172 #undef FUNC_NAME
 173
 174 SCM_DEFINE (scm_char_numeric_p, "char-numeric?", 1, 0, 0,
 175            (SCM chr),
 176             "Return @code{#t} iff @var{chr} is numeric, else @code{#f}.\n")
 177 #define FUNC_NAME s_scm_char_numeric_p
 178 {
 179   return scm_char_set_contains_p (scm_char_set_digit, chr);
 180 }
 181 #undef FUNC_NAME
 182
 183 SCM_DEFINE (scm_char_whitespace_p, "char-whitespace?", 1, 0, 0,
 184            (SCM chr),
 185             "Return @code{#t} iff @var{chr} is whitespace, else @code{#f}.\n")
 186 #define FUNC_NAME s_scm_char_whitespace_p
 187 {
 188   return scm_char_set_contains_p (scm_char_set_whitespace, chr);
 189 }
 190 #undef FUNC_NAME
 191
 192
 193
 194 SCM_DEFINE (scm_char_upper_case_p, "char-upper-case?", 1, 0, 0,
 195            (SCM chr),
 196             "Return @code{#t} iff @var{chr} is uppercase, else @code{#f}.\n")
 197 #define FUNC_NAME s_scm_char_upper_case_p
 198 {
 199   return scm_char_set_contains_p (scm_char_set_upper_case, chr);
 200 }
 201 #undef FUNC_NAME
 202
 203
 204 SCM_DEFINE (scm_char_lower_case_p, "char-lower-case?", 1, 0, 0,
 205            (SCM chr),
 206             "Return @code{#t} iff @var{chr} is lowercase, else @code{#f}.\n")
 207 #define FUNC_NAME s_scm_char_lower_case_p
 208 {
 209   return scm_char_set_contains_p (scm_char_set_lower_case, chr);
 210 }
 211 #undef FUNC_NAME
 212
 213
 214
 215 SCM_DEFINE (scm_char_is_both_p, "char-is-both?", 1, 0, 0,
 216             (SCM chr),
 217             "Return @code{#t} iff @var{chr} is either uppercase or lowercase, else @code{#f}.\n")
 218 #define FUNC_NAME s_scm_char_is_both_p
 219 {
 220   if (scm_is_true (scm_char_set_contains_p (scm_char_set_lower_case, chr)))
 221     return SCM_BOOL_T;
 222   return scm_char_set_contains_p (scm_char_set_upper_case, chr);
 223 }
 224 #undef FUNC_NAME
 225
 226
 227
 228
 229 SCM_DEFINE (scm_char_to_integer, "char->integer", 1, 0, 0,
 230             (SCM chr),
 231             "Return the number corresponding to ordinal position of @var{chr} in the\n"
 232             "ASCII sequence.")
 233 #define FUNC_NAME s_scm_char_to_integer
 234 {
 235   SCM_VALIDATE_CHAR (1, chr);
 236   return scm_from_ulong (SCM_CHAR(chr));
 237 }
 238 #undef FUNC_NAME
 239
 240
 241
 242 SCM_DEFINE (scm_integer_to_char, "integer->char", 1, 0, 0,
 243            (SCM n),
 244             "Return the character at position @var{n} in the ASCII sequence.")
 245 #define FUNC_NAME s_scm_integer_to_char
 246 {
 247   return SCM_MAKE_CHAR (scm_to_uchar (n));
 248 }
 249 #undef FUNC_NAME
 250
 251
 252 SCM_DEFINE (scm_char_upcase, "char-upcase", 1, 0, 0,
 253            (SCM chr),
 254             "Return the uppercase character version of @var{chr}.")
 255 #define FUNC_NAME s_scm_char_upcase
 256 {
 257   SCM_VALIDATE_CHAR (1, chr);
 258   return SCM_MAKE_CHAR (toupper (SCM_CHAR (chr)));
 259 }
 260 #undef FUNC_NAME
 261
 262
 263 SCM_DEFINE (scm_char_downcase, "char-downcase", 1, 0, 0,
 264            (SCM chr),
 265             "Return the lowercase character version of @var{chr}.")
 266 #define FUNC_NAME s_scm_char_downcase
 267 {
 268   SCM_VALIDATE_CHAR (1, chr);
 269   return SCM_MAKE_CHAR (tolower (SCM_CHAR(chr)));
 270 }
 271 #undef FUNC_NAME
 272
 273 \f
 274
 275
 276
 277 /*
 278 TODO: change name  to scm_i_.. ? --hwn
 279 */
 280
 281
 282 int
 283 scm_c_upcase (unsigned int c)
 284 {
 285   if (c <= UCHAR_MAX)
 286     return toupper (c);
 287   else
 288     return c;
 289 }
 290
 291
 292 int
 293 scm_c_downcase (unsigned int c)
 294 {
 295   if (c <= UCHAR_MAX)
 296     return tolower (c);
 297   else
 298     return c;
 299 }
 300
 301
 302 #ifdef _DCC
 303 # define ASCII
 304 #else
 305 # if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
 306 #  define EBCDIC
 307 # endif /*  (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
 308 # if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
 309 #  define ASCII
 310 # endif /*  (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
 311 #endif /* def _DCC */
 312
 313
 314 #ifdef EBCDIC
 315 char *const scm_charnames[] =
 316 {
 317   "nul", "soh", "stx", "etx", "pf", "ht", "lc", "del",
 318    0   , 0   , "smm", "vt", "ff", "cr", "so", "si",
 319   "dle", "dc1", "dc2", "dc3", "res", "nl", "bs", "il",
 320   "can", "em", "cc", 0   , "ifs", "igs", "irs", "ius",
 321    "ds", "sos", "fs", 0   , "byp", "lf", "eob", "pre",
 322    0   , 0   , "sm", 0   , 0   , "enq", "ack", "bel",
 323    0   , 0   , "syn", 0   , "pn", "rs", "uc", "eot",
 324    0   , 0   , 0   , 0   , "dc4", "nak", 0   , "sub",
 325    "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
 326
 327 const char scm_charnums[] =
 328 "\000\001\002\003\004\005\006\007\
 329 \010\011\012\013\014\015\016\017\
 330 \020\021\022\023\024\025\026\027\
 331 \030\031\032\033\034\035\036\037\
 332 \040\041\042\043\044\045\046\047\
 333 \050\051\052\053\054\055\056\057\
 334 \060\061\062\063\064\065\066\067\
 335 \070\071\072\073\074\075\076\077\
 336  \n\t\b\r\f\0";
 337 #endif /* def EBCDIC */
 338 #ifdef ASCII
 339 char *const scm_charnames[] =
 340 {
 341   "nul","soh","stx","etx","eot","enq","ack","bel",
 342    "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
 343   "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
 344   "can", "em","sub","esc", "fs", "gs", "rs", "us",
 345   "space", "sp", "nl", "tab", "backspace", "return", "page", "null", "del"};
 346 const char scm_charnums[] =
 347 "\000\001\002\003\004\005\006\007\
 348 \010\011\012\013\014\015\016\017\
 349 \020\021\022\023\024\025\026\027\
 350 \030\031\032\033\034\035\036\037\
 351   \n\t\b\r\f\0\177";
 352 #endif /* def ASCII */
 353
 354 int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
 355
 356
 357 \f
 358
 359
 360 void
 361 scm_init_chars ()
 362 {
 363 #include "libguile/chars.x"
 364 }
 365
 366
 367 /*
 368   Local Variables:
 369   c-file-style: "gnu"
 370   End:
 371 */