[bpt/guile.git] / libguile / chars.c

/*	Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
 * 
 * This program is free software; you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation; either version 2, or (at your option)
 * any later version.
 * 
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 * 
 * You should have received a copy of the GNU General Public License
 * along with this software; see the file COPYING.  If not, write to
 * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
 * Boston, MA 02111-1307 USA
 *
 * As a special exception, the Free Software Foundation gives permission
 * for additional uses of the text contained in its release of GUILE.
 *
 * The exception is that, if you link the GUILE library with other files
 * to produce an executable, this does not by itself cause the
 * resulting executable to be covered by the GNU General Public License.
 * Your use of that executable is in no way restricted on account of
 * linking the GUILE library code into it.
 *
 * This exception does not however invalidate any other reasons why
 * the executable file might be covered by the GNU General Public License.
 *
 * This exception applies only to the code released by the
 * Free Software Foundation under the name GUILE.  If you copy
 * code from other Free Software Foundation releases into a copy of
 * GUILE, as the General Public License permits, the exception does
 * not apply to the code that you add in this way.  To avoid misleading
 * anyone as to the status of such modified files, you must delete
 * this exception notice from them.
 *
 * If you write modifications of your own for GUILE, it is your choice
 * whether to permit this exception to apply to your modifications.
 * If you do not wish that, delete this exception notice.  */
\f

#include <stdio.h>
#include <ctype.h>
#include "_scm.h"

#include "chars.h"
\f


SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);

SCM
scm_char_p(x)
     SCM x;
{
  return SCM_ICHRP(x) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_eq_p, "char=?", scm_tc7_rpsubr, scm_char_eq_p);

SCM
scm_char_eq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_eq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_eq_p);
  return (SCM_ICHR(x) == SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC1 (s_char_less_p, "char<?", scm_tc7_rpsubr, scm_char_less_p);

SCM
scm_char_less_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_less_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_less_p);
  return (SCM_ICHR(x) < SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_leq_p, "char<=?", scm_tc7_rpsubr, scm_char_leq_p);

SCM
scm_char_leq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_leq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_leq_p);
  return (SCM_ICHR(x) <= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_gr_p, "char>?", scm_tc7_rpsubr, scm_char_gr_p);

SCM
scm_char_gr_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_gr_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_gr_p);
  return (SCM_ICHR(x) > SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_geq_p, "char>=?", scm_tc7_rpsubr, scm_char_geq_p);

SCM
scm_char_geq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_geq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_geq_p);
  return (SCM_ICHR(x) >= SCM_ICHR(y)) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_ci_eq_p, "char-ci=?", scm_tc7_rpsubr, scm_char_ci_eq_p);

SCM
scm_char_ci_eq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_eq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_eq_p);
  return (scm_upcase(SCM_ICHR(x))==scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_ci_less_p, "char-ci<?", scm_tc7_rpsubr, scm_char_ci_less_p);

SCM
scm_char_ci_less_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_less_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_less_p);
  return (scm_upcase(SCM_ICHR(x)) < scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_ci_leq_p, "char-ci<=?", scm_tc7_rpsubr, scm_char_ci_leq_p);

SCM
scm_char_ci_leq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_leq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_leq_p);
  return (scm_upcase(SCM_ICHR(x)) <= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_ci_gr_p, "char-ci>?", scm_tc7_rpsubr, scm_char_ci_gr_p);

