1 /*===========================================================================
2 * Filename : number.c
3 * About : R5RS numbers
4 *
5 * Copyright (C) 2005 Kazuki Ohta <mover AT hct.zaq.ne.jp>
6 * Copyright (C) 2005-2006 Jun Inoue <jun.lambda AT gmail.com>
7 * Copyright (C) 2005-2006 YAMAMOTO Kengo <yamaken AT bp.iij4u.or.jp>
8 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com>
9 *
10 * All rights reserved.
11 *
12 * Redistribution and use in source and binary forms, with or without
13 * modification, are permitted provided that the following conditions
14 * are met:
15 *
16 * 1. Redistributions of source code must retain the above copyright
17 * notice, this list of conditions and the following disclaimer.
18 * 2. Redistributions in binary form must reproduce the above copyright
19 * notice, this list of conditions and the following disclaimer in the
20 * documentation and/or other materials provided with the distribution.
21 * 3. Neither the name of authors nor the names of its contributors
22 * may be used to endorse or promote products derived from this software
23 * without specific prior written permission.
24 *
25 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS
26 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO,
27 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
28 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
29 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
30 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
31 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
32 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
33 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
34 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
35 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
36 ===========================================================================*/
37
38 #include <config.h>
39
40 #include "sigscheme.h"
41 #include "sigschemeinternal.h"
42
43 /*=======================================
44 File Local Macro Definitions
45 =======================================*/
46 #define ERRMSG_DIV_BY_ZERO "division by zero"
47 #define ERRMSG_REQ_1_ARG "at least 1 argument required"
48
49 /*=======================================
50 File Local Type Definitions
51 =======================================*/
52
53 /*=======================================
54 Variable Definitions
55 =======================================*/
56
57 /*=======================================
58 File Local Function Declarations
59 =======================================*/
60
61 /*=======================================
62 Function Definitions
63 =======================================*/
64 /*===========================================================================
65 R5RS : 6.2 Numbers : 6.2.5 Numerical Operations
66 ===========================================================================*/
67 /* Note: SigScheme supports only the integer part of the numerical tower. */
68
69 SCM_EXPORT ScmObj
scm_p_add(ScmObj left,ScmObj right,enum ScmReductionState * state)70 scm_p_add(ScmObj left, ScmObj right, enum ScmReductionState *state)
71 {
72 scm_int_t result, l, r;
73 DECLARE_FUNCTION("+", reduction_operator);
74
75 result = l = 0;
76 switch (*state) {
77 case SCM_REDUCE_PARTWAY:
78 case SCM_REDUCE_LAST:
79 ENSURE_INT(left);
80 l = SCM_INT_VALUE(left);
81 /* Fall through. */
82 case SCM_REDUCE_1:
83 ENSURE_INT(right);
84 r = SCM_INT_VALUE(right);
85 result = l + r;
86 if (INT_OUT_OF_RANGEP(result)
87 || (r > 0 && result < l)
88 || (r < 0 && result > l))
89 ERR(ERRMSG_FIXNUM_OVERFLOW);
90 /* Fall through. */
91 case SCM_REDUCE_0:
92 break;
93 default:
94 SCM_NOTREACHED;
95 }
96
97 return MAKE_INT(result);
98 }
99
100 /* no overflow check */
101 SCM_EXPORT ScmObj
scm_p_multiply(ScmObj left,ScmObj right,enum ScmReductionState * state)102 scm_p_multiply(ScmObj left, ScmObj right, enum ScmReductionState *state)
103 {
104 scm_int_t result;
105 DECLARE_FUNCTION("*", reduction_operator);
106
107 result = 1;
108 switch (*state) {
109 case SCM_REDUCE_PARTWAY:
110 case SCM_REDUCE_LAST:
111 ENSURE_INT(left);
112 result = SCM_INT_VALUE(left);
113 /* Fall through. */
114 case SCM_REDUCE_1:
115 ENSURE_INT(right);
116 result *= SCM_INT_VALUE(right);
117 /* Fall through. */
118 case SCM_REDUCE_0:
119 break;
120 default:
121 SCM_NOTREACHED;
122 }
123
124 return MAKE_INT(result);
125 }
126
127 SCM_EXPORT ScmObj
scm_p_subtract(ScmObj left,ScmObj right,enum ScmReductionState * state)128 scm_p_subtract(ScmObj left, ScmObj right, enum ScmReductionState *state)
129 {
130 scm_int_t result, l, r;
131 DECLARE_FUNCTION("-", reduction_operator);
132
133 result = l = 0;
134 switch (*state) {
135 case SCM_REDUCE_PARTWAY:
136 case SCM_REDUCE_LAST:
137 ENSURE_INT(left);
138 l = SCM_INT_VALUE(left);
139 /* Fall through. */
140 case SCM_REDUCE_1:
141 ENSURE_INT(right);
142 r = SCM_INT_VALUE(right);
143 result = l - r;
144 if (INT_OUT_OF_RANGEP(result)
145 || (r > 0 && result > l)
146 || (r < 0 && result < l))
147 ERR(ERRMSG_FIXNUM_OVERFLOW);
148 break;
149
150 case SCM_REDUCE_0:
151 ERR(ERRMSG_REQ_1_ARG);
152 default:
153 SCM_NOTREACHED;
154 }
155 return MAKE_INT(result);
156 }
157
158 SCM_EXPORT ScmObj
scm_p_divide(ScmObj left,ScmObj right,enum ScmReductionState * state)159 scm_p_divide(ScmObj left, ScmObj right, enum ScmReductionState *state)
160 {
161 scm_int_t result, val;
162 DECLARE_FUNCTION("/", reduction_operator);
163
164 result = 1;
165 switch (*state) {
166 case SCM_REDUCE_PARTWAY:
167 case SCM_REDUCE_LAST:
168 ENSURE_INT(left);
169 result = SCM_INT_VALUE(left);
170 /* Fall through. */
171 case SCM_REDUCE_1:
172 ENSURE_INT(right);
173 val = SCM_INT_VALUE(right);
174 if (val == 0)
175 ERR(ERRMSG_DIV_BY_ZERO);
176 result /= val;
177 break;
178
179 case SCM_REDUCE_0:
180 ERR(ERRMSG_REQ_1_ARG);
181 default:
182 SCM_NOTREACHED;
183 }
184 return MAKE_INT(result);
185 }
186
187 SCM_EXPORT ScmObj
scm_p_numberp(ScmObj obj)188 scm_p_numberp(ScmObj obj)
189 {
190 DECLARE_FUNCTION("number?", procedure_fixed_1);
191
192 return MAKE_BOOL(NUMBERP(obj));
193 }
194
195 SCM_EXPORT ScmObj
scm_p_integerp(ScmObj obj)196 scm_p_integerp(ScmObj obj)
197 {
198 DECLARE_FUNCTION("integer?", procedure_fixed_1);
199
200 return MAKE_BOOL(INTP(obj));
201 }
202
203 #define COMPARATOR_BODY(op) \
204 switch (*state) { \
205 case SCM_REDUCE_0: \
206 case SCM_REDUCE_1: \
207 ERR("at least 2 arguments required"); \
208 case SCM_REDUCE_PARTWAY: \
209 case SCM_REDUCE_LAST: \
210 ENSURE_INT(left); \
211 ENSURE_INT(right); \
212 if (SCM_INT_VALUE(left) op SCM_INT_VALUE(right)) \
213 return (*state == SCM_REDUCE_LAST) ? SCM_TRUE : right; \
214 *state = SCM_REDUCE_STOP; \
215 break; \
216 \
217 default: \
218 SCM_NOTREACHED; \
219 } \
220 return SCM_FALSE
221
222 SCM_EXPORT ScmObj
scm_p_equal(ScmObj left,ScmObj right,enum ScmReductionState * state)223 scm_p_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
224 {
225 DECLARE_FUNCTION("=", reduction_operator);
226
227 COMPARATOR_BODY(==);
228 }
229
230 SCM_EXPORT ScmObj
scm_p_less(ScmObj left,ScmObj right,enum ScmReductionState * state)231 scm_p_less(ScmObj left, ScmObj right, enum ScmReductionState *state)
232 {
233 DECLARE_FUNCTION("<", reduction_operator);
234
235 COMPARATOR_BODY(<);
236 }
237
238 SCM_EXPORT ScmObj
scm_p_less_equal(ScmObj left,ScmObj right,enum ScmReductionState * state)239 scm_p_less_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
240 {
241 DECLARE_FUNCTION("<=", reduction_operator);
242
243 COMPARATOR_BODY(<=);
244 }
245
246 SCM_EXPORT ScmObj
scm_p_greater(ScmObj left,ScmObj right,enum ScmReductionState * state)247 scm_p_greater(ScmObj left, ScmObj right, enum ScmReductionState *state)
248 {
249 DECLARE_FUNCTION(">", reduction_operator);
250
251 COMPARATOR_BODY(>);
252 }
253
254 SCM_EXPORT ScmObj
scm_p_greater_equal(ScmObj left,ScmObj right,enum ScmReductionState * state)255 scm_p_greater_equal(ScmObj left, ScmObj right, enum ScmReductionState *state)
256 {
257 DECLARE_FUNCTION(">=", reduction_operator);
258
259 COMPARATOR_BODY(>=);
260 }
261
262 #undef COMPARATOR_BODY
263
264 SCM_EXPORT ScmObj
scm_p_zerop(ScmObj n)265 scm_p_zerop(ScmObj n)
266 {
267 DECLARE_FUNCTION("zero?", procedure_fixed_1);
268
269 ENSURE_INT(n);
270
271 return MAKE_BOOL(SCM_INT_VALUE(n) == 0);
272 }
273
274 SCM_EXPORT ScmObj
scm_p_positivep(ScmObj n)275 scm_p_positivep(ScmObj n)
276 {
277 DECLARE_FUNCTION("positive?", procedure_fixed_1);
278
279 ENSURE_INT(n);
280
281 return MAKE_BOOL(SCM_INT_VALUE(n) > 0);
282 }
283
284 SCM_EXPORT ScmObj
scm_p_negativep(ScmObj n)285 scm_p_negativep(ScmObj n)
286 {
287 DECLARE_FUNCTION("negative?", procedure_fixed_1);
288
289 ENSURE_INT(n);
290
291 return MAKE_BOOL(SCM_INT_VALUE(n) < 0);
292 }
293
294 SCM_EXPORT ScmObj
scm_p_oddp(ScmObj n)295 scm_p_oddp(ScmObj n)
296 {
297 DECLARE_FUNCTION("odd?", procedure_fixed_1);
298
299 ENSURE_INT(n);
300
301 return MAKE_BOOL(SCM_INT_VALUE(n) & 0x1);
302 }
303
304 SCM_EXPORT ScmObj
scm_p_evenp(ScmObj n)305 scm_p_evenp(ScmObj n)
306 {
307 DECLARE_FUNCTION("even?", procedure_fixed_1);
308
309 ENSURE_INT(n);
310
311 return MAKE_BOOL(!(SCM_INT_VALUE(n) & 0x1));
312 }
313
314 SCM_EXPORT ScmObj
scm_p_max(ScmObj left,ScmObj right,enum ScmReductionState * state)315 scm_p_max(ScmObj left, ScmObj right, enum ScmReductionState *state)
316 {
317 DECLARE_FUNCTION("max", reduction_operator);
318
319 if (*state == SCM_REDUCE_0)
320 ERR(ERRMSG_REQ_1_ARG);
321 ENSURE_INT(left);
322 ENSURE_INT(right);
323
324 return (SCM_INT_VALUE(left) > SCM_INT_VALUE(right)) ? left : right;
325 }
326
327 SCM_EXPORT ScmObj
scm_p_min(ScmObj left,ScmObj right,enum ScmReductionState * state)328 scm_p_min(ScmObj left, ScmObj right, enum ScmReductionState *state)
329 {
330 DECLARE_FUNCTION("min", reduction_operator);
331
332 if (*state == SCM_REDUCE_0)
333 ERR(ERRMSG_REQ_1_ARG);
334 ENSURE_INT(left);
335 ENSURE_INT(right);
336
337 return (SCM_INT_VALUE(left) < SCM_INT_VALUE(right)) ? left : right;
338 }
339
340
341 SCM_EXPORT ScmObj
scm_p_abs(ScmObj _n)342 scm_p_abs(ScmObj _n)
343 {
344 scm_int_t n;
345 DECLARE_FUNCTION("abs", procedure_fixed_1);
346
347 ENSURE_INT(_n);
348
349 n = SCM_INT_VALUE(_n);
350 if (n == SCM_INT_MIN)
351 ERR(ERRMSG_FIXNUM_OVERFLOW);
352
353 return (n < 0) ? MAKE_INT(-n) : _n;
354 }
355
356 SCM_EXPORT ScmObj
scm_p_quotient(ScmObj _n1,ScmObj _n2)357 scm_p_quotient(ScmObj _n1, ScmObj _n2)
358 {
359 scm_int_t n1, n2;
360 DECLARE_FUNCTION("quotient", procedure_fixed_2);
361
362 ENSURE_INT(_n1);
363 ENSURE_INT(_n2);
364
365 n1 = SCM_INT_VALUE(_n1);
366 n2 = SCM_INT_VALUE(_n2);
367 if (n2 == 0)
368 ERR(ERRMSG_DIV_BY_ZERO);
369
370 /*
371 * ISO/IEC 9899:1999(E):
372 *
373 * 6.3.1.4 Real floating and integer
374 *
375 * 1 When a finite value of real floating type is converted to an integer
376 * type other than _Bool, the fractional part is discarded (i.e., the
377 * value is truncated toward zero). If the value of the integral part
378 * cannot be represented by the integer type, the behavior is undefined.
379 */
380 return MAKE_INT((scm_int_t)(n1 / n2));
381 }
382
383 SCM_EXPORT ScmObj
scm_p_modulo(ScmObj _n1,ScmObj _n2)384 scm_p_modulo(ScmObj _n1, ScmObj _n2)
385 {
386 scm_int_t n1, n2, rem;
387 DECLARE_FUNCTION("modulo", procedure_fixed_2);
388
389 ENSURE_INT(_n1);
390 ENSURE_INT(_n2);
391
392 n1 = SCM_INT_VALUE(_n1);
393 n2 = SCM_INT_VALUE(_n2);
394 if (n2 == 0)
395 ERR(ERRMSG_DIV_BY_ZERO);
396
397 rem = n1 % n2;
398 if (rem && ((n1 < 0 && 0 < n2) || (n2 < 0 && 0 < n1)))
399 rem += n2;
400
401 return MAKE_INT(rem);
402 }
403
404 SCM_EXPORT ScmObj
scm_p_remainder(ScmObj _n1,ScmObj _n2)405 scm_p_remainder(ScmObj _n1, ScmObj _n2)
406 {
407 scm_int_t n1, n2;
408 DECLARE_FUNCTION("remainder", procedure_fixed_2);
409
410 ENSURE_INT(_n1);
411 ENSURE_INT(_n2);
412
413 n1 = SCM_INT_VALUE(_n1);
414 n2 = SCM_INT_VALUE(_n2);
415 if (n2 == 0)
416 ERR(ERRMSG_DIV_BY_ZERO);
417
418 return MAKE_INT(n1 % n2);
419 }
420