1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* Character primitives. */
28
29 #include "scheme.h"
30 #include "prims.h"
31 #include <ctype.h>
32
33 long
arg_ascii_char(int n)34 arg_ascii_char (int n)
35 {
36 CHECK_ARG (n, CHARACTER_P);
37 {
38 SCHEME_OBJECT object = (ARG_REF (n));
39 if (! (CHAR_TO_ASCII_P (object)))
40 error_bad_range_arg (n);
41 return (CHAR_TO_ASCII (object));
42 }
43 }
44
45 long
arg_ascii_integer(int n)46 arg_ascii_integer (int n)
47 {
48 return (arg_index_integer (n, MAX_ASCII));
49 }
50
51 DEFINE_PRIMITIVE ("CHAR?", Prim_char_p, 1, 1, 0)
52 {
53 PRIMITIVE_HEADER (1);
54 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (CHARACTER_P (ARG_REF (1))));
55 }
56
57 DEFINE_PRIMITIVE ("MAKE-CHAR", Prim_make_char, 2, 2, 0)
58 {
59 PRIMITIVE_HEADER (2);
60 PRIMITIVE_RETURN
61 (MAKE_CHAR ((arg_index_integer (2, MAX_BITS)),
62 (arg_index_integer (1, MAX_CODE))));
63 }
64
65 DEFINE_PRIMITIVE ("CHAR-BITS", Prim_char_bits, 1, 1, 0)
66 {
67 PRIMITIVE_HEADER (1);
68 CHECK_ARG (1, CHARACTER_P);
69 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_BITS (ARG_REF (1))));
70 }
71
72 DEFINE_PRIMITIVE ("CHAR-CODE", Prim_char_code, 1, 1, 0)
73 {
74 PRIMITIVE_HEADER (1);
75 CHECK_ARG (1, CHARACTER_P);
76 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (CHAR_CODE (ARG_REF (1))));
77 }
78
79 DEFINE_PRIMITIVE ("CHAR->INTEGER", Prim_char_to_integer, 1, 1, 0)
80 {
81 PRIMITIVE_HEADER (1);
82 CHECK_ARG (1, CHARACTER_P);
83 PRIMITIVE_RETURN
84 (LONG_TO_UNSIGNED_FIXNUM ((ARG_REF (1)) & MASK_MIT_ASCII));
85 }
86
87 DEFINE_PRIMITIVE ("INTEGER->CHAR", Prim_integer_to_char, 1, 1, 0)
88 {
89 PRIMITIVE_HEADER (1);
90 PRIMITIVE_RETURN
91 (MAKE_OBJECT (TC_CHARACTER, (arg_index_integer (1, MAX_MIT_ASCII))));
92 }
93
94 long
char_downcase(long c)95 char_downcase (long c)
96 {
97 return ((isupper (c)) ? ((c - 'A') + 'a') : c);
98 }
99
100 long
char_upcase(long c)101 char_upcase (long c)
102 {
103 return ((islower (c)) ? ((c - 'a') + 'A') : c);
104 }
105
106 DEFINE_PRIMITIVE ("CHAR-DOWNCASE", Prim_char_downcase, 1, 1, 0)
107 {
108 PRIMITIVE_HEADER (1);
109 CHECK_ARG (1, CHARACTER_P);
110 PRIMITIVE_RETURN
111 (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
112 (char_downcase (CHAR_CODE (ARG_REF (1))))));
113 }
114
115 DEFINE_PRIMITIVE ("CHAR-UPCASE", Prim_char_upcase, 1, 1, 0)
116 {
117 PRIMITIVE_HEADER (1);
118 CHECK_ARG (1, CHARACTER_P);
119 PRIMITIVE_RETURN
120 (MAKE_CHAR ((CHAR_BITS (ARG_REF (1))),
121 (char_upcase (CHAR_CODE (ARG_REF (1))))));
122 }
123
124 DEFINE_PRIMITIVE ("ASCII->CHAR", Prim_ascii_to_char, 1, 1, 0)
125 {
126 PRIMITIVE_HEADER (1);
127 PRIMITIVE_RETURN (ASCII_TO_CHAR (arg_index_integer (1, MAX_ASCII)));
128 }
129
130 DEFINE_PRIMITIVE ("CHAR->ASCII", Prim_char_to_ascii, 1, 1, 0)
131 {
132 PRIMITIVE_HEADER (1);
133 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (arg_ascii_char (1)));
134 }
135
136 DEFINE_PRIMITIVE ("CHAR-ASCII?", Prim_char_ascii_p, 1, 1, 0)
137 {
138 PRIMITIVE_HEADER (1);
139 CHECK_ARG (1, CHARACTER_P);
140 {
141 SCHEME_OBJECT character = ARG_REF (1);
142 PRIMITIVE_RETURN
143 (((OBJECT_DATUM (character)) >= MAX_ASCII) ?
144 SHARP_F :
145 (LONG_TO_UNSIGNED_FIXNUM (CHAR_TO_ASCII (character))));
146 }
147 }
148