libguile/chars.c

   1 /*      Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program 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
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41 \f
  42
  43 #include <stdio.h>
  44 #include <ctype.h>
  45 #include "_scm.h"
  46
  47 #include "chars.h"
  48 \f
  49
  50
  51
  52 SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);
  53
  54 SCM
  55 scm_char_p(x)
  56      SCM x;
  57 {
  58   return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F;
  59 }
  60
  61 SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p);
  62
  63 SCM
  64 scm_char_eq_p(x, y)
  65      SCM x;
  66      SCM y;
  67 {
  68   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p);
  69   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p);
  70   return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
  71 }
  72
  73
  74 SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p);
  75
  76 SCM
  77 scm_char_less_p(x, y)
  78      SCM x;
  79      SCM y;
  80 {
  81   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p);
  82   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p);
  83   return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
  84 }
  85
  86 SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p);
  87
  88 SCM
  89 scm_char_leq_p(x, y)
  90      SCM x;
  91      SCM y;
  92 {
  93   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p);
  94   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p);
  95   return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
  96 }
  97
  98 SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p);
  99
 100 SCM
 101 scm_char_gr_p(x, y)
 102      SCM x;
 103      SCM y;
 104 {
 105   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p);
 106   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p);
 107   return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
 108 }
 109
 110 SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p);
 111
 112 SCM
 113 scm_char_geq_p(x, y)
 114      SCM x;
 115      SCM y;
 116 {
 117   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p);
 118   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p);
 119   return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
 120 }
 121
 122 SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p);
 123
 124 SCM
 125 scm_char_ci_eq_p(x, y)
 126      SCM x;
 127      SCM y;
 128 {
 129   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p);
 130   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p);
 131   return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
 132 }
 133
 134 SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p);
 135
 136 SCM
 137 scm_char_ci_less_p(x, y)
 138      SCM x;
 139      SCM y;
 140 {
 141   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p);
 142   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p);
 143   return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
 144 }
 145
 146 SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p);
 147
 148 SCM
 149 scm_char_ci_leq_p(x, y)
 150      SCM x;
 151      SCM y;
 152 {
 153   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p);
 154   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p);
 155   return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
 156 }
 157
 158 SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p);
 159
 160 SCM
 161 scm_char_ci_gr_p(x, y)
 162      SCM x;
 163      SCM y;
 164 {
 165   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p);
 166   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p);
 167   return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
 168 }
 169
 170 SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p);
 171
 172 SCM
 173 scm_char_ci_geq_p(x, y)
 174      SCM x;
 175      SCM y;
 176 {
 177   SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p);
 178   SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p);
 179   return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
 180 }
 181
 182
 183 SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);
 184
 185 SCM
 186 scm_char_alphabetic_p(chr)
 187      SCM chr;
 188 {
 189   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p);
 190   return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
 191 }
 192
 193 SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);
 194
 195 SCM
 196 scm_char_numeric_p(chr)
 197      SCM chr;
 198 {
 199   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p);
 200   return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
 201 }
 202
 203 SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);
 204
 205 SCM
 206 scm_char_whitespace_p(chr)
 207      SCM chr;
 208 {
 209   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p);
 210   return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
 211 }
 212
 213
 214
 215 SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);
 216
 217 SCM
 218 scm_char_upper_case_p(chr)
 219      SCM chr;
 220 {
 221   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
 222   return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
 223 }
 224
 225
 226 SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);
 227
 228 SCM
 229 scm_char_lower_case_p(chr)
 230      SCM chr;
 231 {
 232   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p);
 233   return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
 234 }
 235
 236
 237
 238 SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p);
 239
 240 SCM
 241 scm_char_is_both_p (chr)
 242      SCM chr;
 243 {
 244   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
 245   return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))))
 246           ? SCM_BOOL_T
 247           : SCM_BOOL_F);
 248 }
 249
 250
 251
 252
 253 SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);
 254
 255 SCM
 256 scm_char_to_integer(chr)
 257      SCM chr;
 258 {
 259   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer);
 260   return scm_ulong2num((unsigned long)SCM_ICHR(chr));
 261 }
 262
 263
 264
 265 SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);
 266
 267 SCM
 268 scm_integer_to_char(n)
 269      SCM n;
 270 {
 271   unsigned long ni;
 272
 273   ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char);
 274   return SCM_MAKICHR(SCM_INUM(n));
 275 }
 276
 277
 278 SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);
 279
 280 SCM
 281 scm_char_upcase(chr)
 282      SCM chr;
 283 {
 284   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase);
 285   return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr)));
 286 }
 287
 288
 289 SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);
 290
 291 SCM
 292 scm_char_downcase(chr)
 293      SCM chr;
 294 {
 295   SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase);
 296   return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr)));
 297 }
 298
 299 \f
 300
 301
 302
 303 static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT];
 304 static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
 305 static const unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
 306 static const unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
 307
 308
 309 void
 310 scm_tables_prehistory ()
 311 {
 312   int i;
 313   for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
 314     scm_upcase_table[i] = scm_downcase_table[i] = i;
 315   for (i = 0; i < (int) (sizeof scm_lowers / sizeof (scm_lowers[0])); i++)
 316     {
 317       scm_upcase_table[scm_lowers[i]] = scm_uppers[i];
 318       scm_downcase_table[scm_uppers[i]] = scm_lowers[i];
 319     }
 320 }
 321
 322
 323 int
 324 scm_upcase (c)
 325      unsigned int c;
 326 {
 327   if (c < sizeof (scm_upcase_table))
 328     return scm_upcase_table[c];
 329   else
 330     return c;
 331 }
 332
 333
 334 int
 335 scm_downcase (c)
 336      unsigned int c;
 337 {
 338   if (c < sizeof (scm_downcase_table))
 339     return scm_downcase_table[c];
 340   else
 341     return c;
 342 }
 343
 344
 345 #ifdef _DCC
 346 # define ASCII
 347 #else
 348 # if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
 349 #  define EBCDIC
 350 # endif /*  (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
 351 # if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
 352 #  define ASCII
 353 # endif /*  (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
 354 #endif /* def _DCC */
 355
 356
 357 #ifdef EBCDIC
 358 char *const scm_charnames[] =
 359 {
 360   "nul","soh","stx","etx", "pf", "ht", "lc","del",
 361    0   , 0   ,"smm", "vt", "ff", "cr", "so", "si",
 362   "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
 363   "can", "em", "cc", 0   ,"ifs","igs","irs","ius",
 364    "ds","sos", "fs", 0   ,"byp", "lf","eob","pre",
 365    0   , 0   , "sm", 0   , 0   ,"enq","ack","bel",
 366    0   , 0   ,"syn", 0   , "pn", "rs", "uc","eot",
 367    0   , 0   , 0   , 0   ,"dc4","nak", 0   ,"sub",
 368    "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};
 369
 370 const char scm_charnums[] =
 371 "\000\001\002\003\004\005\006\007\
 372 \010\011\012\013\014\015\016\017\
 373 \020\021\022\023\024\025\026\027\
 374 \030\031\032\033\034\035\036\037\
 375 \040\041\042\043\044\045\046\047\
 376 \050\051\052\053\054\055\056\057\
 377 \060\061\062\063\064\065\066\067\
 378 \070\071\072\073\074\075\076\077\
 379  \n\t\b\r\f\0";
 380 #endif /* def EBCDIC */
 381 #ifdef ASCII
 382 char *const scm_charnames[] =
 383 {
 384   "nul","soh","stx","etx","eot","enq","ack","bel",
 385    "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
 386   "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
 387   "can", "em","sub","esc", "fs", "gs", "rs", "us",
 388   "space", "nl", "tab", "backspace", "return", "page", "null", "del"};
 389 const char scm_charnums[] =
 390 "\000\001\002\003\004\005\006\007\
 391 \010\011\012\013\014\015\016\017\
 392 \020\021\022\023\024\025\026\027\
 393 \030\031\032\033\034\035\036\037\
 394  \n\t\b\r\f\0\177";
 395 #endif /* def ASCII */
 396
 397 int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);
 398
 399
 400 \f
 401
 402
 403 void
 404 scm_init_chars ()
 405 {
 406 #include "chars.x"
 407 }
 408