SCM
scm_char_ci_gr_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_gr_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_gr_p);
  return (scm_upcase(SCM_ICHR(x)) > scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC1 (s_char_ci_geq_p, "char-ci>=?", scm_tc7_rpsubr, scm_char_ci_geq_p);

SCM
scm_char_ci_geq_p(x, y)
     SCM x;
     SCM y;
{
  SCM_ASSERT(SCM_ICHRP(x), x, SCM_ARG1, s_char_ci_geq_p);
  SCM_ASSERT(SCM_ICHRP(y), y, SCM_ARG2, s_char_ci_geq_p);
  return (scm_upcase(SCM_ICHR(x)) >= scm_upcase(SCM_ICHR(y))) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC(s_char_alphabetic_p, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p);

SCM
scm_char_alphabetic_p(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_alphabetic_p);
  return (isascii(SCM_ICHR(chr)) && isalpha(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_char_numeric_p, "char-numeric?", 1, 0, 0, scm_char_numeric_p);

SCM
scm_char_numeric_p(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_numeric_p);
  return (isascii(SCM_ICHR(chr)) && isdigit(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}

SCM_PROC(s_char_whitespace_p, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p);

SCM
scm_char_whitespace_p(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_whitespace_p);
  return (isascii(SCM_ICHR(chr)) && isspace(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC(s_char_upper_case_p, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p);

SCM
scm_char_upper_case_p(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
  return (isascii(SCM_ICHR(chr)) && isupper(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC(s_char_lower_case_p, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p);

SCM
scm_char_lower_case_p(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_lower_case_p);
  return (isascii(SCM_ICHR(chr)) && islower(SCM_ICHR(chr))) ? SCM_BOOL_T : SCM_BOOL_F;
}


SCM_PROC (s_char_is_both_p, "char-is-both?", 1, 0, 0, scm_char_is_both_p);

SCM
scm_char_is_both_p (chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upper_case_p);
  return ((isascii(SCM_ICHR(chr)) && (isupper(SCM_ICHR(chr)) || islower(SCM_ICHR(chr))))
	  ? SCM_BOOL_T
	  : SCM_BOOL_F);
}


SCM_PROC(s_char_to_integer, "char->integer", 1, 0, 0, scm_char_to_integer);

SCM
scm_char_to_integer(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_to_integer);
  return scm_ulong2num((unsigned long)SCM_ICHR(chr));
}


SCM_PROC(s_integer_to_char, "integer->char", 1, 0, 0, scm_integer_to_char);

SCM
scm_integer_to_char(n)
     SCM n;
{
  unsigned long ni;

  ni = 0xffff & scm_num2ulong (n, (char *)SCM_ARG1, s_integer_to_char);
  return SCM_MAKICHR(SCM_INUM(n));
}


SCM_PROC(s_char_upcase, "char-upcase", 1, 0, 0, scm_char_upcase);

SCM
scm_char_upcase(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_upcase);
  return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr)));
}


SCM_PROC(s_char_downcase, "char-downcase", 1, 0, 0, scm_char_downcase);

SCM
scm_char_downcase(chr)
     SCM chr;
{
  SCM_ASSERT(SCM_ICHRP(chr), chr, SCM_ARG1, s_char_downcase);
  return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr)));
}

\f


static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT];
static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
static const unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
static const unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";


void 
scm_tables_prehistory ()
{
  int i;
  for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
    scm_upcase_table[i] = scm_downcase_table[i] = i;
  for (i = 0; i < (int) (sizeof scm_lowers / sizeof (scm_lowers[0])); i++)
    {
      scm_upcase_table[scm_lowers[i]] = scm_uppers[i];
      scm_downcase_table[scm_uppers[i]] = scm_lowers[i];
    }
}


int
scm_upcase (c)
     unsigned int c;
{
  if (c < sizeof (scm_upcase_table))
    return scm_upcase_table[c];
  else
    return c;
}


int
scm_downcase (c)
     unsigned int c;
{
  if (c < sizeof (scm_downcase_table))
    return scm_downcase_table[c];
  else
    return c;
}


#ifdef _DCC
# define ASCII
#else
# if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
#  define EBCDIC
# endif /*  (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
# if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
#  define ASCII
# endif /*  (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
#endif /* def _DCC */


#ifdef EBCDIC
char *const scm_charnames[] =
{
  "nul","soh","stx","etx", "pf", "ht", "lc","del",
   0   , 0   ,"smm", "vt", "ff", "cr", "so", "si",
  "dle","dc1","dc2","dc3","res", "nl", "bs", "il",
  "can", "em", "cc", 0   ,"ifs","igs","irs","ius",
   "ds","sos", "fs", 0   ,"byp", "lf","eob","pre",
   0   , 0   , "sm", 0   , 0   ,"enq","ack","bel",
   0   , 0   ,"syn", 0   , "pn", "rs", "uc","eot",
   0   , 0   , 0   , 0   ,"dc4","nak", 0   ,"sub",
   "space", scm_s_newline, "tab", "backspace", "return", "page", "null"};

