1 /* Copyright (C) 1995,1996 Free Software Foundation, Inc.
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)
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.
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.
17 * As a special exception, the Free Software Foundation gives permission
18 * for additional uses of the text contained in its release of GUILE.
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.
26 * This exception does not however invalidate any other reasons why
27 * the executable file might be covered by the GNU General Public License.
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.
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.
52 SCM_PROC(s_char_p
, "char?", 1, 0, 0, scm_char_p
);
58 return SCM_ICHRP(x
) ? SCM_BOOL_T
: SCM_BOOL_F
;
61 SCM_PROC1 (s_char_eq_p
, "char=?", scm_tc7_rpsubr
, scm_char_eq_p
);
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
;
74 SCM_PROC1 (s_char_less_p
, "char<?", scm_tc7_rpsubr
, scm_char_less_p
);
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
;
86 SCM_PROC1 (s_char_leq_p
, "char<=?", scm_tc7_rpsubr
, scm_char_leq_p
);
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
;
98 SCM_PROC1 (s_char_gr_p
, "char>?", scm_tc7_rpsubr
, scm_char_gr_p
);
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
;
110 SCM_PROC1 (s_char_geq_p
, "char>=?", scm_tc7_rpsubr
, scm_char_geq_p
);
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
;
122 SCM_PROC1 (s_char_ci_eq_p
, "char-ci=?", scm_tc7_rpsubr
, scm_char_ci_eq_p
);
125 scm_char_ci_eq_p(x
, y
)
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
;
134 SCM_PROC1 (s_char_ci_less_p
, "char-ci<?", scm_tc7_rpsubr
, scm_char_ci_less_p
);
137 scm_char_ci_less_p(x
, y
)
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
;
146 SCM_PROC1 (s_char_ci_leq_p
, "char-ci<=?", scm_tc7_rpsubr
, scm_char_ci_leq_p
);
149 scm_char_ci_leq_p(x
, y
)
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
;
158 SCM_PROC1 (s_char_ci_gr_p
, "char-ci>?", scm_tc7_rpsubr
, scm_char_ci_gr_p
);
161 scm_char_ci_gr_p(x
, y
)
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
;
170 SCM_PROC1 (s_char_ci_geq_p
, "char-ci>=?", scm_tc7_rpsubr
, scm_char_ci_geq_p
);
173 scm_char_ci_geq_p(x
, y
)
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
;
183 SCM_PROC(s_char_alphabetic_p
, "char-alphabetic?", 1, 0, 0, scm_char_alphabetic_p
);
186 scm_char_alphabetic_p(chr
)
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
;
193 SCM_PROC(s_char_numeric_p
, "char-numeric?", 1, 0, 0, scm_char_numeric_p
);
196 scm_char_numeric_p(chr
)
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
;
203 SCM_PROC(s_char_whitespace_p
, "char-whitespace?", 1, 0, 0, scm_char_whitespace_p
);
206 scm_char_whitespace_p(chr
)
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
;
215 SCM_PROC(s_char_upper_case_p
, "char-upper-case?", 1, 0, 0, scm_char_upper_case_p
);
218 scm_char_upper_case_p(chr
)
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
;
226 SCM_PROC(s_char_lower_case_p
, "char-lower-case?", 1, 0, 0, scm_char_lower_case_p
);
229 scm_char_lower_case_p(chr
)
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
;
238 SCM_PROC (s_char_is_both_p
, "char-is-both?", 1, 0, 0, scm_char_is_both_p
);
241 scm_char_is_both_p (chr
)
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
))))
253 SCM_PROC(s_char_to_integer
, "char->integer", 1, 0, 0, scm_char_to_integer
);
256 scm_char_to_integer(chr
)
259 SCM_ASSERT(SCM_ICHRP(chr
), chr
, SCM_ARG1
, s_char_to_integer
);
260 return scm_ulong2num((unsigned long)SCM_ICHR(chr
));
265 SCM_PROC(s_integer_to_char
, "integer->char", 1, 0, 0, scm_integer_to_char
);
268 scm_integer_to_char(n
)
273 ni
= 0xffff & scm_num2ulong (n
, (char *)SCM_ARG1
, s_integer_to_char
);
274 return SCM_MAKICHR(SCM_INUM(n
));
278 SCM_PROC(s_char_upcase
, "char-upcase", 1, 0, 0, scm_char_upcase
);
284 SCM_ASSERT(SCM_ICHRP(chr
), chr
, SCM_ARG1
, s_char_upcase
);
285 return SCM_MAKICHR(scm_upcase(SCM_ICHR(chr
)));
289 SCM_PROC(s_char_downcase
, "char-downcase", 1, 0, 0, scm_char_downcase
);
292 scm_char_downcase(chr
)
295 SCM_ASSERT(SCM_ICHRP(chr
), chr
, SCM_ARG1
, s_char_downcase
);
296 return SCM_MAKICHR(scm_downcase(SCM_ICHR(chr
)));
303 static unsigned char scm_upcase_table
[SCM_CHAR_CODE_LIMIT
];
304 static unsigned char scm_downcase_table
[SCM_CHAR_CODE_LIMIT
];
305 static unsigned char scm_lowers
[] = "abcdefghijklmnopqrstuvwxyz";
306 static unsigned char scm_uppers
[] = "ABCDEFGHIJKLMNOPQRSTUVWXYZ";
310 scm_tables_prehistory ()
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
< sizeof scm_lowers
/ sizeof (char); i
++)
317 scm_upcase_table
[scm_lowers
[i
]] = scm_uppers
[i
];
318 scm_downcase_table
[scm_uppers
[i
]] = scm_lowers
[i
];
327 if (c
< sizeof (scm_upcase_table
))
328 return scm_upcase_table
[c
];
338 if (c
< sizeof (scm_downcase_table
))
339 return scm_downcase_table
[c
];
348 # if (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301'))
350 # endif /* (('\n'=='\025') && (' '=='\100') && ('a'=='\201') && ('A'=='\301')) */
351 # if (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101'))
353 # endif /* (('\n'=='\012') && (' '=='\040') && ('a'=='\141') && ('A'=='\101')) */
354 #endif /* def _DCC */
358 char *scm_charnames
[] =
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"};
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\
380 #endif /* def EBCDIC */
382 char *scm_charnames
[] =
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\
395 #endif /* def ASCII */
397 int scm_n_charnames
= sizeof (scm_charnames
) / sizeof (char *);