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

/*	Copyright (C) 1995,1996 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, 675 Mass Ave, Cambridge, MA 02139, 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 unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
static 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 < sizeof scm_lowers / sizeof (char); 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 *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"};

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 *scm_charnames[] =
{
  "nul","soh","stx","etx","eot","enq","ack","bel",
   "bs", "ht", "nl", "vt", "np", "cr", "so", "si",
  "dle","dc1","dc2","dc3","dc4","nak","syn","etb",
  "can", "em","sub","esc", "fs", "gs", "rs", "us",
  "space", "newline", "tab", "backspace", "return", "page", "null", "del"};
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
0f2d19dd JB	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
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];
0f2d19dd JB	305	static unsigned char scm_lowers[] = "abcdefghijklmnopqrstuvwxyz";
	306	static unsigned char scm_uppers[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
	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 JB	314	scm_upcase_table[i] = scm_downcase_table[i] = i;
	315	for (i = 0; i < sizeof scm_lowers / sizeof (char); 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
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
	358	char *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	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 *scm_charnames[] =
	383	{
	384	"nul","soh","stx","etx","eot","enq","ack","bel",
	385	"bs", "ht", "nl", "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", "newline", "tab", "backspace", "return", "page", "null", "del"};
	389	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
1cc91f1b	402
0f2d19dd JB	403	void
0f2d19dd JB	404	scm_init_chars ()
0f2d19dd JB	405	{
	406	#include "chars.x"
	407	}
	408