const char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
\040\041\042\043\044\045\046\047\
\050\051\052\053\054\055\056\057\
\060\061\062\063\064\065\066\067\
\070\071\072\073\074\075\076\077\
 \n\t\b\r\f\0";
#endif /* def EBCDIC */
#ifdef ASCII
char *const scm_charnames[] =
{
  "nul","soh","stx","etx","eot","enq","ack","bel",
   "bs", "ht", "newline", "vt", "np", "cr", "so", "si",
  "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  "can", "em","sub","esc", "fs", "gs", "rs", "us",
  "space", "nl", "tab", "backspace", "return", "page", "null", "del"};
const char scm_charnums[] =
"\000\001\002\003\004\005\006\007\
\010\011\012\013\014\015\016\017\
\020\021\022\023\024\025\026\027\
\030\031\032\033\034\035\036\037\
 \n\t\b\r\f\0\177";
#endif /* def ASCII */

int scm_n_charnames = sizeof (scm_charnames) / sizeof (char *);


\f


void
scm_init_chars ()
{
#include "chars.x"
}
Commit	Line	Data
7dc6e754	1	/* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
0f2d19dd JB	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
82892bed JB	15	* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
82892bed JB	16	* Boston, MA 02111-1307 USA
0f2d19dd JB	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.
82892bed	40	* If you do not wish that, delete this exception notice. */
0f2d19dd JB	41	\f
	42
	43	#include <stdio.h>
	44	#include <ctype.h>
	45	#include "_scm.h"
	46
20e6290e	47	#include "chars.h"
0f2d19dd JB	48	\f
	49
	50
	51
	52	SCM_PROC(s_char_p, "char?", 1, 0, 0, scm_char_p);
1cc91f1b	53
0f2d19dd JB	54	SCM
	55	scm_char_p(x)
	56	SCM x;
0f2d19dd JB	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);
1cc91f1b	62
0f2d19dd JB	63	SCM
	64	scm_char_eq_p(x, y)
	65	SCM x;
	66	SCM y;
0f2d19dd JB	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);
1cc91f1b	75
0f2d19dd JB	76	SCM
	77	scm_char_less_p(x, y)
	78	SCM x;
	79	SCM y;
0f2d19dd JB	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);
1cc91f1b	87
0f2d19dd JB	88	SCM
	89	scm_char_leq_p(x, y)
	90	SCM x;
	91	SCM y;
0f2d19dd JB	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);
1cc91f1b	99
0f2d19dd JB	100	SCM
	101	scm_char_gr_p(x, y)
	102	SCM x;
	103	SCM y;
0f2d19dd JB	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);
1cc91f1b	111
0f2d19dd JB	112	SCM
	113	scm_char_geq_p(x, y)
	114	SCM x;
	115	SCM y;
0f2d19dd JB	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);
1cc91f1b	123
0f2d19dd JB	124	SCM
	125	scm_char_ci_eq_p(x, y)
	126	SCM x;
	127	SCM y;
0f2d19dd JB	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);
1cc91f1b	135
0f2d19dd JB	136	SCM
	137	scm_char_ci_less_p(x, y)
	138	SCM x;
	139	SCM y;
0f2d19dd JB	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);
1cc91f1b	147
0f2d19dd JB	148	SCM
	149	scm_char_ci_leq_p(x, y)
	150	SCM x;
	151	SCM y;
0f2d19dd JB	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);
1cc91f1b	159
0f2d19dd JB	160	SCM
	161	scm_char_ci_gr_p(x, y)
	162	SCM x;
	163	SCM y;
0f2d19dd JB	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);
1cc91f1b	171
0f2d19dd JB	172	SCM
	173	scm_char_ci_geq_p(x, y)
	174	SCM x;
	175	SCM y;
0f2d19dd JB	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);
1cc91f1b	184
0f2d19dd JB	185	SCM
	186	scm_char_alphabetic_p(chr)
	187	SCM chr;
