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