libguile/chars.c

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