0f2d19dd JB	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);
1cc91f1b	194
0f2d19dd JB	195	SCM
	196	scm_char_numeric_p(chr)
	197	SCM chr;
0f2d19dd JB	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);
1cc91f1b	204
0f2d19dd JB	205	SCM
	206	scm_char_whitespace_p(chr)
	207	SCM chr;
0f2d19dd JB	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);
1cc91f1b	216
0f2d19dd JB	217	SCM
	218	scm_char_upper_case_p(chr)
	219	SCM chr;
0f2d19dd JB	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);
1cc91f1b	227
0f2d19dd JB	228	SCM
	229	scm_char_lower_case_p(chr)
	230	SCM chr;
0f2d19dd JB	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);
1cc91f1b	239
0f2d19dd JB	240	SCM
	241	scm_char_is_both_p (chr)
	242	SCM chr;
0f2d19dd JB	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);
1cc91f1b	254
0f2d19dd JB	255	SCM
	256	scm_char_to_integer(chr)
	257	SCM chr;
0f2d19dd JB	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);
1cc91f1b	266
0f2d19dd JB	267	SCM
	268	scm_integer_to_char(n)
	269	SCM n;
0f2d19dd JB	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);
1cc91f1b	279
0f2d19dd JB	280	SCM
	281	scm_char_upcase(chr)
	282	SCM chr;
0f2d19dd JB	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);
1cc91f1b	290
0f2d19dd JB	291	SCM
	292	scm_char_downcase(chr)
	293	SCM chr;
0f2d19dd JB	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
e2806c10 MD	303	static unsigned char scm_upcase_table[SCM_CHAR_CODE_LIMIT];
e2806c10 MD	304	static unsigned char scm_downcase_table[SCM_CHAR_CODE_LIMIT];
57e3a543 JB	305	static const unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
57e3a543 JB	306	static const unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
0f2d19dd	307
1cc91f1b	308
0f2d19dd JB	309	void
0f2d19dd JB	310	scm_tables_prehistory ()
0f2d19dd JB	311	{
0f2d19dd JB	312	int i;
e2806c10	313	for (i = 0; i < SCM_CHAR_CODE_LIMIT; i++)
0f2d19dd	314	scm_upcase_table[i] = scm_downcase_table[i] = i;
77364130	315	for (i = 0; i < (int) (sizeof scm_lowers / sizeof (scm_lowers[0])); i++)
0f2d19dd JB	316	{
	317	scm_upcase_table[scm_lowers[i]] = scm_uppers[i];
	318	scm_downcase_table[scm_uppers[i]] = scm_lowers[i];
	319	}
	320	}
	321
1cc91f1b	322
0f2d19dd JB	323	int
	324	scm_upcase (c)
	325	unsigned int c;
0f2d19dd JB	326	{
	327	if (c < sizeof (scm_upcase_table))
	328	return scm_upcase_table[c];
	329	else
	330	return c;
	331	}
	332
1cc91f1b	333
0f2d19dd JB	334	int
	335	scm_downcase (c)
	336	unsigned int c;
0f2d19dd JB	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
57e3a543	358	char *const scm_charnames[] =
0f2d19dd JB	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
57e3a543	370	const char scm_charnums[] =
0f2d19dd JB	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
57e3a543	382	char *const scm_charnames[] =
0f2d19dd JB	383	{
0f2d19dd JB	384	"nul","soh","stx","etx","eot","enq","ack","bel",
35fd4394	385	"bs", "ht", "newline", "vt", "np", "cr", "so", "si",
0f2d19dd JB	386	"dle","dc1","dc2","dc3","dc4","nak","syn","etb",
0f2d19dd JB	387	"can", "em","sub","esc", "fs", "gs", "rs", "us",
35fd4394	388	"space", "nl", "tab", "backspace", "return", "page", "null", "del"};
57e3a543	389	const char scm_charnums[] =
0f2d19dd JB	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
1cc91f1b	402
0f2d19dd JB	403	void
0f2d19dd JB	404	scm_init_chars ()
0f2d19dd JB	405	{
	406	#include "chars.x"
	407	}
	408