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 /* Generic Integer Primitives */
28
29 #include "scheme.h"
30 #include "prims.h"
31
32 #define INTEGER_TEST(test) \
33 { \
34 PRIMITIVE_HEADER (1); \
35 CHECK_ARG (1, INTEGER_P); \
36 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (test (ARG_REF (1)))); \
37 }
38
39 DEFINE_PRIMITIVE ("INTEGER-ZERO?", Prim_integer_zero_p, 1, 1, 0)
INTEGER_TEST(integer_zero_p)40 INTEGER_TEST (integer_zero_p)
41 DEFINE_PRIMITIVE ("INTEGER-NEGATIVE?", Prim_integer_negative_p, 1, 1, 0)
42 INTEGER_TEST (integer_negative_p)
43 DEFINE_PRIMITIVE ("INTEGER-POSITIVE?", Prim_integer_positive_p, 1, 1, 0)
44 INTEGER_TEST (integer_positive_p)
45
46 #define INTEGER_COMPARISON(comparison) \
47 { \
48 PRIMITIVE_HEADER (2); \
49 CHECK_ARG (1, INTEGER_P); \
50 CHECK_ARG (2, INTEGER_P); \
51 PRIMITIVE_RETURN \
52 (BOOLEAN_TO_OBJECT (comparison ((ARG_REF (1)), (ARG_REF (2))))); \
53 }
54
55 DEFINE_PRIMITIVE ("INTEGER-EQUAL?", Prim_integer_equal_p, 2, 2, 0)
56 INTEGER_COMPARISON (integer_equal_p)
57 DEFINE_PRIMITIVE ("INTEGER-LESS?", Prim_integer_less_p, 2, 2, 0)
58 INTEGER_COMPARISON (integer_less_p)
59
60 DEFINE_PRIMITIVE ("INTEGER-GREATER?", Prim_integer_greater_p, 2, 2, 0)
61 {
62 PRIMITIVE_HEADER (2);
63 CHECK_ARG (1, INTEGER_P);
64 CHECK_ARG (2, INTEGER_P);
65 PRIMITIVE_RETURN
66 (BOOLEAN_TO_OBJECT (integer_less_p ((ARG_REF (2)), (ARG_REF (1)))));
67 }
68
69 #define INTEGER_BINARY_OPERATION(operator) \
70 { \
71 PRIMITIVE_HEADER (2); \
72 CHECK_ARG (1, INTEGER_P); \
73 CHECK_ARG (2, INTEGER_P); \
74 PRIMITIVE_RETURN (operator ((ARG_REF (1)), (ARG_REF (2)))); \
75 }
76
77 DEFINE_PRIMITIVE ("INTEGER-ADD", Prim_integer_add, 2, 2, 0)
INTEGER_BINARY_OPERATION(integer_add)78 INTEGER_BINARY_OPERATION (integer_add)
79 DEFINE_PRIMITIVE ("INTEGER-SUBTRACT", Prim_integer_subtract, 2, 2, 0)
80 INTEGER_BINARY_OPERATION (integer_subtract)
81 DEFINE_PRIMITIVE ("INTEGER-MULTIPLY", Prim_integer_multiply, 2, 2, 0)
82 INTEGER_BINARY_OPERATION (integer_multiply)
83 DEFINE_PRIMITIVE ("INTEGER-HAMMING-DISTANCE", Prim_integer_hamming_distance, 2, 2, 0)
84 INTEGER_BINARY_OPERATION (integer_hamming_distance)
85 DEFINE_PRIMITIVE ("INTEGER-BITWISE-AND", Prim_integer_bitwise_and, 2, 2, 0)
86 INTEGER_BINARY_OPERATION (integer_bitwise_and)
87 DEFINE_PRIMITIVE ("INTEGER-BITWISE-ANDC2", Prim_integer_bitwise_andc2, 2, 2, 0)
88 INTEGER_BINARY_OPERATION (integer_bitwise_andc2)
89 DEFINE_PRIMITIVE ("INTEGER-BITWISE-ANDC1", Prim_integer_bitwise_andc1, 2, 2, 0)
90 INTEGER_BINARY_OPERATION (integer_bitwise_andc1)
91 DEFINE_PRIMITIVE ("INTEGER-BITWISE-XOR", Prim_integer_bitwise_xor, 2, 2, 0)
92 INTEGER_BINARY_OPERATION (integer_bitwise_xor)
93 DEFINE_PRIMITIVE ("INTEGER-BITWISE-IOR", Prim_integer_bitwise_ior, 2, 2, 0)
94 INTEGER_BINARY_OPERATION (integer_bitwise_ior)
95 DEFINE_PRIMITIVE ("INTEGER-BITWISE-NOR", Prim_integer_bitwise_nor, 2, 2, 0)
96 INTEGER_BINARY_OPERATION (integer_bitwise_nor)
97 DEFINE_PRIMITIVE ("INTEGER-BITWISE-EQV", Prim_integer_bitwise_eqv, 2, 2, 0)
98 INTEGER_BINARY_OPERATION (integer_bitwise_eqv)
99 DEFINE_PRIMITIVE ("INTEGER-BITWISE-ORC2", Prim_integer_bitwise_orc2, 2, 2, 0)
100 INTEGER_BINARY_OPERATION (integer_bitwise_orc2)
101 DEFINE_PRIMITIVE ("INTEGER-BITWISE-ORC1", Prim_integer_bitwise_orc1, 2, 2, 0)
102 INTEGER_BINARY_OPERATION (integer_bitwise_orc1)
103 DEFINE_PRIMITIVE ("INTEGER-BITWISE-NAND", Prim_integer_bitwise_nand, 2, 2, 0)
104 INTEGER_BINARY_OPERATION (integer_bitwise_nand)
105
106 #define INTEGER_UNARY_OPERATION(operator) \
107 { \
108 PRIMITIVE_HEADER (1); \
109 CHECK_ARG (1, INTEGER_P); \
110 PRIMITIVE_RETURN (operator (ARG_REF (1))); \
111 }
112
113 DEFINE_PRIMITIVE ("INTEGER-NEGATE", Prim_integer_negate, 1, 1, 0)
114 INTEGER_UNARY_OPERATION (integer_negate)
115 DEFINE_PRIMITIVE ("INTEGER-ADD-1", Prim_integer_add_1, 1, 1, 0)
116 INTEGER_UNARY_OPERATION (integer_add_1)
117 DEFINE_PRIMITIVE ("INTEGER-SUBTRACT-1", Prim_integer_subtract_1, 1, 1, 0)
118 INTEGER_UNARY_OPERATION (integer_subtract_1)
119 DEFINE_PRIMITIVE ("INTEGER-LENGTH-IN-BITS", Prim_integer_length_in_bits, 1, 1, 0)
120 INTEGER_UNARY_OPERATION (integer_length_in_bits)
121 DEFINE_PRIMITIVE ("INTEGER-LENGTH", Prim_integer_length, 1, 1, 0)
122 INTEGER_UNARY_OPERATION (integer_length)
123 DEFINE_PRIMITIVE ("INTEGER-FIRST-SET-BIT", Prim_integer_first_set_bit, 1, 1, 0)
124 INTEGER_UNARY_OPERATION (integer_first_set_bit)
125 DEFINE_PRIMITIVE ("INTEGER-BIT-COUNT", Prim_integer_bit_count, 1, 1, 0)
126 INTEGER_UNARY_OPERATION (integer_bit_count)
127 DEFINE_PRIMITIVE ("INTEGER-BITWISE-NOT", Prim_integer_bitwise_not, 1, 1, 0)
128 INTEGER_UNARY_OPERATION (integer_bitwise_not)
129
130 DEFINE_PRIMITIVE ("INTEGER-DIVIDE", Prim_integer_divide, 2, 2, 0)
131 {
132 SCHEME_OBJECT quotient;
133 SCHEME_OBJECT remainder;
134 PRIMITIVE_HEADER (2);
135 CHECK_ARG (1, INTEGER_P);
136 CHECK_ARG (2, INTEGER_P);
137 if (integer_divide ((ARG_REF (1)), (ARG_REF (2)), ("ient), (&remainder)))
138 error_bad_range_arg (2);
139 PRIMITIVE_RETURN (cons (quotient, remainder));
140 }
141
142 #define INTEGER_QR(operator) \
143 { \
144 SCHEME_OBJECT result; \
145 PRIMITIVE_HEADER (2); \
146 CHECK_ARG (1, INTEGER_P); \
147 CHECK_ARG (2, INTEGER_P); \
148 result = (operator ((ARG_REF (1)), (ARG_REF (2)))); \
149 if (result == SHARP_F) \
150 error_bad_range_arg (2); \
151 PRIMITIVE_RETURN (result); \
152 }
153
154 DEFINE_PRIMITIVE ("INTEGER-QUOTIENT", Prim_integer_quotient, 2, 2, 0)
INTEGER_QR(integer_quotient)155 INTEGER_QR (integer_quotient)
156 DEFINE_PRIMITIVE ("INTEGER-REMAINDER", Prim_integer_remainder, 2, 2, 0)
157 INTEGER_QR (integer_remainder)
158
159 DEFINE_PRIMITIVE ("INTEGER?", Prim_integer_p, 1, 1, 0)
160 {
161 PRIMITIVE_HEADER (1);
162 {
163 SCHEME_OBJECT integer = (ARG_REF (1));
164 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (INTEGER_P (integer)));
165 }
166 }
167
168 DEFINE_PRIMITIVE ("INTEGER->FLONUM", Prim_integer_to_flonum, 2, 2, 0)
169 {
170 PRIMITIVE_HEADER (2);
171 CHECK_ARG (1, INTEGER_P);
172 {
173 SCHEME_OBJECT integer = (ARG_REF (1));
174 long control = (arg_index_integer (2, 4));
175 if (FIXNUM_P (integer))
176 {
177 double d = (FIXNUM_TO_DOUBLE (integer));
178 if ((0 == (control & 1))
179 || ((DOUBLE_TO_FIXNUM_P (d))
180 && (integer == (DOUBLE_TO_FIXNUM (d)))))
181 PRIMITIVE_RETURN (double_to_flonum (d));
182 if ((control & 2) != 0)
183 error_bad_range_arg (1);
184 PRIMITIVE_RETURN (SHARP_F);
185 }
186 if (((control & 1) != 0)
187 ? (LOSSLESS_BIGNUM_TO_DOUBLE_P (integer))
188 : (BIGNUM_TO_DOUBLE_P (integer)))
189 PRIMITIVE_RETURN (BIGNUM_TO_FLONUM (integer));
190 if ((control & 2) != 0)
191 error_bad_range_arg (1);
192 PRIMITIVE_RETURN (SHARP_F);
193 }
194 }
195
196 DEFINE_PRIMITIVE ("INTEGER-NONNEGATIVE-ONE-BITS", Prim_integer_nonnegative_one_bits, 2, 2, 0)
197 {
198 PRIMITIVE_HEADER (2);
199 PRIMITIVE_RETURN
200 (integer_nonnegative_one_bits
201 ((arg_ulong_integer (1)), (arg_ulong_integer (2))));
202 }
203
204 DEFINE_PRIMITIVE ("INTEGER-NEGATIVE-ZERO-BITS", Prim_integer_negative_zero_bits, 2, 2, 0)
205 {
206 PRIMITIVE_HEADER (2);
207 PRIMITIVE_RETURN
208 (integer_negative_zero_bits
209 ((arg_ulong_integer (1)), (arg_ulong_integer (2))));
210 }
211
212 DEFINE_PRIMITIVE ("INTEGER-SHIFT-LEFT", Prim_integer_shift_left, 2, 2, 0)
213 {
214 PRIMITIVE_HEADER (2);
215 CHECK_ARG (1, INTEGER_P);
216 PRIMITIVE_RETURN
217 (integer_shift_left ((ARG_REF (1)), (arg_ulong_integer (2))));
218 }
219
220 DEFINE_PRIMITIVE ("INTEGER-SHIFT-RIGHT", Prim_integer_shift_right, 2, 2, 0)
221 {
222 PRIMITIVE_HEADER (2);
223 CHECK_ARG (1, INTEGER_P);
224 {
225 SCHEME_OBJECT n = (ARG_REF (1));
226 SCHEME_OBJECT m = (ARG_REF (2));
227 if (FIXNUM_P (m))
228 {
229 if (FIXNUM_NEGATIVE_P (m))
230 error_bad_range_arg (2);
231 PRIMITIVE_RETURN (integer_shift_right (n, (FIXNUM_TO_ULONG (m))));
232 }
233 else if (BIGNUM_P (m))
234 {
235 if (BIGNUM_NEGATIVE_P (m))
236 error_bad_range_arg (2);
237 PRIMITIVE_RETURN (FIXNUM_ZERO);
238 }
239 else
240 error_wrong_type_arg (2);
241 }
242 }
243
244 static unsigned int
list_to_integer_producer(void * context)245 list_to_integer_producer (void * context)
246 {
247 SCHEME_OBJECT * digits = context;
248 unsigned int digit = (UNSIGNED_FIXNUM_TO_LONG (PAIR_CAR (*digits)));
249 (*digits) = (PAIR_CDR (*digits));
250 return (digit);
251 }
252
253 DEFINE_PRIMITIVE ("LIST->INTEGER", Prim_list_to_integer, 3, 3,
254 "(list radix negative?)\n\
255 LIST is a non-null list of digits in RADIX, most-significant first.\n\
256 Converts the list to an integer. NEGATIVE? specifies the sign.")
257 {
258 PRIMITIVE_HEADER (3);
259 CHECK_ARG (1, PAIR_P);
260 {
261 SCHEME_OBJECT digits = (ARG_REF (1));
262 unsigned long radix = (arg_ulong_integer (2));
263 unsigned int n_digits;
264 if ((radix < 2)
265 || (radix >= ((unsigned long) (bignum_max_digit_stream_radix ()))))
266 error_bad_range_arg (2);
267 {
268 SCHEME_OBJECT scan = digits;
269 n_digits = 0;
270 while (1)
271 {
272 SCHEME_OBJECT digit = (PAIR_CAR (scan));
273 if (!UNSIGNED_FIXNUM_P (digit))
274 error_wrong_type_arg (1);
275 if (((unsigned long) (UNSIGNED_FIXNUM_TO_LONG (digit))) >= radix)
276 error_bad_range_arg (1);
277 n_digits += 1;
278 scan = (PAIR_CDR (scan));
279 if (EMPTY_LIST_P (scan))
280 break;
281 if (!PAIR_P (scan))
282 error_wrong_type_arg (1);
283 }
284 }
285 PRIMITIVE_RETURN
286 (bignum_to_integer
287 (digit_stream_to_bignum (n_digits,
288 list_to_integer_producer,
289 (&digits),
290 radix,
291 (OBJECT_TO_BOOLEAN (ARG_REF (3))))));
292 }
293 }
294